]>
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) | |
bd378884 | 172 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 173 | * LEPTO |
174 | **LUND single / double precision | |
175 | REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
176 | COMMON /LEPTOU/ CUT(14),LST(40),PARL(30), | |
177 | & TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
178 | * LEPTO | |
179 | REAL RPPN | |
180 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
181 | * steering flags for qel neutrino scattering modules | |
182 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
183 | * event flag | |
184 | COMMON /DTEVNO/ NEVENT,ICASCA | |
185 | ||
186 | INTEGER PYCOMP | |
187 | ||
188 | C DIMENSION XPARA(5) | |
189 | DIMENSION XDUMB(40),IPRANG(5) | |
190 | ||
191 | PARAMETER (MXCARD=58) | |
192 | CHARACTER*78 CLINE,CTITLE | |
193 | CHARACTER*60 CWHAT | |
194 | CHARACTER*8 BLANK,SDUM | |
195 | CHARACTER*10 CODE,CODEWD | |
196 | CHARACTER*72 HEADER | |
197 | LOGICAL LSTART,LEINP,LXSTAB | |
198 | DIMENSION WHAT(6),CODE(MXCARD) | |
199 | DATA CODE/ | |
200 | & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ', | |
201 | & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ', | |
202 | & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ', | |
203 | & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ', | |
204 | & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ', | |
205 | & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ', | |
206 | & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ', | |
207 | & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ', | |
208 | & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ', | |
209 | & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ', | |
210 | & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ', | |
211 | & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ', | |
212 | & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ', | |
213 | & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL', | |
214 | & 'START ','STOP '/ | |
215 | DATA BLANK /' '/ | |
216 | ||
217 | DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/ | |
218 | DATA CMEOLD /0.0D0/ | |
219 | ||
220 | *--------------------------------------------------------------------- | |
221 | * at the first call of INIT: initialize event generation | |
222 | EPNSAV = EPN | |
223 | IF (LSTART) THEN | |
224 | CALL DT_TITLE | |
225 | * initialization and test of the random number generator | |
226 | IF (ITRSPT.NE.1) THEN | |
227 | CALL DT_RNDMST(22,54,76,92) | |
228 | CALL DT_RNDMTE(1) | |
229 | ENDIF | |
230 | * initialization of BAMJET, DECAY and HADRIN | |
231 | CALL DT_DDATAR | |
232 | CALL DT_DHADDE | |
233 | CALL DT_DCHANT | |
234 | CALL DT_DCHANH | |
235 | * set default values for input variables | |
236 | CALL DT_DEFAUL(EPN,PPN) | |
237 | IGLAU = 0 | |
238 | IXSQEL = 0 | |
239 | * flag for collision energy input | |
240 | LEINP = .FALSE. | |
241 | LSTART = .FALSE. | |
242 | ENDIF | |
243 | ||
244 | *--------------------------------------------------------------------- | |
245 | 10 CONTINUE | |
246 | ||
247 | * bypass reading input cards (e.g. for use with Fluka) | |
248 | * in this case Epn is expected to carry the beam momentum | |
249 | IF (NCASES.EQ.-1) THEN | |
250 | IP = NPMASS | |
251 | IPZ = NPCHAR | |
252 | PPN = EPNSAV | |
253 | EPN = ZERO | |
254 | CMENER = ZERO | |
255 | LEINP = .TRUE. | |
256 | MKCRON = 0 | |
257 | WHAT(1) = 1 | |
258 | WHAT(2) = 0 | |
259 | CODEWD = 'START ' | |
260 | GOTO 900 | |
261 | ENDIF | |
262 | ||
263 | * read control card from input-unit LINP | |
264 | READ(LINP,'(A78)',END=9999) CLINE | |
265 | IF (CLINE(1:1).EQ.'*') THEN | |
266 | * comment-line | |
267 | WRITE(LOUT,'(A78)') CLINE | |
268 | GOTO 10 | |
269 | ENDIF | |
270 | C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM | |
271 | C1000 FORMAT(A10,6E10.0,A8) | |
272 | DO 1008 I=1,6 | |
273 | WHAT(I) = ZERO | |
274 | 1008 CONTINUE | |
275 | READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM | |
276 | 1006 FORMAT(A10,A60,A8) | |
277 | READ(CWHAT,*,END=1007) (WHAT(I),I=1,6) | |
278 | 1007 CONTINUE | |
279 | WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM | |
280 | 1001 FORMAT(A10,6G10.3,A8) | |
281 | ||
282 | 900 CONTINUE | |
283 | ||
284 | * check for valid control card and get card index | |
285 | ICW = 0 | |
286 | DO 11 I=1,MXCARD | |
287 | IF (CODEWD.EQ.CODE(I)) ICW = I | |
288 | 11 CONTINUE | |
289 | IF (ICW.EQ.0) THEN | |
290 | WRITE(LOUT,1002) CODEWD | |
291 | 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/) | |
292 | GOTO 10 | |
293 | ENDIF | |
294 | ||
295 | GOTO( | |
296 | *------------------------------------------------------------ | |
297 | * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM, | |
298 | & 100 , 110 , 120 , 130 , 140 , | |
299 | * | |
300 | *------------------------------------------------------------ | |
301 | * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI , | |
302 | & 150 , 160 , 170 , 180 , 190 , | |
303 | * | |
304 | *------------------------------------------------------------ | |
305 | * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL , | |
306 | & 200 , 210 , 220 , 230 , 240 , | |
307 | * | |
308 | *------------------------------------------------------------ | |
309 | * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN, | |
310 | & 250 , 260 , 270 , 280 , 290 , | |
311 | * | |
312 | *------------------------------------------------------------ | |
313 | * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR, | |
314 | & 300 , 310 , 320 , 330 , 340 , | |
315 | * | |
316 | *------------------------------------------------------------ | |
317 | * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH, | |
318 | & 350 , 360 , 370 , 380 , 390 , | |
319 | * | |
320 | *------------------------------------------------------------ | |
321 | * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM , | |
322 | & 400 , 410 , 420 , 430 , 440 , | |
323 | * | |
324 | *------------------------------------------------------------ | |
325 | * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU, | |
326 | & 450 , 451 , 452 , 460 , 470 , | |
327 | * | |
328 | *------------------------------------------------------------ | |
329 | * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT, | |
330 | & 480 , 490 , 500 , 510 , 520 , | |
331 | * | |
332 | *------------------------------------------------------------ | |
333 | * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI, | |
334 | & 530 , 540 , 550 , 560 , 565 , | |
335 | * | |
336 | *------------------------------------------------------------ | |
337 | * , , VDM-PAR2, XS-QELPRO, RNDMINIT , | |
338 | & 570 , 580 , 590 , | |
339 | * | |
340 | *------------------------------------------------------------ | |
341 | * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP ) | |
342 | & 600 , 610 , 620 , 630 , 640 ) , ICW | |
343 | * | |
344 | *------------------------------------------------------------ | |
345 | ||
346 | GOTO 10 | |
347 | ||
348 | ********************************************************************* | |
349 | * * | |
350 | * control card: codewd = TITLE * | |
351 | * * | |
352 | * what (1..6), sdum no meaning * | |
353 | * * | |
354 | * Note: The control-card following this must consist of * | |
355 | * a string of characters usually giving the title of * | |
356 | * the run. * | |
357 | * * | |
358 | ********************************************************************* | |
359 | ||
360 | 100 CONTINUE | |
361 | READ(LINP,'(A78)') CTITLE | |
362 | WRITE(LOUT,'(//,5X,A78,//)') CTITLE | |
363 | GOTO 10 | |
364 | ||
365 | ********************************************************************* | |
366 | * * | |
367 | * control card: codewd = PROJPAR * | |
368 | * * | |
369 | * what (1) = mass number of projectile nucleus default: 1 * | |
370 | * what (2) = charge of projectile nucleus default: 1 * | |
371 | * what (3..6) no meaning * | |
372 | * sdum projectile particle code word * | |
373 | * * | |
374 | * Note: If sdum is defined what (1..2) have no meaning. * | |
375 | * * | |
376 | ********************************************************************* | |
377 | ||
378 | 110 CONTINUE | |
379 | IF (SDUM.EQ.BLANK) THEN | |
380 | IP = INT(WHAT(1)) | |
381 | IPZ = INT(WHAT(2)) | |
382 | IJPROJ = 1 | |
383 | IBPROJ = 1 | |
384 | ELSE | |
385 | IJPROJ = 0 | |
386 | DO 111 II=1,30 | |
387 | IF (SDUM.EQ.BTYPE(II)) THEN | |
388 | IP = 1 | |
389 | IPZ = 1 | |
390 | IF (II.EQ.26) THEN | |
391 | IJPROJ = 135 | |
392 | ELSEIF (II.EQ.27) THEN | |
393 | IJPROJ = 136 | |
394 | ELSEIF (II.EQ.28) THEN | |
395 | IJPROJ = 133 | |
396 | ELSEIF (II.EQ.29) THEN | |
397 | IJPROJ = 134 | |
398 | ELSE | |
399 | IJPROJ = II | |
400 | ENDIF | |
401 | IBPROJ = IIBAR(IJPROJ) | |
402 | * photon | |
403 | IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1) | |
404 | * lepton | |
405 | IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR. | |
406 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND. | |
407 | & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1) | |
408 | ENDIF | |
409 | 111 CONTINUE | |
410 | IF (IJPROJ.EQ.0) THEN | |
411 | WRITE(LOUT,1110) | |
412 | 1110 FORMAT(/,1X,'invalid PROJPAR card !',/) | |
413 | GOTO 9999 | |
414 | ENDIF | |
415 | ENDIF | |
416 | GOTO 10 | |
417 | ||
418 | ********************************************************************* | |
419 | * * | |
420 | * control card: codewd = TARPAR * | |
421 | * * | |
422 | * what (1) = mass number of target nucleus default: 1 * | |
423 | * what (2) = charge of target nucleus default: 1 * | |
424 | * what (3..6) no meaning * | |
425 | * sdum target particle code word * | |
426 | * * | |
427 | * Note: If sdum is defined what (1..2) have no meaning. * | |
428 | * * | |
429 | ********************************************************************* | |
430 | ||
431 | 120 CONTINUE | |
432 | IF (SDUM.EQ.BLANK) THEN | |
433 | IT = INT(WHAT(1)) | |
434 | ITZ = INT(WHAT(2)) | |
435 | IJTARG = 1 | |
436 | IBTARG = 1 | |
437 | ELSE | |
438 | IJTARG = 0 | |
439 | DO 121 II=1,30 | |
440 | IF (SDUM.EQ.BTYPE(II)) THEN | |
441 | IT = 1 | |
442 | ITZ = 1 | |
443 | IJTARG = II | |
444 | IBTARG = IIBAR(IJTARG) | |
445 | ENDIF | |
446 | 121 CONTINUE | |
447 | IF (IJTARG.EQ.0) THEN | |
448 | WRITE(LOUT,1120) | |
449 | 1120 FORMAT(/,1X,'invalid TARPAR card !',/) | |
450 | GOTO 9999 | |
451 | ENDIF | |
452 | ENDIF | |
453 | GOTO 10 | |
454 | ||
455 | ********************************************************************* | |
456 | * * | |
457 | * control card: codewd = ENERGY * | |
458 | * * | |
459 | * what (1) = energy (GeV) of projectile in Lab. * | |
460 | * if what(1) < 0: |what(1)| = kinetic energy * | |
461 | * default: 200 GeV * | |
462 | * if |what(2)| > 0: min. energy for variable * | |
463 | * energy runs * | |
464 | * what (2) = max. energy for variable energy runs * | |
465 | * if what(2) < 0: |what(2)| = kinetic energy * | |
466 | * * | |
467 | ********************************************************************* | |
468 | ||
469 | 130 CONTINUE | |
470 | EPN = WHAT(1) | |
471 | PPN = ZERO | |
472 | CMENER = ZERO | |
473 | IF ((ABS(WHAT(2)).GT.ZERO).AND. | |
474 | & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN | |
475 | VARELO = WHAT(1) | |
476 | VAREHI = WHAT(2) | |
477 | EPN = VAREHI | |
478 | ENDIF | |
479 | LEINP = .TRUE. | |
480 | GOTO 10 | |
481 | ||
482 | ********************************************************************* | |
483 | * * | |
484 | * control card: codewd = MOMENTUM * | |
485 | * * | |
486 | * what (1) = momentum (GeV/c) of projectile in Lab. * | |
487 | * default: 200 GeV/c * | |
488 | * what (2..6), sdum no meaning * | |
489 | * * | |
490 | ********************************************************************* | |
491 | ||
492 | 140 CONTINUE | |
493 | EPN = ZERO | |
494 | PPN = WHAT(1) | |
495 | CMENER = ZERO | |
496 | LEINP = .TRUE. | |
497 | GOTO 10 | |
498 | ||
499 | ********************************************************************* | |
500 | * * | |
501 | * control card: codewd = CMENERGY * | |
502 | * * | |
503 | * what (1) = energy in nucleon-nucleon cms. * | |
504 | * default: none * | |
505 | * what (2..6), sdum no meaning * | |
506 | * * | |
507 | ********************************************************************* | |
508 | ||
509 | 150 CONTINUE | |
510 | EPN = ZERO | |
511 | PPN = ZERO | |
512 | CMENER = WHAT(1) | |
513 | LEINP = .TRUE. | |
514 | GOTO 10 | |
515 | ||
516 | ********************************************************************* | |
517 | * * | |
518 | * control card: codewd = EMULSION * | |
519 | * * | |
520 | * definition of nuclear emulsions * | |
521 | * * | |
522 | * what(1) mass number of emulsion component * | |
523 | * what(2) charge of emulsion component * | |
524 | * what(3) fraction of events in which a scattering on a * | |
525 | * nucleus of this properties is performed * | |
526 | * what(4,5,6) as what(1,2,3) but for another component * | |
527 | * default: no emulsion * | |
528 | * sdum no meaning * | |
529 | * * | |
530 | * Note: If this input-card is once used with valid parameters * | |
531 | * TARPAR is obsolete. * | |
532 | * Not the absolute values of the fractions are important * | |
533 | * but only the ratios of fractions of different comp. * | |
534 | * This control card can be repeatedly used to define * | |
535 | * emulsions consisting of up to 10 elements. * | |
536 | * * | |
537 | ********************************************************************* | |
538 | ||
539 | 160 CONTINUE | |
540 | IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO) | |
541 | & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN | |
542 | NCOMPO = NCOMPO+1 | |
543 | IF (NCOMPO.GT.NCOMPX) THEN | |
544 | WRITE(LOUT,1600) | |
545 | STOP | |
546 | ENDIF | |
547 | IEMUMA(NCOMPO) = INT(WHAT(1)) | |
548 | IEMUCH(NCOMPO) = INT(WHAT(2)) | |
549 | EMUFRA(NCOMPO) = WHAT(3) | |
550 | IEMUL = 1 | |
551 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
552 | ENDIF | |
553 | IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO) | |
554 | & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN | |
555 | NCOMPO = NCOMPO+1 | |
556 | IF (NCOMPO.GT.NCOMPX) THEN | |
557 | WRITE(LOUT,1001) | |
558 | STOP | |
559 | ENDIF | |
560 | IEMUMA(NCOMPO) = INT(WHAT(4)) | |
561 | IEMUCH(NCOMPO) = INT(WHAT(5)) | |
562 | EMUFRA(NCOMPO) = WHAT(6) | |
563 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
564 | ENDIF | |
565 | 1600 FORMAT(1X,'too many emulsion components - program stopped') | |
566 | GOTO 10 | |
567 | ||
568 | ********************************************************************* | |
569 | * * | |
570 | * control card: codewd = FERMI * | |
571 | * * | |
572 | * what (1) = -1 Fermi-motion of nucleons not treated * | |
573 | * default: 1 * | |
574 | * what (2) = scale factor for Fermi-momentum * | |
575 | * default: 0.75 * | |
576 | * what (3..6), sdum no meaning * | |
577 | * * | |
578 | ********************************************************************* | |
579 | ||
580 | 170 CONTINUE | |
581 | IF (WHAT(1).EQ.-1.0D0) THEN | |
582 | LFERMI = .FALSE. | |
583 | ELSE | |
584 | LFERMI = .TRUE. | |
585 | ENDIF | |
586 | XMOD = WHAT(2) | |
587 | IF (XMOD.GE.ZERO) FERMOD = XMOD | |
588 | GOTO 10 | |
589 | ||
590 | ********************************************************************* | |
591 | * * | |
592 | * control card: codewd = TAUFOR * | |
593 | * * | |
594 | * formation time supressed intranuclear cascade * | |
595 | * * | |
596 | * what (1) formation time (in fm/c) * | |
597 | * note: what(1)=10. corresponds roughly to an * | |
598 | * average formation time of 1 fm/c * | |
599 | * default: 5. fm/c * | |
600 | * what (2) number of generations followed * | |
601 | * default: 25 * | |
602 | * what (3) = 1. p_t-dependent formation zone * | |
603 | * = 2. constant formation zone * | |
604 | * default: 1 * | |
605 | * what (4) modus of selection of nucleus where the * | |
606 | * cascade if followed first * | |
607 | * = 1. proj./target-nucleus with probab. 1/2 * | |
608 | * = 2. nucleus with highest mass * | |
609 | * = 3. proj. nucleus if particle is moving in pos. z * | |
610 | * targ. nucleus if particle is moving in neg. z * | |
611 | * default: 1 * | |
612 | * what (5..6), sdum no meaning * | |
613 | * * | |
614 | ********************************************************************* | |
615 | ||
616 | 180 CONTINUE | |
617 | TAUFOR = WHAT(1) | |
618 | KTAUGE = INT(WHAT(2)) | |
619 | INCMOD = 1 | |
620 | IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0)) | |
621 | & ITAUVE = INT(WHAT(3)) | |
622 | IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0)) | |
623 | & INCMOD = INT(WHAT(4)) | |
624 | GOTO 10 | |
625 | ||
626 | ********************************************************************* | |
627 | * * | |
628 | * control card: codewd = PAULI * | |
629 | * * | |
630 | * what (1) = -1 Pauli's principle for secondary * | |
631 | * interactions not treated * | |
632 | * default: 1 * | |
633 | * what (2..6), sdum no meaning * | |
634 | * * | |
635 | ********************************************************************* | |
636 | ||
637 | 190 CONTINUE | |
638 | IF (WHAT(1).EQ.-1.0D0) THEN | |
639 | LPAULI = .FALSE. | |
640 | ELSE | |
641 | LPAULI = .TRUE. | |
642 | ENDIF | |
643 | GOTO 10 | |
644 | ||
645 | ********************************************************************* | |
646 | * * | |
647 | * control card: codewd = COULOMB * | |
648 | * * | |
649 | * what (1) = -1. Coulomb-energy treatment switched off * | |
650 | * default: 1 * | |
651 | * what (2..6), sdum no meaning * | |
652 | * * | |
653 | ********************************************************************* | |
654 | ||
655 | 200 CONTINUE | |
656 | ICOUL = 1 | |
657 | IF (WHAT(1).EQ.-1.0D0) THEN | |
658 | ICOUL = 0 | |
659 | ELSE | |
660 | ICOUL = 1 | |
661 | ENDIF | |
662 | GOTO 10 | |
663 | ||
664 | ********************************************************************* | |
665 | * * | |
666 | * control card: codewd = HADRIN * | |
667 | * * | |
668 | * HADRIN module * | |
669 | * * | |
670 | * what (1) = 0. elastic/inelastic interactions with probab. * | |
671 | * as defined by cross-sections * | |
672 | * = 1. inelastic interactions forced * | |
673 | * = 2. elastic interactions forced * | |
674 | * default: 1 * | |
675 | * what (2) upper threshold in total energy (GeV) below * | |
676 | * which interactions are sampled by HADRIN * | |
677 | * default: 5. GeV * | |
678 | * what (3..6), sdum no meaning * | |
679 | * * | |
680 | ********************************************************************* | |
681 | ||
682 | 210 CONTINUE | |
683 | IWHAT = INT(WHAT(1)) | |
684 | IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT | |
685 | IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2) | |
686 | GOTO 10 | |
687 | ||
688 | ********************************************************************* | |
689 | * * | |
690 | * control card: codewd = EVAP * | |
691 | * * | |
692 | * evaporation module * | |
693 | * * | |
694 | * what (1) =< -1 ==> evaporation is switched off * | |
695 | * >= 1 ==> evaporation is performed * | |
696 | * * | |
697 | * what (1) = i1 + i2*10 + i3*100 + i4*10000 * | |
698 | * (i1, i2, i3, i4 >= 0 ) * | |
699 | * * | |
700 | * i1 is the flag for selecting the T=0 level density option used * | |
701 | * = 1: standard EVAP level densities with Cook pairing * | |
702 | * energies * | |
703 | * = 2: Z,N-dependent Gilbert & Cameron level densities * | |
704 | * (default) * | |
705 | * = 3: Julich A-dependent level densities * | |
706 | * = 4: Z,N-dependent Brancazio & Cameron level densities * | |
707 | * * | |
708 | * i2 >= 1: high energy fission activated * | |
709 | * (default high energy fission activated) * | |
710 | * * | |
711 | * i3 = 0: No energy dependence for level densities * | |
712 | * = 1: Standard Ignyatuk (1975, 1st) energy dependence * | |
713 | * for level densities (default) * | |
714 | * = 2: Standard Ignyatuk (1975, 1st) energy dependence * | |
715 | * for level densities with NOT used set of parameters * | |
716 | * = 3: Standard Ignyatuk (1975, 1st) energy dependence * | |
717 | * for level densities with NOT used set of parameters * | |
718 | * = 4: Second Ignyatuk (1975, 2nd) energy dependence * | |
719 | * for level densities * | |
720 | * = 5: Second Ignyatuk (1975, 2nd) energy dependence * | |
721 | * for level densities with fit 1 Iljinov & Mebel set of * | |
722 | * parameters * | |
723 | * = 6: Second Ignyatuk (1975, 2nd) energy dependence * | |
724 | * for level densities with fit 2 Iljinov & Mebel set of * | |
725 | * parameters * | |
726 | * = 7: Second Ignyatuk (1975, 2nd) energy dependence * | |
727 | * for level densities with fit 3 Iljinov & Mebel set of * | |
728 | * parameters * | |
729 | * = 8: Second Ignyatuk (1975, 2nd) energy dependence * | |
730 | * for level densities with fit 4 Iljinov & Mebel set of * | |
731 | * parameters * | |
732 | * * | |
733 | * i4 >= 1: Original Gilbert and Cameron pairing energies used * | |
734 | * (default Cook's modified pairing energies) * | |
735 | * * | |
736 | * what (2) = ig + 10 * if (ig and if must have the same sign) * | |
737 | * * | |
738 | * ig =< -1 ==> deexcitation gammas are not produced * | |
739 | * (if the evaporation step is not performed * | |
740 | * they are never produced) * | |
741 | * if =< -1 ==> Fermi Break Up is not invoked * | |
742 | * (if the evaporation step is not performed * | |
743 | * it is never invoked) * | |
744 | * The default is: deexcitation gamma produced and Fermi break up * | |
745 | * activated for the new preequilibrium, not * | |
746 | * activated otherwise. * | |
747 | * what (3..6), sdum no meaning * | |
748 | * * | |
749 | ********************************************************************* | |
750 | ||
751 | 220 CONTINUE | |
752 | WRITE(LOUT,1009) | |
753 | 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since', | |
754 | & ' evaporation modules not available with this version.') | |
755 | LEVPRT = .FALSE. | |
756 | LDEEXG = .FALSE. | |
757 | LHEAVY = .FALSE. | |
758 | LFRMBK = .FALSE. | |
759 | IFISS = 0 | |
760 | IEVFSS = 0 | |
761 | ||
762 | GOTO 10 | |
763 | ||
764 | ********************************************************************* | |
765 | * * | |
766 | * control card: codewd = EMCCHECK * | |
767 | * * | |
768 | * extended energy-momentum / quantum-number conservation check * | |
769 | * * | |
770 | * what (1) = -1 extended check not performed * | |
771 | * default: 1. * | |
772 | * what (2..6), sdum no meaning * | |
773 | * * | |
774 | ********************************************************************* | |
775 | ||
776 | 230 CONTINUE | |
777 | IF (WHAT(1).EQ.-1) THEN | |
778 | LEMCCK = .FALSE. | |
779 | ELSE | |
780 | LEMCCK = .TRUE. | |
781 | ENDIF | |
782 | GOTO 10 | |
783 | ||
784 | ********************************************************************* | |
785 | * * | |
786 | * control card: codewd = MODEL * | |
787 | * * | |
788 | * Model to be used to treat nucleon-nucleon interactions * | |
789 | * * | |
790 | * sdum = DTUNUC two-chain model * | |
791 | * = PHOJET multiple chains including minijets * | |
792 | * = LEPTO DIS * | |
793 | * = QNEUTRIN quasi-elastic neutrino scattering * | |
794 | * default: PHOJET * | |
795 | * * | |
796 | * if sdum = LEPTO: * | |
797 | * what (1) (variable INTER) * | |
798 | * = 1 gamma exchange * | |
799 | * = 2 W+- exchange * | |
800 | * = 3 Z0 exchange * | |
801 | * = 4 gamma/Z0 exchange * | |
802 | * * | |
803 | * if sdum = QNEUTRIN: * | |
804 | * what (1) = 0 elastic scattering on nucleon and * | |
805 | * tau does not decay (default) * | |
806 | * = 1 decay of tau into mu.. * | |
807 | * = 2 decay of tau into e.. * | |
808 | * = 10 CC events on p and n * | |
809 | * = 11 NC events on p and n * | |
810 | * * | |
811 | * what (2..6) no meaning * | |
812 | * * | |
813 | ********************************************************************* | |
814 | ||
815 | 240 CONTINUE | |
816 | IF (SDUM.EQ.CMODEL(1)) THEN | |
817 | MCGENE = 1 | |
818 | ELSEIF (SDUM.EQ.CMODEL(2)) THEN | |
819 | MCGENE = 2 | |
820 | ELSEIF (SDUM.EQ.CMODEL(3)) THEN | |
821 | MCGENE = 3 | |
822 | IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0)) | |
823 | & INTER = INT(WHAT(1)) | |
824 | ELSEIF (SDUM.EQ.CMODEL(4)) THEN | |
825 | MCGENE = 4 | |
826 | IWHAT = INT(WHAT(1)) | |
827 | IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR. | |
828 | & (IWHAT.EQ.10).OR.(IWHAT.EQ.11)) | |
829 | & NEUDEC = IWHAT | |
830 | ELSE | |
831 | STOP ' Unknown model !' | |
832 | ENDIF | |
833 | GOTO 10 | |
834 | ||
835 | ********************************************************************* | |
836 | * * | |
837 | * control card: codewd = PHOINPUT * | |
838 | * * | |
839 | * Start of input-section for PHOJET-specific input-cards * | |
840 | * Note: This section will not be finished before giving * | |
841 | * ENDINPUT-card * | |
842 | * what (1..6), sdum no meaning * | |
843 | * * | |
844 | ********************************************************************* | |
845 | ||
846 | 250 CONTINUE | |
847 | IF (LPHOIN) THEN | |
848 | CALL PHO_INIT(LINP,LOUT,IREJ1) | |
849 | IF (IREJ1.NE.0) THEN | |
850 | WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed' | |
851 | STOP | |
852 | ENDIF | |
853 | LPHOIN = .FALSE. | |
854 | ENDIF | |
855 | GOTO 10 | |
856 | ||
857 | ********************************************************************* | |
858 | * * | |
859 | * control card: codewd = GLAUBERI * | |
860 | * * | |
861 | * Pre-initialization of impact parameter selection * | |
862 | * * | |
863 | * what (1..6), sdum no meaning * | |
864 | * * | |
865 | ********************************************************************* | |
866 | ||
867 | 260 CONTINUE | |
868 | IF (IFIRST.NE.99) THEN | |
869 | CALL DT_RNDMST(12,34,56,78) | |
870 | CALL DT_RNDMTE(1) | |
871 | OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN') | |
872 | C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN') | |
873 | IFIRST = 99 | |
874 | ENDIF | |
875 | ||
876 | IPPN = 8 | |
877 | PLOW = 10.0D0 | |
878 | C IPPN = 1 | |
879 | C PLOW = 100.0D0 | |
880 | PHI = 1.0D5 | |
881 | APLOW = LOG10(PLOW) | |
882 | APHI = LOG10(PHI) | |
883 | ADP = (APHI-APLOW)/DBLE(IPPN) | |
884 | ||
885 | IPLOW = 1 | |
886 | IDIP = 1 | |
887 | IIP = 5 | |
888 | C IPLOW = 1 | |
889 | C IDIP = 1 | |
890 | C IIP = 1 | |
891 | IPRANG(1) = 1 | |
892 | IPRANG(2) = 2 | |
893 | IPRANG(3) = 5 | |
894 | IPRANG(4) = 10 | |
895 | IPRANG(5) = 20 | |
896 | ||
897 | ITLOW = 30 | |
898 | IDIT = 3 | |
899 | IIT = 60 | |
900 | C IDIT = 10 | |
901 | C IIT = 21 | |
902 | ||
903 | DO 473 NCIT=1,IIT | |
904 | IT = ITLOW+(NCIT-1)*IDIT | |
905 | C IPHI = IT | |
906 | C IDIP = 10 | |
907 | C IIP = (IPHI-IPLOW)/IDIP | |
908 | C IF (IIP.EQ.0) IIP = 1 | |
909 | C IF (IT.EQ.IPLOW) IIP = 0 | |
910 | ||
911 | DO 472 NCIP=1,IIP | |
912 | IP = IPRANG(NCIP) | |
913 | CC IF (NCIP.LE.IIP) THEN | |
914 | C IP = IPLOW+(NCIP-1)*IDIP | |
915 | CC ELSE | |
916 | CC IP = IT | |
917 | CC ENDIF | |
918 | IF (IP.GT.IT) GOTO 472 | |
919 | ||
920 | DO 471 NCP=1,IPPN+1 | |
921 | APPN = APLOW+DBLE(NCP-1)*ADP | |
922 | PPN = 10**APPN | |
923 | ||
924 | OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN') | |
925 | WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN | |
926 | CLOSE(12) | |
927 | ||
928 | XLIM1 = 0.0D0 | |
929 | XLIM2 = 50.0D0 | |
930 | XLIM3 = ZERO | |
931 | IBIN = 50 | |
932 | CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM) | |
933 | CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA) | |
934 | ||
935 | NEVFIT = 5 | |
936 | C IF ((IP.GT.10).OR.(IT.GT.10)) THEN | |
937 | C NEVFIT = 5 | |
938 | C ELSE | |
939 | C NEVFIT = 10 | |
940 | C ENDIF | |
941 | SIGAV = 0.0D0 | |
942 | ||
943 | DO 478 I=1,NEVFIT | |
944 | CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99) | |
945 | SIGAV = SIGAV+XSPRO(1,1,1) | |
946 | DO 479 J=1,50 | |
947 | XC = DBLE(J) | |
948 | CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I) | |
949 | 479 CONTINUE | |
950 | 478 CONTINUE | |
951 | ||
952 | CALL DT_EVTHIS(IDUM) | |
953 | HEADER = ' BSITE' | |
954 | C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1) | |
955 | ||
956 | C CALL GENFIT(XPARA) | |
957 | C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)') | |
958 | C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA | |
959 | ||
960 | 471 CONTINUE | |
961 | ||
962 | 472 CONTINUE | |
963 | ||
964 | 473 CONTINUE | |
965 | ||
966 | STOP | |
967 | ||
968 | ********************************************************************* | |
969 | * * | |
970 | * control card: codewd = FLUCTUAT * | |
971 | * * | |
972 | * Treatment of cross section fluctuations * | |
973 | * * | |
974 | * what (1) = 1 treat cross section fluctuations * | |
975 | * default: 0. * | |
976 | * what (1..6), sdum no meaning * | |
977 | * * | |
978 | ********************************************************************* | |
979 | ||
980 | 270 CONTINUE | |
981 | IFLUCT = 0 | |
982 | IF (WHAT(1).EQ.ONE) THEN | |
983 | IFLUCT = 1 | |
984 | CALL DT_FLUINI | |
985 | ENDIF | |
986 | GOTO 10 | |
987 | ||
988 | ********************************************************************* | |
989 | * * | |
990 | * control card: codewd = CENTRAL * | |
991 | * * | |
992 | * what (1) = 1. central production forced default: 0 * | |
993 | * if what (1) < 0 and > -100 * | |
994 | * what (2) = min. impact parameter default: 0 * | |
995 | * what (3) = max. impact parameter default: b_max * | |
996 | * if what (1) < -99 * | |
997 | * what (2) = fraction of cross section default: 1 * | |
998 | * if what (1) = -1 : evaporation/fzc suppressed * | |
999 | * if what (1) < -1 : evaporation/fzc allowed * | |
1000 | * * | |
1001 | * what (4..6), sdum no meaning * | |
1002 | * * | |
1003 | ********************************************************************* | |
1004 | ||
1005 | 280 CONTINUE | |
1006 | ICENTR = INT(WHAT(1)) | |
1007 | IF (ICENTR.LT.0) THEN | |
1008 | IF (ICENTR.GT.-100) THEN | |
1009 | BIMIN = WHAT(2) | |
1010 | BIMAX = WHAT(3) | |
1011 | ELSE | |
1012 | XSFRAC = WHAT(2) | |
1013 | ENDIF | |
1014 | ENDIF | |
1015 | GOTO 10 | |
1016 | ||
1017 | ********************************************************************* | |
1018 | * * | |
1019 | * control card: codewd = RECOMBIN * | |
1020 | * * | |
1021 | * Chain recombination * | |
1022 | * (recombine S-S and V-V chains to V-S chains) * | |
1023 | * * | |
1024 | * what (1) = -1. recombination switched off default: 1 * | |
1025 | * what (2..6), sdum no meaning * | |
1026 | * * | |
1027 | ********************************************************************* | |
1028 | ||
1029 | 290 CONTINUE | |
1030 | IRECOM = 1 | |
1031 | IF (WHAT(1).EQ.-1.0D0) IRECOM = 0 | |
1032 | GOTO 10 | |
1033 | ||
1034 | ********************************************************************* | |
1035 | * * | |
1036 | * control card: codewd = COMBIJET * | |
1037 | * * | |
1038 | * chain fusion (2 q-aq --> qq-aqaq) * | |
1039 | * * | |
1040 | * what (1) = 1 fusion treated * | |
1041 | * default: 0. * | |
1042 | * what (2) minimum number of uncombined chains from * | |
1043 | * single projectile or target nucleons * | |
1044 | * default: 0. * | |
1045 | * what (3..6), sdum no meaning * | |
1046 | * * | |
1047 | ********************************************************************* | |
1048 | ||
1049 | 300 CONTINUE | |
1050 | LCO2CR = .FALSE. | |
1051 | IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE. | |
1052 | IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2) | |
1053 | GOTO 10 | |
1054 | ||
1055 | ********************************************************************* | |
1056 | * * | |
1057 | * control card: codewd = XCUTS * | |
1058 | * * | |
1059 | * thresholds for x-sampling * | |
1060 | * * | |
1061 | * what (1) defines lower threshold for val.-q x-value (CVQ) * | |
1062 | * default: 1. * | |
1063 | * what (2) defines lower threshold for val.-qq x-value (CDQ) * | |
1064 | * default: 2. * | |
1065 | * what (3) defines lower threshold for sea-q x-value (CSEA) * | |
1066 | * default: 0.2 * | |
1067 | * what (4) sea-q x-values in S-S chains (SSMIMA) * | |
1068 | * default: 0.14 * | |
1069 | * what (5) not used * | |
1070 | * default: 2. * | |
1071 | * what (6), sdum no meaning * | |
1072 | * * | |
1073 | * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM * | |
1074 | * * | |
1075 | ********************************************************************* | |
1076 | ||
1077 | 310 CONTINUE | |
1078 | IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1) | |
1079 | IF (WHAT(2).GE.ONE) CDQ = WHAT(2) | |
1080 | IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3) | |
1081 | IF (WHAT(4).GE.ZERO) THEN | |
1082 | SSMIMA = WHAT(4) | |
1083 | SSMIMQ = SSMIMA**2 | |
1084 | ENDIF | |
1085 | IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5) | |
1086 | GOTO 10 | |
1087 | ||
1088 | ********************************************************************* | |
1089 | * * | |
1090 | * control card: codewd = INTPT * | |
1091 | * * | |
1092 | * what (1) = -1 intrinsic transverse momenta of partons * | |
1093 | * not treated default: 1 * | |
1094 | * what (2..6), sdum no meaning * | |
1095 | * * | |
1096 | ********************************************************************* | |
1097 | ||
1098 | 320 CONTINUE | |
1099 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1100 | LINTPT = .FALSE. | |
1101 | ELSE | |
1102 | LINTPT = .TRUE. | |
1103 | ENDIF | |
1104 | GOTO 10 | |
1105 | ||
1106 | ********************************************************************* | |
1107 | * * | |
1108 | * control card: codewd = CRONINPT * | |
1109 | * * | |
1110 | * Cronin effect (multiple scattering of partons at chain ends) * | |
1111 | * * | |
1112 | * what (1) = -1 Cronin effect not treated default: 1 * | |
1113 | * what (2) = 0 scattering parameter default: 0.64 * | |
1114 | * what (3..6), sdum no meaning * | |
1115 | * * | |
1116 | ********************************************************************* | |
1117 | ||
1118 | 330 CONTINUE | |
1119 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1120 | MKCRON = 0 | |
1121 | ELSE | |
1122 | MKCRON = 1 | |
1123 | ENDIF | |
1124 | CRONCO = WHAT(2) | |
1125 | GOTO 10 | |
1126 | ||
1127 | ********************************************************************* | |
1128 | * * | |
1129 | * control card: codewd = SEADISTR * | |
1130 | * * | |
1131 | * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. * | |
1132 | * what (2) (UNON) default: 2. * | |
1133 | * what (3) (UNOM) default: 1.5 * | |
1134 | * what (4) (UNOSEA) default: 5. * | |
1135 | * qdis(x) prop. (1-x)**what (1) etc. * | |
1136 | * what (5..6), sdum no meaning * | |
1137 | * * | |
1138 | ********************************************************************* | |
1139 | ||
1140 | 340 CONTINUE | |
1141 | XSEACO = WHAT(1) | |
1142 | XSEACU = 1.05D0-XSEACO | |
1143 | UNON = WHAT(2) | |
1144 | IF (UNON.LT.0.1D0) UNON = 2.0D0 | |
1145 | UNOM = WHAT(3) | |
1146 | IF (UNOM.LT.0.1D0) UNOM = 1.5D0 | |
1147 | UNOSEA = WHAT(4) | |
1148 | IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0 | |
1149 | GOTO 10 | |
1150 | ||
1151 | ********************************************************************* | |
1152 | * * | |
1153 | * control card: codewd = SEASU3 * | |
1154 | * * | |
1155 | * Treatment of strange-quarks at chain ends * | |
1156 | * * | |
1157 | * what (1) (SEASQ) strange-quark supression factor * | |
1158 | * iflav = 1.+rndm*(2.+SEASQ) * | |
1159 | * default: 1. * | |
1160 | * what (2..6), sdum no meaning * | |
1161 | * * | |
1162 | ********************************************************************* | |
1163 | ||
1164 | 350 CONTINUE | |
1165 | SEASQ = WHAT(1) | |
1166 | GOTO 10 | |
1167 | ||
1168 | ********************************************************************* | |
1169 | * * | |
1170 | * control card: codewd = DIQUARKS * | |
1171 | * * | |
1172 | * what (1) = -1. sea-diquark/antidiquark-pairs not treated * | |
1173 | * default: 1. * | |
1174 | * what (2..6), sdum no meaning * | |
1175 | * * | |
1176 | ********************************************************************* | |
1177 | ||
1178 | 360 CONTINUE | |
1179 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1180 | LSEADI = .FALSE. | |
1181 | ELSE | |
1182 | LSEADI = .TRUE. | |
1183 | ENDIF | |
1184 | GOTO 10 | |
1185 | ||
1186 | ********************************************************************* | |
1187 | * * | |
1188 | * control card: codewd = RESONANC * | |
1189 | * * | |
1190 | * treatment of low mass chains * | |
1191 | * * | |
1192 | * what (1) = -1 low chain masses are not corrected for resonance * | |
1193 | * masses (obsolete for BAMJET-fragmentation) * | |
1194 | * default: 1. * | |
1195 | * what (2) = -1 massless partons default: 1. (massive) * | |
1196 | * default: 1. (massive) * | |
1197 | * what (3) = -1 chain-system containing chain of too small * | |
1198 | * mass is rejected (note: this does not fully * | |
1199 | * apply to S-S chains) default: 0. * | |
1200 | * what (4..6), sdum no meaning * | |
1201 | * * | |
1202 | ********************************************************************* | |
1203 | ||
1204 | 370 CONTINUE | |
1205 | IRESCO = 1 | |
1206 | IMSHL = 1 | |
1207 | IRESRJ = 0 | |
1208 | IF (WHAT(1).EQ.-ONE) IRESCO = 0 | |
1209 | IF (WHAT(2).EQ.-ONE) IMSHL = 0 | |
1210 | IF (WHAT(3).EQ.-ONE) IRESRJ = 1 | |
1211 | GOTO 10 | |
1212 | ||
1213 | ********************************************************************* | |
1214 | * * | |
1215 | * control card: codewd = DIFFRACT * | |
1216 | * * | |
1217 | * Treatment of diffractive events * | |
1218 | * * | |
1219 | * what (1) = (ISINGD) 0 no single diffraction * | |
1220 | * 1 single diffraction included * | |
1221 | * +-2 single diffractive events only * | |
1222 | * +-3 projectile single diffraction only * | |
1223 | * +-4 target single diffraction only * | |
1224 | * -5 double pomeron exchange only * | |
1225 | * (neg. sign applies to PHOJET events) * | |
1226 | * default: 0. * | |
1227 | * * | |
1228 | * what (2) = (IDOUBD) 0 no double diffraction * | |
1229 | * 1 double diffraction included * | |
1230 | * 2 double diffractive events only * | |
1231 | * default: 0. * | |
1232 | * what (3) = 1 projectile diffraction treated (2-channel form.) * | |
1233 | * default: 0. * | |
1234 | * what (4) = alpha-parameter in projectile diffraction * | |
1235 | * default: 0. * | |
1236 | * what (5..6), sdum no meaning * | |
1237 | * * | |
1238 | ********************************************************************* | |
1239 | ||
1240 | 380 CONTINUE | |
1241 | IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1)) | |
1242 | IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2)) | |
1243 | IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN | |
1244 | WRITE(LOUT,1380) | |
1245 | 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/, | |
1246 | & 11X,'IDOUBD is reset to zero') | |
1247 | IDOUBD = 0 | |
1248 | ENDIF | |
1249 | IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3) | |
1250 | IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4) | |
1251 | GOTO 10 | |
1252 | ||
1253 | ********************************************************************* | |
1254 | * * | |
1255 | * control card: codewd = SINGLECH * | |
1256 | * * | |
1257 | * what (1) = 1. Regge contribution (one chain) included * | |
1258 | * default: 0. * | |
1259 | * what (2..6), sdum no meaning * | |
1260 | * * | |
1261 | ********************************************************************* | |
1262 | ||
1263 | 390 CONTINUE | |
1264 | ISICHA = 0 | |
1265 | IF (WHAT(1).EQ.ONE) ISICHA = 1 | |
1266 | GOTO 10 | |
1267 | ||
1268 | ********************************************************************* | |
1269 | * * | |
1270 | * control card: codewd = NOFRAGME * | |
1271 | * * | |
1272 | * biased chain hadronization * | |
1273 | * * | |
1274 | * what (1..6) = -1 no of hadronizsation of S-S chains * | |
1275 | * = -2 no of hadronizsation of D-S chains * | |
1276 | * = -3 no of hadronizsation of S-D chains * | |
1277 | * = -4 no of hadronizsation of S-V chains * | |
1278 | * = -5 no of hadronizsation of D-V chains * | |
1279 | * = -6 no of hadronizsation of V-S chains * | |
1280 | * = -7 no of hadronizsation of V-D chains * | |
1281 | * = -8 no of hadronizsation of V-V chains * | |
1282 | * = -9 no of hadronizsation of comb. chains * | |
1283 | * default: complete hadronization * | |
1284 | * sdum no meaning * | |
1285 | * * | |
1286 | ********************************************************************* | |
1287 | ||
1288 | 400 CONTINUE | |
1289 | DO 401 I=1,6 | |
1290 | ICHAIN = INT(WHAT(I)) | |
1291 | IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9)) | |
1292 | & LHADRO(ABS(ICHAIN)) = .FALSE. | |
1293 | 401 CONTINUE | |
1294 | GOTO 10 | |
1295 | ||
1296 | ********************************************************************* | |
1297 | * * | |
1298 | * control card: codewd = HADRONIZE * | |
1299 | * * | |
1300 | * hadronization model and parameter switch * | |
1301 | * * | |
1302 | * what (1) = 1 hadronization via BAMJET * | |
1303 | * = 2 hadronization via JETSET * | |
1304 | * default: 2 * | |
1305 | * what (2) = 1..3 parameter set to be used * | |
1306 | * JETSET: 3 sets available * | |
1307 | * ( = 3 default JETSET-parameters) * | |
1308 | * BAMJET: 1 set available * | |
1309 | * default: 1 * | |
1310 | * what (3..6), sdum no meaning * | |
1311 | * * | |
1312 | ********************************************************************* | |
1313 | ||
1314 | 410 CONTINUE | |
1315 | IWHAT1 = INT(WHAT(1)) | |
1316 | IWHAT2 = INT(WHAT(2)) | |
1317 | IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1 | |
1318 | IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3)) | |
1319 | & IFRAG(2) = IWHAT2 | |
1320 | GOTO 10 | |
1321 | ||
1322 | ********************************************************************* | |
1323 | * * | |
1324 | * control card: codewd = POPCORN * | |
1325 | * * | |
1326 | * "Popcorn-effect" in fragmentation and diquark breaking diagrams * | |
1327 | * * | |
1328 | * what (1) = (PDB) frac. of diquark fragmenting directly into * | |
1329 | * baryons (PYTHIA/JETSET fragmentation) * | |
1330 | * (JETSET: = 0. Popcorn mechanism switched off) * | |
1331 | * default: 0.5 * | |
1332 | * what (2) = probability for accepting a diquark breaking * | |
1333 | * diagram involving the generation of a u/d quark- * | |
1334 | * antiquark pair default: 0.0 * | |
1335 | * what (3) = same a what (2), here for s quark-antiquark pair * | |
1336 | * default: 0.0 * | |
1337 | * what (4..6), sdum no meaning * | |
1338 | * * | |
1339 | ********************************************************************* | |
1340 | ||
1341 | 420 CONTINUE | |
1342 | IF (WHAT(1).GE.0.0D0) PDB = WHAT(1) | |
1343 | IF (WHAT(2).GE.0.0D0) THEN | |
1344 | PDBSEA(1) = WHAT(2) | |
1345 | PDBSEA(2) = WHAT(2) | |
1346 | ENDIF | |
1347 | IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3) | |
1348 | DO 421 I=1,8 | |
1349 | DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1)) | |
1350 | DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2)) | |
1351 | DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3)) | |
1352 | 421 CONTINUE | |
1353 | GOTO 10 | |
1354 | ||
1355 | ********************************************************************* | |
1356 | * * | |
1357 | * control card: codewd = PARDECAY * | |
1358 | * * | |
1359 | * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET * | |
1360 | * = 2. pion^0 decay after intranucl. cascade * | |
1361 | * default: no decay * | |
1362 | * what (2..6), sdum no meaning * | |
1363 | * * | |
1364 | ********************************************************************* | |
1365 | ||
1366 | 430 CONTINUE | |
1367 | IF (WHAT(1).EQ.ONE) ISIG0 = 1 | |
1368 | IF (WHAT(1).EQ.2.0D0) IPI0 = 1 | |
1369 | GOTO 10 | |
1370 | ||
1371 | ********************************************************************* | |
1372 | * * | |
1373 | * control card: codewd = BEAM * | |
1374 | * * | |
1375 | * definition of beam parameters * | |
1376 | * * | |
1377 | * what (1/2) > 0 : energy of beam 1/2 (GeV) * | |
1378 | * < 0 : abs(what(1/2)) energy per charge of * | |
1379 | * beam 1/2 (GeV) * | |
1380 | * (beam 1 is directed into positive z-direction) * | |
1381 | * what (3) beam crossing angle, defined as 2x angle between * | |
1382 | * one beam and the z-axis (micro rad) * | |
1383 | * what (4) angle with x-axis defining the collision plane * | |
1384 | * what (5..6), sdum no meaning * | |
1385 | * * | |
1386 | * Note: this card requires previously defined projectile and * | |
1387 | * target identities (PROJPAR, TARPAR) * | |
1388 | * * | |
1389 | ********************************************************************* | |
1390 | ||
1391 | 440 CONTINUE | |
1392 | CALL DT_BEAMPR(WHAT,PPN,1) | |
1393 | EPN = ZERO | |
1394 | CMENER = ZERO | |
1395 | LEINP = .TRUE. | |
1396 | GOTO 10 | |
1397 | ||
1398 | ********************************************************************* | |
1399 | * * | |
1400 | * control card: codewd = LUND-MSTU * | |
1401 | * * | |
1402 | * set parameter MSTU in JETSET-common /LUDAT1/ * | |
1403 | * * | |
1404 | * what (1) = index according to LUND-common block * | |
1405 | * what (2) = new value of MSTU( int(what(1)) ) * | |
1406 | * what (3), what(4) and what (5), what(6) further * | |
1407 | * parameter in the same way as what (1) and * | |
1408 | * what (2) * | |
1409 | * default: default-Lund or corresponding to * | |
1410 | * the set given in HADRONIZE * | |
1411 | * * | |
1412 | ********************************************************************* | |
1413 | ||
1414 | 450 CONTINUE | |
1415 | IF (WHAT(1).GT.ZERO) THEN | |
1416 | NMSTU = NMSTU+1 | |
1417 | IMSTU(NMSTU) = INT(WHAT(1)) | |
1418 | MSTUX(NMSTU) = INT(WHAT(2)) | |
1419 | ENDIF | |
1420 | IF (WHAT(3).GT.ZERO) THEN | |
1421 | NMSTU = NMSTU+1 | |
1422 | IMSTU(NMSTU) = INT(WHAT(3)) | |
1423 | MSTUX(NMSTU) = INT(WHAT(4)) | |
1424 | ENDIF | |
1425 | IF (WHAT(5).GT.ZERO) THEN | |
1426 | NMSTU = NMSTU+1 | |
1427 | IMSTU(NMSTU) = INT(WHAT(5)) | |
1428 | MSTUX(NMSTU) = INT(WHAT(6)) | |
1429 | ENDIF | |
1430 | GOTO 10 | |
1431 | ||
1432 | ********************************************************************* | |
1433 | * * | |
1434 | * control card: codewd = LUND-MSTJ * | |
1435 | * * | |
1436 | * set parameter MSTJ in JETSET-common /LUDAT1/ * | |
1437 | * * | |
1438 | * what (1) = index according to LUND-common block * | |
1439 | * what (2) = new value of MSTJ( int(what(1)) ) * | |
1440 | * what (3), what(4) and what (5), what(6) further * | |
1441 | * parameter in the same way as what (1) and * | |
1442 | * what (2) * | |
1443 | * default: default-Lund or corresponding to * | |
1444 | * the set given in HADRONIZE * | |
1445 | * * | |
1446 | ********************************************************************* | |
1447 | ||
1448 | 451 CONTINUE | |
1449 | IF (WHAT(1).GT.ZERO) THEN | |
1450 | NMSTJ = NMSTJ+1 | |
1451 | IMSTJ(NMSTJ) = INT(WHAT(1)) | |
1452 | MSTJX(NMSTJ) = INT(WHAT(2)) | |
1453 | ENDIF | |
1454 | IF (WHAT(3).GT.ZERO) THEN | |
1455 | NMSTJ = NMSTJ+1 | |
1456 | IMSTJ(NMSTJ) = INT(WHAT(3)) | |
1457 | MSTJX(NMSTJ) = INT(WHAT(4)) | |
1458 | ENDIF | |
1459 | IF (WHAT(5).GT.ZERO) THEN | |
1460 | NMSTJ = NMSTJ+1 | |
1461 | IMSTJ(NMSTJ) = INT(WHAT(5)) | |
1462 | MSTJX(NMSTJ) = INT(WHAT(6)) | |
1463 | ENDIF | |
1464 | GOTO 10 | |
1465 | ||
1466 | ********************************************************************* | |
1467 | * * | |
1468 | * control card: codewd = LUND-MDCY * | |
1469 | * * | |
1470 | * set parameter MDCY(I,1) for particle decays in JETSET-common * | |
1471 | * /LUDAT3/ * | |
1472 | * * | |
1473 | * what (1-6) = PDG particle index of particle which should * | |
1474 | * not decay * | |
1475 | * default: default-Lund or forced in * | |
1476 | * DT_INITJS * | |
1477 | * * | |
1478 | ********************************************************************* | |
1479 | ||
1480 | 452 CONTINUE | |
1481 | DO 4521 I=1,6 | |
1482 | IF (WHAT(I).NE.ZERO) THEN | |
1483 | KC = PYCOMP(INT(WHAT(I))) | |
1484 | MDCY(KC,1) = 0 | |
1485 | ENDIF | |
1486 | 4521 CONTINUE | |
1487 | GOTO 10 | |
1488 | ||
1489 | ********************************************************************* | |
1490 | * * | |
1491 | * control card: codewd = LUND-PARJ * | |
1492 | * * | |
1493 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1494 | * * | |
1495 | * what (1) = index according to LUND-common block * | |
1496 | * what (2) = new value of PARJ( int(what(1)) ) * | |
1497 | * what (3), what(4) and what (5), what(6) further * | |
1498 | * parameter in the same way as what (1) and * | |
1499 | * what (2) * | |
1500 | * default: default-Lund or corresponding to * | |
1501 | * the set given in HADRONIZE * | |
1502 | * * | |
1503 | ********************************************************************* | |
1504 | ||
1505 | 460 CONTINUE | |
1506 | IF (WHAT(1).NE.ZERO) THEN | |
1507 | NPARJ = NPARJ+1 | |
1508 | IPARJ(NPARJ) = INT(WHAT(1)) | |
1509 | PARJX(NPARJ) = WHAT(2) | |
1510 | ENDIF | |
1511 | IF (WHAT(3).NE.ZERO) THEN | |
1512 | NPARJ = NPARJ+1 | |
1513 | IPARJ(NPARJ) = INT(WHAT(3)) | |
1514 | PARJX(NPARJ) = WHAT(4) | |
1515 | ENDIF | |
1516 | IF (WHAT(5).NE.ZERO) THEN | |
1517 | NPARJ = NPARJ+1 | |
1518 | IPARJ(NPARJ) = INT(WHAT(5)) | |
1519 | PARJX(NPARJ) = WHAT(6) | |
1520 | ENDIF | |
1521 | GOTO 10 | |
1522 | ||
1523 | ********************************************************************* | |
1524 | * * | |
1525 | * control card: codewd = LUND-PARU * | |
1526 | * * | |
1527 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1528 | * * | |
1529 | * what (1) = index according to LUND-common block * | |
1530 | * what (2) = new value of PARU( int(what(1)) ) * | |
1531 | * what (3), what(4) and what (5), what(6) further * | |
1532 | * parameter in the same way as what (1) and * | |
1533 | * what (2) * | |
1534 | * default: default-Lund or corresponding to * | |
1535 | * the set given in HADRONIZE * | |
1536 | * * | |
1537 | ********************************************************************* | |
1538 | ||
1539 | 470 CONTINUE | |
1540 | IF (WHAT(1).GT.ZERO) THEN | |
1541 | NPARU = NPARU+1 | |
1542 | IPARU(NPARU) = INT(WHAT(1)) | |
1543 | PARUX(NPARU) = WHAT(2) | |
1544 | ENDIF | |
1545 | IF (WHAT(3).GT.ZERO) THEN | |
1546 | NPARU = NPARU+1 | |
1547 | IPARU(NPARU) = INT(WHAT(3)) | |
1548 | PARUX(NPARU) = WHAT(4) | |
1549 | ENDIF | |
1550 | IF (WHAT(5).GT.ZERO) THEN | |
1551 | NPARU = NPARU+1 | |
1552 | IPARU(NPARU) = INT(WHAT(5)) | |
1553 | PARUX(NPARU) = WHAT(6) | |
1554 | ENDIF | |
1555 | GOTO 10 | |
1556 | ||
1557 | ********************************************************************* | |
1558 | * * | |
1559 | * control card: codewd = OUTLEVEL * | |
1560 | * * | |
1561 | * output control switches * | |
1562 | * * | |
1563 | * what (1) = internal rejection informations default: 0 * | |
1564 | * what (2) = energy-momentum conservation check output * | |
1565 | * default: 0 * | |
1566 | * what (3) = internal warning messages default: 0 * | |
1567 | * what (4..6), sdum not yet used * | |
1568 | * * | |
1569 | ********************************************************************* | |
1570 | ||
1571 | 480 CONTINUE | |
1572 | DO 481 K=1,6 | |
1573 | IOULEV(K) = INT(WHAT(K)) | |
1574 | 481 CONTINUE | |
1575 | GOTO 10 | |
1576 | ||
1577 | ********************************************************************* | |
1578 | * * | |
1579 | * control card: codewd = FRAME * | |
1580 | * * | |
1581 | * frame in which final state is given in DTEVT1 * | |
1582 | * * | |
1583 | * what (1) = 1 target rest frame (laboratory) * | |
1584 | * = 2 nucleon-nucleon cms * | |
1585 | * default: 1 * | |
1586 | * * | |
1587 | ********************************************************************* | |
1588 | ||
1589 | 490 CONTINUE | |
1590 | KFRAME = INT(WHAT(1)) | |
1591 | IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME | |
1592 | GOTO 10 | |
1593 | ||
1594 | ********************************************************************* | |
1595 | * * | |
1596 | * control card: codewd = L-TAG * | |
1597 | * * | |
1598 | * lepton tagger: * | |
1599 | * definition of kinematical cuts for radiated photon and * | |
1600 | * outgoing lepton detection in lepton-nucleus interactions * | |
1601 | * * | |
1602 | * what (1) = y_min * | |
1603 | * what (2) = y_max * | |
1604 | * what (3) = Q^2_min * | |
1605 | * what (4) = Q^2_max * | |
1606 | * what (5) = theta_min (Lab) * | |
1607 | * what (6) = theta_max (Lab) * | |
1608 | * default: no cuts * | |
1609 | * sdum no meaning * | |
1610 | * * | |
1611 | ********************************************************************* | |
1612 | ||
1613 | 500 CONTINUE | |
1614 | YMIN = WHAT(1) | |
1615 | YMAX = WHAT(2) | |
1616 | Q2MIN = WHAT(3) | |
1617 | Q2MAX = WHAT(4) | |
1618 | THMIN = WHAT(5) | |
1619 | THMAX = WHAT(6) | |
1620 | GOTO 10 | |
1621 | ||
1622 | ********************************************************************* | |
1623 | * * | |
1624 | * control card: codewd = L-ETAG * | |
1625 | * * | |
1626 | * lepton tagger: * | |
1627 | * what (1) = min. outgoing lepton energy (in Lab) * | |
1628 | * what (2) = min. photon energy (in Lab) * | |
1629 | * what (3) = max. photon energy (in Lab) * | |
1630 | * default: no cuts * | |
1631 | * what (2..6), sdum no meaning * | |
1632 | * * | |
1633 | ********************************************************************* | |
1634 | ||
1635 | 510 CONTINUE | |
1636 | ELMIN = MAX(WHAT(1),ZERO) | |
1637 | EGMIN = MAX(WHAT(2),ZERO) | |
1638 | EGMAX = MAX(WHAT(3),ZERO) | |
1639 | GOTO 10 | |
1640 | ||
1641 | ********************************************************************* | |
1642 | * * | |
1643 | * control card: codewd = ECMS-CUT * | |
1644 | * * | |
1645 | * what (1) = min. c.m. energy to be sampled * | |
1646 | * what (2) = max. c.m. energy to be sampled * | |
1647 | * what (3) = min x_Bj to be sampled * | |
1648 | * default: no cuts * | |
1649 | * what (3..6), sdum no meaning * | |
1650 | * * | |
1651 | ********************************************************************* | |
1652 | ||
1653 | 520 CONTINUE | |
1654 | ECMIN = WHAT(1) | |
1655 | ECMAX = WHAT(2) | |
1656 | IF (ECMIN.GT.ECMAX) ECMIN = ECMAX | |
1657 | XBJMIN = MAX(WHAT(3),ZERO) | |
1658 | GOTO 10 | |
1659 | ||
1660 | ********************************************************************* | |
1661 | * * | |
1662 | * control card: codewd = VDM-PAR1 * | |
1663 | * * | |
1664 | * parameters in gamma-nucleus cross section calculation * | |
1665 | * * | |
1666 | * what (1) = Lambda^2 default: 2. * | |
1667 | * what (2) lower limit in M^2 integration * | |
1668 | * = 1 (3m_pi)^2 * | |
1669 | * = 2 (m_rho0)^2 * | |
1670 | * = 3 (m_phi)^2 default: 1 * | |
1671 | * what (3) upper limit in M^2 integration * | |
1672 | * = 1 s/2 * | |
1673 | * = 2 s/4 * | |
1674 | * = 3 s default: 3 * | |
1675 | * what (4) CKMT F_2 structure function * | |
1676 | * = 2212 proton * | |
1677 | * = 100 deuteron default: 2212 * | |
1678 | * what (5) calculation of gamma-nucleon xsections * | |
1679 | * = 1 according to CKMT-parametrization of F_2 * | |
1680 | * = 2 integrating SIGVP over M^2 * | |
1681 | * = 3 using SIGGA * | |
1682 | * = 4 PHOJET cross sections default: 4 * | |
1683 | * * | |
1684 | * what (6), sdum no meaning * | |
1685 | * * | |
1686 | ********************************************************************* | |
1687 | ||
1688 | 530 CONTINUE | |
1689 | IF (WHAT(1).GE.ZERO) RL2 = WHAT(1) | |
1690 | IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2)) | |
1691 | IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3)) | |
1692 | IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4)) | |
1693 | IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5)) | |
1694 | GOTO 10 | |
1695 | ||
1696 | ********************************************************************* | |
1697 | * * | |
1698 | * control card: codewd = HISTOGRAM * | |
1699 | * * | |
1700 | * activate different classes of histograms * | |
1701 | * * | |
1702 | * default: no histograms * | |
1703 | * * | |
1704 | ********************************************************************* | |
1705 | ||
1706 | 540 CONTINUE | |
1707 | DO 541 J=1,6 | |
1708 | IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN | |
1709 | IHISPP(INT(WHAT(J))-100) = 1 | |
1710 | ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN | |
1711 | IHISXS(INT(ABS(WHAT(J)))-200) = 1 | |
1712 | IF (WHAT(J).LT.ZERO) IXSTBL = 1 | |
1713 | ENDIF | |
1714 | 541 CONTINUE | |
1715 | GOTO 10 | |
1716 | ||
1717 | ********************************************************************* | |
1718 | * * | |
1719 | * control card: codewd = XS-TABLE * | |
1720 | * * | |
1721 | * output of cross section table for requested interaction * | |
1722 | * - particle production deactivated ! - * | |
1723 | * * | |
1724 | * what (1) lower energy limit for tabulation * | |
1725 | * > 0 Lab. frame * | |
1726 | * < 0 nucleon-nucleon cms * | |
1727 | * what (2) upper energy limit for tabulation * | |
1728 | * > 0 Lab. frame * | |
1729 | * < 0 nucleon-nucleon cms * | |
1730 | * what (3) > 0 # of equidistant lin. bins in E * | |
1731 | * < 0 # of equidistant log. bins in E * | |
1732 | * what (4) lower limit of particle virtuality (photons) * | |
1733 | * what (5) upper limit of particle virtuality (photons) * | |
1734 | * what (6) > 0 # of equidistant lin. bins in Q^2 * | |
1735 | * < 0 # of equidistant log. bins in Q^2 * | |
1736 | * * | |
1737 | ********************************************************************* | |
1738 | ||
1739 | 550 CONTINUE | |
1740 | IF (WHAT(1).EQ.99999.0D0) THEN | |
1741 | IRATIO = INT(WHAT(2)) | |
1742 | GOTO 10 | |
1743 | ENDIF | |
1744 | CMENER = ABS(WHAT(2)) | |
1745 | IF (.NOT.LXSTAB) THEN | |
1746 | CALL DT_BERTTP | |
1747 | CALL DT_INCINI | |
1748 | ENDIF | |
1749 | IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN | |
1750 | CMEOLD = CMENER | |
1751 | IF (WHAT(2).GT.ZERO) | |
1752 | & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1)) | |
1753 | EPN = ZERO | |
1754 | PPN = ZERO | |
1755 | C WRITE(LOUT,*) 'CMENER = ',CMENER | |
1756 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1) | |
1757 | CALL DT_PHOINI | |
1758 | ENDIF | |
1759 | CALL DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
1760 | IXSQEL = 0 | |
1761 | LXSTAB = .TRUE. | |
1762 | GOTO 10 | |
1763 | ||
1764 | ********************************************************************* | |
1765 | * * | |
1766 | * control card: codewd = GLAUB-PAR * | |
1767 | * * | |
1768 | * parameters in Glauber-formalism * | |
1769 | * * | |
1770 | * what (1) # of nucleon configurations sampled in integration * | |
1771 | * over nuclear desity default: 1000 * | |
1772 | * what (2) # of bins for integration over impact-parameter and * | |
1773 | * for profile-function calculation default: 49 * | |
1774 | * what (3) = 1 calculation of tot., el. and qel. cross sections * | |
1775 | * default: 0 * | |
1776 | * what (4) = 1 read pre-calculated impact-parameter distrib. * | |
1777 | * from "sdum".glb * | |
1778 | * =-1 dump pre-calculated impact-parameter distrib. * | |
1779 | * into "sdum".glb * | |
1780 | * = 100 read pre-calculated impact-parameter distrib. * | |
1781 | * for variable projectile/target/energy runs * | |
1782 | * from "sdum".glb * | |
1783 | * default: 0 * | |
1784 | * what (5..6) no meaning * | |
1785 | * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) * | |
1786 | * * | |
1787 | ********************************************************************* | |
1788 | ||
1789 | 560 CONTINUE | |
1790 | IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1)) | |
1791 | IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2)) | |
1792 | IF (WHAT(3).EQ.ONE) LPROD = .FALSE. | |
1793 | IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN | |
1794 | IOGLB = INT(WHAT(4)) | |
1795 | CGLB = SDUM | |
1796 | ENDIF | |
1797 | GOTO 10 | |
1798 | ||
1799 | ********************************************************************* | |
1800 | * * | |
1801 | * control card: codewd = GLAUB-INI * | |
1802 | * * | |
1803 | * pre-initialization of profile function * | |
1804 | * * | |
1805 | * what (1) lower energy limit for initialization * | |
1806 | * > 0 Lab. frame * | |
1807 | * < 0 nucleon-nucleon cms * | |
1808 | * what (2) upper energy limit for initialization * | |
1809 | * > 0 Lab. frame * | |
1810 | * < 0 nucleon-nucleon cms * | |
1811 | * what (3) > 0 # of equidistant lin. bins in E * | |
1812 | * < 0 # of equidistant log. bins in E * | |
1813 | * what (4) maximum projectile mass number for which the * | |
1814 | * Glauber data are initialized for each * | |
1815 | * projectile mass number * | |
1816 | * (if <= mass given with the PROJPAR-card) * | |
1817 | * default: 18 * | |
1818 | * what (5) steps in mass number starting from what (4) * | |
1819 | * up to mass number defined with PROJPAR-card * | |
1820 | * for which Glauber data are initialized * | |
1821 | * default: 5 * | |
1822 | * what (6) no meaning * | |
1823 | * sdum no meaning * | |
1824 | * * | |
1825 | ********************************************************************* | |
1826 | ||
1827 | 565 CONTINUE | |
1828 | IOGLB = -100 | |
1829 | CALL DT_GLBINI(WHAT) | |
1830 | GOTO 10 | |
1831 | ||
1832 | ********************************************************************* | |
1833 | * * | |
1834 | * control card: codewd = VDM-PAR2 * | |
1835 | * * | |
1836 | * parameters in gamma-nucleus cross section calculation * | |
1837 | * * | |
1838 | * what (1) = 0 no suppression of shadowing by direct photon * | |
1839 | * processes * | |
1840 | * = 1 suppression .. default: 1 * | |
1841 | * what (2) = 0 no suppression of shadowing by anomalous * | |
1842 | * component if photon-F_2 * | |
1843 | * = 1 suppression .. default: 1 * | |
1844 | * what (3) = 0 no suppression of shadowing by coherence * | |
1845 | * length of the photon * | |
1846 | * = 1 suppression .. default: 1 * | |
1847 | * what (4) = 1 longitudinal polarized photons are taken into * | |
1848 | * account * | |
1849 | * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 * | |
1850 | * what (5..6), sdum no meaning * | |
1851 | * * | |
1852 | ********************************************************************* | |
1853 | ||
1854 | 570 CONTINUE | |
1855 | IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1)) | |
1856 | IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2)) | |
1857 | IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3)) | |
1858 | EPSPOL = WHAT(4) | |
1859 | GOTO 10 | |
1860 | ||
1861 | ********************************************************************* | |
1862 | * * | |
1863 | * control card: XS-QELPRO * | |
1864 | * * | |
1865 | * what (1..6), sdum no meaning * | |
1866 | * * | |
1867 | ********************************************************************* | |
1868 | ||
1869 | 580 CONTINUE | |
1870 | IXSQEL = ABS(WHAT(1)) | |
1871 | GOTO 10 | |
1872 | ||
1873 | ********************************************************************* | |
1874 | * * | |
1875 | * control card: RNDMINIT * | |
1876 | * * | |
1877 | * initialization of random number generator * | |
1878 | * * | |
1879 | * what (1..4) values for initialization (= 1..168) * | |
1880 | * what (5..6), sdum no meaning * | |
1881 | * * | |
1882 | ********************************************************************* | |
1883 | ||
1884 | 590 CONTINUE | |
1885 | IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN | |
1886 | NA1 = 22 | |
1887 | ELSE | |
1888 | NA1 = WHAT(1) | |
1889 | ENDIF | |
1890 | IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN | |
1891 | NA2 = 54 | |
1892 | ELSE | |
1893 | NA2 = WHAT(2) | |
1894 | ENDIF | |
1895 | IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN | |
1896 | NA3 = 76 | |
1897 | ELSE | |
1898 | NA3 = WHAT(3) | |
1899 | ENDIF | |
1900 | IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN | |
1901 | NA4 = 92 | |
1902 | ELSE | |
1903 | NA4 = WHAT(4) | |
1904 | ENDIF | |
1905 | CALL DT_RNDMST(NA1,NA2,NA3,NA4) | |
1906 | GOTO 10 | |
1907 | ||
1908 | ********************************************************************* | |
1909 | * * | |
1910 | * control card: codewd = LEPTO-CUT * | |
1911 | * * | |
1912 | * set parameter CUT in LEPTO-common /LEPTOU/ * | |
1913 | * * | |
1914 | * what (1) = index in CUT-array * | |
1915 | * what (2) = new value of CUT( int(what(1)) ) * | |
1916 | * what (3), what(4) and what (5), what(6) further * | |
1917 | * parameter in the same way as what (1) and * | |
1918 | * what (2) * | |
1919 | * default: default-LEPTO parameters * | |
1920 | * * | |
1921 | ********************************************************************* | |
1922 | ||
1923 | 600 CONTINUE | |
1924 | IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2) | |
1925 | IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4) | |
1926 | IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6) | |
1927 | GOTO 10 | |
1928 | ||
1929 | ********************************************************************* | |
1930 | * * | |
1931 | * control card: codewd = LEPTO-LST * | |
1932 | * * | |
1933 | * set parameter LST in LEPTO-common /LEPTOU/ * | |
1934 | * * | |
1935 | * what (1) = index in LST-array * | |
1936 | * what (2) = new value of LST( int(what(1)) ) * | |
1937 | * what (3), what(4) and what (5), what(6) further * | |
1938 | * parameter in the same way as what (1) and * | |
1939 | * what (2) * | |
1940 | * default: default-LEPTO parameters * | |
1941 | * * | |
1942 | ********************************************************************* | |
1943 | ||
1944 | 610 CONTINUE | |
1945 | IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2)) | |
1946 | IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4)) | |
1947 | IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6)) | |
1948 | GOTO 10 | |
1949 | ||
1950 | ********************************************************************* | |
1951 | * * | |
1952 | * control card: codewd = LEPTO-PARL * | |
1953 | * * | |
1954 | * set parameter PARL in LEPTO-common /LEPTOU/ * | |
1955 | * * | |
1956 | * what (1) = index in PARL-array * | |
1957 | * what (2) = new value of PARL( int(what(1)) ) * | |
1958 | * what (3), what(4) and what (5), what(6) further * | |
1959 | * parameter in the same way as what (1) and * | |
1960 | * what (2) * | |
1961 | * default: default-LEPTO parameters * | |
1962 | * * | |
1963 | ********************************************************************* | |
1964 | ||
1965 | 620 CONTINUE | |
1966 | IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2) | |
1967 | IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4) | |
1968 | IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6) | |
1969 | GOTO 10 | |
1970 | ||
1971 | ********************************************************************* | |
1972 | * * | |
1973 | * control card: codewd = START * | |
1974 | * * | |
1975 | * what (1) = number of events default: 100. * | |
1976 | * what (2) = 0 Glauber initialization follows * | |
1977 | * = 1 Glauber initialization supressed, fitted * | |
1978 | * results are used instead * | |
1979 | * (this does not apply if emulsion-treatment * | |
1980 | * is requested) * | |
1981 | * = 2 Glauber initialization is written to * | |
1982 | * output-file shmakov.out * | |
1983 | * = 3 Glauber initialization is read from input-file * | |
1984 | * shmakov.out default: 0 * | |
1985 | * what (3..6) no meaning * | |
1986 | * what (3..6) no meaning * | |
1987 | * * | |
1988 | ********************************************************************* | |
1989 | ||
1990 | 630 CONTINUE | |
1991 | ||
1992 | * check for cross-section table output only | |
1993 | IF (LXSTAB) STOP | |
1994 | ||
1995 | NCASES = INT(WHAT(1)) | |
1996 | IF (NCASES.LE.0) NCASES = 100 | |
1997 | IGLAU = INT(WHAT(2)) | |
1998 | IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3)) | |
1999 | & IGLAU = 0 | |
2000 | ||
2001 | NPMASS = IP | |
2002 | NPCHAR = IPZ | |
2003 | NTMASS = IT | |
2004 | NTCHAR = ITZ | |
2005 | IDP = IJPROJ | |
2006 | IDT = IJTARG | |
2007 | IF (IDP.LE.0) IDP = 1 | |
2008 | * muon neutrinos: temporary (missing index) | |
2009 | * (new patch in projpar: therefore the following this is probably not | |
2010 | * necessary anymore..) | |
2011 | C IF (IDP.EQ.26) IDP = 5 | |
2012 | C IF (IDP.EQ.27) IDP = 6 | |
2013 | ||
2014 | * redefine collision energy | |
2015 | IF (LEINP) THEN | |
2016 | IF (ABS(VAREHI).GT.ZERO) THEN | |
2017 | PDUM = ZERO | |
2018 | IF (VARELO.LT.EHADLO) VARELO = EHADLO | |
2019 | CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1) | |
2020 | PDUM = ZERO | |
2021 | CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1) | |
2022 | ENDIF | |
2023 | CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1) | |
2024 | ELSE | |
2025 | WRITE(LOUT,1003) | |
2026 | 1003 FORMAT(1X,'INIT: collision energy not defined!',/, | |
2027 | & 1X,' -program stopped- ') | |
2028 | STOP | |
2029 | ENDIF | |
2030 | ||
2031 | * switch off evaporation (even if requested) if central coll. requ. | |
2032 | IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN | |
2033 | IF (LEVPRT) THEN | |
2034 | WRITE(LOUT,1004) | |
2035 | 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', | |
2036 | & ' central collisions forced.') | |
2037 | LEVPRT = .FALSE. | |
2038 | LDEEXG = .FALSE. | |
2039 | LHEAVY = .FALSE. | |
2040 | ENDIF | |
2041 | ENDIF | |
2042 | ||
2043 | * initialization of evaporation-module | |
2044 | ||
2045 | WRITE(LOUT,1010) | |
2046 | 1010 FORMAT(1X,/,'Warning! No evaporation performed since', | |
2047 | & ' evaporation modules not available with this version.') | |
2048 | LEVPRT = .FALSE. | |
2049 | LDEEXG = .FALSE. | |
2050 | LHEAVY = .FALSE. | |
2051 | LFRMBK = .FALSE. | |
2052 | IFISS = 0 | |
2053 | IEVFSS = 0 | |
2054 | CALL DT_BERTTP | |
2055 | CALL DT_INCINI | |
2056 | ||
2057 | * save the default JETSET-parameter | |
2058 | CALL DT_JSPARA(0) | |
2059 | ||
2060 | * force use of phojet for g-A | |
2061 | IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 | |
2062 | * initialization of nucleon-nucleon event generator | |
2063 | IF (MCGENE.EQ.2) CALL DT_PHOINI | |
2064 | * initialization of LEPTO event generator | |
2065 | IF (MCGENE.EQ.3) THEN | |
2066 | ||
2067 | STOP ' This version does not contain LEPTO !' | |
2068 | ||
2069 | ENDIF | |
2070 | ||
2071 | * initialization of quasi-elastic neutrino scattering | |
2072 | IF (MCGENE.EQ.4) THEN | |
2073 | IF (IJPROJ.EQ.5) THEN | |
2074 | NEUTYP = 1 | |
2075 | ELSEIF (IJPROJ.EQ.6) THEN | |
2076 | NEUTYP = 2 | |
2077 | ELSEIF (IJPROJ.EQ.135) THEN | |
2078 | NEUTYP = 3 | |
2079 | ELSEIF (IJPROJ.EQ.136) THEN | |
2080 | NEUTYP = 4 | |
2081 | ELSEIF (IJPROJ.EQ.133) THEN | |
2082 | NEUTYP = 5 | |
2083 | ELSEIF (IJPROJ.EQ.134) THEN | |
2084 | NEUTYP = 6 | |
2085 | ENDIF | |
2086 | ENDIF | |
2087 | ||
2088 | * normalize fractions of emulsion components | |
2089 | IF (NCOMPO.GT.0) THEN | |
2090 | SUMFRA = ZERO | |
2091 | DO 491 I=1,NCOMPO | |
2092 | SUMFRA = SUMFRA+EMUFRA(I) | |
2093 | 491 CONTINUE | |
2094 | IF (SUMFRA.GT.ZERO) THEN | |
2095 | DO 492 I=1,NCOMPO | |
2096 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
2097 | 492 CONTINUE | |
2098 | ENDIF | |
2099 | ENDIF | |
2100 | ||
2101 | * disallow Cronin's multiple scattering for nucleus-nucleus interactions | |
6cf1df4c | 2102 | IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN |
9aaba0d6 | 2103 | WRITE(LOUT,1005) |
2104 | 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/) | |
2105 | MKCRON = 0 | |
2106 | ENDIF | |
2107 | ||
2108 | * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) | |
2109 | C IF (NCOMPO.LE.0) THEN | |
2110 | C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) | |
2111 | C ELSE | |
2112 | C DO 493 I=1,NCOMPO | |
2113 | C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) | |
2114 | C 493 CONTINUE | |
2115 | C ENDIF | |
2116 | ||
2117 | * pre-tabulation of elastic cross-sections | |
2118 | CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1) | |
2119 | ||
2120 | CALL DT_XTIME | |
2121 | ||
2122 | RETURN | |
2123 | ||
2124 | ********************************************************************* | |
2125 | * * | |
2126 | * control card: codewd = STOP * | |
2127 | * * | |
2128 | * stop of the event generation * | |
2129 | * * | |
2130 | * what (1..6) no meaning * | |
2131 | * * | |
2132 | ********************************************************************* | |
2133 | ||
2134 | 9999 CONTINUE | |
2135 | WRITE(LOUT,9000) | |
2136 | 9000 FORMAT(1X,'---> unexpected end of input !') | |
2137 | ||
2138 | 640 CONTINUE | |
2139 | STOP | |
2140 | ||
2141 | END | |
2142 | ||
2143 | *$ CREATE DT_KKINC.FOR | |
2144 | *COPY DT_KKINC | |
2145 | * | |
2146 | *===kkinc==============================================================* | |
2147 | * | |
2148 | SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT, | |
2149 | & IREJ) | |
2150 | ||
2151 | ************************************************************************ | |
2152 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
2153 | * This subroutine is an update of the previous version written * | |
2154 | * by J. Ranft/ H.-J. Moehring. * | |
2155 | * This version dated 19.11.95 is written by S. Roesler * | |
2156 | ************************************************************************ | |
2157 | ||
2158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2159 | SAVE | |
2160 | PARAMETER ( LINP = 10 , | |
2161 | & LOUT = 6 , | |
2162 | & LDAT = 9 ) | |
2163 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5, | |
2164 | & TINY2=1.0D-2,TINY3=1.0D-3) | |
2165 | ||
2166 | LOGICAL LFZC | |
2167 | ||
2168 | * event history | |
09b429a4 | 2169 | |
2170 | PARAMETER (NMXHEP=4000) | |
2171 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
2172 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
2173 | & VHEP(4,NMXHEP), NSD1, NSD2, NDD | |
2174 | ||
9aaba0d6 | 2175 | PARAMETER (NMXHKK=200000) |
2176 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2177 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2178 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2179 | * extended event history | |
2180 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2181 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2182 | & IHIST(2,NMXHKK) | |
2183 | * particle properties (BAMJET index convention) | |
2184 | CHARACTER*8 ANAME | |
2185 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2186 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2187 | * properties of interacting particles | |
2188 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2189 | * Lorentz-parameters of the current interaction | |
2190 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
2191 | & UMO,PPCM,EPROJ,PPROJ | |
2192 | * flags for input different options | |
2193 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2194 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2195 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2196 | * flags for particle decays | |
2197 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2198 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2199 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2200 | * cuts for variable energy runs | |
2201 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2202 | * Glauber formalism: flags and parameters for statistics | |
2203 | LOGICAL LPROD | |
2204 | CHARACTER*8 CGLB | |
2205 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2206 | ||
2207 | DIMENSION WHAT(6) | |
2208 | ||
2209 | IREJ = 0 | |
2210 | ILOOP = 0 | |
09b429a4 | 2211 | NSD1 = 0 |
2212 | NSD2 = 0 | |
2213 | NDD = 0 | |
9aaba0d6 | 2214 | 100 CONTINUE |
2215 | IF (ILOOP.EQ.4) THEN | |
2216 | WRITE(LOUT,1000) NEVHKK | |
2217 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') | |
2218 | GOTO 9999 | |
2219 | ENDIF | |
2220 | ILOOP = ILOOP+1 | |
2221 | ||
2222 | * variable energy-runs, recalculate parameters for LT's | |
2223 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN | |
2224 | PDUM = ZERO | |
2225 | CDUM = ZERO | |
2226 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) | |
2227 | ENDIF | |
2228 | IF (EPN.GT.EPROJ) THEN | |
2229 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') | |
2230 | & ' Requested energy (',EPN,'GeV) exceeds', | |
2231 | & ' initialization energy (',EPROJ,'GeV) !' | |
2232 | STOP | |
2233 | ENDIF | |
2234 | ||
2235 | * re-initialize /DTPRTA/ | |
2236 | IP = NPMASS | |
2237 | IPZ = NPCHAR | |
2238 | IT = NTMASS | |
2239 | ITZ = NTCHAR | |
2240 | IJPROJ = IDP | |
2241 | IBPROJ = IIBAR(IJPROJ) | |
2242 | ||
2243 | * calculate nuclear potentials (common /DTNPOT/) | |
2244 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
2245 | ||
2246 | * initialize treatment for residual nuclei | |
2247 | CALL DT_RESNCL(EPN,NLOOP,1) | |
2248 | ||
2249 | * sample hadron/nucleus-nucleus interaction | |
2250 | CALL DT_KKEVNT(KKMAT,IREJ1) | |
2251 | IF (IREJ1.GT.0) THEN | |
2252 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' | |
2253 | GOTO 9999 | |
2254 | ENDIF | |
2255 | ||
2256 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN | |
2257 | ||
2258 | * intranuclear cascade of final state particles for KTAUGE generations | |
2259 | * of secondaries | |
2260 | CALL DT_FOZOCA(LFZC,IREJ1) | |
2261 | IF (IREJ1.GT.0) THEN | |
2262 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' | |
2263 | GOTO 9999 | |
2264 | ENDIF | |
2265 | ||
2266 | * baryons unable to escape the nuclear potential are treated as | |
2267 | * excited nucleons (ISTHKK=15,16) | |
2268 | CALL DT_SCN4BA | |
2269 | ||
2270 | * decay of resonances produced in intranuclear cascade processes | |
2271 | **sr 15-11-95 should be obsolete | |
2272 | C IF (LFZC) CALL DT_DECAY1 | |
2273 | ||
2274 | 101 CONTINUE | |
2275 | * treatment of residual nuclei | |
2276 | CALL DT_RESNCL(EPN,NLOOP,2) | |
2277 | ||
2278 | * evaporation / fission / fragmentation | |
2279 | * (if intranuclear cascade was sampled only) | |
2280 | IF (LFZC) THEN | |
2281 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) | |
2282 | IF (IREJ1.GT.1) GOTO 101 | |
2283 | IF (IREJ1.EQ.1) GOTO 100 | |
2284 | ENDIF | |
2285 | ||
2286 | ENDIF | |
2287 | ||
2288 | * rejection of unphysical configurations | |
2289 | CALL DT_REJUCO(1,IREJ1) | |
2290 | IF (IREJ1.GT.0) THEN | |
2291 | IF (IOULEV(1).GT.0) | |
2292 | & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x' | |
2293 | GOTO 100 | |
2294 | ENDIF | |
2295 | ||
2296 | * transform finale state into Lab. | |
2297 | IFLAG = 2 | |
2298 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) | |
2299 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB | |
2300 | ||
2301 | IF (IPI0.EQ.1) CALL DT_DECPI0 | |
2302 | ||
2303 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) | |
9aaba0d6 | 2304 | RETURN |
2305 | 9999 CONTINUE | |
2306 | IREJ = 1 | |
09b429a4 | 2307 | |
9aaba0d6 | 2308 | RETURN |
2309 | END | |
2310 | ||
2311 | *$ CREATE DT_DEFAUL.FOR | |
2312 | *COPY DT_DEFAUL | |
2313 | * | |
2314 | *===defaul=============================================================* | |
2315 | * | |
2316 | SUBROUTINE DT_DEFAUL(EPN,PPN) | |
2317 | ||
2318 | ************************************************************************ | |
2319 | * Variables are set to default values. * | |
2320 | * This version dated 8.5.95 is written by S. Roesler. * | |
2321 | ************************************************************************ | |
2322 | ||
2323 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2324 | SAVE | |
2325 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
2326 | PARAMETER (TWOPI = 6.283185307179586454D+00) | |
2327 | ||
2328 | * particle properties (BAMJET index convention) | |
2329 | CHARACTER*8 ANAME | |
2330 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2331 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2332 | * nuclear potential | |
2333 | LOGICAL LFERMI | |
2334 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
2335 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
2336 | & ETACOU(2),ICOUL,LFERMI | |
2337 | * interface HADRIN-DPM | |
2338 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
2339 | * central particle production, impact parameter biasing | |
2340 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
2341 | * properties of interacting particles | |
2342 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2343 | * properties of photon/lepton projectiles | |
2344 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2345 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2346 | * emulsion treatment | |
2347 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2348 | & NCOMPO,IEMUL | |
2349 | * parameter for intranuclear cascade | |
2350 | LOGICAL LPAULI | |
2351 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
2352 | * various options for treatment of partons (DTUNUC 1.x) | |
2353 | * (chain recombination, Cronin,..) | |
2354 | LOGICAL LCO2CR,LINTPT | |
2355 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
2356 | & LCO2CR,LINTPT | |
2357 | * threshold values for x-sampling (DTUNUC 1.x) | |
2358 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
2359 | & SSMIMQ,VVMTHR | |
2360 | * flags for input different options | |
2361 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2362 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2363 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2364 | * n-n cross section fluctuations | |
2365 | PARAMETER (NBINS = 1000) | |
2366 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
2367 | * flags for particle decays | |
2368 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2369 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2370 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2371 | * diquark-breaking mechanism | |
2372 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
2373 | * nucleon-nucleon event-generator | |
2374 | CHARACTER*8 CMODEL | |
2375 | LOGICAL LPHOIN | |
2376 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2377 | * flags for diffractive interactions (DTUNUC 1.x) | |
2378 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
2379 | * VDM parameter for photon-nucleus interactions | |
2380 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
2381 | * Glauber formalism: flags and parameters for statistics | |
2382 | LOGICAL LPROD | |
2383 | CHARACTER*8 CGLB | |
2384 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2385 | * kinematical cuts for lepton-nucleus interactions | |
2386 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2387 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2388 | * flags for activated histograms | |
2389 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2390 | * cuts for variable energy runs | |
2391 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2392 | * parameters for hA-diffraction | |
2393 | COMMON /DTDIHA/ DIBETA,DIALPH | |
2394 | * LEPTO | |
2395 | REAL RPPN | |
2396 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
2397 | * steering flags for qel neutrino scattering modules | |
2398 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
2399 | * event flag | |
2400 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2401 | ||
2402 | DATA POTMES /0.002D0/ | |
2403 | ||
2404 | * common /DTNPOT/ | |
2405 | DO 10 I=1,2 | |
2406 | PFERMP(I) = ZERO | |
2407 | PFERMN(I) = ZERO | |
2408 | EBINDP(I) = ZERO | |
2409 | EBINDN(I) = ZERO | |
2410 | DO 11 J=1,210 | |
2411 | EPOT(I,J) = ZERO | |
2412 | 11 CONTINUE | |
2413 | * nucleus independent meson potential | |
2414 | EPOT(I,13) = POTMES | |
2415 | EPOT(I,14) = POTMES | |
2416 | EPOT(I,15) = POTMES | |
2417 | EPOT(I,16) = POTMES | |
2418 | EPOT(I,23) = POTMES | |
2419 | EPOT(I,24) = POTMES | |
2420 | EPOT(I,25) = POTMES | |
2421 | 10 CONTINUE | |
2422 | FERMOD = 0.55D0 | |
2423 | ETACOU(1) = ZERO | |
2424 | ETACOU(2) = ZERO | |
2425 | ICOUL = 1 | |
2426 | LFERMI = .TRUE. | |
2427 | ||
2428 | * common /HNTHRE/ | |
2429 | EHADTH = -99.0D0 | |
2430 | EHADLO = 4.06D0 | |
2431 | EHADHI = 6.0D0 | |
2432 | INTHAD = 1 | |
2433 | IDXTA = 2 | |
2434 | ||
2435 | * common /DTIMPA/ | |
2436 | ICENTR = 0 | |
2437 | BIMIN = ZERO | |
2438 | BIMAX = 1.0D10 | |
2439 | XSFRAC = 1.0D0 | |
2440 | ||
2441 | * common /DTPRTA/ | |
2442 | IP = 1 | |
2443 | IPZ = 1 | |
2444 | IT = 1 | |
2445 | ITZ = 1 | |
2446 | IJPROJ = 1 | |
2447 | IBPROJ = 1 | |
2448 | IJTARG = 1 | |
2449 | IBTARG = 1 | |
2450 | * common /DTGPRO/ | |
2451 | VIRT = ZERO | |
2452 | DO 14 I=1,4 | |
2453 | PGAMM(I) = ZERO | |
2454 | PLEPT0(I) = ZERO | |
2455 | PLEPT1(I) = ZERO | |
2456 | PNUCL(I) = ZERO | |
2457 | 14 CONTINUE | |
2458 | IDIREC = 0 | |
2459 | ||
2460 | * common /DTFOTI/ | |
2461 | **sr 7.4.98: changed after corrected B-sampling | |
2462 | C TAUFOR = 4.4D0 | |
2463 | TAUFOR = 3.5D0 | |
2464 | KTAUGE = 25 | |
2465 | ITAUVE = 1 | |
2466 | INCMOD = 1 | |
2467 | LPAULI = .TRUE. | |
2468 | ||
2469 | * common /DTCHAI/ | |
2470 | SEASQ = ONE | |
2471 | MKCRON = 1 | |
2472 | CRONCO = 0.64D0 | |
2473 | ISICHA = 0 | |
2474 | CUTOF = 100.0D0 | |
2475 | LCO2CR = .FALSE. | |
2476 | IRECOM = 1 | |
2477 | LINTPT = .TRUE. | |
2478 | ||
2479 | * common /DTXCUT/ | |
2480 | * definition of soft quark distributions | |
2481 | XSEACU = 0.05D0 | |
2482 | UNON = 2.0D0 | |
2483 | UNOM = 1.5D0 | |
2484 | UNOSEA = 5.0D0 | |
2485 | * cutoff parameters for x-sampling | |
2486 | CVQ = 1.0D0 | |
2487 | CDQ = 2.0D0 | |
2488 | C CSEA = 0.3D0 | |
2489 | CSEA = 0.1D0 | |
2490 | SSMIMA = 1.2D0 | |
2491 | SSMIMQ = SSMIMA**2 | |
2492 | VVMTHR = 2.0D0 | |
2493 | ||
2494 | * common /DTXSFL/ | |
2495 | IFLUCT = 0 | |
2496 | ||
2497 | * common /DTFRPA/ | |
2498 | PDB = 0.15D0 | |
2499 | PDBSEA(1) = 0.0D0 | |
2500 | PDBSEA(2) = 0.0D0 | |
2501 | PDBSEA(3) = 0.0D0 | |
2502 | ISIG0 = 0 | |
2503 | IPI0 = 0 | |
2504 | NMSTU = 0 | |
2505 | NPARU = 0 | |
2506 | NMSTJ = 0 | |
2507 | NPARJ = 0 | |
2508 | ||
2509 | * common /DTDIQB/ | |
2510 | DO 15 I=1,8 | |
2511 | DBRKR(1,I) = 5.0D0 | |
2512 | DBRKR(2,I) = 5.0D0 | |
2513 | DBRKR(3,I) = 10.0D0 | |
2514 | DBRKA(1,I) = ZERO | |
2515 | DBRKA(2,I) = ZERO | |
2516 | DBRKA(3,I) = ZERO | |
2517 | 15 CONTINUE | |
2518 | CHAM1 = 0.2D0 | |
2519 | CHAM3 = 0.5D0 | |
2520 | CHAB1 = 0.7D0 | |
2521 | CHAB3 = 1.0D0 | |
2522 | ||
2523 | * common /DTFLG3/ | |
2524 | ISINGD = 0 | |
2525 | IDOUBD = 0 | |
2526 | IFLAGD = 0 | |
2527 | IDIFF = 0 | |
2528 | ||
2529 | * common /DTMODL/ | |
2530 | MCGENE = 2 | |
2531 | CMODEL(1) = 'DTUNUC ' | |
2532 | CMODEL(2) = 'PHOJET ' | |
2533 | CMODEL(3) = 'LEPTO ' | |
2534 | CMODEL(4) = 'QNEUTRIN' | |
2535 | LPHOIN = .TRUE. | |
2536 | ELOJET = 5.0D0 | |
2537 | ||
2538 | * common /DTLCUT/ | |
2539 | ECMIN = 3.5D0 | |
2540 | ECMAX = 1.0D10 | |
2541 | XBJMIN = ZERO | |
2542 | ELMIN = ZERO | |
2543 | EGMIN = ZERO | |
2544 | EGMAX = 1.0D10 | |
2545 | YMIN = TINY10 | |
2546 | YMAX = 0.999D0 | |
2547 | Q2MIN = TINY10 | |
2548 | Q2MAX = 10.0D0 | |
2549 | THMIN = ZERO | |
2550 | THMAX = TWOPI | |
2551 | Q2LI = ZERO | |
2552 | Q2HI = 1.0D10 | |
2553 | ECMLI = ZERO | |
2554 | ECMHI = 1.0D10 | |
2555 | ||
2556 | * common /DTVDMP/ | |
2557 | RL2 = 2.0D0 | |
2558 | INTRGE(1) = 1 | |
2559 | INTRGE(2) = 3 | |
2560 | IDPDF = 2212 | |
2561 | MODEGA = 4 | |
2562 | ISHAD(1) = 1 | |
2563 | ISHAD(2) = 1 | |
2564 | ISHAD(3) = 1 | |
2565 | EPSPOL = ZERO | |
2566 | ||
2567 | * common /DTGLGP/ | |
2568 | JSTATB = 1000 | |
2569 | JBINSB = 49 | |
2570 | CGLB = ' ' | |
2571 | IF (ITRSPT.EQ.1) THEN | |
2572 | IOGLB = 100 | |
2573 | ELSE | |
2574 | IOGLB = 0 | |
2575 | ENDIF | |
2576 | LPROD = .TRUE. | |
2577 | ||
2578 | * common /DTHIS3/ | |
2579 | DO 16 I=1,50 | |
2580 | IHISPP(I) = 0 | |
2581 | IHISXS(I) = 0 | |
2582 | 16 CONTINUE | |
2583 | IXSTBL = 0 | |
2584 | ||
2585 | * common /DTVARE/ | |
2586 | VARELO = ZERO | |
2587 | VAREHI = ZERO | |
2588 | VARCLO = ZERO | |
2589 | VARCHI = ZERO | |
2590 | ||
2591 | * common /DTDIHA/ | |
2592 | DIBETA = -1.0D0 | |
2593 | DIALPH = ZERO | |
2594 | ||
2595 | * common /LEPTOI/ | |
2596 | RPPN = 0.0 | |
2597 | LEPIN = 0 | |
2598 | INTER = 0 | |
2599 | ||
2600 | * common /QNEUTO/ | |
2601 | NEUTYP = 1 | |
2602 | NEUDEC = 0 | |
2603 | ||
2604 | * common /DTEVNO/ | |
2605 | NEVENT = 1 | |
2606 | IF (ITRSPT.EQ.1) THEN | |
2607 | ICASCA = 1 | |
2608 | ELSE | |
2609 | ICASCA = 0 | |
2610 | ENDIF | |
2611 | ||
2612 | * default Lab.-energy | |
2613 | EPN = 200.0D0 | |
2614 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) | |
2615 | ||
2616 | RETURN | |
2617 | END | |
2618 | ||
2619 | *$ CREATE DT_AAEVT.FOR | |
2620 | *COPY DT_AAEVT | |
2621 | * | |
2622 | *===aaevt==============================================================* | |
2623 | * | |
2624 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2625 | & IDP,IGLAU) | |
2626 | ||
2627 | ************************************************************************ | |
2628 | * This version dated 22.03.96 is written by S. Roesler. * | |
2629 | ************************************************************************ | |
2630 | ||
2631 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2632 | SAVE | |
2633 | PARAMETER ( LINP = 10 , | |
2634 | & LOUT = 6 , | |
2635 | & LDAT = 9 ) | |
2636 | ||
2637 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2638 | * emulsion treatment | |
2639 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2640 | & NCOMPO,IEMUL | |
2641 | * event flag | |
2642 | COMMON /DTEVNO/ NEVENT,ICASCA | |
9aaba0d6 | 2643 | CHARACTER*8 DATE,HHMMSS |
2644 | DIMENSION IDMNYR(3) | |
09b429a4 | 2645 | NSD1 = 0 |
2646 | NSD2 = 0 | |
2647 | NDD = 0 | |
9aaba0d6 | 2648 | KKMAT = 1 |
2649 | NMSG = MAX(NEVTS/100,1) | |
2650 | ||
2651 | * initialization of run-statistics and histograms | |
2652 | CALL DT_STATIS(1) | |
2653 | CALL PHO_PHIST(1000,DUM) | |
2654 | ||
2655 | * initialization of Glauber-formalism | |
2656 | IF (NCOMPO.LE.0) THEN | |
2657 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2658 | ELSE | |
2659 | DO 1 I=1,NCOMPO | |
2660 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2661 | 1 CONTINUE | |
2662 | ENDIF | |
2663 | CALL DT_SIGEMU | |
2664 | ||
2665 | CALL IDATE(IDMNYR) | |
2666 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2667 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2668 | CALL ITIME(IDMNYR) | |
2669 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2670 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2671 | WRITE(LOUT,1001) DATE,HHMMSS | |
2672 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, | |
2673 | & ' Time: ',A8,' )') | |
2674 | ||
2675 | * generate NEVTS events | |
2676 | DO 2 IEVT=1,NEVTS | |
2677 | ||
2678 | * print run-status message | |
2679 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2680 | CALL IDATE(IDMNYR) | |
2681 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2682 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2683 | CALL ITIME(IDMNYR) | |
2684 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2685 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2686 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS | |
2687 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, | |
2688 | & ' Time: ',A,' )',/) | |
2689 | C WRITE(LOUT,1000) IEVT-1 | |
2690 | C1000 FORMAT(1X,I8,' events sampled') | |
2691 | ENDIF | |
2692 | NEVENT = IEVT | |
2693 | * treat nuclear emulsions | |
2694 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
2695 | * composite targets only | |
2696 | KKMAT = -KKMAT | |
2697 | * sample this event | |
2698 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) | |
2699 | ||
2700 | CALL PHO_PHIST(2000,DUM) | |
09b429a4 | 2701 | |
2702 | write(6,*) "Diffractive collisions", NSD1, NSD2, NDD | |
9aaba0d6 | 2703 | |
2704 | 2 CONTINUE | |
2705 | ||
2706 | * print run-statistics and histograms to output-unit 6 | |
2707 | CALL PHO_PHIST(3000,DUM) | |
2708 | CALL DT_STATIS(2) | |
9aaba0d6 | 2709 | RETURN |
2710 | END | |
2711 | ||
2712 | *$ CREATE DT_LAEVT.FOR | |
2713 | *COPY DT_LAEVT | |
2714 | * | |
2715 | *===laevt==============================================================* | |
2716 | * | |
2717 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2718 | & IDP,IGLAU) | |
2719 | ||
2720 | ************************************************************************ | |
2721 | * Interface to run DPMJET for lepton-nucleus interactions. * | |
2722 | * Kinematics is sampled using the equivalent photon approximation * | |
2723 | * Based on GPHERA-routine by R. Engel. * | |
2724 | * This version dated 23.03.96 is written by S. Roesler. * | |
2725 | ************************************************************************ | |
2726 | ||
2727 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2728 | SAVE | |
2729 | PARAMETER ( LINP = 10 , | |
2730 | & LOUT = 6 , | |
2731 | & LDAT = 9 ) | |
2732 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, | |
2733 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
2734 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
2735 | & PI = TWOPI/TWO, | |
2736 | & ALPHEM = ONE/137.0D0) | |
2737 | ||
2738 | C CHARACTER*72 HEADER | |
2739 | ||
2740 | * particle properties (BAMJET index convention) | |
2741 | CHARACTER*8 ANAME | |
2742 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2743 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2744 | * event history | |
2745 | PARAMETER (NMXHKK=200000) | |
2746 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2747 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2748 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2749 | * extended event history | |
2750 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2751 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2752 | & IHIST(2,NMXHKK) | |
2753 | * kinematical cuts for lepton-nucleus interactions | |
2754 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2755 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2756 | * properties of interacting particles | |
2757 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2758 | * properties of photon/lepton projectiles | |
2759 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2760 | * kinematics at lepton-gamma vertex | |
2761 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) | |
2762 | * flags for activated histograms | |
2763 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2764 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2765 | * emulsion treatment | |
2766 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2767 | & NCOMPO,IEMUL | |
2768 | * Glauber formalism: cross sections | |
2769 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
2770 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
2771 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
2772 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
2773 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
2774 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
2775 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
2776 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
2777 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
2778 | & BSLOPE,NEBINI,NQBINI | |
2779 | * nucleon-nucleon event-generator | |
2780 | CHARACTER*8 CMODEL | |
2781 | LOGICAL LPHOIN | |
2782 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2783 | * flags for input different options | |
2784 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2785 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2786 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2787 | * event flag | |
2788 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2789 | ||
2790 | DIMENSION XDUMB(40),BGTA(4) | |
2791 | ||
2792 | * LEPTO | |
2793 | IF (MCGENE.EQ.3) THEN | |
2794 | STOP ' This version does not contain LEPTO !' | |
2795 | ENDIF | |
2796 | ||
2797 | KKMAT = 1 | |
2798 | NMSG = MAX(NEVTS/10,1) | |
2799 | ||
2800 | * mass of incident lepton | |
2801 | AMLPT = AAM(IDP) | |
2802 | AMLPT2 = AMLPT**2 | |
2803 | IDPPDG = IDT_IPDGHA(IDP) | |
2804 | ||
2805 | * consistency of kinematical limits | |
2806 | Q2MIN = MAX(Q2MIN,TINY10) | |
2807 | Q2MAX = MAX(Q2MAX,TINY10) | |
2808 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) | |
2809 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) | |
2810 | ||
2811 | * total energy of the lepton-nucleon system | |
2812 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 | |
2813 | & +(PLEPT0(3)+PNUCL(3))**2 ) | |
2814 | ETOTLN = PLEPT0(4)+PNUCL(4) | |
2815 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) | |
2816 | ECMAX = MIN(ECMAX,ECMLN) | |
2817 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, | |
2818 | & THMIN,THMAX,ELMIN | |
2819 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, | |
2820 | & '------------------',/,9X,'W (min) =', | |
2821 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', | |
2822 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, | |
2823 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' | |
2824 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', | |
2825 | & F7.4,' for E_lpt >',F7.1,' GeV',/) | |
2826 | ||
2827 | * Lorentz-parameter for transf. into Lab | |
2828 | BGTA(1) = PNUCL(1)/AAM(1) | |
2829 | BGTA(2) = PNUCL(2)/AAM(1) | |
2830 | BGTA(3) = PNUCL(3)/AAM(1) | |
2831 | BGTA(4) = PNUCL(4)/AAM(1) | |
2832 | * LT of incident lepton into Lab and dump it in DTEVT1 | |
2833 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2834 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), | |
2835 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) | |
2836 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2837 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), | |
2838 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) | |
2839 | * maximum energy of photon nucleon system | |
2840 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 | |
2841 | & +(YMAX*PPL0(3)+PPA(3))**2) | |
2842 | ETOTGN = YMAX*PPL0(4)+PPA(4) | |
2843 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2844 | EGNMAX = MIN(EGNMAX,ECMAX) | |
2845 | * minimum energy of photon nucleon system | |
2846 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 | |
2847 | & +(YMIN*PPL0(3)+PPA(3))**2) | |
2848 | ETOTGN = YMIN*PPL0(4)+PPA(4) | |
2849 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2850 | EGNMIN = MAX(EGNMIN,ECMIN) | |
2851 | ||
2852 | * limits for Glauber-initialization | |
2853 | Q2LI = Q2MIN | |
2854 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) | |
2855 | ECMLI = MAX(EGNMIN,THREE) | |
2856 | ECMHI = EGNMAX | |
2857 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI | |
2858 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, | |
2859 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', | |
2860 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, | |
2861 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, | |
2862 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) | |
2863 | * initialization of Glauber-formalism | |
2864 | IF (NCOMPO.LE.0) THEN | |
2865 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2866 | ELSE | |
2867 | DO 9 I=1,NCOMPO | |
2868 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2869 | 9 CONTINUE | |
2870 | ENDIF | |
2871 | CALL DT_SIGEMU | |
2872 | ||
2873 | * initialization of run-statistics and histograms | |
2874 | CALL DT_STATIS(1) | |
2875 | CALL PHO_PHIST(1000,DUM) | |
2876 | ||
2877 | * maximum photon-nucleus cross section | |
2878 | I1 = 1 | |
2879 | I2 = 1 | |
2880 | RAT = ONE | |
2881 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN | |
2882 | I1 = NEBINI | |
2883 | I2 = NEBINI | |
2884 | RAT = ONE | |
2885 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN | |
2886 | DO 5 I=2,NEBINI | |
2887 | IF (EGNMAX.LT.ECMNN(I)) THEN | |
2888 | I1 = I-1 | |
2889 | I2 = I | |
2890 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2891 | GOTO 6 | |
2892 | ENDIF | |
2893 | 5 CONTINUE | |
2894 | 6 CONTINUE | |
2895 | ENDIF | |
2896 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2897 | EGNXX = EGNMAX | |
2898 | I1 = 1 | |
2899 | I2 = 1 | |
2900 | RAT = ONE | |
2901 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN | |
2902 | I1 = NEBINI | |
2903 | I2 = NEBINI | |
2904 | RAT = ONE | |
2905 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN | |
2906 | DO 7 I=2,NEBINI | |
2907 | IF (EGNMIN.LT.ECMNN(I)) THEN | |
2908 | I1 = I-1 | |
2909 | I2 = I | |
2910 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2911 | GOTO 8 | |
2912 | ENDIF | |
2913 | 7 CONTINUE | |
2914 | 8 CONTINUE | |
2915 | ENDIF | |
2916 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2917 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN | |
2918 | SIGMAX = MAX(SIGMAX,SIGXX) | |
2919 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' | |
2920 | ||
2921 | * plot photon flux table | |
2922 | AYMIN = LOG(YMIN) | |
2923 | AYMAX = LOG(YMAX) | |
2924 | AYRGE = AYMAX-AYMIN | |
2925 | MAXTAB = 50 | |
2926 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) | |
2927 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' | |
2928 | DO 1 I=1,MAXTAB | |
2929 | Y = EXP(AYMIN+ADY*DBLE(I-1)) | |
2930 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) | |
2931 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2932 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) | |
2933 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2934 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) | |
2935 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 | |
2936 | 1 CONTINUE | |
2937 | ||
2938 | * maximum residual weight for flux sampling (dy/y) | |
2939 | YY = YMIN | |
2940 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2941 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) | |
2942 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2943 | ||
2944 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) | |
2945 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) | |
2946 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) | |
2947 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) | |
2948 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) | |
2949 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) | |
2950 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) | |
2951 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) | |
2952 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) | |
2953 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) | |
2954 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) | |
2955 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) | |
2956 | XBLOW = 0.001D0 | |
2957 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) | |
2958 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) | |
2959 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) | |
2960 | ||
2961 | ITRY = 0 | |
2962 | ITRW = 0 | |
2963 | NC0 = 0 | |
2964 | NC1 = 0 | |
2965 | ||
2966 | * generate events | |
2967 | DO 2 IEVT=1,NEVTS | |
2968 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2969 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', | |
2970 | C & STATUS='UNKNOWN') | |
2971 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' | |
2972 | C CLOSE(LDAT) | |
2973 | ENDIF | |
2974 | NEVENT = IEVT | |
2975 | ||
2976 | 100 CONTINUE | |
2977 | ITRY = ITRY+1 | |
2978 | ||
2979 | * sample y | |
2980 | 101 CONTINUE | |
2981 | ITRW = ITRW+1 | |
2982 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) | |
2983 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2984 | Q2LOG = LOG(Q2MAX/Q2LOW) | |
2985 | WGH = (ONE+(ONE-YY)**2)*Q2LOG | |
2986 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2987 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH | |
2988 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) | |
2989 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 | |
2990 | ||
2991 | * sample Q2 | |
2992 | YEFF = ONE+(ONE-YY)**2 | |
2993 | 102 CONTINUE | |
2994 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) | |
2995 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF | |
2996 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 | |
2997 | ||
2998 | c NC0 = NC0+1 | |
2999 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) | |
3000 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) | |
3001 | ||
3002 | * kinematics at lepton-photon vertex | |
3003 | * scattered electron | |
3004 | YQ2 = SQRT((ONE-YY)*Q2) | |
3005 | Q2E = Q2/(4.0D0*PLEPT0(4)) | |
3006 | E1Y = (ONE-YY)*PLEPT0(4) | |
3007 | CALL DT_DSFECF(SIF,COF) | |
3008 | PLEPT1(1) = YQ2*COF | |
3009 | PLEPT1(2) = YQ2*SIF | |
3010 | PLEPT1(3) = E1Y-Q2E | |
3011 | PLEPT1(4) = E1Y+Q2E | |
3012 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) | |
3013 | * radiated photon | |
3014 | PGAMM(1) = -PLEPT1(1) | |
3015 | PGAMM(2) = -PLEPT1(2) | |
3016 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) | |
3017 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) | |
3018 | * E_cm cut | |
3019 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 | |
3020 | & +(PGAMM(3)+PNUCL(3))**2 ) | |
3021 | ETOTGN = PGAMM(4)+PNUCL(4) | |
3022 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) | |
3023 | IF (ECMGN.LT.0.1D0) GOTO 101 | |
3024 | ECMGN = SQRT(ECMGN) | |
3025 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 | |
3026 | ||
3027 | * Lorentz-transformation into nucleon-rest system | |
3028 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3029 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), | |
3030 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) | |
3031 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3032 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), | |
3033 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) | |
3034 | * temporary checks.. | |
3035 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) | |
3036 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP | |
3037 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', | |
3038 | & 2F10.4) | |
3039 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) | |
3040 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP | |
3041 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', | |
3042 | & 2F10.2) | |
3043 | YYTMP = PPG(4)/PPL0(4) | |
3044 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP | |
3045 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', | |
3046 | & 2F10.4) | |
3047 | ||
3048 | * lepton tagger (Lab) | |
3049 | THETA = ACOS( PPL1(3)/PLTOT ) | |
3050 | IF (PPL1(4).GT.ELMIN) THEN | |
3051 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 | |
3052 | ENDIF | |
3053 | * photon energy-cut (Lab) | |
3054 | IF (PPG(4).LT.EGMIN) GOTO 101 | |
3055 | IF (PPG(4).GT.EGMAX) GOTO 101 | |
3056 | * x_Bj cut | |
3057 | XBJ = ABS(Q2/(1.876D0*PPG(4))) | |
3058 | IF (XBJ.LT.XBJMIN) GOTO 101 | |
3059 | ||
3060 | NC0 = NC0+1 | |
3061 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) | |
3062 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) | |
3063 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) | |
3064 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) | |
3065 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) | |
3066 | ||
3067 | * rotation angles against z-axis | |
3068 | COD = PPG(3)/PGTOT | |
3069 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3070 | PPT = SQRT(PPG(1)**2+PPG(2)**2) | |
3071 | SID = PPT/PGTOT | |
3072 | COF = ONE | |
3073 | SIF = ZERO | |
3074 | IF (PGTOT*SID.GT.TINY10) THEN | |
3075 | COF = PPG(1)/(SID*PGTOT) | |
3076 | SIF = PPG(2)/(SID*PGTOT) | |
3077 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3078 | COF = COF/ANORF | |
3079 | SIF = SIF/ANORF | |
3080 | ENDIF | |
3081 | ||
3082 | IF (IXSTBL.EQ.0) THEN | |
3083 | * change to photon projectile | |
3084 | IJPROJ = 7 | |
3085 | * set virtuality | |
3086 | VIRT = Q2 | |
3087 | * re-initialize LTs with new kinematics | |
3088 | * !!PGAMM ist set in cms (ECMGN) along z | |
3089 | EPN = ZERO | |
3090 | PPN = ZERO | |
3091 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) | |
3092 | * force Lab-system | |
3093 | IFRAME = 1 | |
3094 | * get emulsion component if requested | |
3095 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
3096 | * convolute with cross section | |
3097 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) | |
3098 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) | |
3099 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') | |
3100 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, | |
3101 | & Q2,ECMGN,STOT | |
3102 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 | |
3103 | NC1 = NC1+1 | |
3104 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) | |
3105 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) | |
3106 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) | |
3107 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) | |
3108 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) | |
3109 | * composite targets only | |
3110 | KKMAT = -KKMAT | |
3111 | * sample this event | |
3112 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, | |
3113 | & IREJ) | |
3114 | * rotate momenta of final state particles back in photon-nucleon syst. | |
3115 | DO 4 I=NPOINT(4),NHKK | |
3116 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3117 | & (ISTHKK(I).EQ.1001)) THEN | |
3118 | PX = PHKK(1,I) | |
3119 | PY = PHKK(2,I) | |
3120 | PZ = PHKK(3,I) | |
3121 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, | |
3122 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) | |
3123 | ENDIF | |
3124 | 4 CONTINUE | |
3125 | ENDIF | |
3126 | ||
3127 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) | |
3128 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) | |
3129 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) | |
3130 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) | |
3131 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) | |
3132 | ||
3133 | * dump this event to histograms | |
3134 | CALL PHO_PHIST(2000,DUM) | |
3135 | ||
3136 | 2 CONTINUE | |
3137 | ||
3138 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) | |
3139 | WGY = WGY*LOG(YMAX/YMIN) | |
3140 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) | |
3141 | ||
3142 | C HEADER = ' LAEVT: Q^2 distribution 0' | |
3143 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3144 | C HEADER = ' LAEVT: Q^2 distribution 1' | |
3145 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3146 | C HEADER = ' LAEVT: Q^2 distribution 2' | |
3147 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3148 | C HEADER = ' LAEVT: y distribution 0' | |
3149 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3150 | C HEADER = ' LAEVT: y distribution 1' | |
3151 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3152 | C HEADER = ' LAEVT: y distribution 2' | |
3153 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3154 | C HEADER = ' LAEVT: x distribution 0' | |
3155 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3156 | C HEADER = ' LAEVT: x distribution 1' | |
3157 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3158 | C HEADER = ' LAEVT: x distribution 2' | |
3159 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3160 | C HEADER = ' LAEVT: E_g distribution 0' | |
3161 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3162 | C HEADER = ' LAEVT: E_g distribution 1' | |
3163 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3164 | C HEADER = ' LAEVT: E_g distribution 2' | |
3165 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3166 | C HEADER = ' LAEVT: E_c distribution 0' | |
3167 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3168 | C HEADER = ' LAEVT: E_c distribution 1' | |
3169 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3170 | C HEADER = ' LAEVT: E_c distribution 2' | |
3171 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3172 | ||
3173 | * print run-statistics and histograms to output-unit 6 | |
3174 | CALL PHO_PHIST(3000,DUM) | |
3175 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) | |
3176 | ||
3177 | RETURN | |
3178 | END | |
3179 | ||
3180 | *$ CREATE DT_DTUINI.FOR | |
3181 | *COPY DT_DTUINI | |
3182 | * | |
3183 | *===dtuini=============================================================* | |
3184 | * | |
3185 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
3186 | & IDP,IEMU) | |
3187 | ||
3188 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3189 | SAVE | |
3190 | ||
3191 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
3192 | * emulsion treatment | |
3193 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
3194 | & NCOMPO,IEMUL | |
3195 | * Glauber formalism: flags and parameters for statistics | |
3196 | LOGICAL LPROD | |
3197 | CHARACTER*8 CGLB | |
3198 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
3199 | ||
3200 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) | |
3201 | CALL DT_STATIS(1) | |
3202 | CALL PHO_PHIST(1000,DUM) | |
3203 | IF (NCOMPO.LE.0) THEN | |
3204 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
3205 | ELSE | |
3206 | DO 1 I=1,NCOMPO | |
3207 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
3208 | 1 CONTINUE | |
3209 | ENDIF | |
3210 | IF (IOGLB.NE.100) CALL DT_SIGEMU | |
3211 | IEMU = IEMUL | |
3212 | ||
3213 | RETURN | |
3214 | END | |
3215 | ||
3216 | *$ CREATE DT_DTUOUT.FOR | |
3217 | *COPY DT_DTUOUT | |
3218 | * | |
3219 | *===dtuout=============================================================* | |
3220 | * | |
3221 | SUBROUTINE DT_DTUOUT | |
3222 | ||
3223 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3224 | SAVE | |
3225 | ||
3226 | CALL PHO_PHIST(3000,DUM) | |
3227 | CALL DT_STATIS(2) | |
3228 | ||
3229 | RETURN | |
3230 | END | |
3231 | ||
3232 | *$ CREATE DT_BEAMPR.FOR | |
3233 | *COPY DT_BEAMPR | |
3234 | * | |
3235 | *===beampr=============================================================* | |
3236 | * | |
3237 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) | |
3238 | ||
3239 | ************************************************************************ | |
3240 | * Initialization of event generation * | |
3241 | * This version dated 7.4.98 is written by S. Roesler. * | |
3242 | ************************************************************************ | |
3243 | ||
3244 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3245 | SAVE | |
3246 | ||
3247 | PARAMETER ( LINP = 10 , | |
3248 | & LOUT = 6 , | |
3249 | & LDAT = 9 ) | |
3250 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3251 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3252 | ||
3253 | LOGICAL LBEAM | |
3254 | ||
3255 | * event history | |
3256 | PARAMETER (NMXHKK=200000) | |
3257 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3258 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3259 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3260 | * extended event history | |
3261 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3262 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3263 | & IHIST(2,NMXHKK) | |
3264 | * properties of interacting particles | |
3265 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3266 | * particle properties (BAMJET index convention) | |
3267 | CHARACTER*8 ANAME | |
3268 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3269 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3270 | * beam momenta | |
3271 | COMMON /DTBEAM/ P1(4),P2(4) | |
3272 | ||
3273 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) | |
3274 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) | |
3275 | ||
3276 | DATA LBEAM /.FALSE./ | |
3277 | ||
3278 | GOTO (1,2) MODE | |
3279 | ||
3280 | 1 CONTINUE | |
3281 | ||
3282 | E1 = WHAT(1) | |
3283 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) | |
3284 | E2 = WHAT(2) | |
3285 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) | |
3286 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) | |
3287 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) | |
3288 | TH = 1.D-6*WHAT(3)/2.D0 | |
3289 | PH = WHAT(4)*BOG | |
3290 | P1(1) = PP1*SIN(TH)*COS(PH) | |
3291 | P1(2) = PP1*SIN(TH)*SIN(PH) | |
3292 | P1(3) = PP1*COS(TH) | |
3293 | P1(4) = E1 | |
3294 | P2(1) = PP2*SIN(TH)*COS(PH) | |
3295 | P2(2) = PP2*SIN(TH)*SIN(PH) | |
3296 | P2(3) = -PP2*COS(TH) | |
3297 | P2(4) = E2 | |
3298 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 | |
3299 | & -(P1(3)+P2(3))**2 ) | |
3300 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) | |
3301 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) | |
3302 | BGX = (P1(1)+P2(1))/ECM | |
3303 | BGY = (P1(2)+P2(2))/ECM | |
3304 | BGZ = (P1(3)+P2(3))/ECM | |
3305 | BGE = (P1(4)+P2(4))/ECM | |
3306 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), | |
3307 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) | |
3308 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), | |
3309 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) | |
3310 | COD = P1CMS(3)/P1TOT | |
3311 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3312 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) | |
3313 | SID = PPT/P1TOT | |
3314 | COF = ONE | |
3315 | SIF = ZERO | |
3316 | IF (P1TOT*SID.GT.TINY10) THEN | |
3317 | COF = P1CMS(1)/(SID*P1TOT) | |
3318 | SIF = P1CMS(2)/(SID*P1TOT) | |
3319 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3320 | COF = COF/ANORF | |
3321 | SIF = SIF/ANORF | |
3322 | ENDIF | |
3323 | **check | |
3324 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3325 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3326 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT | |
3327 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT | |
3328 | C PAX = ZERO | |
3329 | C PAY = ZERO | |
3330 | C PAZ = P1TOT | |
3331 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) | |
3332 | C PBX = ZERO | |
3333 | C PBY = ZERO | |
3334 | C PBZ = -P2TOT | |
3335 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) | |
3336 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE | |
3337 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE | |
3338 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, | |
3339 | C & P1CMS(1),P1CMS(2),P1CMS(3)) | |
3340 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, | |
3341 | C & P2CMS(1),P2CMS(2),P2CMS(3)) | |
3342 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) | |
3343 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) | |
3344 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), | |
3345 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) | |
3346 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), | |
3347 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) | |
3348 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3349 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3350 | C STOP | |
3351 | ** | |
3352 | ||
3353 | LBEAM = .TRUE. | |
3354 | ||
3355 | RETURN | |
3356 | ||
3357 | 2 CONTINUE | |
3358 | ||
3359 | IF (LBEAM) THEN | |
3360 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3361 | DO 20 I=NPOINT(4),NHKK | |
430525dd | 3362 | IF ((ABS(ISTHKK(I)).EQ.1) .OR. |
3363 | & (ABS(ISTHKK(I)).EQ.2) .OR. | |
3364 | & (ISTHKK(I).EQ.1000) .OR. | |
3365 | & (ISTHKK(I).EQ.1001)) THEN | |
3366 | ||
9aaba0d6 | 3367 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), |
3368 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) | |
3369 | PECMS = PHKK(4,I) | |
3370 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, | |
3371 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) | |
3372 | ENDIF | |
3373 | 20 CONTINUE | |
3374 | ELSE | |
3375 | MODE = -1 | |
3376 | ENDIF | |
3377 | ||
3378 | RETURN | |
3379 | END | |
3380 | ||
3381 | *$ CREATE DT_REJUCO.FOR | |
3382 | *COPY DT_REJUCO | |
3383 | * | |
3384 | *===rejuco=============================================================* | |
3385 | * | |
3386 | SUBROUTINE DT_REJUCO(MODE,IREJ) | |
3387 | ||
3388 | ************************************************************************ | |
3389 | * REJection of Unphysical COnfigurations * | |
3390 | * MODE = 1 rejection of particles with unphysically large energy * | |
3391 | * * | |
3392 | * This version dated 27.12.2006 is written by S. Roesler. * | |
3393 | ************************************************************************ | |
3394 | ||
3395 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3396 | SAVE | |
3397 | ||
3398 | PARAMETER ( LINP = 10 , | |
3399 | & LOUT = 6 , | |
3400 | & LDAT = 9 ) | |
3401 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3402 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3403 | ||
3404 | * maximum x_cms of final state particle | |
3405 | PARAMETER (XCMSMX = 1.4D0) | |
3406 | ||
3407 | * event history | |
3408 | PARAMETER (NMXHKK=200000) | |
3409 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3410 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3411 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3412 | * extended event history | |
3413 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3414 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3415 | & IHIST(2,NMXHKK) | |
3416 | * Lorentz-parameters of the current interaction | |
3417 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
3418 | & UMO,PPCM,EPROJ,PPROJ | |
3419 | ||
3420 | IREJ = 0 | |
3421 | ||
3422 | IF (MODE.EQ.1) THEN | |
3423 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3424 | ECMHLF = UMO/2.0D0 | |
3425 | DO 10 I=NPOINT(4),NHKK | |
3426 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN | |
3427 | XCMS = ABS(PHKK(4,I))/ECMHLF | |
3428 | IF (XCMS.GT.XCMSMX) GOTO 9999 | |
3429 | ENDIF | |
3430 | 10 CONTINUE | |
3431 | ENDIF | |
3432 | ||
3433 | RETURN | |
3434 | 9999 CONTINUE | |
3435 | IREJ = 1 | |
3436 | RETURN | |
3437 | END | |
3438 | ||
3439 | *$ CREATE DT_EVENTB.FOR | |
3440 | *COPY DT_EVENTB | |
3441 | * | |
3442 | *===eventb=============================================================* | |
3443 | * | |
3444 | SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
3445 | ||
3446 | ************************************************************************ | |
3447 | * Treatment of nucleon-nucleon interactions with full two-component * | |
3448 | * Dual Parton Model. * | |
3449 | * NCSY number of nucleon-nucleon interactions * | |
3450 | * IREJ rejection flag * | |
3451 | * This version dated 14.01.2000 is written by S. Roesler * | |
3452 | ************************************************************************ | |
3453 | ||
3454 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3455 | SAVE | |
3456 | PARAMETER ( LINP = 10 , | |
3457 | & LOUT = 6 , | |
3458 | & LDAT = 9 ) | |
3459 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
3460 | ||
3461 | * event history | |
3462 | PARAMETER (NMXHKK=200000) | |
3463 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3464 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3465 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3466 | * extended event history | |
3467 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3468 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3469 | & IHIST(2,NMXHKK) | |
3470 | *! uncomment this line for internal phojet-fragmentation | |
3471 | C #include "dtu_dtevtp.inc" | |
3472 | * particle properties (BAMJET index convention) | |
3473 | CHARACTER*8 ANAME | |
3474 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3475 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3476 | * flags for input different options | |
3477 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
3478 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
3479 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
3480 | * rejection counter | |
3481 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
3482 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
3483 | & IREXCI(3),IRDIFF(2),IRINC | |
3484 | * properties of interacting particles | |
3485 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3486 | * properties of photon/lepton projectiles | |
3487 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
3488 | * various options for treatment of partons (DTUNUC 1.x) | |
3489 | * (chain recombination, Cronin,..) | |
3490 | LOGICAL LCO2CR,LINTPT | |
3491 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
3492 | & LCO2CR,LINTPT | |
3493 | * statistics | |
3494 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
3495 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
3496 | & ICEVTG(8,0:30) | |
3497 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
3498 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
3499 | * Glauber formalism: collision properties | |
3500 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
3501 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
3502 | * flags for diffractive interactions (DTUNUC 1.x) | |
3503 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
3504 | * statistics: double-Pomeron exchange | |
3505 | COMMON /DTFLG2/ INTFLG,IPOPO | |
3506 | * flags for particle decays | |
3507 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
3508 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
3509 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
3510 | * nucleon-nucleon event-generator | |
3511 | CHARACTER*8 CMODEL | |
3512 | LOGICAL LPHOIN | |
3513 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
3514 | C nucleon-nucleus / nucleus-nucleus interface to DPMJET | |
3515 | INTEGER IDEQP,IDEQB,IHFLD,IHFLS | |
3516 | DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB | |
3517 | COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, | |
3518 | & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) | |
3519 | C model switches and parameters | |
3520 | CHARACTER*8 MDLNA | |
3521 | INTEGER ISWMDL,IPAMDL | |
3522 | DOUBLE PRECISION PARMDL | |
3523 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
3524 | C initial state parton radiation (internal part) | |
3525 | INTEGER MXISR3,MXISR4 | |
3526 | PARAMETER ( MXISR3 = 50, MXISR4 = 100 ) | |
3527 | INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC | |
3528 | DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT | |
3529 | COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), | |
3530 | & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), | |
3531 | & IFL1(2,MXISR3),IFL2(2,MXISR3), | |
3532 | & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC | |
3533 | C event debugging information | |
3534 | INTEGER NMAXD | |
3535 | PARAMETER (NMAXD=100) | |
3536 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
3537 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3538 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
3539 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3540 | C general process information | |
3541 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
3542 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
3543 | ||
3544 | DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), | |
3545 | & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), | |
3546 | & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), | |
3547 | & KPRON(15),ISINGL(2000) | |
3548 | ||
3549 | * initial values for max. number of phojet scatterings and dtunuc chains | |
3550 | * to be fragmented with one pyexec call | |
3551 | DATA MXPHFR,MXDTFR /10,100/ | |
3552 | ||
3553 | IREJ = 0 | |
3554 | * pointer to first parton of the first chain in dtevt common | |
3555 | NPOINT(3) = NHKK+1 | |
3556 | * special flag for double-Pomeron statistics | |
3557 | IPOPO = 1 | |
3558 | * counter for low-mass (DTUNUC) interactions | |
3559 | NDTUSC = 0 | |
3560 | * counter for interactions treated by PHOJET | |
3561 | NPHOSC = 0 | |
3562 | ||
3563 | * scan interactions for single nucleon-nucleon interactions | |
3564 | * (this has to be checked here because Cronin modifies parton momenta) | |
3565 | NC = NPOINT(2) | |
3566 | IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! ' | |
3567 | DO 8 I=1,NCSY | |
3568 | ISINGL(I) = 0 | |
3569 | MOP = JMOHKK(1,NC) | |
3570 | MOT = JMOHKK(1,NC+1) | |
3571 | DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2)) | |
3572 | DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3)) | |
3573 | IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1 | |
3574 | NC = NC+4 | |
3575 | 8 CONTINUE | |
3576 | ||
3577 | * multiple scattering of chain ends | |
3578 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
3579 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
3580 | ||
3581 | * switch to PHOJET-settings for JETSET parameter | |
3582 | CALL DT_INITJS(1) | |
3583 | ||
3584 | * loop over nucleon-nucleon interaction | |
3585 | NC = NPOINT(2) | |
3586 | DO 2 I=1,NCSY | |
3587 | * | |
3588 | * pick up one nucleon-nucleon interaction from DTEVT1 | |
3589 | * ppnn / ptnn - momenta of the interacting nucleons (cms) | |
3590 | * ptotnn - total momentum of the interacting nucleons (cms) | |
3591 | * pp1,2 / pt1,2 - momenta of the four partons | |
3592 | * pp / pt - total momenta of the proj / targ partons | |
3593 | * ptot - total momentum of the four partons | |
3594 | MOP = JMOHKK(1,NC) | |
3595 | MOT = JMOHKK(1,NC+1) | |
3596 | DO 3 K=1,4 | |
3597 | PPNN(K) = PHKK(K,MOP) | |
3598 | PTNN(K) = PHKK(K,MOT) | |
3599 | PTOTNN(K) = PPNN(K)+PTNN(K) | |
3600 | PP1(K) = PHKK(K,NC) | |
3601 | PT1(K) = PHKK(K,NC+1) | |
3602 | PP2(K) = PHKK(K,NC+2) | |
3603 | PT2(K) = PHKK(K,NC+3) | |
3604 | PP(K) = PP1(K)+PP2(K) | |
3605 | PT(K) = PT1(K)+PT2(K) | |
3606 | PTOT(K) = PP(K)+PT(K) | |
3607 | 3 CONTINUE | |
3608 | * | |
3609 | *----------------------------------------------------------------------- | |
3610 | * this is a complete nucleon-nucleon interaction | |
3611 | * | |
3612 | IF (ISINGL(I).EQ.1) THEN | |
3613 | * | |
3614 | * initialize PHOJET-variables for remnant/valence-partons | |
3615 | IHFLD(1,1) = 0 | |
3616 | IHFLD(1,2) = 0 | |
3617 | IHFLD(2,1) = 0 | |
3618 | IHFLD(2,2) = 0 | |
3619 | IHFLS(1) = 1 | |
3620 | IHFLS(2) = 1 | |
3621 | * save current settings of PHOJET process and min. bias flags | |
3622 | DO 9 K=1,11 | |
3623 | KPRON(K) = IPRON(K,1) | |
3624 | 9 CONTINUE | |
3625 | ISWSAV = ISWMDL(2) | |
3626 | * | |
3627 | * check if forced sampling of diffractive interaction requested | |
3628 | IF (ISINGD.LT.-1) THEN | |
3629 | DO 90 K=1,11 | |
3630 | IPRON(K,1) = 0 | |
3631 | 90 CONTINUE | |
3632 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1 | |
3633 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1 | |
3634 | IF (ISINGD.EQ.-5) IPRON(4,1) = 1 | |
3635 | ENDIF | |
3636 | * | |
3637 | * for photons: a direct/anomalous interaction is not sampled | |
3638 | * in PHOJET but already in Glauber-formalism. Here we check if such | |
3639 | * an interaction is requested | |
3640 | IF (IJPROJ.EQ.7) THEN | |
3641 | * first switch off direct interactions | |
3642 | IPRON(8,1) = 0 | |
3643 | * this is a direct interactions | |
3644 | IF (IDIREC.EQ.1) THEN | |
3645 | DO 12 K=1,11 | |
3646 | IPRON(K,1) = 0 | |
3647 | 12 CONTINUE | |
3648 | IPRON(8,1) = 1 | |
3649 | * this is an anomalous interactions | |
3650 | * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) ) | |
3651 | ELSEIF (IDIREC.EQ.2) THEN | |
3652 | ISWMDL(2) = 0 | |
3653 | ENDIF | |
3654 | ELSE | |
3655 | IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! ' | |
3656 | ENDIF | |
3657 | * | |
3658 | * make sure that total momenta of partons, pp and pt, are on mass | |
3659 | * shell (Cronin may have srewed this up..) | |
3660 | CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1) | |
3661 | IF (IR1.NE.0) THEN | |
3662 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)') | |
3663 | & 'EVENTB: mass shell correction rejected' | |
3664 | GOTO 9999 | |
3665 | ENDIF | |
3666 | * | |
3667 | * initialize the incoming particles in PHOJET | |
3668 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3669 | CALL PHO_SETPAR(1,22,0,VIRT) | |
3670 | ELSE | |
3671 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) | |
3672 | ENDIF | |
3673 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) | |
3674 | * | |
3675 | * initialize rejection loop counter for anomalous processes | |
3676 | IRJANO = 0 | |
3677 | 800 CONTINUE | |
3678 | IRJANO = IRJANO+1 | |
3679 | * | |
3680 | * temporary fix for ifano problem | |
3681 | IFANO(1) = 0 | |
3682 | IFANO(2) = 0 | |
3683 | * | |
3684 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET | |
3685 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) | |
3686 | * | |
3687 | * for photons: special consistency check for anomalous interactions | |
3688 | IF (IJPROJ.EQ.7) THEN | |
3689 | IF (IRJANO.LT.30) THEN | |
3690 | IF (IFANO(1).NE.0) THEN | |
3691 | * here, an anomalous interaction was generated. Check if it | |
3692 | * was also requested. Otherwise reject this event. | |
3693 | IF (IDIREC.EQ.0) GOTO 800 | |
3694 | ELSE | |
3695 | * here, an anomalous interaction was not generated. Check if it | |
3696 | * was requested in which case we need to reject this event. | |
3697 | IF (IDIREC.EQ.2) GOTO 800 | |
3698 | ENDIF | |
3699 | ELSE | |
3700 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', | |
3701 | & IRJANO,IDIREC,NEVHKK | |
3702 | ENDIF | |
3703 | ENDIF | |
3704 | * | |
3705 | * copy back original settings of PHOJET process and min. bias flags | |
3706 | DO 10 K=1,11 | |
3707 | IPRON(K,1) = KPRON(K) | |
3708 | 10 CONTINUE | |
3709 | ISWMDL(2) = ISWSAV | |
3710 | * | |
3711 | * check if PHOJET has rejected this event | |
3712 | IF (IREJ1.NE.0) THEN | |
3713 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3714 | WRITE(LOUT,'(1X,A,I4)') | |
3715 | & 'EVENTB: chain system rejected',IDIREC | |
3716 | CALL PHO_PREVNT(0) | |
3717 | GOTO 9999 | |
3718 | ENDIF | |
3719 | * | |
3720 | * copy partons and strings from PHOJET common back into DTEVT for | |
3721 | * external fragmentation | |
3722 | MO1 = NC | |
3723 | MO2 = NC+3 | |
3724 | *! uncomment this line for internal phojet-fragmentation | |
3725 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) | |
3726 | NPHOSC = NPHOSC+1 | |
3727 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) | |
3728 | IF (IREJ1.NE.0) THEN | |
3729 | IF (IOULEV(1).GT.0) | |
3730 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' | |
3731 | GOTO 9999 | |
3732 | ENDIF | |
3733 | * | |
3734 | * update statistics counter | |
3735 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 | |
3736 | * | |
3737 | *----------------------------------------------------------------------- | |
3738 | * this interaction involves "remnants" | |
3739 | * | |
3740 | ELSE | |
3741 | * | |
3742 | * total mass of this system | |
3743 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) | |
3744 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) | |
3745 | IF (AMTOT2.LT.ZERO) THEN | |
3746 | AMTOT = ZERO | |
3747 | ELSE | |
3748 | AMTOT = SQRT(AMTOT2) | |
3749 | ENDIF | |
3750 | * | |
3751 | * systems with masses larger than elojet are treated with PHOJET | |
3752 | IF (AMTOT.GT.ELOJET) THEN | |
3753 | * | |
3754 | * initialize PHOJET-variables for remnant/valence-partons | |
3755 | * projectile parton flavors and valence flag | |
3756 | IHFLD(1,1) = IDHKK(NC) | |
3757 | IHFLD(1,2) = IDHKK(NC+2) | |
3758 | IHFLS(1) = 0 | |
3759 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) | |
3760 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 | |
3761 | * target parton flavors and valence flag | |
3762 | IHFLD(2,1) = IDHKK(NC+1) | |
3763 | IHFLD(2,2) = IDHKK(NC+3) | |
3764 | IHFLS(2) = 0 | |
3765 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) | |
3766 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 | |
3767 | * flag signalizing PHOJET how to treat the remnant: | |
3768 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld | |
3769 | * iremn > -1 valence remnant: PHOJET assumes flavors according | |
3770 | * to mother particle | |
3771 | IREMN1 = IHFLS(1)-1 | |
3772 | IREMN2 = IHFLS(2)-1 | |
3773 | * | |
3774 | * initialize the incoming particles in PHOJET | |
3775 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3776 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) | |
3777 | ELSE | |
3778 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) | |
3779 | ENDIF | |
3780 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) | |
3781 | * | |
3782 | * calculate Lorentz parameter of the nucleon-nucleon cm-system | |
3783 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) | |
3784 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) | |
3785 | BGX = PTOTNN(1)/AMNN | |
3786 | BGY = PTOTNN(2)/AMNN | |
3787 | BGZ = PTOTNN(3)/AMNN | |
3788 | GAM = PTOTNN(4)/AMNN | |
3789 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3790 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3791 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, | |
3792 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) | |
3793 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3794 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, | |
3795 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) | |
3796 | * transform (total) momenta of the proj and targ partons into | |
3797 | * nucleon-nucleon cm-system | |
3798 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3799 | & PP(1),PP(2),PP(3),PP(4), | |
3800 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) | |
3801 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3802 | & PT(1),PT(2),PT(3),PT(4), | |
3803 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) | |
3804 | * energy fractions of the proj and targ partons | |
3805 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) | |
3806 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) | |
3807 | *** | |
3808 | * testprint | |
3809 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3810 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3811 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3812 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3813 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3814 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3815 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3816 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3817 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3818 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3819 | *** | |
3820 | * | |
3821 | * save current settings of PHOJET process and min. bias flags | |
3822 | DO 7 K=1,11 | |
3823 | KPRON(K) = IPRON(K,1) | |
3824 | 7 CONTINUE | |
3825 | * disallow direct photon int. (does not make sense here anyway) | |
3826 | IPRON(8,1) = 0 | |
3827 | * disallow double pomeron processes (due to technical problems | |
3828 | * in PHOJET, needs to be solved sometime) | |
3829 | IPRON(4,1) = 0 | |
3830 | * disallow diffraction for sea-diquarks | |
3831 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. | |
3832 | & (IABS(IHFLD(1,2)).GT.1100)) THEN | |
3833 | IPRON(3,1) = 0 | |
3834 | IPRON(6,1) = 0 | |
3835 | ENDIF | |
3836 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. | |
3837 | & (IABS(IHFLD(2,2)).GT.1100)) THEN | |
3838 | IPRON(3,1) = 0 | |
3839 | IPRON(5,1) = 0 | |
3840 | ENDIF | |
3841 | * | |
3842 | * we need massless partons: transform them on mass shell | |
3843 | XMP = ZERO | |
3844 | XMT = ZERO | |
3845 | DO 6 K=1,4 | |
3846 | PPTMP(K) = PPSUB(K) | |
3847 | PTTMP(K) = PTSUB(K) | |
3848 | 6 CONTINUE | |
3849 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) | |
3850 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) | |
3851 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) | |
3852 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ | |
3853 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) | |
3854 | * total energy of the subsysten after mass transformation | |
3855 | * (should be the same as before..) | |
3856 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* | |
3857 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) | |
3858 | * | |
3859 | * after mass shell transformation the x_sub - relation has to be | |
3860 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. | |
3861 | * | |
3862 | * The old version was to scale based on the original x_sub and the | |
3863 | * 4-momenta of the subsystem. At very high energy this could lead to | |
3864 | * "pseudo-cm energies" of the parent system considerably exceeding | |
3865 | * the true cm energy. Now we keep the true cm energy and calculate | |
3866 | * new x_sub instead. | |
3867 | C old version PPTCMS(4) = PPSUB(4)/XPSUB | |
3868 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) | |
3869 | XPSUB = PPSUB(4)/PPTCMS(4) | |
3870 | IF (IJPROJ.EQ.7) THEN | |
3871 | AMP2 = PHKK(5,MOT)**2 | |
3872 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) | |
3873 | ELSE | |
3874 | *??????? | |
3875 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) | |
3876 | & *(PPTCMS(4)+PHKK(5,MOP))) | |
3877 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) | |
3878 | C & *(PPTCMS(4)+PHKK(5,MOT))) | |
3879 | ENDIF | |
3880 | C old version PTTCMS(4) = PTSUB(4)/XTSUB | |
3881 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) | |
3882 | XTSUB = PTSUB(4)/PTTCMS(4) | |
3883 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) | |
3884 | & *(PTTCMS(4)+PHKK(5,MOT))) | |
3885 | DO 4 K=1,3 | |
3886 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO | |
3887 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO | |
3888 | 4 CONTINUE | |
3889 | *** | |
3890 | * testprint | |
3891 | * | |
3892 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) | |
3893 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) | |
3894 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) | |
3895 | * pp1,2 / pt1,2 - momenta of the four partons | |
3896 | * | |
3897 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) | |
3898 | * ptot - total momentum of the four partons (cms, negl. Fermi) | |
3899 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) | |
3900 | * | |
3901 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3902 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3903 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3904 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3905 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3906 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3907 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3908 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3909 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3910 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3911 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN | |
3912 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM | |
3913 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU | |
3914 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB | |
3915 | c ENDIF | |
3916 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM | |
3917 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM | |
3918 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM | |
3919 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM | |
3920 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3921 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3922 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, | |
3923 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) | |
3924 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3925 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, | |
3926 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) | |
3927 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3928 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, | |
3929 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) | |
3930 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3931 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, | |
3932 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) | |
3933 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + | |
3934 | c & (PPNEW2+PTNEW2)**2 + | |
3935 | c & (PPNEW3+PTNEW3)**2 ) | |
3936 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * | |
3937 | c & (PPNEW4+PTNEW4+PTSTCM) ) | |
3938 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + | |
3939 | c & (PPSUB2+PTSUB2)**2 + | |
3940 | c & (PPSUB3+PTSUB3)**2 ) | |
3941 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * | |
3942 | c & (PPSUB4+PTSUB4+PTSTSU) ) | |
3943 | C WRITE(*,*) ' mother cmE :' | |
3944 | C WRITE(*,*) ETSTCM,ENEWCM | |
3945 | C WRITE(*,*) ' subsystem cmE :' | |
3946 | C WRITE(*,*) ETSTSU,ENEWSU | |
3947 | C WRITE(*,*) ' projectile mother :' | |
3948 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 | |
3949 | C WRITE(*,*) ' target mother :' | |
3950 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 | |
3951 | C WRITE(*,*) ' projectile subsystem:' | |
3952 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 | |
3953 | C WRITE(*,*) ' target subsystem:' | |
3954 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 | |
3955 | C WRITE(*,*) ' projectile subsystem should be:' | |
3956 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, | |
3957 | C & XPSUB*ETSTCM/2.0D0 | |
3958 | C WRITE(*,*) ' target subsystem should be:' | |
3959 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, | |
3960 | C & XTSUB*ETSTCM/2.0D0 | |
3961 | C WRITE(*,*) ' subsystem cmE should be: ' | |
3962 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB | |
3963 | *** | |
3964 | * | |
3965 | * generate complete remnant - nucleon/remnant event with PHOJET | |
3966 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) | |
3967 | * | |
3968 | * copy back original settings of PHOJET process flags | |
3969 | DO 11 K=1,11 | |
3970 | IPRON(K,1) = KPRON(K) | |
3971 | 11 CONTINUE | |
3972 | * | |
3973 | * check if PHOJET has rejected this event | |
3974 | IF (IREJ1.NE.0) THEN | |
3975 | IF (IOULEV(1).GT.0) | |
3976 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' | |
3977 | WRITE(LOUT,*) | |
3978 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT | |
3979 | CALL PHO_PREVNT(0) | |
3980 | GOTO 9999 | |
3981 | ENDIF | |
3982 | * | |
3983 | * copy partons and strings from PHOJET common back into DTEVT for | |
3984 | * external fragmentation | |
3985 | MO1 = NC | |
3986 | MO2 = NC+3 | |
3987 | *! uncomment this line for internal phojet-fragmentation | |
3988 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) | |
3989 | NPHOSC = NPHOSC+1 | |
3990 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) | |
3991 | IF (IREJ1.NE.0) THEN | |
3992 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3993 | & 'EVENTB: chain system rejected 2' | |
3994 | GOTO 9999 | |
3995 | ENDIF | |
3996 | * | |
3997 | * update statistics counter | |
3998 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 | |
3999 | * | |
4000 | *----------------------------------------------------------------------- | |
4001 | * two-chain approx. for smaller systems | |
4002 | * | |
4003 | ELSE | |
4004 | * | |
4005 | NDTUSC = NDTUSC+1 | |
4006 | * special flag for double-Pomeron statistics | |
4007 | IPOPO = 0 | |
4008 | * | |
4009 | * pick up flavors at the ends of the two chains | |
4010 | IFP1 = IDHKK(NC) | |
4011 | IFT1 = IDHKK(NC+1) | |
4012 | IFP2 = IDHKK(NC+2) | |
4013 | IFT2 = IDHKK(NC+3) | |
4014 | * ..and the indices of the mothers | |
4015 | MOP1 = NC | |
4016 | MOT1 = NC+1 | |
4017 | MOP2 = NC+2 | |
4018 | MOT2 = NC+3 | |
4019 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
4020 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
4021 | * | |
4022 | * check if this chain system was rejected | |
4023 | IF (IREJ1.GT.0) THEN | |
4024 | IF (IOULEV(1).GT.0) THEN | |
4025 | WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4026 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') | |
4027 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT | |
4028 | ENDIF | |
4029 | IRHHA = IRHHA+1 | |
4030 | GOTO 9999 | |
4031 | ENDIF | |
4032 | * the following lines are for sea-sea chains rejected in GETCSY | |
4033 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 | |
4034 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 | |
4035 | ENDIF | |
4036 | * | |
4037 | ENDIF | |
4038 | * | |
4039 | * update statistics counter | |
4040 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 | |
4041 | * | |
4042 | NC = NC+4 | |
4043 | * | |
4044 | 2 CONTINUE | |
4045 | * | |
4046 | *----------------------------------------------------------------------- | |
4047 | * treatment of low-mass chains (if there are any) | |
4048 | * | |
4049 | IF (NDTUSC.GT.0) THEN | |
4050 | * | |
4051 | * correct chains of very low masses for possible resonances | |
4052 | IF (IRESCO.EQ.1) THEN | |
4053 | CALL DT_EVTRES(IREJ1) | |
4054 | IF (IREJ1.GT.0) THEN | |
4055 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' | |
4056 | IRRES(1) = IRRES(1)+1 | |
4057 | GOTO 9999 | |
4058 | ENDIF | |
4059 | ENDIF | |
4060 | * fragmentation of low-mass chains | |
4061 | *! uncomment this line for internal phojet-fragmentation | |
4062 | * (of course it will still be fragmented by DPMJET-routines but it | |
4063 | * has to be done here instead of further below) | |
4064 | C CALL DT_EVTFRA(IREJ1) | |
4065 | C IF (IREJ1.GT.0) THEN | |
4066 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' | |
4067 | C IRFRAG = IRFRAG+1 | |
4068 | C GOTO 9999 | |
4069 | C ENDIF | |
4070 | ELSE | |
4071 | *! uncomment this line for internal phojet-fragmentation | |
4072 | C NPOINT(4) = NHKK+1 | |
4073 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
4074 | ENDIF | |
4075 | * | |
4076 | *----------------------------------------------------------------------- | |
4077 | * new di-quark breaking mechanisms | |
4078 | * | |
4079 | MXLEFT = 2 | |
4080 | CALL DT_CHASTA(0) | |
4081 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
4082 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
4083 | CALL DT_DIQBRK | |
4084 | MXLEFT = 4 | |
4085 | ENDIF | |
4086 | * | |
4087 | *----------------------------------------------------------------------- | |
4088 | * hadronize this event | |
4089 | * | |
4090 | * hadronize PHOJET chain systems | |
4091 | NPYMAX = 0 | |
4092 | NPJE = NPHOSC/MXPHFR | |
4093 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 | |
4094 | IF (NPJE.GT.1) THEN | |
4095 | NLEFT = NPHOSC-NPJE*MXPHFR | |
4096 | DO 20 JFRG=1,NPJE | |
4097 | NFRG = JFRG*MXPHFR | |
4098 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN | |
4099 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4100 | IF (IREJ1.GT.0) GOTO 22 | |
4101 | NLEFT = 0 | |
4102 | ELSE | |
4103 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) | |
4104 | IF (IREJ1.GT.0) GOTO 22 | |
4105 | ENDIF | |
4106 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4107 | 20 CONTINUE | |
4108 | IF (NLEFT.GT.0) THEN | |
4109 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4110 | IF (IREJ1.GT.0) GOTO 22 | |
4111 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4112 | ENDIF | |
4113 | ELSE | |
4114 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4115 | IF (IREJ1.GT.0) GOTO 22 | |
4116 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4117 | ENDIF | |
4118 | * | |
4119 | * check max. filling level of jetset common and | |
4120 | * reduce mxphfr if necessary | |
4121 | IF (NPYMAX.GT.3000) THEN | |
4122 | IF (NPYMAX.GT.3500) THEN | |
4123 | MXPHFR = MAX(1,MXPHFR-2) | |
4124 | ELSE | |
4125 | MXPHFR = MAX(1,MXPHFR-1) | |
4126 | ENDIF | |
4127 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR | |
4128 | ENDIF | |
4129 | * | |
4130 | * hadronize DTUNUC chain systems | |
4131 | 23 CONTINUE | |
4132 | IBACK = MXDTFR | |
4133 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) | |
4134 | IF (IREJ2.GT.0) GOTO 22 | |
4135 | * | |
4136 | * check max. filling level of jetset common and | |
4137 | * reduce mxdtfr if necessary | |
4138 | IF (NPYMEM.GT.3000) THEN | |
4139 | IF (NPYMEM.GT.3500) THEN | |
4140 | MXDTFR = MAX(1,MXDTFR-20) | |
4141 | ELSE | |
4142 | MXDTFR = MAX(1,MXDTFR-10) | |
4143 | ENDIF | |
4144 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR | |
4145 | ENDIF | |
4146 | * | |
4147 | IF (IBACK.EQ.-1) GOTO 23 | |
4148 | * | |
4149 | 22 CONTINUE | |
4150 | C CALL DT_EVTFRG(1,IREJ1) | |
4151 | C CALL DT_EVTFRG(2,IREJ2) | |
4152 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN | |
4153 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4154 | IRFRAG = IRFRAG+1 | |
4155 | GOTO 9999 | |
4156 | ENDIF | |
4157 | * | |
4158 | * get final state particles from /DTEVTP/ | |
4159 | *! uncomment this line for internal phojet-fragmentation | |
4160 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) | |
4161 | ||
4162 | IF (IJPROJ.NE.7) | |
4163 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) | |
4164 | C IF (IREJ3.NE.0) GOTO 9999 | |
4165 | ||
4166 | RETURN | |
4167 | ||
4168 | 9999 CONTINUE | |
4169 | IREVT = IREVT+1 | |
4170 | IREJ = 1 | |
4171 | RETURN | |
4172 | END | |
4173 | ||
4174 | *$ CREATE DT_GETPJE.FOR | |
4175 | *COPY DT_GETPJE | |
4176 | * | |
4177 | *===getpje=============================================================* | |
4178 | * | |
4179 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) | |
4180 | ||
4181 | ************************************************************************ | |
4182 | * This subroutine copies PHOJET partons and strings from POEVT1 into * | |
4183 | * DTEVT1. * | |
4184 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * | |
4185 | * PP,PT 4-momenta of projectile/target being handled by * | |
4186 | * PHOJET * | |
4187 | * This version dated 11.12.99 is written by S. Roesler * | |
4188 | ************************************************************************ | |
4189 | ||
4190 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4191 | SAVE | |
4192 | PARAMETER ( LINP = 10 , | |
4193 | & LOUT = 6 , | |
4194 | & LDAT = 9 ) | |
4195 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, | |
4196 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) | |
4197 | ||
4198 | LOGICAL LFLIP | |
4199 | ||
4200 | * event history | |
4201 | PARAMETER (NMXHKK=200000) | |
4202 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4203 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4204 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4205 | * extended event history | |
4206 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4207 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4208 | & IHIST(2,NMXHKK) | |
4209 | * Lorentz-parameters of the current interaction | |
4210 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4211 | & UMO,PPCM,EPROJ,PPROJ | |
4212 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
4213 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
4214 | * flags for input different options | |
4215 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4216 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4217 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4218 | * statistics: double-Pomeron exchange | |
4219 | COMMON /DTFLG2/ INTFLG,IPOPO | |
4220 | * statistics | |
4221 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
4222 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
4223 | & ICEVTG(8,0:30) | |
4224 | * rejection counter | |
4225 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
4226 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
4227 | & IREXCI(3),IRDIFF(2),IRINC | |
4228 | C standard particle data interface | |
4229 | INTEGER NMXHEP | |
4230 | PARAMETER (NMXHEP=4000) | |
4231 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
4232 | DOUBLE PRECISION PHEP,VHEP | |
4233 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
4234 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
09b429a4 | 4235 | & VHEP(4,NMXHEP), NSD1, NSD2, NDD |
9aaba0d6 | 4236 | C extension to standard particle data interface (PHOJET specific) |
4237 | INTEGER IMPART,IPHIST,ICOLOR | |
4238 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
4239 | C color string configurations including collapsed strings and hadrons | |
4240 | INTEGER MSTR | |
4241 | PARAMETER (MSTR=500) | |
4242 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD | |
4243 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), | |
4244 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), | |
4245 | & NNCH(MSTR),IBHAD(MSTR),ISTR | |
4246 | C general process information | |
4247 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4248 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4249 | C model switches and parameters | |
4250 | CHARACTER*8 MDLNA | |
4251 | INTEGER ISWMDL,IPAMDL | |
4252 | DOUBLE PRECISION PARMDL | |
4253 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4254 | C event debugging information | |
4255 | INTEGER NMAXD | |
4256 | PARAMETER (NMAXD=100) | |
4257 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
4258 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4259 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
4260 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4261 | ||
4262 | DIMENSION PP(4),PT(4) | |
4263 | DATA MAXLOP /10000/ | |
4264 | ||
4265 | INHKK = NHKK | |
4266 | LFLIP = .TRUE. | |
4267 | 1 CONTINUE | |
4268 | NPVAL = 0 | |
4269 | NTVAL = 0 | |
4270 | IREJ = 0 | |
4271 | ||
4272 | * store initial momenta for energy-momentum conservation check | |
4273 | IF (LEMCCK) THEN | |
4274 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) | |
4275 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) | |
4276 | ENDIF | |
4277 | * copy partons and strings from POEVT1 into DTEVT1 | |
4278 | DO 11 I=1,ISTR | |
4279 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN | |
4280 | IF (NCODE(I).EQ.-99) THEN | |
4281 | IDXSTG = NPOS(1,I) | |
4282 | IDSTG = IDHEP(IDXSTG) | |
4283 | PX = PHEP(1,IDXSTG) | |
4284 | PY = PHEP(2,IDXSTG) | |
4285 | PZ = PHEP(3,IDXSTG) | |
4286 | PE = PHEP(4,IDXSTG) | |
4287 | IF (MODE.LT.0) THEN | |
4288 | ISTAT = 70000+IPJE | |
4289 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, | |
4290 | & 11,IDSTG,0) | |
4291 | IF (LEMCCK) THEN | |
4292 | PX = -PX | |
4293 | PY = -PY | |
4294 | PZ = -PZ | |
4295 | PE = -PE | |
4296 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4297 | ENDIF | |
4298 | ELSE | |
4299 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4300 | & PPX,PPY,PPZ,PPE) | |
4301 | ISTAT = 70000+IPJE | |
4302 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, | |
4303 | & 11,IDSTG,0) | |
4304 | IF (LEMCCK) THEN | |
4305 | PX = -PPX | |
4306 | PY = -PPY | |
4307 | PZ = -PPZ | |
4308 | PE = -PPE | |
4309 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4310 | ENDIF | |
4311 | ENDIF | |
4312 | NOBAM(NHKK) = 0 | |
4313 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) | |
4314 | IHIST(2,NHKK) = 0 | |
4315 | ELSEIF (NCODE(I).GE.0) THEN | |
4316 | * indices of partons and string in POEVT1 | |
4317 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) | |
4318 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) | |
4319 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN | |
4320 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, | |
4321 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' | |
4322 | STOP ' GETPJE 1' | |
4323 | ENDIF | |
4324 | IDXSTG = NPOS(1,I) | |
4325 | * find "mother" string of the string | |
4326 | IDXMS1 = ABS(JMOHEP(1,IDX1)) | |
4327 | IDXMS2 = ABS(JMOHEP(1,IDX2)) | |
4328 | IF (IDXMS1.NE.IDXMS2) THEN | |
4329 | IDXMS1 = IDXSTG | |
4330 | IDXMS2 = IDXSTG | |
4331 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' | |
4332 | ENDIF | |
4333 | * search POEVT1 for the original hadron of the parton | |
4334 | ILOOP = 0 | |
4335 | IPOM1 = 0 | |
4336 | 14 CONTINUE | |
4337 | ILOOP = ILOOP+1 | |
4338 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 | |
4339 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) | |
4340 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. | |
4341 | & (ILOOP.LT.MAXLOP)) GOTO 14 | |
4342 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' | |
4343 | IPOM2 = 0 | |
4344 | ILOOP = 0 | |
4345 | 15 CONTINUE | |
4346 | ILOOP = ILOOP+1 | |
4347 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 | |
4348 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN | |
4349 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) | |
4350 | ELSE | |
4351 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) | |
4352 | ENDIF | |
4353 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. | |
4354 | & (ILOOP.LT.MAXLOP)) GOTO 15 | |
4355 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' | |
4356 | * parton 1 | |
4357 | IF (IDXMS1.EQ.1) THEN | |
4358 | ISPTN1 = ISTHKK(MO1) | |
4359 | M1PTN1 = MO1 | |
4360 | M2PTN1 = MO1+2 | |
4361 | ELSE | |
4362 | ISPTN1 = ISTHKK(MO2) | |
4363 | M1PTN1 = MO2-2 | |
4364 | M2PTN1 = MO2 | |
4365 | ENDIF | |
4366 | * parton 2 | |
4367 | IF (IDXMS2.EQ.1) THEN | |
4368 | ISPTN2 = ISTHKK(MO1) | |
4369 | M1PTN2 = MO1 | |
4370 | M2PTN2 = MO1+2 | |
4371 | ELSE | |
4372 | ISPTN2 = ISTHKK(MO2) | |
4373 | M1PTN2 = MO2-2 | |
4374 | M2PTN2 = MO2 | |
4375 | ENDIF | |
4376 | * check for mis-identified mothers and switch mother indices if necessary | |
4377 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) | |
4378 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. | |
4379 | & (LFLIP)) THEN | |
4380 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN | |
4381 | ISPTN1 = ISTHKK(MO1) | |
4382 | M1PTN1 = MO1 | |
4383 | M2PTN1 = MO1+2 | |
4384 | ISPTN2 = ISTHKK(MO2) | |
4385 | M1PTN2 = MO2-2 | |
4386 | M2PTN2 = MO2 | |
4387 | ELSE | |
4388 | ISPTN1 = ISTHKK(MO2) | |
4389 | M1PTN1 = MO2-2 | |
4390 | M2PTN1 = MO2 | |
4391 | ISPTN2 = ISTHKK(MO1) | |
4392 | M1PTN2 = MO1 | |
4393 | M2PTN2 = MO1+2 | |
4394 | ENDIF | |
4395 | ENDIF | |
4396 | * register partons in temporary common | |
4397 | * parton at chain end | |
4398 | PX = PHEP(1,IDX1) | |
4399 | PY = PHEP(2,IDX1) | |
4400 | PZ = PHEP(3,IDX1) | |
4401 | PE = PHEP(4,IDX1) | |
4402 | * flag only partons coming from Pomeron with 41/42 | |
4403 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4404 | IF (IPOM1.NE.0) THEN | |
4405 | ISTX = ABS(ISPTN1)/10 | |
4406 | IMO = ABS(ISPTN1)-10*ISTX | |
4407 | ISPTN1 = -(40+IMO) | |
4408 | ELSE | |
4409 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN | |
4410 | ISTX = ABS(ISPTN1)/10 | |
4411 | IMO = ABS(ISPTN1)-10*ISTX | |
4412 | IF ((IDHEP(IDX1).EQ.21).OR. | |
4413 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN | |
4414 | ISPTN1 = -(60+IMO) | |
4415 | ELSE | |
4416 | ISPTN1 = -(50+IMO) | |
4417 | ENDIF | |
4418 | ENDIF | |
4419 | ENDIF | |
4420 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 | |
4421 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 | |
4422 | IF (MODE.LT.0) THEN | |
4423 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, | |
4424 | & PZ,PE,0,0,0) | |
4425 | ELSE | |
4426 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4427 | & PPX,PPY,PPZ,PPE) | |
4428 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, | |
4429 | & PPZ,PPE,0,0,0) | |
4430 | ENDIF | |
4431 | IHIST(1,NHKK) = IPHIST(1,IDX1) | |
4432 | IHIST(2,NHKK) = 0 | |
4433 | DO 19 KK=1,4 | |
4434 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) | |
4435 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) | |
4436 | 19 CONTINUE | |
4437 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB | |
4438 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB | |
4439 | M1STRG = NHKK | |
4440 | * gluon kinks | |
4441 | NGLUON = IDX2-IDX1-1 | |
4442 | IF (NGLUON.GT.0) THEN | |
4443 | DO 17 IGLUON=1,NGLUON | |
4444 | IDX = IDX1+IGLUON | |
4445 | IDXMS = ABS(JMOHEP(1,IDX)) | |
4446 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN | |
4447 | ILOOP = 0 | |
4448 | 16 CONTINUE | |
4449 | ILOOP = ILOOP+1 | |
4450 | IDXMS = ABS(JMOHEP(1,IDXMS)) | |
4451 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. | |
4452 | & (ILOOP.LT.MAXLOP)) GOTO 16 | |
4453 | IF (ILOOP.EQ.MAXLOP) | |
4454 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' | |
4455 | ENDIF | |
4456 | IF (IDXMS.EQ.1) THEN | |
4457 | ISPTN = ISTHKK(MO1) | |
4458 | M1PTN = MO1 | |
4459 | M2PTN = MO1+2 | |
4460 | ELSE | |
4461 | ISPTN = ISTHKK(MO2) | |
4462 | M1PTN = MO2-2 | |
4463 | M2PTN = MO2 | |
4464 | ENDIF | |
4465 | PX = PHEP(1,IDX) | |
4466 | PY = PHEP(2,IDX) | |
4467 | PZ = PHEP(3,IDX) | |
4468 | PE = PHEP(4,IDX) | |
4469 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN | |
4470 | ISTX = ABS(ISPTN)/10 | |
4471 | IMO = ABS(ISPTN)-10*ISTX | |
4472 | IF ((IDHEP(IDX).EQ.21).OR. | |
4473 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN | |
4474 | ISPTN = -(60+IMO) | |
4475 | ELSE | |
4476 | ISPTN = -(50+IMO) | |
4477 | ENDIF | |
4478 | ENDIF | |
4479 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 | |
4480 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 | |
4481 | IF (MODE.LT.0) THEN | |
4482 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4483 | & PX,PY,PZ,PE,0,0,0) | |
4484 | ELSE | |
4485 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4486 | & PPX,PPY,PPZ,PPE) | |
4487 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4488 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4489 | ENDIF | |
4490 | IHIST(1,NHKK) = IPHIST(1,IDX) | |
4491 | IHIST(2,NHKK) = 0 | |
4492 | DO 20 KK=1,4 | |
4493 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) | |
4494 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) | |
4495 | 20 CONTINUE | |
4496 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB | |
4497 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB | |
4498 | 17 CONTINUE | |
4499 | ENDIF | |
4500 | * parton at chain end | |
4501 | PX = PHEP(1,IDX2) | |
4502 | PY = PHEP(2,IDX2) | |
4503 | PZ = PHEP(3,IDX2) | |
4504 | PE = PHEP(4,IDX2) | |
4505 | * flag only partons coming from Pomeron with 41/42 | |
4506 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4507 | IF (IPOM2.NE.0) THEN | |
4508 | ISTX = ABS(ISPTN2)/10 | |
4509 | IMO = ABS(ISPTN2)-10*ISTX | |
4510 | ISPTN2 = -(40+IMO) | |
4511 | ELSE | |
4512 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN | |
4513 | ISTX = ABS(ISPTN2)/10 | |
4514 | IMO = ABS(ISPTN2)-10*ISTX | |
4515 | IF ((IDHEP(IDX2).EQ.21).OR. | |
4516 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN | |
4517 | ISPTN2 = -(60+IMO) | |
4518 | ELSE | |
4519 | ISPTN2 = -(50+IMO) | |
4520 | ENDIF | |
4521 | ENDIF | |
4522 | ENDIF | |
4523 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 | |
4524 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 | |
4525 | IF (MODE.LT.0) THEN | |
4526 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4527 | & PX,PY,PZ,PE,0,0,0) | |
4528 | ELSE | |
4529 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4530 | & PPX,PPY,PPZ,PPE) | |
4531 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4532 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4533 | ENDIF | |
4534 | IHIST(1,NHKK) = IPHIST(1,IDX2) | |
4535 | IHIST(2,NHKK) = 0 | |
4536 | DO 21 KK=1,4 | |
4537 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) | |
4538 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) | |
4539 | 21 CONTINUE | |
4540 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB | |
4541 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB | |
4542 | M2STRG = NHKK | |
4543 | * register string | |
4544 | JSTRG = 100*IPROCE+NCODE(I) | |
4545 | PX = PHEP(1,IDXSTG) | |
4546 | PY = PHEP(2,IDXSTG) | |
4547 | PZ = PHEP(3,IDXSTG) | |
4548 | PE = PHEP(4,IDXSTG) | |
4549 | IF (MODE.LT.0) THEN | |
4550 | ISTAT = 70000+IPJE | |
4551 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4552 | & PX,PY,PZ,PE,0,0,0) | |
4553 | IF (LEMCCK) THEN | |
4554 | PX = -PX | |
4555 | PY = -PY | |
4556 | PZ = -PZ | |
4557 | PE = -PE | |
4558 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4559 | ENDIF | |
4560 | ELSE | |
4561 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4562 | & PPX,PPY,PPZ,PPE) | |
4563 | ISTAT = 70000+IPJE | |
4564 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4565 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4566 | IF (LEMCCK) THEN | |
4567 | PX = -PPX | |
4568 | PY = -PPY | |
4569 | PZ = -PPZ | |
4570 | PE = -PPE | |
4571 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4572 | ENDIF | |
4573 | ENDIF | |
4574 | NOBAM(NHKK) = 0 | |
4575 | IHIST(1,NHKK) = 0 | |
4576 | IHIST(2,NHKK) = 0 | |
4577 | DO 18 KK=1,4 | |
4578 | VHKK(KK,NHKK) = VHKK(KK,MO2) | |
4579 | WHKK(KK,NHKK) = WHKK(KK,MO1) | |
4580 | 18 CONTINUE | |
4581 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
4582 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
4583 | ENDIF | |
4584 | 11 CONTINUE | |
4585 | ||
4586 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN | |
4587 | NHKK = INHKK | |
4588 | LFLIP = .FALSE. | |
4589 | GOTO 1 | |
4590 | ENDIF | |
4591 | ||
4592 | IF (LEMCCK) THEN | |
4593 | IF (UMO.GT.1.0D5) THEN | |
4594 | CHKLEV = 1.0D0 | |
4595 | ELSE | |
4596 | CHKLEV = TINY1 | |
4597 | ENDIF | |
4598 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) | |
4599 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) | |
4600 | ENDIF | |
4601 | ||
4602 | * internal statistics | |
4603 | * dble-Po statistics. | |
4604 | IF (IPROCE.NE.4) IPOPO = 0 | |
4605 | ||
4606 | INTFLG = IPROCE | |
4607 | IDCHSY = IDCH(MO1) | |
4608 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN | |
4609 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 | |
4610 | ELSE | |
4611 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 | |
4612 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, | |
4613 | & ') at evt(chain) ',I6,'(',I2,')') | |
4614 | ENDIF | |
4615 | IF (IPROCE.EQ.5) THEN | |
4616 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN | |
4617 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 | |
4618 | ELSE | |
4619 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4620 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', | |
4621 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') | |
4622 | ENDIF | |
4623 | ELSEIF (IPROCE.EQ.6) THEN | |
4624 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4625 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 | |
4626 | ELSE | |
4627 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4628 | ENDIF | |
4629 | ELSEIF (IPROCE.EQ.7) THEN | |
4630 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. | |
4631 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4632 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) | |
4633 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 | |
4634 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) | |
4635 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 | |
4636 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) | |
4637 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 | |
4638 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) | |
4639 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 | |
4640 | ELSE | |
4641 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4642 | ENDIF | |
4643 | ENDIF | |
4644 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) | |
4645 | & THEN | |
4646 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4647 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4648 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4649 | ENDIF | |
4650 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM | |
4651 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM | |
4652 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG | |
4653 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) | |
4654 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) | |
4655 | ||
4656 | RETURN | |
4657 | ||
4658 | 9999 CONTINUE | |
4659 | IREJ = 1 | |
4660 | RETURN | |
4661 | END | |
4662 | ||
4663 | *$ CREATE DT_PHOINI.FOR | |
4664 | *COPY DT_PHOINI | |
4665 | * | |
4666 | *===phoini=============================================================* | |
4667 | * | |
4668 | SUBROUTINE DT_PHOINI | |
4669 | ||
4670 | ************************************************************************ | |
4671 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * | |
4672 | * This version dated 16.11.95 is written by S. Roesler * | |
4673 | * * | |
4674 | * Last change 27.12.2006 by S. Roesler. * | |
4675 | ************************************************************************ | |
4676 | ||
4677 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4678 | SAVE | |
4679 | PARAMETER ( LINP = 10 , | |
4680 | & LOUT = 6 , | |
4681 | & LDAT = 9 ) | |
4682 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
4683 | ||
4684 | * nucleon-nucleon event-generator | |
4685 | CHARACTER*8 CMODEL | |
4686 | LOGICAL LPHOIN | |
4687 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
4688 | * particle properties (BAMJET index convention) | |
4689 | CHARACTER*8 ANAME | |
4690 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
4691 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
4692 | * Lorentz-parameters of the current interaction | |
4693 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4694 | & UMO,PPCM,EPROJ,PPROJ | |
4695 | * properties of interacting particles | |
4696 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4697 | * properties of photon/lepton projectiles | |
4698 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
4699 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
4700 | * emulsion treatment | |
4701 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
4702 | & NCOMPO,IEMUL | |
4703 | * VDM parameter for photon-nucleus interactions | |
4704 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
4705 | * nuclear potential | |
4706 | LOGICAL LFERMI | |
4707 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4708 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4709 | & ETACOU(2),ICOUL,LFERMI | |
4710 | * Glauber formalism: flags and parameters for statistics | |
4711 | LOGICAL LPROD | |
4712 | CHARACTER*8 CGLB | |
4713 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
4714 | * | |
4715 | * parameters for cascade calculations: | |
4716 | * maximum mumber of PDF's which can be defined in phojet (limited | |
4717 | * by the dimension of ipdfs in pho_setpdf) | |
4718 | PARAMETER (MAXPDF = 20) | |
4719 | * PDF parametrization and number of set for the first 30 hadrons in | |
4720 | * the bamjet-code list | |
4721 | * negative numbers mean that the PDF is set in phojet, | |
4722 | * zero stands for "not a hadron" | |
4723 | DIMENSION IPARPD(30),ISETPD(30) | |
4724 | * PDF parametrization | |
4725 | DATA IPARPD / | |
4726 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, | |
4727 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ | |
4728 | * number of set | |
4729 | DATA ISETPD / | |
4730 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, | |
4731 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ | |
4732 | ||
4733 | **PHOJET105a | |
4734 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4735 | C PARAMETER ( MAXPRO = 16 ) | |
4736 | C PARAMETER ( MAXTAB = 20 ) | |
4737 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), | |
4738 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB | |
4739 | C CHARACTER*8 MDLNA | |
4740 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
4741 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) | |
4742 | **PHOJET110 | |
4743 | C global event kinematics and particle IDs | |
4744 | INTEGER IFPAP,IFPAB | |
4745 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
4746 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4747 | C hard cross sections and MC selection weights | |
4748 | INTEGER Max_pro_2 | |
4749 | PARAMETER ( Max_pro_2 = 16 ) | |
4750 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, | |
4751 | & MH_acc_1,MH_acc_2 | |
4752 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last | |
4753 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), | |
4754 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), | |
4755 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, | |
4756 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), | |
4757 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) | |
4758 | C model switches and parameters | |
4759 | CHARACTER*8 MDLNA | |
4760 | INTEGER ISWMDL,IPAMDL | |
4761 | DOUBLE PRECISION PARMDL | |
4762 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4763 | C general process information | |
4764 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4765 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4766 | ** | |
4767 | DIMENSION PP(4),PT(4) | |
4768 | ||
4769 | LOGICAL LSTART | |
4770 | DATA LSTART /.TRUE./ | |
4771 | ||
4772 | IJP = IJPROJ | |
4773 | IJT = IJTARG | |
4774 | Q2 = VIRT | |
4775 | * lepton-projectiles: initialize real photon instead | |
4776 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
4777 | IJP = 7 | |
4778 | Q2 = ZERO | |
4779 | ENDIF | |
4780 | IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM) | |
4781 | * switch Reggeon off | |
4782 | C IPAMDL(3)= 0 | |
4783 | IF (IP.EQ.1) THEN | |
4784 | IFPAP(1) = IDT_IPDGHA(IJP) | |
4785 | IFPAB(1) = IJP | |
4786 | ELSE | |
4787 | IFPAP(1) = 2212 | |
4788 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) | |
4789 | ENDIF | |
4790 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) | |
4791 | PVIRT(1) = PMASS(1)**2 | |
4792 | IF (IT.EQ.1) THEN | |
4793 | IFPAP(2) = IDT_IPDGHA(IJT) | |
4794 | IFPAB(2) = IJT | |
4795 | ELSE | |
4796 | IFPAP(2) = 2212 | |
4797 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) | |
4798 | ENDIF | |
4799 | PMASS(2) = AAM(IFPAB(2)) | |
4800 | PVIRT(2) = ZERO | |
4801 | DO 1 K=1,4 | |
4802 | PP(K) = ZERO | |
4803 | PT(K) = ZERO | |
4804 | 1 CONTINUE | |
4805 | * get max. possible momenta of incoming particles to be used for PHOJET ini. | |
4806 | PPF = ZERO | |
4807 | PTF = ZERO | |
4808 | SCPF= 1.5D0 | |
4809 | IF (UMO.GE.1.E5) THEN | |
4810 | SCPF= 5.0D0 | |
4811 | ENDIF | |
4812 | IF (NCOMPO.GT.0) THEN | |
4813 | DO 2 I=1,NCOMPO | |
4814 | IF (IT.GT.1) THEN | |
4815 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) | |
4816 | ELSE | |
4817 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) | |
4818 | ENDIF | |
4819 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) | |
4820 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) | |
4821 | IF (PPFTMP.GT.PPF) PPF = PPFTMP | |
4822 | IF (PTFTMP.GT.PTF) PTF = PTFTMP | |
4823 | 2 CONTINUE | |
4824 | ELSE | |
4825 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
4826 | PPF = MAX(PFERMP(1),PFERMN(1)) | |
4827 | PTF = MAX(PFERMP(2),PFERMN(2)) | |
4828 | ENDIF | |
4829 | PTF = -PTF | |
4830 | PPF = SCPF*PPF | |
4831 | PTF = SCPF*PTF | |
4832 | IF (IJP.EQ.7) THEN | |
4833 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4834 | PP(3) = PPCM | |
4835 | PP(4) = SQRT(AMP2+PP(3)**2) | |
4836 | ELSE | |
4837 | EPF = SQRT(PPF**2+PMASS(1)**2) | |
4838 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) | |
4839 | ENDIF | |
4840 | ETF = SQRT(PTF**2+PMASS(2)**2) | |
4841 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) | |
4842 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
4843 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
4844 | IF (LSTART) THEN | |
4845 | WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP | |
4846 | 1001 FORMAT( | |
4847 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', | |
4848 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4849 | IF (NCOMPO.GT.0) THEN | |
4850 | WRITE(LOUT,1002) SCPF,PTF,PT | |
4851 | ELSE | |
4852 | WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT | |
4853 | ENDIF | |
4854 | 1002 FORMAT( | |
4855 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', | |
4856 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4857 | 1003 FORMAT( | |
4858 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', | |
4859 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4860 | WRITE(LOUT,1004) ECMINI | |
4861 | 1004 FORMAT(' E_cm = ',E10.3) | |
4862 | IF (IJP.EQ.8) WRITE(LOUT,1005) | |
4863 | 1005 FORMAT( | |
4864 | & ' DT_PHOINI: warning! proton parameters used for neutron', | |
4865 | & ' projectile') | |
4866 | LSTART = .FALSE. | |
4867 | ENDIF | |
4868 | * switch off new diffractive cross sections at low energies for nuclei | |
4869 | * (temporary solution) | |
4870 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN | |
4871 | WRITE(LOUT,'(1X,A)') | |
4872 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' | |
4873 | CALL PHO_SETMDL(30,0,1) | |
4874 | ENDIF | |
4875 | * | |
4876 | C IF (IJP.EQ.7) THEN | |
4877 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4878 | C PP(3) = PPCM | |
4879 | C PP(4) = SQRT(AMP2+PP(3)**2) | |
4880 | C ELSE | |
4881 | C PFERMX = ZERO | |
4882 | C IF (IP.GT.1) PFERMX = 0.5D0 | |
4883 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) | |
4884 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) | |
4885 | C ENDIF | |
4886 | C PFERMX = ZERO | |
4887 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 | |
4888 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) | |
4889 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) | |
4890 | **sr 26.10.96 | |
4891 | ISAV = IPAMDL(13) | |
4892 | IF ((ISHAD(2).EQ.1).AND. | |
4893 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. | |
4894 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 | |
4895 | ** | |
4896 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) | |
4897 | **sr 26.10.96 | |
4898 | IPAMDL(13) = ISAV | |
4899 | ** | |
4900 | * | |
4901 | * patch for cascade calculations: | |
4902 | * define parton distribution functions for other hadrons, i.e. other | |
4903 | * then defined already in phojet | |
4904 | IF (IOGLB.EQ.100) THEN | |
4905 | WRITE(LOUT,1006) | |
4906 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', | |
4907 | & ' assiged (ID,IPAR,ISET)',/) | |
4908 | NPDF = 0 | |
4909 | DO 3 I=1,30 | |
4910 | IF (IPARPD(I).NE.0) THEN | |
4911 | NPDF = NPDF+1 | |
4912 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' | |
4913 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN | |
4914 | IDPDG = IDT_IPDGHA(I) | |
4915 | IPAR = IPARPD(I) | |
4916 | ISET = ISETPD(I) | |
4917 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET | |
4918 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) | |
4919 | ENDIF | |
4920 | ENDIF | |
4921 | 3 CONTINUE | |
4922 | ENDIF | |
4923 | ||
4924 | C CALL PHO_PHIST(-1,SIGMAX) | |
4925 | IF (IREJ1.NE.0) THEN | |
4926 | WRITE(LOUT,1000) | |
4927 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') | |
4928 | STOP | |
4929 | ENDIF | |
4930 | ||
4931 | RETURN | |
4932 | END | |
4933 | ||
4934 | *$ CREATE DT_EVENTD.FOR | |
4935 | *COPY DT_EVENTD | |
4936 | * | |
4937 | *===eventd=============================================================* | |
4938 | * | |
4939 | SUBROUTINE DT_EVENTD(IREJ) | |
4940 | ||
4941 | ************************************************************************ | |
4942 | * Quasi-elastic neutrino nucleus scattering. * | |
4943 | * This version dated 29.04.00 is written by S. Roesler. * | |
4944 | ************************************************************************ | |
4945 | ||
4946 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4947 | SAVE | |
4948 | PARAMETER ( LINP = 10 , | |
4949 | & LOUT = 6 , | |
4950 | & LDAT = 9 ) | |
4951 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) | |
4952 | PARAMETER (SQTINF=1.0D+15) | |
4953 | ||
4954 | LOGICAL LFIRST | |
4955 | ||
4956 | * event history | |
4957 | PARAMETER (NMXHKK=200000) | |
4958 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4959 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4960 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4961 | * extended event history | |
4962 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4963 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4964 | & IHIST(2,NMXHKK) | |
4965 | * flags for input different options | |
4966 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4967 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4968 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4969 | PARAMETER (MAXLND=4000) | |
4970 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
4971 | * properties of interacting particles | |
4972 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4973 | * Lorentz-parameters of the current interaction | |
4974 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4975 | & UMO,PPCM,EPROJ,PPROJ | |
4976 | * nuclear potential | |
4977 | LOGICAL LFERMI | |
4978 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4979 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4980 | & ETACOU(2),ICOUL,LFERMI | |
4981 | * steering flags for qel neutrino scattering modules | |
4982 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
4983 | COMMON /QNPOL/ POLARX(4),PMODUL | |
4984 | INTEGER PYK | |
4985 | ||
4986 | DATA LFIRST /.TRUE./ | |
4987 | ||
4988 | IREJ = 0 | |
4989 | ||
4990 | IF (LFIRST) THEN | |
4991 | LFIRST = .FALSE. | |
4992 | CALL DT_MASS_INI | |
4993 | ENDIF | |
4994 | ||
4995 | * JETSET parameter | |
4996 | CALL DT_INITJS(0) | |
4997 | ||
4998 | * interacting target nucleon | |
4999 | LTYP = NEUTYP | |
5000 | IF (NEUDEC.LE.9) THEN | |
5001 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN | |
5002 | NUCTYP = 2112 | |
5003 | NUCTOP = 2 | |
5004 | ELSE | |
5005 | NUCTYP = 2212 | |
5006 | NUCTOP = 1 | |
5007 | ENDIF | |
5008 | ELSE | |
5009 | RTYP = DT_RNDM(RTYP) | |
5010 | ZFRAC = DBLE(ITZ)/DBLE(IT) | |
5011 | IF (RTYP.LE.ZFRAC) THEN | |
5012 | NUCTYP = 2212 | |
5013 | NUCTOP = 1 | |
5014 | ELSE | |
5015 | NUCTYP = 2112 | |
5016 | NUCTOP = 2 | |
5017 | ENDIF | |
5018 | ENDIF | |
5019 | ||
5020 | * select first nucleon in list with matching id and reset all other | |
5021 | * nucleons which have been marked as "wounded" by ININUC | |
5022 | IFOUND = 0 | |
5023 | DO 1 I=1,NHKK | |
5024 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN | |
5025 | ISTHKK(I) = 12 | |
5026 | IFOUND = 1 | |
5027 | IDX = I | |
5028 | ELSE | |
5029 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 | |
5030 | ENDIF | |
5031 | 1 CONTINUE | |
5032 | IF (IFOUND.EQ.0) | |
5033 | & STOP ' EVENTD: interacting target nucleon not found! ' | |
5034 | ||
5035 | * correct position of proj. lepton: assume position of target nucleon | |
5036 | DO 3 I=1,4 | |
5037 | VHKK(I,1) = VHKK(I,IDX) | |
5038 | WHKK(I,1) = WHKK(I,IDX) | |
5039 | 3 CONTINUE | |
5040 | ||
5041 | * load initial momenta for conservation check | |
5042 | IF (LEMCCK) THEN | |
5043 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) | |
5044 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), | |
5045 | & 2,IDUM,IDUM) | |
5046 | ENDIF | |
5047 | ||
5048 | * quasi-elastic scattering | |
5049 | IF (NEUDEC.LT.9) THEN | |
5050 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), | |
5051 | & PHKK(4,IDX),PHKK(5,IDX)) | |
5052 | * CC event on p or n | |
5053 | ELSEIF (NEUDEC.EQ.10) THEN | |
5054 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), | |
5055 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5056 | * NC event on p or n | |
5057 | ELSEIF (NEUDEC.EQ.11) THEN | |
5058 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), | |
5059 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5060 | ENDIF | |
5061 | ||
5062 | * get final state particles from Lund-common and write them into HKKEVT | |
5063 | NPOINT(1) = NHKK+1 | |
5064 | NPOINT(4) = NHKK+1 | |
5065 | NLINES = PYK(0,1) | |
5066 | NHKK0 = NHKK+1 | |
5067 | DO 4 I=4,NLINES | |
5068 | IF (K(I,1).EQ.1) THEN | |
5069 | ID = K(I,2) | |
5070 | PX = P(I,1) | |
5071 | PY = P(I,2) | |
5072 | PZ = P(I,3) | |
5073 | PE = P(I,4) | |
5074 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) | |
5075 | IDBJ = IDT_ICIHAD(ID) | |
5076 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) | |
5077 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN | |
5078 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 | |
5079 | ENDIF | |
5080 | VHKK(1,NHKK) = VHKK(1,IDX) | |
5081 | VHKK(2,NHKK) = VHKK(2,IDX) | |
5082 | VHKK(3,NHKK) = VHKK(3,IDX) | |
5083 | VHKK(4,NHKK) = VHKK(4,IDX) | |
5084 | C IF (I.EQ.4) THEN | |
5085 | C WHKK(1,NHKK) = POLARX(1) | |
5086 | C WHKK(2,NHKK) = POLARX(2) | |
5087 | C WHKK(3,NHKK) = POLARX(3) | |
5088 | C WHKK(4,NHKK) = POLARX(4) | |
5089 | C ELSE | |
5090 | WHKK(1,NHKK) = WHKK(1,IDX) | |
5091 | WHKK(2,NHKK) = WHKK(2,IDX) | |
5092 | WHKK(3,NHKK) = WHKK(3,IDX) | |
5093 | WHKK(4,NHKK) = WHKK(4,IDX) | |
5094 | C ENDIF | |
5095 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
5096 | ENDIF | |
5097 | 4 CONTINUE | |
5098 | ||
5099 | IF (LEMCCK) THEN | |
5100 | CHKLEV = TINY5 | |
5101 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) | |
5102 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
5103 | ENDIF | |
5104 | ||
5105 | * transform momenta into cms (as required for inc etc.) | |
5106 | DO 5 I=NHKK0,NHKK | |
5107 | IF (ISTHKK(I).EQ.1) THEN | |
5108 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) | |
5109 | PHKK(3,I) = PZ | |
5110 | PHKK(4,I) = PE | |
5111 | ENDIF | |
5112 | 5 CONTINUE | |
5113 | ||
5114 | RETURN | |
5115 | END | |
5116 | ||
5117 | *$ CREATE DT_KKEVNT.FOR | |
5118 | *COPY DT_KKEVNT | |
5119 | * | |
5120 | *===kkevnt=============================================================* | |
5121 | * | |
5122 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) | |
5123 | ||
5124 | ************************************************************************ | |
5125 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
5126 | * without nuclear effects (one event). * | |
5127 | * This subroutine is an update of the previous version (KKEVT) written * | |
5128 | * by J. Ranft/ H.-J. Moehring. * | |
5129 | * This version dated 20.04.95 is written by S. Roesler * | |
5130 | ************************************************************************ | |
5131 | ||
5132 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5133 | SAVE | |
5134 | PARAMETER ( LINP = 10 , | |
5135 | & LOUT = 6 , | |
5136 | & LDAT = 9 ) | |
5137 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) | |
5138 | ||
5139 | PARAMETER ( MAXNCL = 260, | |
5140 | & MAXVQU = MAXNCL, | |
5141 | & MAXSQU = 20*MAXVQU, | |
5142 | & MAXINT = MAXVQU+MAXSQU) | |
5143 | * event history | |
5144 | PARAMETER (NMXHKK=200000) | |
5145 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5146 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5147 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5148 | * extended event history | |
5149 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5150 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5151 | & IHIST(2,NMXHKK) | |
5152 | * flags for input different options | |
5153 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5154 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5155 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5156 | * rejection counter | |
5157 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
5158 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
5159 | & IREXCI(3),IRDIFF(2),IRINC | |
5160 | * statistics | |
5161 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5162 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5163 | & ICEVTG(8,0:30) | |
5164 | * properties of interacting particles | |
5165 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5166 | * Lorentz-parameters of the current interaction | |
5167 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5168 | & UMO,PPCM,EPROJ,PPROJ | |
5169 | * flags for diffractive interactions (DTUNUC 1.x) | |
5170 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5171 | * interface HADRIN-DPM | |
5172 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5173 | * nucleon-nucleon event-generator | |
5174 | CHARACTER*8 CMODEL | |
5175 | LOGICAL LPHOIN | |
5176 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
5177 | * coordinates of nucleons | |
5178 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
5179 | * interface between Glauber formalism and DPM | |
5180 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
5181 | & INTER1(MAXINT),INTER2(MAXINT) | |
5182 | * Glauber formalism: collision properties | |
5183 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
7cbda79e | 5184 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
5185 | & NCP,NCT | |
9aaba0d6 | 5186 | * central particle production, impact parameter biasing |
5187 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5188 | **temporary | |
5189 | * statistics: Glauber-formalism | |
5190 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5191 | ** | |
5192 | ||
5193 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ | |
5194 | ||
5195 | IREJ = 0 | |
5196 | ICREQU = ICREQU+1 | |
5197 | NC = 0 | |
7cbda79e | 5198 | NCP = 0 |
5199 | NCT = 0 | |
9aaba0d6 | 5200 | |
5201 | 1 CONTINUE | |
5202 | ICSAMP = ICSAMP+1 | |
5203 | NC = NC+1 | |
5204 | IF (MOD(NC,10).EQ.0) THEN | |
5205 | WRITE(LOUT,1000) NEVHKK | |
5206 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') | |
5207 | GOTO 9999 | |
5208 | ENDIF | |
5209 | ||
5210 | * initialize DTEVT1/DTEVT2 | |
5211 | CALL DT_EVTINI | |
5212 | ||
5213 | * We need the following only in order to sample nucleon coordinates. | |
5214 | * However we don't have parameters (cross sections, slope etc.) | |
5215 | * for neutrinos available. Therefore switch projectile to proton | |
5216 | * in this case. | |
5217 | IF (MCGENE.EQ.4) THEN | |
5218 | JJPROJ = 1 | |
5219 | ELSE | |
5220 | JJPROJ = IJPROJ | |
5221 | ENDIF | |
5222 | ||
5223 | 10 CONTINUE | |
5224 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. | |
5225 | * make sure that Glauber-formalism is called each time the interaction | |
5226 | * configuration changed | |
5227 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. | |
5228 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN | |
5229 | * sample number of nucleon-nucleon coll. according to Glauber-form. | |
5230 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) | |
5231 | NWTSAM = NN | |
5232 | NWASAM = NP | |
5233 | NWBSAM = NT | |
5234 | NEVOLD = NEVHKK | |
5235 | IPOLD = IP | |
5236 | ITOLD = IT | |
5237 | JJPOLD = JJPROJ | |
5238 | EPROLD = EPROJ | |
7cbda79e | 5239 | DO 8 I=1, IP |
5240 | NCP = NCP+JSSH(I) | |
5241 | * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP | |
5242 | 8 CONTINUE | |
5243 | DO 9 I=1, IT | |
5244 | NCT = NCT+JTSH(I) | |
5245 | * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT | |
5246 | 9 CONTINUE | |
9aaba0d6 | 5247 | ENDIF |
5248 | ||
5249 | * force diffractive particle production in h-K interactions | |
5250 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. | |
5251 | & (IP.EQ.1).AND.(NN.NE.1)) THEN | |
5252 | NEVOLD = 0 | |
5253 | GOTO 10 | |
5254 | ENDIF | |
5255 | ||
5256 | * check number of involved proj. nucl. (NP) if central prod.is requested | |
5257 | IF (ICENTR.GT.0) THEN | |
5258 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5259 | IF (IBACK.GT.0) GOTO 10 | |
5260 | ENDIF | |
5261 | ||
5262 | * get initial nucleon-configuration in projectile and target | |
5263 | * rest-system (including Fermi-momenta if requested) | |
5264 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) | |
5265 | MODE = 2 | |
5266 | IF (EPROJ.LE.EHADTH) MODE = 3 | |
5267 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) | |
5268 | ||
5269 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN | |
5270 | ||
5271 | * activate HADRIN at low energies (implemented for h-N scattering only) | |
5272 | IF (EPROJ.LE.EHADHI) THEN | |
5273 | IF (EHADTH.LT.ZERO) THEN | |
5274 | * smooth transition btwn. DPM and HADRIN | |
5275 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) | |
5276 | RR = DT_RNDM(FRAC) | |
5277 | IF (RR.GT.FRAC) THEN | |
5278 | IF (IP.EQ.1) THEN | |
5279 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5280 | IF (IREJ1.GT.0) GOTO 1 | |
5281 | RETURN | |
5282 | ELSE | |
5283 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5284 | ENDIF | |
5285 | ENDIF | |
5286 | ELSE | |
5287 | * fixed threshold for onset of production via HADRIN | |
5288 | IF (EPROJ.LE.EHADTH) THEN | |
5289 | IF (IP.EQ.1) THEN | |
5290 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5291 | IF (IREJ1.GT.0) GOTO 1 | |
5292 | RETURN | |
5293 | ELSE | |
5294 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5295 | ENDIF | |
5296 | ENDIF | |
5297 | ENDIF | |
5298 | ENDIF | |
5299 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', | |
5300 | & I3,') with target (m=',I3,')',/,11X, | |
5301 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, | |
5302 | & 'GeV) cannot be handled') | |
5303 | ||
5304 | * sampling of momentum-x fractions & flavors of chain ends | |
5305 | CALL DT_SPLPTN(NN) | |
5306 | ||
5307 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms | |
5308 | CALL DT_NUC2CM | |
5309 | ||
5310 | * collect momenta of chain ends and put them into DTEVT1 | |
5311 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) | |
5312 | IF (IREJ1.NE.0) GOTO 1 | |
5313 | ||
5314 | ENDIF | |
5315 | ||
5316 | * handle chains including fragmentation (two-chain approximation) | |
5317 | IF (MCGENE.EQ.1) THEN | |
5318 | * two-chain approximation | |
5319 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) | |
5320 | IF (IREJ1.NE.0) THEN | |
5321 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' | |
5322 | GOTO 1 | |
5323 | ENDIF | |
5324 | ELSEIF (MCGENE.EQ.2) THEN | |
5325 | * multiple-Po exchange including minijets | |
5326 | CALL DT_EVENTB(NCSY,IREJ1) | |
5327 | IF (IREJ1.NE.0) THEN | |
5328 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' | |
5329 | GOTO 1 | |
5330 | ENDIF | |
5331 | ELSEIF (MCGENE.EQ.3) THEN | |
5332 | STOP ' This version does not contain LEPTO !' | |
5333 | ELSEIF (MCGENE.EQ.4) THEN | |
5334 | * quasi-elastic neutrino scattering | |
5335 | CALL DT_EVENTD(IREJ1) | |
5336 | IF (IREJ1.NE.0) THEN | |
5337 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' | |
5338 | GOTO 1 | |
5339 | ENDIF | |
5340 | ELSE | |
5341 | WRITE(LOUT,1002) MCGENE | |
5342 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, | |
5343 | & ' not available - program stopped') | |
5344 | STOP | |
5345 | ENDIF | |
5346 | ||
5347 | RETURN | |
5348 | ||
5349 | 9999 CONTINUE | |
5350 | IREJ = 1 | |
5351 | RETURN | |
5352 | END | |
5353 | ||
5354 | *$ CREATE DT_CHKCEN.FOR | |
5355 | *COPY DT_CHKCEN | |
5356 | * | |
5357 | *===chkcen=============================================================* | |
5358 | * | |
5359 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5360 | ||
5361 | ************************************************************************ | |
5362 | * Check of number of involved projectile nucleons if central production* | |
5363 | * is requested. * | |
5364 | * Adopted from a part of the old KKEVT routine which was written by * | |
5365 | * J. Ranft/H.-J.Moehring. * | |
5366 | * This version dated 13.01.95 is written by S. Roesler * | |
5367 | ************************************************************************ | |
5368 | ||
5369 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5370 | SAVE | |
5371 | PARAMETER ( LINP = 10 , | |
5372 | & LOUT = 6 , | |
5373 | & LDAT = 9 ) | |
5374 | ||
5375 | * statistics | |
5376 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5377 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5378 | & ICEVTG(8,0:30) | |
5379 | * central particle production, impact parameter biasing | |
5380 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5381 | ||
5382 | IBACK = 0 | |
5383 | ||
5384 | * old version | |
5385 | IF (ICENTR.EQ.2) THEN | |
5386 | IF (IP.LT.IT) THEN | |
5387 | IF (IP.LE.8) THEN | |
5388 | IF (NP.LT.IP-1) IBACK = 1 | |
5389 | ELSEIF (IP.LE.16) THEN | |
5390 | IF (NP.LT.IP-2) IBACK = 1 | |
5391 | ELSEIF (IP.LE.32) THEN | |
5392 | IF (NP.LT.IP-3) IBACK = 1 | |
5393 | ELSEIF (IP.GE.33) THEN | |
5394 | IF (NP.LT.IP-5) IBACK = 1 | |
5395 | ENDIF | |
5396 | ELSEIF (IP.EQ.IT) THEN | |
5397 | IF (IP.EQ.32) THEN | |
5398 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5399 | ELSE | |
5400 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5401 | ENDIF | |
5402 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5403 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5404 | ENDIF | |
5405 | ELSE | |
5406 | * new version (DPMJET, 5.6.99) | |
5407 | IF (IP.LT.IT) THEN | |
5408 | IF (IP.LE.8) THEN | |
5409 | IF (NP.LT.IP-1) IBACK = 1 | |
5410 | ELSEIF (IP.LE.16) THEN | |
5411 | IF (NP.LT.IP-2) IBACK = 1 | |
5412 | ELSEIF (IP.LT.32) THEN | |
5413 | IF (NP.LT.IP-3) IBACK = 1 | |
5414 | ELSEIF (IP.GE.32) THEN | |
5415 | IF (IT.LE.150) THEN | |
5416 | * Example: S-Ag | |
5417 | IF (NP.LT.IP-1) IBACK = 1 | |
5418 | ELSE | |
5419 | * Example: S-Au | |
5420 | IF (NP.LT.IP) IBACK = 1 | |
5421 | ENDIF | |
5422 | ENDIF | |
5423 | ELSEIF (IP.EQ.IT) THEN | |
5424 | * Example: S-S | |
5425 | IF (IP.EQ.32) THEN | |
5426 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5427 | * Example: Pb-Pb | |
5428 | ELSE | |
5429 | IF (NP.LT.IP-IP/4) IBACK = 1 | |
5430 | ENDIF | |
5431 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5432 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5433 | ENDIF | |
5434 | ENDIF | |
5435 | ||
5436 | ICCPRO = ICCPRO+1 | |
5437 | ||
5438 | RETURN | |
5439 | END | |
5440 | ||
5441 | *$ CREATE DT_ININUC.FOR | |
5442 | *COPY DT_ININUC | |
5443 | * | |
5444 | *===ininuc=============================================================* | |
5445 | * | |
5446 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) | |
5447 | ||
5448 | ************************************************************************ | |
5449 | * Samples initial configuration of nucleons in nucleus with mass NMASS * | |
5450 | * including Fermi-momenta (if reqested). * | |
5451 | * ID BAMJET-code for hadrons (instead of nuclei) * | |
5452 | * NMASS mass number of nucleus (number of nucleons) * | |
5453 | * NCH charge of nucleus * | |
5454 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * | |
5455 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * | |
5456 | * IMODE = 1 projectile nucleus * | |
5457 | * = 2 target nucleus * | |
5458 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * | |
5459 | * Adopted from a part of the old KKEVT routine which was written by * | |
5460 | * J. Ranft/H.-J.Moehring. * | |
5461 | * This version dated 13.01.95 is written by S. Roesler * | |
5462 | ************************************************************************ | |
5463 | ||
5464 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5465 | SAVE | |
5466 | PARAMETER ( LINP = 10 , | |
5467 | & LOUT = 6 , | |
5468 | & LDAT = 9 ) | |
5469 | PARAMETER (FM2MM=1.0D-12) | |
5470 | ||
5471 | PARAMETER ( MAXNCL = 260, | |
5472 | & MAXVQU = MAXNCL, | |
5473 | & MAXSQU = 20*MAXVQU, | |
5474 | & MAXINT = MAXVQU+MAXSQU) | |
5475 | * event history | |
5476 | PARAMETER (NMXHKK=200000) | |
5477 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5478 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5479 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5480 | * extended event history | |
5481 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5482 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5483 | & IHIST(2,NMXHKK) | |
5484 | * flags for input different options | |
5485 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5486 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5487 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5488 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5489 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5490 | * nuclear potential | |
5491 | LOGICAL LFERMI | |
5492 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5493 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5494 | & ETACOU(2),ICOUL,LFERMI | |
5495 | * properties of photon/lepton projectiles | |
5496 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5497 | * particle properties (BAMJET index convention) | |
5498 | CHARACTER*8 ANAME | |
5499 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5500 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5501 | * Glauber formalism: collision properties | |
5502 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5503 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5504 | * flavors of partons (DTUNUC 1.x) | |
5505 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5506 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5507 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5508 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5509 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5510 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5511 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5512 | * interface HADRIN-DPM | |
5513 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5514 | ||
5515 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) | |
5516 | ||
5517 | * number of neutrons | |
5518 | NNEU = NMASS-NCH | |
5519 | * initializations | |
5520 | NP = 0 | |
5521 | NN = 0 | |
5522 | DO 1 K=1,4 | |
5523 | PFTOT(K) = 0.0D0 | |
5524 | 1 CONTINUE | |
5525 | MODE = IMODE | |
5526 | IF (IMODE.GT.2) MODE = 2 | |
5527 | **sr 29.5. new NPOINT(1)-definition | |
5528 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 | |
5529 | ** | |
5530 | NHADRI = 0 | |
5531 | NC = NHKK | |
5532 | ||
5533 | * get initial configuration | |
5534 | DO 2 I=1,NMASS | |
5535 | NHKK = NHKK+1 | |
5536 | IF (JS(I).GT.0) THEN | |
5537 | ISTHKK(NHKK) = 10+MODE | |
5538 | IF (IMODE.EQ.3) THEN | |
5539 | * additional treatment if HADRIN-generator is requested | |
5540 | NHADRI = NHADRI+1 | |
5541 | IF (NHADRI.EQ.1) IDXTA = NHKK | |
5542 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 | |
5543 | ENDIF | |
5544 | ELSE | |
5545 | ISTHKK(NHKK) = 12+MODE | |
5546 | ENDIF | |
5547 | IF (NMASS.GE.2) THEN | |
5548 | * treatment for nuclei | |
5549 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) | |
5550 | RR = DT_RNDM(FRAC) | |
5551 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN | |
5552 | IDX = 8 | |
5553 | NN = NN+1 | |
5554 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN | |
5555 | IDX = 1 | |
5556 | NP = NP+1 | |
5557 | ELSEIF (NN.LT.NNEU) THEN | |
5558 | IDX = 8 | |
5559 | NN = NN+1 | |
5560 | ELSEIF (NP.LT.NCH) THEN | |
5561 | IDX = 1 | |
5562 | NP = NP+1 | |
5563 | ENDIF | |
5564 | IDHKK(NHKK) = IDT_IPDGHA(IDX) | |
5565 | IDBAM(NHKK) = IDX | |
5566 | IF (MODE.EQ.1) THEN | |
5567 | IPOSP(I) = NHKK | |
5568 | KKPROJ(I) = IDX | |
5569 | ELSE | |
5570 | IPOST(I) = NHKK | |
5571 | KKTARG(I) = IDX | |
5572 | ENDIF | |
5573 | IF (IDX.EQ.1) THEN | |
5574 | PFER = PFERMP(MODE) | |
5575 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) | |
5576 | ELSE | |
5577 | PFER = PFERMN(MODE) | |
5578 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) | |
5579 | ENDIF | |
5580 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) | |
5581 | DO 3 K=1,4 | |
5582 | PFTOT(K) = PFTOT(K)+PF(K) | |
5583 | PHKK(K,NHKK) = PF(K) | |
5584 | 3 CONTINUE | |
5585 | PHKK(5,NHKK) = AAM(IDX) | |
5586 | ELSE | |
5587 | * treatment for hadrons | |
5588 | IDHKK(NHKK) = IDT_IPDGHA(ID) | |
5589 | IDBAM(NHKK) = ID | |
5590 | PHKK(4,NHKK) = AAM(ID) | |
5591 | PHKK(5,NHKK) = AAM(ID) | |
5592 | C* VDM assumption | |
5593 | C IF (IDHKK(NHKK).EQ.22) THEN | |
5594 | C PHKK(4,NHKK) = AAM(33) | |
5595 | C PHKK(5,NHKK) = AAM(33) | |
5596 | C ENDIF | |
5597 | IF (MODE.EQ.1) THEN | |
5598 | IPOSP(I) = NHKK | |
5599 | KKPROJ(I) = ID | |
5600 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) | |
5601 | ELSE | |
5602 | IPOST(I) = NHKK | |
5603 | KKTARG(I) = ID | |
5604 | ENDIF | |
5605 | ENDIF | |
5606 | DO 4 K=1,3 | |
5607 | VHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5608 | WHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5609 | 4 CONTINUE | |
5610 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM | |
5611 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM | |
5612 | VHKK(4,NHKK) = 0.0D0 | |
5613 | WHKK(4,NHKK) = 0.0D0 | |
5614 | 2 CONTINUE | |
5615 | ||
5616 | * balance Fermi-momenta | |
5617 | IF (NMASS.GE.2) THEN | |
5618 | DO 5 I=1,NMASS | |
5619 | NC = NC+1 | |
5620 | DO 6 K=1,3 | |
5621 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) | |
5622 | 6 CONTINUE | |
5623 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ | |
5624 | & PHKK(2,NC)**2+PHKK(3,NC)**2) | |
5625 | 5 CONTINUE | |
5626 | ENDIF | |
5627 | ||
5628 | RETURN | |
5629 | END | |
5630 | ||
5631 | *$ CREATE DT_FER4M.FOR | |
5632 | *COPY DT_FER4M | |
5633 | * | |
5634 | *===fer4m==============================================================* | |
5635 | * | |
5636 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) | |
5637 | ||
5638 | ************************************************************************ | |
5639 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * | |
5640 | * processed by S. Roesler, 17.10.95 * | |
5641 | ************************************************************************ | |
5642 | ||
5643 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5644 | SAVE | |
5645 | PARAMETER ( LINP = 10 , | |
5646 | & LOUT = 6 , | |
5647 | & LDAT = 9 ) | |
5648 | ||
5649 | LOGICAL LSTART | |
5650 | ||
5651 | * particle properties (BAMJET index convention) | |
5652 | CHARACTER*8 ANAME | |
5653 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5654 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5655 | * nuclear potential | |
5656 | LOGICAL LFERMI | |
5657 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5658 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5659 | & ETACOU(2),ICOUL,LFERMI | |
5660 | ||
5661 | DATA LSTART /.TRUE./ | |
5662 | ||
5663 | ILOOP = 0 | |
5664 | IF (LFERMI) THEN | |
5665 | IF (LSTART) THEN | |
5666 | WRITE(LOUT,1000) | |
5667 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') | |
5668 | LSTART = .FALSE. | |
5669 | ENDIF | |
5670 | 1 CONTINUE | |
5671 | CALL DT_DFERMI(PABS) | |
5672 | PABS = PFERM*PABS | |
5673 | C IF (PABS.GE.PBIND) THEN | |
5674 | C ILOOP = ILOOP+1 | |
5675 | C IF (MOD(ILOOP,500).EQ.0) THEN | |
5676 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP | |
5677 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', | |
5678 | C & ' energy ',2E12.3,I6) | |
5679 | C ENDIF | |
5680 | C GOTO 1 | |
5681 | C ENDIF | |
5682 | CALL DT_DPOLI(POLC,POLS) | |
5683 | CALL DT_DSFECF(SFE,CFE) | |
5684 | CXTA = POLS*CFE | |
5685 | CYTA = POLS*SFE | |
5686 | CZTA = POLC | |
5687 | ET = SQRT(PABS*PABS+AAM(KT)**2) | |
5688 | PXT = CXTA*PABS | |
5689 | PYT = CYTA*PABS | |
5690 | PZT = CZTA*PABS | |
5691 | ELSE | |
5692 | ET = AAM(KT) | |
5693 | PXT = 0.0D0 | |
5694 | PYT = 0.0D0 | |
5695 | PZT = 0.0D0 | |
5696 | ENDIF | |
5697 | ||
5698 | RETURN | |
5699 | END | |
5700 | ||
5701 | *$ CREATE DT_NUC2CM.FOR | |
5702 | *COPY DT_NUC2CM | |
5703 | * | |
5704 | *===nuc2cm=============================================================* | |
5705 | * | |
5706 | SUBROUTINE DT_NUC2CM | |
5707 | ||
5708 | ************************************************************************ | |
5709 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * | |
5710 | * nucl. cms. (This subroutine replaces NUCMOM.) * | |
5711 | * This version dated 15.01.95 is written by S. Roesler * | |
5712 | ************************************************************************ | |
5713 | ||
5714 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5715 | SAVE | |
5716 | PARAMETER ( LINP = 10 , | |
5717 | & LOUT = 6 , | |
5718 | & LDAT = 9 ) | |
5719 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
5720 | ||
5721 | * event history | |
5722 | PARAMETER (NMXHKK=200000) | |
5723 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5724 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5725 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5726 | * extended event history | |
5727 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5728 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5729 | & IHIST(2,NMXHKK) | |
5730 | * statistics | |
5731 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5732 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5733 | & ICEVTG(8,0:30) | |
5734 | * properties of photon/lepton projectiles | |
5735 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5736 | * particle properties (BAMJET index convention) | |
5737 | CHARACTER*8 ANAME | |
5738 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5739 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5740 | * Glauber formalism: collision properties | |
5741 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5742 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5743 | **temporary | |
5744 | * statistics: Glauber-formalism | |
5745 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5746 | ** | |
5747 | ||
5748 | ICWP = 0 | |
5749 | ICWT = 0 | |
5750 | NWTACC = 0 | |
5751 | NWAACC = 0 | |
5752 | NWBACC = 0 | |
5753 | ||
5754 | NPOINT(1) = NHKK+1 | |
5755 | NEND = NHKK | |
5756 | DO 1 I=1,NEND | |
5757 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN | |
5758 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 | |
5759 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 | |
5760 | MODE = ISTHKK(I)-9 | |
5761 | C IF (IDHKK(I).EQ.22) THEN | |
5762 | C* VDM assumption | |
5763 | C PEIN = AAM(33) | |
5764 | C IDB = 33 | |
5765 | C ELSE | |
5766 | C PEIN = PHKK(4,I) | |
5767 | C IDB = IDBAM(I) | |
5768 | C ENDIF | |
5769 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, | |
5770 | C & PX,PY,PZ,PE,IDB,MODE) | |
5771 | IF (PHKK(5,I).GT.ZERO) THEN | |
5772 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
5773 | & PX,PY,PZ,PE,IDBAM(I),MODE) | |
5774 | ELSE | |
5775 | PX = PGAMM(1) | |
5776 | PY = PGAMM(2) | |
5777 | PZ = PGAMM(3) | |
5778 | PE = PGAMM(4) | |
5779 | ENDIF | |
5780 | IST = ISTHKK(I)-2 | |
5781 | ID = IDHKK(I) | |
5782 | C* VDM assumption | |
5783 | C IF (ID.EQ.22) ID = 113 | |
5784 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) | |
5785 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 | |
5786 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 | |
5787 | ENDIF | |
5788 | 1 CONTINUE | |
5789 | ||
5790 | NWTACC = MAX(NWAACC,NWBACC) | |
5791 | ICDPR = ICDPR+ICWP | |
5792 | ICDTA = ICDTA+ICWT | |
5793 | **temporary | |
5794 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN | |
5795 | CALL DT_EVTOUT(4) | |
5796 | STOP | |
5797 | ENDIF | |
5798 | ||
5799 | RETURN | |
5800 | END | |
5801 | ||
5802 | *$ CREATE DT_SPLPTN.FOR | |
5803 | *COPY DT_SPLPTN | |
5804 | * | |
5805 | *===splptn=============================================================* | |
5806 | * | |
5807 | SUBROUTINE DT_SPLPTN(NN) | |
5808 | ||
5809 | ************************************************************************ | |
5810 | * SamPLing of ParToN momenta and flavors. * | |
5811 | * This version dated 15.01.95 is written by S. Roesler * | |
5812 | ************************************************************************ | |
5813 | ||
5814 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5815 | SAVE | |
5816 | PARAMETER ( LINP = 10 , | |
5817 | & LOUT = 6 , | |
5818 | & LDAT = 9 ) | |
5819 | ||
5820 | * Lorentz-parameters of the current interaction | |
5821 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5822 | & UMO,PPCM,EPROJ,PPROJ | |
5823 | ||
5824 | * sample flavors of sea-quarks | |
5825 | CALL DT_SPLFLA(NN,1) | |
5826 | ||
5827 | * sample x-values of partons at chain ends | |
5828 | ECM = UMO | |
5829 | CALL DT_XKSAMP(NN,ECM) | |
5830 | ||
5831 | * samle flavors | |
5832 | CALL DT_SPLFLA(NN,2) | |
5833 | ||
5834 | RETURN | |
5835 | END | |
5836 | ||
5837 | *$ CREATE DT_SPLFLA.FOR | |
5838 | *COPY DT_SPLFLA | |
5839 | * | |
5840 | *===splfla=============================================================* | |
5841 | * | |
5842 | SUBROUTINE DT_SPLFLA(NN,MODE) | |
5843 | ||
5844 | ************************************************************************ | |
5845 | * SamPLing of FLAvors of partons at chain ends. * | |
5846 | * This subroutine replaces FLKSAA/FLKSAM. * | |
5847 | * NN number of nucleon-nucleon interactions * | |
5848 | * MODE = 1 sea-flavors * | |
5849 | * = 2 valence-flavors * | |
5850 | * Based on the original version written by J. Ranft/H.-J. Moehring. * | |
5851 | * This version dated 16.01.95 is written by S. Roesler * | |
5852 | ************************************************************************ | |
5853 | ||
5854 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5855 | SAVE | |
5856 | PARAMETER ( LINP = 10 , | |
5857 | & LOUT = 6 , | |
5858 | & LDAT = 9 ) | |
5859 | ||
5860 | PARAMETER ( MAXNCL = 260, | |
5861 | & MAXVQU = MAXNCL, | |
5862 | & MAXSQU = 20*MAXVQU, | |
5863 | & MAXINT = MAXVQU+MAXSQU) | |
5864 | * flavors of partons (DTUNUC 1.x) | |
5865 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5866 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5867 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5868 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5869 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5870 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5871 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5872 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5873 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5874 | & IXPV,IXPS,IXTV,IXTS, | |
5875 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5876 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5877 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5878 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5879 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5880 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5881 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5882 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5883 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5884 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
5885 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
5886 | * particle properties (BAMJET index convention) | |
5887 | CHARACTER*8 ANAME | |
5888 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5889 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5890 | * various options for treatment of partons (DTUNUC 1.x) | |
5891 | * (chain recombination, Cronin,..) | |
5892 | LOGICAL LCO2CR,LINTPT | |
5893 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
5894 | & LCO2CR,LINTPT | |
5895 | ||
5896 | IF (MODE.EQ.1) THEN | |
5897 | * sea-flavors | |
5898 | DO 1 I=1,NN | |
5899 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5900 | IPSAQ(I) = -IPSQ(I) | |
5901 | 1 CONTINUE | |
5902 | DO 2 I=1,NN | |
5903 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5904 | ITSAQ(I)= -ITSQ(I) | |
5905 | 2 CONTINUE | |
5906 | ELSEIF (MODE.EQ.2) THEN | |
5907 | * valence flavors | |
5908 | DO 3 I=1,IXPV | |
5909 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) | |
5910 | 3 CONTINUE | |
5911 | DO 4 I=1,IXTV | |
5912 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) | |
5913 | 4 CONTINUE | |
5914 | ENDIF | |
5915 | ||
5916 | RETURN | |
5917 | END | |
5918 | ||
5919 | *$ CREATE DT_GETPTN.FOR | |
5920 | *COPY DT_GETPTN | |
5921 | * | |
5922 | *===getptn=============================================================* | |
5923 | * | |
5924 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) | |
5925 | ||
5926 | ************************************************************************ | |
5927 | * This subroutine collects partons at chain ends from temporary * | |
5928 | * commons and puts them into DTEVT1. * | |
5929 | * This version dated 15.01.95 is written by S. Roesler * | |
5930 | ************************************************************************ | |
5931 | ||
5932 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5933 | SAVE | |
5934 | PARAMETER ( LINP = 10 , | |
5935 | & LOUT = 6 , | |
5936 | & LDAT = 9 ) | |
5937 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) | |
5938 | ||
5939 | LOGICAL LCHK | |
5940 | ||
5941 | PARAMETER ( MAXNCL = 260, | |
5942 | & MAXVQU = MAXNCL, | |
5943 | & MAXSQU = 20*MAXVQU, | |
5944 | & MAXINT = MAXVQU+MAXSQU) | |
5945 | * event history | |
5946 | PARAMETER (NMXHKK=200000) | |
5947 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5948 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5949 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5950 | * extended event history | |
5951 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5952 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5953 | & IHIST(2,NMXHKK) | |
5954 | * flags for input different options | |
5955 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5956 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5957 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5958 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5959 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5960 | * statistics | |
5961 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5962 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5963 | & ICEVTG(8,0:30) | |
5964 | * flags for diffractive interactions (DTUNUC 1.x) | |
5965 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5966 | * x-values of partons (DTUNUC 1.x) | |
5967 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
5968 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
5969 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
5970 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
5971 | * flavors of partons (DTUNUC 1.x) | |
5972 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5973 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5974 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5975 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5976 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5977 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5978 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5979 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5980 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5981 | & IXPV,IXPS,IXTV,IXTS, | |
5982 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5983 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5984 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5985 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5986 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5987 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5988 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5989 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5990 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5991 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
5992 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
5993 | ||
5994 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) | |
5995 | ||
5996 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ | |
5997 | ||
5998 | IREJ = 0 | |
5999 | NCSY = 0 | |
6000 | NPOINT(2) = NHKK+1 | |
6001 | ||
6002 | * sea-sea chains | |
6003 | DO 10 I=1,NSS | |
6004 | IF (ISKPCH(1,I).EQ.99) GOTO 10 | |
6005 | ICCHAI(1,1) = ICCHAI(1,1)+2 | |
6006 | IDXP = INTSS1(I) | |
6007 | IDXT = INTSS2(I) | |
6008 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6009 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6010 | DO 11 K=1,4 | |
6011 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6012 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6013 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6014 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6015 | 11 CONTINUE | |
6016 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6017 | & +(PP1(3)+PT1(3))**2) | |
6018 | ECH = PP1(4)+PT1(4) | |
6019 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6020 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6021 | & +(PP2(3)+PT2(3))**2) | |
6022 | ECH = PP2(4)+PT2(4) | |
6023 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6024 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6025 | AM1 = SQRT(AM1) | |
6026 | AM2 = SQRT(AM2) | |
6027 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN | |
6028 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6029 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) | |
6030 | ENDIF | |
6031 | ELSE | |
6032 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6033 | ENDIF | |
6034 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6035 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6036 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6037 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6038 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6039 | & 0,0,1) | |
6040 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6041 | & 0,0,1) | |
6042 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6043 | & 0,0,1) | |
6044 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6045 | & 0,0,1) | |
6046 | NCSY = NCSY+1 | |
6047 | 10 CONTINUE | |
6048 | ||
6049 | * disea-sea chains | |
6050 | DO 20 I=1,NDS | |
6051 | IF (ISKPCH(2,I).EQ.99) GOTO 20 | |
6052 | ICCHAI(1,2) = ICCHAI(1,2)+2 | |
6053 | IDXP = INTDS1(I) | |
6054 | IDXT = INTDS2(I) | |
6055 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6056 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6057 | DO 21 K=1,4 | |
6058 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6059 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6060 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6061 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6062 | 21 CONTINUE | |
6063 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6064 | & +(PP1(3)+PT1(3))**2) | |
6065 | ECH = PP1(4)+PT1(4) | |
6066 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6067 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6068 | & +(PP2(3)+PT2(3))**2) | |
6069 | ECH = PP2(4)+PT2(4) | |
6070 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6071 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6072 | AM1 = SQRT(AM1) | |
6073 | AM2 = SQRT(AM2) | |
6074 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6075 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6076 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) | |
6077 | ENDIF | |
6078 | ELSE | |
6079 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6080 | ENDIF | |
6081 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6082 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6083 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6084 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6085 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6086 | & 0,0,2) | |
6087 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6088 | & 0,0,2) | |
6089 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6090 | & 0,0,2) | |
6091 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6092 | & 0,0,2) | |
6093 | NCSY = NCSY+1 | |
6094 | 20 CONTINUE | |
6095 | ||
6096 | * sea-disea chains | |
6097 | DO 30 I=1,NSD | |
6098 | IF (ISKPCH(3,I).EQ.99) GOTO 30 | |
6099 | ICCHAI(1,3) = ICCHAI(1,3)+2 | |
6100 | IDXP = INTSD1(I) | |
6101 | IDXT = INTSD2(I) | |
6102 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6103 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6104 | DO 31 K=1,4 | |
6105 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6106 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6107 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6108 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6109 | 31 CONTINUE | |
6110 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6111 | & +(PP1(3)+PT1(3))**2) | |
6112 | ECH = PP1(4)+PT1(4) | |
6113 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6114 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6115 | & +(PP2(3)+PT2(3))**2) | |
6116 | ECH = PP2(4)+PT2(4) | |
6117 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6118 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6119 | AM1 = SQRT(AM1) | |
6120 | AM2 = SQRT(AM2) | |
6121 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6122 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6123 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) | |
6124 | ENDIF | |
6125 | ELSE | |
6126 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6127 | ENDIF | |
6128 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6129 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6130 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6131 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6132 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6133 | & 0,0,3) | |
6134 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6135 | & 0,0,3) | |
6136 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6137 | & 0,0,3) | |
6138 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6139 | & 0,0,3) | |
6140 | NCSY = NCSY+1 | |
6141 | 30 CONTINUE | |
6142 | ||
6143 | * disea-valence chains | |
6144 | DO 50 I=1,NDV | |
6145 | IF (ISKPCH(5,I).EQ.99) GOTO 50 | |
6146 | ICCHAI(1,5) = ICCHAI(1,5)+2 | |
6147 | IDXP = INTDV1(I) | |
6148 | IDXT = INTDV2(I) | |
6149 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6150 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6151 | DO 51 K=1,4 | |
6152 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6153 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6154 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6155 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6156 | 51 CONTINUE | |
6157 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6158 | & +(PP1(3)+PT1(3))**2) | |
6159 | ECH = PP1(4)+PT1(4) | |
6160 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6161 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6162 | & +(PP2(3)+PT2(3))**2) | |
6163 | ECH = PP2(4)+PT2(4) | |
6164 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6165 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6166 | AM1 = SQRT(AM1) | |
6167 | AM2 = SQRT(AM2) | |
6168 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6169 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6170 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) | |
6171 | ENDIF | |
6172 | ELSE | |
6173 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6174 | ENDIF | |
6175 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6176 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6177 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6178 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6179 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6180 | & 0,0,5) | |
6181 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6182 | & 0,0,5) | |
6183 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6184 | & 0,0,5) | |
6185 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6186 | & 0,0,5) | |
6187 | NCSY = NCSY+1 | |
6188 | 50 CONTINUE | |
6189 | ||
6190 | * valence-sea chains | |
6191 | DO 60 I=1,NVS | |
6192 | IF (ISKPCH(6,I).EQ.99) GOTO 60 | |
6193 | ICCHAI(1,6) = ICCHAI(1,6)+2 | |
6194 | IDXP = INTVS1(I) | |
6195 | IDXT = INTVS2(I) | |
6196 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6197 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6198 | DO 61 K=1,4 | |
6199 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6200 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6201 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6202 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6203 | 61 CONTINUE | |
6204 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6205 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6206 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6207 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6208 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6209 | IF (LCHK) THEN | |
6210 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6211 | & 0,0,6) | |
6212 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6213 | & 0,0,6) | |
6214 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6215 | & 0,0,6) | |
6216 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6217 | & 0,0,6) | |
6218 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6219 | & +(PP1(3)+PT1(3))**2) | |
6220 | ECH = PP1(4)+PT1(4) | |
6221 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6222 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6223 | & +(PP2(3)+PT2(3))**2) | |
6224 | ECH = PP2(4)+PT2(4) | |
6225 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6226 | ELSE | |
6227 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6228 | & 0,0,6) | |
6229 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6230 | & 0,0,6) | |
6231 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6232 | & 0,0,6) | |
6233 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6234 | & 0,0,6) | |
6235 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6236 | & +(PP1(3)+PT2(3))**2) | |
6237 | ECH = PP1(4)+PT2(4) | |
6238 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6239 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6240 | & +(PP2(3)+PT1(3))**2) | |
6241 | ECH = PP2(4)+PT1(4) | |
6242 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6243 | ENDIF | |
6244 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6245 | AM1 = SQRT(AM1) | |
6246 | AM2 = SQRT(AM2) | |
6247 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN | |
6248 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6249 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) | |
6250 | ENDIF | |
6251 | ELSE | |
6252 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6253 | ENDIF | |
6254 | NCSY = NCSY+1 | |
6255 | 60 CONTINUE | |
6256 | ||
6257 | * sea-valence chains | |
6258 | DO 40 I=1,NSV | |
6259 | IF (ISKPCH(4,I).EQ.99) GOTO 40 | |
6260 | ICCHAI(1,4) = ICCHAI(1,4)+2 | |
6261 | IDXP = INTSV1(I) | |
6262 | IDXT = INTSV2(I) | |
6263 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6264 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6265 | DO 41 K=1,4 | |
6266 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6267 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6268 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6269 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6270 | 41 CONTINUE | |
6271 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6272 | & +(PP1(3)+PT1(3))**2) | |
6273 | ECH = PP1(4)+PT1(4) | |
6274 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6275 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6276 | & +(PP2(3)+PT2(3))**2) | |
6277 | ECH = PP2(4)+PT2(4) | |
6278 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6279 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6280 | AM1 = SQRT(AM1) | |
6281 | AM2 = SQRT(AM2) | |
6282 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN | |
6283 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6284 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) | |
6285 | ENDIF | |
6286 | ELSE | |
6287 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6288 | ENDIF | |
6289 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6290 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6291 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6292 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6293 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6294 | & 0,0,4) | |
6295 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6296 | & 0,0,4) | |
6297 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6298 | & 0,0,4) | |
6299 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6300 | & 0,0,4) | |
6301 | NCSY = NCSY+1 | |
6302 | 40 CONTINUE | |
6303 | ||
6304 | * valence-disea chains | |
6305 | DO 70 I=1,NVD | |
6306 | IF (ISKPCH(7,I).EQ.99) GOTO 70 | |
6307 | ICCHAI(1,7) = ICCHAI(1,7)+2 | |
6308 | IDXP = INTVD1(I) | |
6309 | IDXT = INTVD2(I) | |
6310 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6311 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6312 | DO 71 K=1,4 | |
6313 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6314 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6315 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6316 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6317 | 71 CONTINUE | |
6318 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6319 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6320 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6321 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6322 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6323 | IF (LCHK) THEN | |
6324 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6325 | & 0,0,7) | |
6326 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6327 | & 0,0,7) | |
6328 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6329 | & 0,0,7) | |
6330 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6331 | & 0,0,7) | |
6332 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6333 | & +(PP1(3)+PT1(3))**2) | |
6334 | ECH = PP1(4)+PT1(4) | |
6335 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6336 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6337 | & +(PP2(3)+PT2(3))**2) | |
6338 | ECH = PP2(4)+PT2(4) | |
6339 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6340 | ELSE | |
6341 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6342 | & 0,0,7) | |
6343 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6344 | & 0,0,7) | |
6345 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6346 | & 0,0,7) | |
6347 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6348 | & 0,0,7) | |
6349 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6350 | & +(PP1(3)+PT2(3))**2) | |
6351 | ECH = PP1(4)+PT2(4) | |
6352 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6353 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6354 | & +(PP2(3)+PT1(3))**2) | |
6355 | ECH = PP2(4)+PT1(4) | |
6356 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6357 | ENDIF | |
6358 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6359 | AM1 = SQRT(AM1) | |
6360 | AM2 = SQRT(AM2) | |
6361 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6362 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6363 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) | |
6364 | ENDIF | |
6365 | ELSE | |
6366 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6367 | ENDIF | |
6368 | NCSY = NCSY+1 | |
6369 | 70 CONTINUE | |
6370 | ||
6371 | * valence-valence chains | |
6372 | DO 80 I=1,NVV | |
6373 | IF (ISKPCH(8,I).EQ.99) GOTO 80 | |
6374 | ICCHAI(1,8) = ICCHAI(1,8)+2 | |
6375 | IDXP = INTVV1(I) | |
6376 | IDXT = INTVV2(I) | |
6377 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6378 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6379 | DO 81 K=1,4 | |
6380 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) | |
6381 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) | |
6382 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) | |
6383 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) | |
6384 | 81 CONTINUE | |
6385 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6386 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6387 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6388 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6389 | ||
6390 | * check for diffractive event | |
6391 | IDIFF = 0 | |
6392 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. | |
6393 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN | |
6394 | DO 800 K=1,4 | |
6395 | PP(K) = PP1(K)+PP2(K) | |
6396 | PT(K) = PT1(K)+PT2(K) | |
6397 | 800 CONTINUE | |
6398 | ISTCK = NHKK | |
6399 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
6400 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) | |
6401 | C IF (IREJ1.NE.0) GOTO 9999 | |
6402 | IF (IREJ1.NE.0) THEN | |
6403 | IDIFF = 0 | |
6404 | NHKK = ISTCK | |
6405 | ENDIF | |
6406 | ELSE | |
6407 | IDIFF = 0 | |
6408 | ENDIF | |
6409 | ||
6410 | IF (IDIFF.EQ.0) THEN | |
6411 | * valence-valence chain system | |
6412 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6413 | IF (LCHK) THEN | |
6414 | * baryon-baryon | |
6415 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6416 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6417 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6418 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6419 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6420 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6421 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6422 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6423 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6424 | & +(PP1(3)+PT1(3))**2) | |
6425 | ECH = PP1(4)+PT1(4) | |
6426 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6427 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6428 | & +(PP2(3)+PT2(3))**2) | |
6429 | ECH = PP2(4)+PT2(4) | |
6430 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6431 | ELSE | |
6432 | * antibaryon-baryon | |
6433 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6434 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6435 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6436 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6437 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6438 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6439 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6440 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6441 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6442 | & +(PP1(3)+PT2(3))**2) | |
6443 | ECH = PP1(4)+PT2(4) | |
6444 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6445 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6446 | & +(PP2(3)+PT1(3))**2) | |
6447 | ECH = PP2(4)+PT1(4) | |
6448 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6449 | ENDIF | |
6450 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6451 | AM1 = SQRT(AM1) | |
6452 | AM2 = SQRT(AM2) | |
6453 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN | |
6454 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6455 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) | |
6456 | ENDIF | |
6457 | ELSE | |
6458 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6459 | ENDIF | |
6460 | NCSY = NCSY+1 | |
6461 | ENDIF | |
6462 | 80 CONTINUE | |
6463 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 | |
6464 | ||
6465 | * energy-momentum & flavor conservation check | |
6466 | IF (ABS(IDIFF).NE.1) THEN | |
6467 | IF (IDIFF.NE.0) THEN | |
6468 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, | |
6469 | & 1,3,10,IREJ) | |
6470 | ELSE | |
6471 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, | |
6472 | & 1,3,10,IREJ) | |
6473 | ENDIF | |
6474 | IF (IREJ.NE.0) THEN | |
6475 | CALL DT_EVTOUT(4) | |
6476 | STOP | |
6477 | ENDIF | |
6478 | ENDIF | |
6479 | ||
6480 | RETURN | |
6481 | ||
6482 | 9999 CONTINUE | |
6483 | IREJ = 1 | |
6484 | RETURN | |
6485 | END | |
6486 | ||
6487 | *$ CREATE DT_CHKCSY.FOR | |
6488 | *COPY DT_CHKCSY | |
6489 | * | |
6490 | *===chkcsy=============================================================* | |
6491 | * | |
6492 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) | |
6493 | ||
6494 | ************************************************************************ | |
6495 | * CHeCk Chain SYstem for consistency of partons at chain ends. * | |
6496 | * ID1,ID2 PDG-numbers of partons at chain ends * | |
6497 | * LCHK = .true. consistent chain * | |
6498 | * = .false. inconsistent chain * | |
6499 | * This version dated 18.01.95 is written by S. Roesler * | |
6500 | ************************************************************************ | |
6501 | ||
6502 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6503 | SAVE | |
6504 | PARAMETER ( LINP = 10 , | |
6505 | & LOUT = 6 , | |
6506 | & LDAT = 9 ) | |
6507 | ||
6508 | LOGICAL LCHK | |
6509 | ||
6510 | LCHK = .TRUE. | |
6511 | ||
6512 | * q-aq chain | |
6513 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN | |
6514 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6515 | * q-qq, aq-aqaq chain | |
6516 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. | |
6517 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN | |
6518 | IF (ID1*ID2.LT.0) LCHK = .FALSE. | |
6519 | * qq-aqaq chain | |
6520 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN | |
6521 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6522 | ENDIF | |
6523 | ||
6524 | RETURN | |
6525 | END | |
6526 | ||
6527 | *$ CREATE DT_EVENTA.FOR | |
6528 | *COPY DT_EVENTA | |
6529 | * | |
6530 | *===eventa=============================================================* | |
6531 | * | |
6532 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) | |
6533 | ||
6534 | ************************************************************************ | |
6535 | * Treatment of nucleon-nucleon interactions in a two-chain * | |
6536 | * approximation. * | |
6537 | * (input) ID BAMJET-index of projectile hadron (in case of * | |
6538 | * h-K scattering) * | |
6539 | * IP/IT mass number of projectile/target nucleus * | |
6540 | * NCSY number of two chain systems * | |
6541 | * IREJ rejection flag * | |
6542 | * This version dated 15.01.95 is written by S. Roesler * | |
6543 | ************************************************************************ | |
6544 | ||
6545 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6546 | SAVE | |
6547 | PARAMETER ( LINP = 10 , | |
6548 | & LOUT = 6 , | |
6549 | & LDAT = 9 ) | |
6550 | PARAMETER (TINY10=1.0D-10) | |
6551 | ||
6552 | * event history | |
6553 | PARAMETER (NMXHKK=200000) | |
6554 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6555 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6556 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6557 | * extended event history | |
6558 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6559 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6560 | & IHIST(2,NMXHKK) | |
6561 | * rejection counter | |
6562 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6563 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6564 | & IREXCI(3),IRDIFF(2),IRINC | |
6565 | * flags for diffractive interactions (DTUNUC 1.x) | |
6566 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6567 | * particle properties (BAMJET index convention) | |
6568 | CHARACTER*8 ANAME | |
6569 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6570 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6571 | * flags for input different options | |
6572 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6573 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6574 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6575 | * various options for treatment of partons (DTUNUC 1.x) | |
6576 | * (chain recombination, Cronin,..) | |
6577 | LOGICAL LCO2CR,LINTPT | |
6578 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
6579 | & LCO2CR,LINTPT | |
6580 | ||
6581 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
6582 | ||
6583 | IREJ = 0 | |
6584 | NPOINT(3) = NHKK+1 | |
6585 | ||
6586 | * skip following treatment for low-mass diffraction | |
6587 | IF (ABS(IFLAGD).EQ.1) THEN | |
6588 | NPOINT(3) = NPOINT(2) | |
6589 | GOTO 5 | |
6590 | ENDIF | |
6591 | ||
6592 | * multiple scattering of chain ends | |
6593 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
6594 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
6595 | ||
6596 | NC = NPOINT(2) | |
6597 | * get a two-chain system from DTEVT1 | |
6598 | DO 3 I=1,NCSY | |
6599 | IFP1 = IDHKK(NC) | |
6600 | IFT1 = IDHKK(NC+1) | |
6601 | IFP2 = IDHKK(NC+2) | |
6602 | IFT2 = IDHKK(NC+3) | |
6603 | DO 4 K=1,4 | |
6604 | PP1(K) = PHKK(K,NC) | |
6605 | PT1(K) = PHKK(K,NC+1) | |
6606 | PP2(K) = PHKK(K,NC+2) | |
6607 | PT2(K) = PHKK(K,NC+3) | |
6608 | 4 CONTINUE | |
6609 | MOP1 = NC | |
6610 | MOT1 = NC+1 | |
6611 | MOP2 = NC+2 | |
6612 | MOT2 = NC+3 | |
6613 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
6614 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
6615 | IF (IREJ1.GT.0) THEN | |
6616 | IRHHA = IRHHA+1 | |
6617 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' | |
6618 | GOTO 9999 | |
6619 | ENDIF | |
6620 | NC = NC+4 | |
6621 | 3 CONTINUE | |
6622 | ||
6623 | * meson/antibaryon projectile: | |
6624 | * sample single-chain valence-valence systems (Reggeon contrib.) | |
6625 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN | |
6626 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH | |
6627 | ENDIF | |
6628 | ||
6629 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6630 | * check DTEVT1 for remaining resonance mass corrections | |
6631 | CALL DT_EVTRES(IREJ1) | |
6632 | IF (IREJ1.GT.0) THEN | |
6633 | IRRES(1) = IRRES(1)+1 | |
6634 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' | |
6635 | GOTO 9999 | |
6636 | ENDIF | |
6637 | ENDIF | |
6638 | ||
6639 | * assign p_t to two-"chain" systems consisting of two resonances only | |
6640 | * since only entries for chains will be affected, this is obsolete | |
6641 | * in case of JETSET-fragmetation | |
6642 | CALL DT_RESPT | |
6643 | ||
6644 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) | |
6645 | IF (LCO2CR) CALL DT_COM2CR | |
6646 | ||
6647 | 5 CONTINUE | |
6648 | ||
6649 | * fragmentation of the complete event | |
6650 | **uncomment for internal phojet-fragmentation | |
6651 | C CALL DT_EVTFRA(IREJ1) | |
6652 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) | |
6653 | IF (IREJ1.GT.0) THEN | |
6654 | IRFRAG = IRFRAG+1 | |
6655 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' | |
6656 | GOTO 9999 | |
6657 | ENDIF | |
6658 | ||
6659 | * decay of possible resonances (should be obsolete) | |
6660 | CALL DT_DECAY1 | |
6661 | ||
6662 | RETURN | |
6663 | ||
6664 | 9999 CONTINUE | |
6665 | IREVT = IREVT+1 | |
6666 | IREJ = 1 | |
6667 | RETURN | |
6668 | END | |
6669 | ||
6670 | *$ CREATE DT_GETCSY.FOR | |
6671 | *COPY DT_GETCSY | |
6672 | * | |
6673 | *===getcsy=============================================================* | |
6674 | * | |
6675 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, | |
6676 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) | |
6677 | ||
6678 | ************************************************************************ | |
6679 | * This version dated 15.01.95 is written by S. Roesler * | |
6680 | ************************************************************************ | |
6681 | ||
6682 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6683 | SAVE | |
6684 | PARAMETER ( LINP = 10 , | |
6685 | & LOUT = 6 , | |
6686 | & LDAT = 9 ) | |
6687 | PARAMETER (TINY10=1.0D-10) | |
6688 | ||
6689 | * event history | |
6690 | PARAMETER (NMXHKK=200000) | |
6691 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6692 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6693 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6694 | * extended event history | |
6695 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6696 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6697 | & IHIST(2,NMXHKK) | |
6698 | * rejection counter | |
6699 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6700 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6701 | & IREXCI(3),IRDIFF(2),IRINC | |
6702 | * flags for input different options | |
6703 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6704 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6705 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6706 | * flags for diffractive interactions (DTUNUC 1.x) | |
6707 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6708 | ||
6709 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), | |
6710 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) | |
6711 | ||
6712 | IREJ = 0 | |
6713 | ||
6714 | * get quark content of partons | |
6715 | DO 1 I=1,2 | |
6716 | IFP1(I) = 0 | |
6717 | IFP2(I) = 0 | |
6718 | IFT1(I) = 0 | |
6719 | IFT2(I) = 0 | |
6720 | 1 CONTINUE | |
6721 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) | |
6722 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) | |
6723 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) | |
6724 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) | |
6725 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) | |
6726 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) | |
6727 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) | |
6728 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) | |
6729 | ||
6730 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) | |
6731 | IDCH1 = 2 | |
6732 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 | |
6733 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 | |
6734 | IDCH2 = 2 | |
6735 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 | |
6736 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 | |
6737 | ||
6738 | * store initial configuration for energy-momentum cons. check | |
6739 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) | |
6740 | ||
6741 | * sample intrinsic p_t at chain-ends | |
6742 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, | |
6743 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, | |
6744 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) | |
6745 | IF (IREJ1.NE.0) THEN | |
6746 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' | |
6747 | IRPT = IRPT+1 | |
6748 | GOTO 9999 | |
6749 | ENDIF | |
6750 | ||
6751 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6752 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN | |
6753 | C* check second chain for resonance | |
6754 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6755 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6756 | C IF (IREJ1.NE.0) GOTO 9999 | |
6757 | C IF (IDR2.NE.0) THEN | |
6758 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6759 | C & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6760 | C IF (IREJ1.NE.0) GOTO 9999 | |
6761 | C ENDIF | |
6762 | C* check first chain for resonance | |
6763 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6764 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6765 | C IF (IREJ1.NE.0) GOTO 9999 | |
6766 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6767 | C ELSE | |
6768 | C* check first chain for resonance | |
6769 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6770 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6771 | C IF (IREJ1.NE.0) GOTO 9999 | |
6772 | C IF (IDR1.NE.0) THEN | |
6773 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6774 | C & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6775 | C IF (IREJ1.NE.0) GOTO 9999 | |
6776 | C ENDIF | |
6777 | C* check second chain for resonance | |
6778 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6779 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6780 | C IF (IREJ1.NE.0) GOTO 9999 | |
6781 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6782 | C ENDIF | |
6783 | C ENDIF | |
6784 | ||
6785 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6786 | * check chains for resonances | |
6787 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6788 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6789 | IF (IREJ1.NE.0) GOTO 9999 | |
6790 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6791 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6792 | IF (IREJ1.NE.0) GOTO 9999 | |
6793 | * change kinematics corresponding to resonance-masses | |
6794 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN | |
6795 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6796 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6797 | IF (IREJ1.GT.0) GOTO 9999 | |
6798 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6799 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6800 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6801 | IF (IREJ1.NE.0) GOTO 9999 | |
6802 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6803 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN | |
6804 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6805 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6806 | IF (IREJ1.GT.0) GOTO 9999 | |
6807 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6808 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6809 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6810 | IF (IREJ1.NE.0) GOTO 9999 | |
6811 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6812 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN | |
6813 | AMDIF1 = ABS(AMCH1-AMCH1N) | |
6814 | AMDIF2 = ABS(AMCH2-AMCH2N) | |
6815 | IF (AMDIF2.LT.AMDIF1) THEN | |
6816 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6817 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6818 | IF (IREJ1.GT.0) GOTO 9999 | |
6819 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6820 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), | |
6821 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) | |
6822 | IF (IREJ1.NE.0) GOTO 9999 | |
6823 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6824 | ELSE | |
6825 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6826 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6827 | IF (IREJ1.GT.0) GOTO 9999 | |
6828 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6829 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), | |
6830 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) | |
6831 | IF (IREJ1.NE.0) GOTO 9999 | |
6832 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6833 | ENDIF | |
6834 | ENDIF | |
6835 | ENDIF | |
6836 | ||
6837 | * store final configuration for energy-momentum cons. check | |
6838 | IF (LEMCCK) THEN | |
6839 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) | |
6840 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
6841 | IF (IREJ1.NE.0) GOTO 9999 | |
6842 | ENDIF | |
6843 | ||
6844 | * put partons and chains into DTEVT1 | |
6845 | DO 10 I=1,4 | |
6846 | PCH1(I) = PP1(I)+PT1(I) | |
6847 | PCH2(I) = PP2(I)+PT2(I) | |
6848 | 10 CONTINUE | |
6849 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), | |
6850 | & PP1(3),PP1(4),0,0,0) | |
6851 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), | |
6852 | & PT1(3),PT1(4),0,0,0) | |
6853 | KCH = 100+IDCH(MOP1)*10+1 | |
6854 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6855 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) | |
6856 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), | |
6857 | & PP2(3),PP2(4),0,0,0) | |
6858 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), | |
6859 | & PT2(3),PT2(4),0,0,0) | |
6860 | KCH = KCH+1 | |
6861 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6862 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) | |
6863 | ||
6864 | RETURN | |
6865 | ||
6866 | 9999 CONTINUE | |
6867 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN | |
6868 | * "cancel" sea-sea chains | |
6869 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) | |
6870 | IF (IREJ1.NE.0) GOTO 9998 | |
6871 | **sr 16.5. flag for EVENTB | |
6872 | IREJ = -1 | |
6873 | RETURN | |
6874 | ENDIF | |
6875 | 9998 CONTINUE | |
6876 | IREJ = 1 | |
6877 | RETURN | |
6878 | END | |
6879 | ||
6880 | *$ CREATE DT_CHKINE.FOR | |
6881 | *COPY DT_CHKINE | |
6882 | * | |
6883 | *===chkine=============================================================* | |
6884 | * | |
6885 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, | |
6886 | & AMCH1,AMCH1N,AMCH2,IREJ) | |
6887 | ||
6888 | ************************************************************************ | |
6889 | * This subroutine replaces CORMOM. * | |
6890 | * This version dated 05.01.95 is written by S. Roesler * | |
6891 | ************************************************************************ | |
6892 | ||
6893 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6894 | SAVE | |
6895 | PARAMETER ( LINP = 10 , | |
6896 | & LOUT = 6 , | |
6897 | & LDAT = 9 ) | |
6898 | PARAMETER (TINY10=1.0D-10) | |
6899 | ||
6900 | * flags for input different options | |
6901 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6902 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6903 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6904 | * rejection counter | |
6905 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6906 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6907 | & IREXCI(3),IRDIFF(2),IRINC | |
6908 | ||
6909 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), | |
6910 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) | |
6911 | ||
6912 | IREJ = 0 | |
6913 | JMSHL = IMSHL | |
6914 | ||
6915 | SCALE = AMCH1N/MAX(AMCH1,TINY10) | |
6916 | DO 10 I=1,4 | |
6917 | PP1(I) = PP1I(I) | |
6918 | PP2(I) = PP2I(I) | |
6919 | PT1(I) = PT1I(I) | |
6920 | PT2(I) = PT2I(I) | |
6921 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) | |
6922 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) | |
6923 | PP1(I) = SCALE*PP1(I) | |
6924 | PT1(I) = SCALE*PT1(I) | |
6925 | 10 CONTINUE | |
6926 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. | |
6927 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 | |
6928 | ||
6929 | ECH = PP2(4)+PT2(4) | |
6930 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ | |
6931 | & (PP2(3)+PT2(3))**2 ) | |
6932 | AMCH22 = (ECH-PCH)*(ECH+PCH) | |
6933 | IF (AMCH22.LT.0.0D0) THEN | |
6934 | IF (IOULEV(1).GT.0) | |
6935 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' | |
6936 | GOTO 9997 | |
6937 | ENDIF | |
6938 | ||
6939 | AMCH1 = AMCH1N | |
6940 | AMCH2 = SQRT(AMCH22) | |
6941 | ||
6942 | * put partons again on mass shell | |
6943 | 13 CONTINUE | |
6944 | XM1 = 0.0D0 | |
6945 | XM2 = 0.0D0 | |
6946 | IF (JMSHL.EQ.1) THEN | |
6947 | XM1 = PYMASS(IFP1) | |
6948 | XM2 = PYMASS(IFT1) | |
6949 | ENDIF | |
6950 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
6951 | IF (IREJ1.NE.0) THEN | |
6952 | IF (JMSHL.EQ.0) GOTO 9998 | |
6953 | JMSHL = 0 | |
6954 | GOTO 13 | |
6955 | ENDIF | |
6956 | JMSHL = IMSHL | |
6957 | DO 11 I=1,4 | |
6958 | PP1(I) = P1(I) | |
6959 | PT1(I) = P2(I) | |
6960 | 11 CONTINUE | |
6961 | 14 CONTINUE | |
6962 | XM1 = 0.0D0 | |
6963 | XM2 = 0.0D0 | |
6964 | IF (JMSHL.EQ.1) THEN | |
6965 | XM1 = PYMASS(IFP2) | |
6966 | XM2 = PYMASS(IFT2) | |
6967 | ENDIF | |
6968 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) | |
6969 | IF (IREJ1.NE.0) THEN | |
6970 | IF (JMSHL.EQ.0) GOTO 9998 | |
6971 | JMSHL = 0 | |
6972 | GOTO 14 | |
6973 | ENDIF | |
6974 | DO 12 I=1,4 | |
6975 | PP2(I) = P1(I) | |
6976 | PT2(I) = P2(I) | |
6977 | 12 CONTINUE | |
6978 | DO 15 I=1,4 | |
6979 | PP1I(I) = PP1(I) | |
6980 | PP2I(I) = PP2(I) | |
6981 | PT1I(I) = PT1(I) | |
6982 | PT2I(I) = PT2(I) | |
6983 | 15 CONTINUE | |
6984 | RETURN | |
6985 | ||
6986 | 9997 IRCHKI(1) = IRCHKI(1)+1 | |
6987 | **sr | |
6988 | C GOTO 9999 | |
6989 | IREJ = -1 | |
6990 | RETURN | |
6991 | ** | |
6992 | 9998 IRCHKI(2) = IRCHKI(2)+1 | |
6993 | ||
6994 | 9999 CONTINUE | |
6995 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' | |
6996 | IREJ = 1 | |
6997 | RETURN | |
6998 | END | |
6999 | ||
7000 | *$ CREATE DT_CH2RES.FOR | |
7001 | *COPY DT_CH2RES | |
7002 | * | |
7003 | *===ch2res=============================================================* | |
7004 | * | |
7005 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, | |
7006 | & AM,AMN,IMODE,IREJ) | |
7007 | ||
7008 | ************************************************************************ | |
7009 | * Check chains for resonance production. * | |
7010 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * | |
7011 | * input: * | |
7012 | * IF1,2,3,4 input flavors (q,aq in any order) * | |
7013 | * AM chain mass * | |
7014 | * MODE = 1 check q-aq chain for meson-resonance * | |
7015 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * | |
7016 | * = 3 check qq-aqaq chain for lower mass cut * | |
7017 | * output: * | |
7018 | * IDR = 0 no resonances found * | |
7019 | * = -1 pseudoscalar meson/octet baryon * | |
7020 | * = 1 vector-meson/decuplet baryon * | |
7021 | * IDXR BAMJET-index of corresponding resonance * | |
7022 | * AMN mass of corresponding resonance * | |
7023 | * * | |
7024 | * IREJ rejection flag * | |
7025 | * This version dated 06.01.95 is written by S. Roesler * | |
7026 | ************************************************************************ | |
7027 | ||
7028 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7029 | SAVE | |
7030 | PARAMETER ( LINP = 10 , | |
7031 | & LOUT = 6 , | |
7032 | & LDAT = 9 ) | |
7033 | ||
7034 | * particle properties (BAMJET index convention) | |
7035 | CHARACTER*8 ANAME | |
7036 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7037 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7038 | * quark-content to particle index conversion (DTUNUC 1.x) | |
7039 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
7040 | & IA08(6,21),IA10(6,21) | |
7041 | * rejection counter | |
7042 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7043 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7044 | & IREXCI(3),IRDIFF(2),IRINC | |
7045 | * flags for input different options | |
7046 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7047 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7048 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7049 | ||
7050 | DIMENSION IF(4),JF(4) | |
7051 | ||
7052 | **sr 4.7. test | |
7053 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ | |
7054 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ | |
7055 | ** | |
7056 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ | |
7057 | ||
7058 | MODE = ABS(IMODE) | |
7059 | ||
7060 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN | |
7061 | WRITE(LOUT,1000) MODE | |
7062 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, | |
7063 | & 1X,' program stopped') | |
7064 | STOP | |
7065 | ENDIF | |
7066 | ||
7067 | AMX = AM | |
7068 | IREJ = 0 | |
7069 | IDR = 0 | |
7070 | IDXR = 0 | |
7071 | AMN = AMX | |
7072 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM | |
7073 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB | |
7074 | ||
7075 | IF(1) = IF1 | |
7076 | IF(2) = IF2 | |
7077 | IF(3) = IF3 | |
7078 | IF(4) = IF4 | |
7079 | NF = 0 | |
7080 | DO 100 I=1,4 | |
7081 | IF (IF(I).NE.0) THEN | |
7082 | NF = NF+1 | |
7083 | JF(NF) = IF(I) | |
7084 | ENDIF | |
7085 | 100 CONTINUE | |
7086 | IF (NF.LE.MODE) THEN | |
7087 | WRITE(LOUT,1001) MODE,IF | |
7088 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', | |
7089 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) | |
7090 | GOTO 9999 | |
7091 | ENDIF | |
7092 | ||
7093 | GOTO (1,2,3) MODE | |
7094 | ||
7095 | * check for meson resonance | |
7096 | 1 CONTINUE | |
7097 | IFQ = JF(1) | |
7098 | IFAQ = ABS(JF(2)) | |
7099 | IF (JF(2).GT.0) THEN | |
7100 | IFQ = JF(2) | |
7101 | IFAQ = ABS(JF(1)) | |
7102 | ENDIF | |
7103 | IFPS = IMPS(IFAQ,IFQ) | |
7104 | IFV = IMVE(IFAQ,IFQ) | |
7105 | AMPS = AAM(IFPS) | |
7106 | AMV = AAM(IFV) | |
7107 | AMHI = AMV+0.3D0 | |
7108 | IF (AMX.LT.AMV) THEN | |
7109 | IF (AMX.LT.AMPS) THEN | |
7110 | IF (IMODE.GT.0) THEN | |
7111 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 | |
7112 | ELSE | |
7113 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 | |
7114 | ENDIF | |
7115 | LOMRES = LOMRES+1 | |
7116 | ENDIF | |
7117 | * replace chain by pseudoscalar meson | |
7118 | IDR = -1 | |
7119 | IDXR = IFPS | |
7120 | AMN = AMPS | |
7121 | ELSEIF (AMX.LT.AMHI) THEN | |
7122 | * replace chain by vector-meson | |
7123 | IDR = 1 | |
7124 | IDXR = IFV | |
7125 | AMN = AMV | |
7126 | ENDIF | |
7127 | RETURN | |
7128 | ||
7129 | * check for baryon resonance | |
7130 | 2 CONTINUE | |
7131 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) | |
7132 | AM8 = AAM(JB8) | |
7133 | AM10 = AAM(JB10) | |
7134 | AMHI = AM10+0.3D0 | |
7135 | IF (AMX.LT.AM10) THEN | |
7136 | IF (AMX.LT.AM8) THEN | |
7137 | IF (IMODE.GT.0) THEN | |
7138 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 | |
7139 | ELSE | |
7140 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 | |
7141 | ENDIF | |
7142 | LOBRES = LOBRES+1 | |
7143 | ENDIF | |
7144 | * replace chain by oktet baryon | |
7145 | IDR = -1 | |
7146 | IDXR = JB8 | |
7147 | AMN = AM8 | |
7148 | ELSEIF (AMX.LT.AMHI) THEN | |
7149 | IDR = 1 | |
7150 | IDXR = JB10 | |
7151 | AMN = AM10 | |
7152 | ENDIF | |
7153 | RETURN | |
7154 | ||
7155 | * check qq-aqaq for lower mass cut | |
7156 | 3 CONTINUE | |
7157 | * empirical definition of AMHI to allow for (b-antib)-pair prod. | |
7158 | AMHI = 2.5D0 | |
7159 | IF (AMX.LT.AMHI) GOTO 9999 | |
7160 | RETURN | |
7161 | ||
7162 | 9999 CONTINUE | |
7163 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) | |
7164 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE | |
7165 | IREJ = 1 | |
7166 | IRRES(2) = IRRES(2)+1 | |
7167 | RETURN | |
7168 | END | |
7169 | ||
7170 | *$ CREATE DT_RJSEAC.FOR | |
7171 | *COPY DT_RJSEAC | |
7172 | * | |
7173 | *===rjseac=============================================================* | |
7174 | * | |
7175 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) | |
7176 | ||
7177 | ************************************************************************ | |
7178 | * ReJection of SEA-sea Chains. * | |
7179 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * | |
7180 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * | |
7181 | * This version dated 16.01.95 is written by S. Roesler * | |
7182 | ************************************************************************ | |
7183 | ||
7184 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7185 | SAVE | |
7186 | PARAMETER ( LINP = 10 , | |
7187 | & LOUT = 6 , | |
7188 | & LDAT = 9 ) | |
7189 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
7190 | ||
7191 | * event history | |
7192 | PARAMETER (NMXHKK=200000) | |
7193 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7194 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7195 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7196 | * extended event history | |
7197 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7198 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7199 | & IHIST(2,NMXHKK) | |
7200 | * statistics | |
7201 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7202 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7203 | & ICEVTG(8,0:30) | |
7204 | ||
7205 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) | |
7206 | ||
7207 | IREJ = 0 | |
7208 | ||
7209 | * projectile sea q-aq-pair | |
7210 | * indices of sea-pair | |
7211 | IDXSEA(1,1) = MOP1 | |
7212 | IDXSEA(1,2) = MOP2 | |
7213 | * index of mother-nucleon | |
7214 | IDXNUC(1) = JMOHKK(1,MOP1) | |
7215 | * status of valence quarks to be corrected | |
7216 | ISTVAL(1) = -21 | |
7217 | ||
7218 | * target sea q-aq-pair | |
7219 | * indices of sea-pair | |
7220 | IDXSEA(2,1) = MOT1 | |
7221 | IDXSEA(2,2) = MOT2 | |
7222 | * index of mother-nucleon | |
7223 | IDXNUC(2) = JMOHKK(1,MOT1) | |
7224 | * status of valence quarks to be corrected | |
7225 | ISTVAL(2) = -22 | |
7226 | ||
7227 | DO 1 N=1,2 | |
7228 | IDONE = 0 | |
7229 | DO 2 I=NPOINT(2),NHKK | |
7230 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. | |
7231 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN | |
7232 | * valence parton found | |
7233 | * inrease 4-momentum by sea 4-momentum | |
7234 | DO 3 K=1,4 | |
7235 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ | |
7236 | & PHKK(K,IDXSEA(N,2)) | |
7237 | 3 CONTINUE | |
7238 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
7239 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
7240 | * "cancel" sea-pair | |
7241 | DO 4 J=1,2 | |
7242 | ISTHKK(IDXSEA(N,J)) = 100 | |
7243 | IDHKK(IDXSEA(N,J)) = 0 | |
7244 | JMOHKK(1,IDXSEA(N,J)) = 0 | |
7245 | JMOHKK(2,IDXSEA(N,J)) = 0 | |
7246 | JDAHKK(1,IDXSEA(N,J)) = 0 | |
7247 | JDAHKK(2,IDXSEA(N,J)) = 0 | |
7248 | DO 5 K=1,4 | |
7249 | PHKK(K,IDXSEA(N,J)) = ZERO | |
7250 | VHKK(K,IDXSEA(N,J)) = ZERO | |
7251 | WHKK(K,IDXSEA(N,J)) = ZERO | |
7252 | 5 CONTINUE | |
7253 | PHKK(5,IDXSEA(N,J)) = ZERO | |
7254 | 4 CONTINUE | |
7255 | IDONE = 1 | |
7256 | ENDIF | |
7257 | 2 CONTINUE | |
7258 | IF (IDONE.NE.1) THEN | |
7259 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 | |
7260 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', | |
7261 | & '-record!',/,1X,' sea-quark pairs ', | |
7262 | & 2I5,4X,2I5,' could not be canceled!') | |
7263 | GOTO 9999 | |
7264 | ENDIF | |
7265 | 1 CONTINUE | |
7266 | ICRJSS = ICRJSS+1 | |
7267 | RETURN | |
7268 | ||
7269 | 9999 CONTINUE | |
7270 | IREJ = 1 | |
7271 | RETURN | |
7272 | END | |
7273 | ||
7274 | *$ CREATE DT_VV2SCH.FOR | |
7275 | *COPY DT_VV2SCH | |
7276 | * | |
7277 | *===vv2sch=============================================================* | |
7278 | * | |
7279 | SUBROUTINE DT_VV2SCH | |
7280 | ||
7281 | ************************************************************************ | |
7282 | * Change Valence-Valence chain systems to Single CHain systems for * | |
7283 | * hadron-nucleus collisions with meson or antibaryon projectile. * | |
7284 | * (Reggeon contribution) * | |
7285 | * The single chain system is approximately treated as one chain and a * | |
7286 | * meson at rest. * | |
7287 | * This version dated 18.01.95 is written by S. Roesler * | |
7288 | ************************************************************************ | |
7289 | ||
7290 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7291 | SAVE | |
7292 | PARAMETER ( LINP = 10 , | |
7293 | & LOUT = 6 , | |
7294 | & LDAT = 9 ) | |
7295 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) | |
7296 | ||
7297 | LOGICAL LSTART | |
7298 | ||
7299 | * event history | |
7300 | PARAMETER (NMXHKK=200000) | |
7301 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7302 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7303 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7304 | * extended event history | |
7305 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7306 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7307 | & IHIST(2,NMXHKK) | |
7308 | * flags for input different options | |
7309 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7310 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7311 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7312 | * statistics | |
7313 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7314 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7315 | & ICEVTG(8,0:30) | |
7316 | ||
7317 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), | |
7318 | & PCH2(4) | |
7319 | ||
7320 | DATA LSTART /.TRUE./ | |
7321 | ||
7322 | IFSC = 0 | |
7323 | IF (LSTART) THEN | |
7324 | WRITE(LOUT,1000) | |
7325 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', | |
7326 | & 'valence chains treated') | |
7327 | LSTART = .FALSE. | |
7328 | ENDIF | |
7329 | ||
7330 | NSTOP = NHKK | |
7331 | ||
7332 | * get index of first chain | |
7333 | DO 1 I=NPOINT(3),NHKK | |
7334 | IF (IDHKK(I).EQ.88888) THEN | |
7335 | NC = I | |
7336 | GOTO 2 | |
7337 | ENDIF | |
7338 | 1 CONTINUE | |
7339 | ||
7340 | 2 CONTINUE | |
7341 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) | |
7342 | & .AND.(NC.LT.NSTOP)) THEN | |
7343 | * get valence-valence chains | |
7344 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN | |
7345 | * get "mother"-hadron indices | |
7346 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) | |
7347 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) | |
7348 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) | |
7349 | KTARG = IDT_ICIHAD(IDHKK(MO2)) | |
7350 | * Lab momentum of projectile hadron | |
7351 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) | |
7352 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ | |
7353 | & PHKK(3,MO1)**2) | |
7354 | ||
7355 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) | |
7356 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN | |
7357 | ICVV2S = ICVV2S+1 | |
7358 | * single chain requested | |
7359 | * get flavors of chain-end partons | |
7360 | MO(1) = JMOHKK(1,NC) | |
7361 | MO(2) = JMOHKK(2,NC) | |
7362 | MO(3) = JMOHKK(1,NC+3) | |
7363 | MO(4) = JMOHKK(2,NC+3) | |
7364 | DO 3 I=1,4 | |
7365 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) | |
7366 | IF(I,2) = 0 | |
7367 | IF (ABS(IDHKK(MO(I))).GE.1000) | |
7368 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) | |
7369 | 3 CONTINUE | |
7370 | * which one is the q-aq chain? | |
7371 | * N1,N1+1 - DTEVT1-entries for q-aq system | |
7372 | * N2,N2+1 - DTEVT1-entries for the other chain | |
7373 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN | |
7374 | K1 = 1 | |
7375 | K2 = 3 | |
7376 | N1 = NC-2 | |
7377 | N2 = NC+1 | |
7378 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN | |
7379 | K1 = 3 | |
7380 | K2 = 1 | |
7381 | N1 = NC+1 | |
7382 | N2 = NC-2 | |
7383 | ELSE | |
7384 | GOTO 10 | |
7385 | ENDIF | |
7386 | DO 4 K=1,4 | |
7387 | PP1(K) = PHKK(K,N1) | |
7388 | PT1(K) = PHKK(K,N1+1) | |
7389 | PP2(K) = PHKK(K,N2) | |
7390 | PT2(K) = PHKK(K,N2+1) | |
7391 | 4 CONTINUE | |
7392 | AMCH1 = PHKK(5,N1+2) | |
7393 | AMCH2 = PHKK(5,N2+2) | |
7394 | * get meson-identity corresponding to flavors of q-aq chain | |
7395 | ITMP = IRESRJ | |
7396 | IRESRJ = 0 | |
7397 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, | |
7398 | & ZERO,AMCH1N,1,IDUM) | |
7399 | IRESRJ = ITMP | |
7400 | * change kinematics of chains | |
7401 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), | |
7402 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), | |
7403 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7404 | IF (IREJ1.NE.0) GOTO 10 | |
7405 | * check second chain for resonance | |
7406 | IDCHAI = 2 | |
7407 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 | |
7408 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), | |
7409 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) | |
7410 | IF (IREJ1.NE.0) GOTO 10 | |
7411 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7412 | * add partons and chains to DTEVT1 | |
7413 | DO 5 K=1,4 | |
7414 | PCH1(K) = PP1(K)+PT1(K) | |
7415 | PCH2(K) = PP2(K)+PT2(K) | |
7416 | 5 CONTINUE | |
7417 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), | |
7418 | & PP1(3),PP1(4),0,0,0) | |
7419 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), | |
7420 | & PT1(2),PT1(3),PT1(4),0,0,0) | |
7421 | KCH = ISTHKK(N1+2)+100 | |
7422 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), | |
7423 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) | |
7424 | IDHKK(N1+2) = 22222 | |
7425 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), | |
7426 | & PP2(3),PP2(4),0,0,0) | |
7427 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), | |
7428 | & PT2(2),PT2(3),PT2(4),0,0,0) | |
7429 | KCH = ISTHKK(N2+2)+100 | |
7430 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), | |
7431 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) | |
7432 | IDHKK(N2+2) = 22222 | |
7433 | ENDIF | |
7434 | ENDIF | |
7435 | ELSE | |
7436 | GOTO 11 | |
7437 | ENDIF | |
7438 | 10 CONTINUE | |
7439 | NC = NC+6 | |
7440 | GOTO 2 | |
7441 | ||
7442 | 11 CONTINUE | |
7443 | ||
7444 | RETURN | |
7445 | END | |
7446 | ||
7447 | *$ CREATE DT_PHNSCH.FOR | |
7448 | *COPY DT_PHNSCH | |
7449 | * | |
7450 | *=== phnsch ===========================================================* | |
7451 | * | |
7452 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) | |
7453 | ||
7454 | *----------------------------------------------------------------------* | |
7455 | * * | |
7456 | * Probability for Hadron Nucleon Single CHain interactions: * | |
7457 | * * | |
7458 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * | |
7459 | * Infn - Milan * | |
7460 | * * | |
7461 | * Last change on 04-jan-94 by Alfredo Ferrari * | |
7462 | * * | |
7463 | * modified by J.R.for use in DTUNUC 6.1.94 * | |
7464 | * * | |
7465 | * Input variables: * | |
7466 | * Kp = hadron projectile index (Part numbering * | |
7467 | * scheme) * | |
7468 | * Ktarg = target nucleon index (1=proton, 8=neutron) * | |
7469 | * Plab = projectile laboratory momentum (GeV/c) * | |
7470 | * Output variable: * | |
7471 | * Phnsch = probability per single chain (particle * | |
7472 | * exchange) interactions * | |
7473 | * * | |
7474 | *----------------------------------------------------------------------* | |
7475 | ||
7476 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7477 | SAVE | |
7478 | ||
7479 | PARAMETER ( LUNOUT = 6 ) | |
7480 | PARAMETER ( LUNERR = 6 ) | |
7481 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
7482 | PARAMETER ( ZERZER = 0.D+00 ) | |
7483 | PARAMETER ( ONEONE = 1.D+00 ) | |
7484 | PARAMETER ( TWOTWO = 2.D+00 ) | |
7485 | PARAMETER ( FIVFIV = 5.D+00 ) | |
7486 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
7487 | ||
7488 | PARAMETER ( NALLWP = 39 ) | |
7489 | PARAMETER ( IDMAXP = 210 ) | |
7490 | ||
7491 | DIMENSION ICHRGE(39),AM(39) | |
7492 | ||
7493 | * particle properties (BAMJET index convention) | |
7494 | CHARACTER*8 ANAME | |
7495 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7496 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7497 | ||
7498 | DIMENSION KPTOIP(210) | |
7499 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
7500 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
7501 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
7502 | & IQTCHR(-6:6),MQUARK(3,39) | |
7503 | ||
7504 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) | |
7505 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) | |
454792a9 | 7506 | CPH SAVE SGTCOE, IHLP |
7507 | CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2 | |
9aaba0d6 | 7508 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) |
7509 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) | |
7510 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) | |
7511 | ||
7512 | * Conversion from part to paprop numbering | |
7513 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
7514 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, | |
7515 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ | |
7516 | ||
7517 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: | |
7518 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, | |
7519 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / | |
7520 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / | |
7521 | DATA SGTCO1 / | |
7522 | * 1st reaction: gamma p total | |
7523 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, | |
7524 | * 2nd reaction: gamma d total | |
7525 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, | |
7526 | * 3rd reaction: pi+ p total | |
7527 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , | |
7528 | * 4th reaction: pi- p total | |
7529 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, | |
7530 | * 5th reaction: pi+/- d total | |
7531 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, | |
7532 | * 6th reaction: K+ p total | |
7533 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, | |
7534 | * 7th reaction: K+ n total | |
7535 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, | |
7536 | * 8th reaction: K+ d total | |
7537 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, | |
7538 | * 9th reaction: K- p total | |
7539 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, | |
7540 | * 10th reaction: K- n total | |
7541 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ | |
7542 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / | |
7543 | DATA SGTCO2 / | |
7544 | * 11th reaction: K- d total | |
7545 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, | |
7546 | * 12th reaction: p p total | |
7547 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, | |
7548 | * 13th reaction: p n total | |
7549 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, | |
7550 | * 14th reaction: p d total | |
7551 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, | |
7552 | * 15th reaction: pbar p total | |
7553 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, | |
7554 | * 16th reaction: pbar n total | |
7555 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, | |
7556 | * 17th reaction: pbar d total | |
7557 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, | |
7558 | * 18th reaction: Lamda p total | |
7559 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ | |
7560 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / | |
7561 | DATA SGTCO3 / | |
7562 | * 19th reaction: pi+ p elastic | |
7563 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , | |
7564 | * 20th reaction: pi- p elastic | |
7565 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , | |
7566 | * 21st reaction: K+ p elastic | |
7567 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, | |
7568 | * 22nd reaction: K- p elastic | |
7569 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, | |
7570 | * 23rd reaction: p p elastic | |
7571 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, | |
7572 | * 24th reaction: p d elastic | |
7573 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, | |
7574 | * 25th reaction: pbar p elastic | |
7575 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, | |
7576 | * 26th reaction: pbar p elastic bis | |
7577 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, | |
7578 | * 27th reaction: pbar n elastic | |
7579 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, | |
7580 | * 28th reaction: Lamda p elastic | |
7581 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, | |
7582 | * 29th reaction: K- p ela bis | |
7583 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, | |
7584 | * 30th reaction: pi- p cx | |
7585 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , | |
7586 | * 31st reaction: K- p cx | |
7587 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , | |
7588 | * 32nd reaction: K+ n cx | |
7589 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , | |
7590 | * 33rd reaction: pbar p cx | |
7591 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / | |
7592 | * | |
7593 | * +-------------------------------------------------------------------* | |
7594 | ICHRGE(KTARG)=IICH(KTARG) | |
7595 | AM (KTARG)=AAM (KTARG) | |
7596 | * | Check for pi0 (d-dbar) | |
7597 | IF ( KP .NE. 26 ) THEN | |
7598 | IP = KPTOIP (KP) | |
7599 | IF(IP.EQ.0)IP=1 | |
7600 | ICHRGE(IP)=IICH(KP) | |
7601 | AM (IP)=AAM (KP) | |
7602 | * | | |
7603 | * +-------------------------------------------------------------------* | |
7604 | * | | |
7605 | ELSE | |
7606 | IP = 23 | |
7607 | ICHRGE(IP)=0 | |
7608 | END IF | |
7609 | * | | |
7610 | * +-------------------------------------------------------------------* | |
7611 | * +-------------------------------------------------------------------* | |
7612 | * | No such interactions for baryon-baryon | |
7613 | IF ( IIBAR (KP) .GT. 0 ) THEN | |
7614 | DT_PHNSCH = ZERZER | |
7615 | RETURN | |
7616 | * | | |
7617 | * +-------------------------------------------------------------------* | |
7618 | * | No "annihilation" diagram possible for K+ p/n | |
7619 | ELSE IF ( IP .EQ. 15 ) THEN | |
7620 | DT_PHNSCH = ZERZER | |
7621 | RETURN | |
7622 | * | | |
7623 | * +-------------------------------------------------------------------* | |
7624 | * | No "annihilation" diagram possible for K0 p/n | |
7625 | ELSE IF ( IP .EQ. 24 ) THEN | |
7626 | DT_PHNSCH = ZERZER | |
7627 | RETURN | |
7628 | * | | |
7629 | * +-------------------------------------------------------------------* | |
7630 | * | No "annihilation" diagram possible for Omebar p/n | |
7631 | ELSE IF ( IP .GE. 38 ) THEN | |
7632 | DT_PHNSCH = ZERZER | |
7633 | RETURN | |
7634 | END IF | |
7635 | * | | |
7636 | * +-------------------------------------------------------------------* | |
7637 | * +-------------------------------------------------------------------* | |
7638 | * | If the momentum is larger than 50 GeV/c, compute the single | |
7639 | * | chain probability at 50 GeV/c and extrapolate to the present | |
7640 | * | momentum according to 1/sqrt(s) | |
7641 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch | |
7642 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) | |
7643 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 | |
7644 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) | |
7645 | * | x sqrt(s/s(50)) | |
7646 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
7647 | IF ( PLAB .GT. 50.D+00 ) THEN | |
7648 | PLA = 50.D+00 | |
7649 | AMPSQ = AM (IP)**2 | |
7650 | AMTSQ = AM (KTARG)**2 | |
7651 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7652 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7653 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7654 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7655 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7656 | * | | |
7657 | * +-------------------------------------------------------------------* | |
7658 | * | P < 3 GeV/c | |
7659 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN | |
7660 | PLA = 3.D+00 | |
7661 | AMPSQ = AM (IP)**2 | |
7662 | AMTSQ = AM (KTARG)**2 | |
7663 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7664 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7665 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7666 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7667 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7668 | * | | |
7669 | * +-------------------------------------------------------------------* | |
7670 | * | P < 50 GeV/c | |
7671 | ELSE | |
7672 | PLA = PLAB | |
7673 | UMORAT = ONEONE | |
7674 | END IF | |
7675 | * | | |
7676 | * +-------------------------------------------------------------------* | |
7677 | ALGPLA = LOG (PLA) | |
7678 | * +-------------------------------------------------------------------* | |
7679 | * | Pions: | |
7680 | IF ( IHLP (IP) .EQ. 2 ) THEN | |
7681 | ACOF = SGTCOE (1,3) | |
7682 | BCOF = SGTCOE (2,3) | |
7683 | ENNE = SGTCOE (3,3) | |
7684 | CCOF = SGTCOE (4,3) | |
7685 | DCOF = SGTCOE (5,3) | |
7686 | * | Compute the pi+ p total cross section: | |
7687 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7688 | & + DCOF * ALGPLA | |
7689 | ACOF = SGTCOE (1,19) | |
7690 | BCOF = SGTCOE (2,19) | |
7691 | ENNE = SGTCOE (3,19) | |
7692 | CCOF = SGTCOE (4,19) | |
7693 | DCOF = SGTCOE (5,19) | |
7694 | * | Compute the pi+ p elastic cross section: | |
7695 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7696 | & + DCOF * ALGPLA | |
7697 | * | Compute the pi+ p inelastic cross section: | |
7698 | SPPPIN = SPPPTT - SPPPEL | |
7699 | ACOF = SGTCOE (1,4) | |
7700 | BCOF = SGTCOE (2,4) | |
7701 | ENNE = SGTCOE (3,4) | |
7702 | CCOF = SGTCOE (4,4) | |
7703 | DCOF = SGTCOE (5,4) | |
7704 | * | Compute the pi- p total cross section: | |
7705 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7706 | & + DCOF * ALGPLA | |
7707 | ACOF = SGTCOE (1,20) | |
7708 | BCOF = SGTCOE (2,20) | |
7709 | ENNE = SGTCOE (3,20) | |
7710 | CCOF = SGTCOE (4,20) | |
7711 | DCOF = SGTCOE (5,20) | |
7712 | * | Compute the pi- p elastic cross section: | |
7713 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7714 | & + DCOF * ALGPLA | |
7715 | * | Compute the pi- p inelastic cross section: | |
7716 | SPMPIN = SPMPTT - SPMPEL | |
7717 | SIGDIA = SPMPIN - SPPPIN | |
7718 | * | +----------------------------------------------------------------* | |
7719 | * | | Charged pions: besides isospin consideration it is supposed | |
7720 | * | | that (pi+ n)el is almost equal to (pi- p)el | |
7721 | * | | and (pi+ p)el " " " " (pi- n)el | |
7722 | * | | and all are almost equal among each others | |
7723 | * | | (reasonable above 5 GeV/c) | |
7724 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7725 | KHELP = KTARG / 8 | |
7726 | JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP | |
7727 | ACOF = SGTCOE (1,JREAC) | |
7728 | BCOF = SGTCOE (2,JREAC) | |
7729 | ENNE = SGTCOE (3,JREAC) | |
7730 | CCOF = SGTCOE (4,JREAC) | |
7731 | DCOF = SGTCOE (5,JREAC) | |
7732 | * | | Compute the total cross section: | |
7733 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7734 | & + DCOF * ALGPLA | |
7735 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP | |
7736 | ACOF = SGTCOE (1,JREAC) | |
7737 | BCOF = SGTCOE (2,JREAC) | |
7738 | ENNE = SGTCOE (3,JREAC) | |
7739 | CCOF = SGTCOE (4,JREAC) | |
7740 | DCOF = SGTCOE (5,JREAC) | |
7741 | * | | Compute the elastic cross section: | |
7742 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7743 | & + DCOF * ALGPLA | |
7744 | * | | Compute the inelastic cross section: | |
7745 | SHNCIN = SHNCTT - SHNCEL | |
7746 | * | | Number of diagrams: | |
7747 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP | |
7748 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7749 | IQFSC1 = 1 + IP - 13 | |
7750 | IQFSC2 = 0 | |
7751 | IQBSC1 = 1 + KHELP | |
7752 | IQBSC2 = 1 + IP - 13 | |
7753 | * | | | |
7754 | * | +----------------------------------------------------------------* | |
7755 | * | | pi0: besides isospin consideration it is supposed that the | |
7756 | * | | elastic cross section is not very different from | |
7757 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) | |
7758 | ELSE | |
7759 | KHELP = KTARG / 8 | |
7760 | K2HLP = ( KP - 23 ) / 3 | |
7761 | * | | Number of diagrams: | |
7762 | * | | For u ubar (k2hlp=0): | |
7763 | * NDIAGR = 2 - KHELP | |
7764 | * | | For d dbar (k2hlp=1): | |
7765 | * NDIAGR = 2 + KHELP - K2HLP | |
7766 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP | |
7767 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) | |
7768 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7769 | IQFSC1 = 1 + K2HLP | |
7770 | IQFSC2 = 0 | |
7771 | IQBSC1 = 1 + KHELP | |
7772 | IQBSC2 = 2 - K2HLP | |
7773 | END IF | |
7774 | * | | | |
7775 | * | +----------------------------------------------------------------* | |
7776 | * | end pi's | |
7777 | * +-------------------------------------------------------------------* | |
7778 | * | Kaons: | |
7779 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN | |
7780 | ACOF = SGTCOE (1,6) | |
7781 | BCOF = SGTCOE (2,6) | |
7782 | ENNE = SGTCOE (3,6) | |
7783 | CCOF = SGTCOE (4,6) | |
7784 | DCOF = SGTCOE (5,6) | |
7785 | * | Compute the K+ p total cross section: | |
7786 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7787 | & + DCOF * ALGPLA | |
7788 | ACOF = SGTCOE (1,21) | |
7789 | BCOF = SGTCOE (2,21) | |
7790 | ENNE = SGTCOE (3,21) | |
7791 | CCOF = SGTCOE (4,21) | |
7792 | DCOF = SGTCOE (5,21) | |
7793 | * | Compute the K+ p elastic cross section: | |
7794 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7795 | & + DCOF * ALGPLA | |
7796 | * | Compute the K+ p inelastic cross section: | |
7797 | SKPPIN = SKPPTT - SKPPEL | |
7798 | ACOF = SGTCOE (1,9) | |
7799 | BCOF = SGTCOE (2,9) | |
7800 | ENNE = SGTCOE (3,9) | |
7801 | CCOF = SGTCOE (4,9) | |
7802 | DCOF = SGTCOE (5,9) | |
7803 | * | Compute the K- p total cross section: | |
7804 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7805 | & + DCOF * ALGPLA | |
7806 | ACOF = SGTCOE (1,22) | |
7807 | BCOF = SGTCOE (2,22) | |
7808 | ENNE = SGTCOE (3,22) | |
7809 | CCOF = SGTCOE (4,22) | |
7810 | DCOF = SGTCOE (5,22) | |
7811 | * | Compute the K- p elastic cross section: | |
7812 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7813 | & + DCOF * ALGPLA | |
7814 | * | Compute the K- p inelastic cross section: | |
7815 | SKMPIN = SKMPTT - SKMPEL | |
7816 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) | |
7817 | * | +----------------------------------------------------------------* | |
7818 | * | | Charged Kaons: actually only K- | |
7819 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7820 | KHELP = KTARG / 8 | |
7821 | * | | +-------------------------------------------------------------* | |
7822 | * | | | Proton target: | |
7823 | IF ( KHELP .EQ. 0 ) THEN | |
7824 | SHNCIN = SKMPIN | |
7825 | * | | | Number of diagrams: | |
7826 | NDIAGR = 2 | |
7827 | * | | | | |
7828 | * | | +-------------------------------------------------------------* | |
7829 | * | | | Neutron target: besides isospin consideration it is supposed | |
7830 | * | | | that (K- n)el is almost equal to (K- p)el | |
7831 | * | | | (reasonable above 5 GeV/c) | |
7832 | ELSE | |
7833 | ACOF = SGTCOE (1,10) | |
7834 | BCOF = SGTCOE (2,10) | |
7835 | ENNE = SGTCOE (3,10) | |
7836 | CCOF = SGTCOE (4,10) | |
7837 | DCOF = SGTCOE (5,10) | |
7838 | * | | | Compute the total cross section: | |
7839 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7840 | & + DCOF * ALGPLA | |
7841 | * | | | Compute the elastic cross section: | |
7842 | SHNCEL = SKMPEL | |
7843 | * | | | Compute the inelastic cross section: | |
7844 | SHNCIN = SHNCTT - SHNCEL | |
7845 | * | | | Number of diagrams: | |
7846 | NDIAGR = 1 | |
7847 | END IF | |
7848 | * | | | | |
7849 | * | | +-------------------------------------------------------------* | |
7850 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7851 | IQFSC1 = 3 | |
7852 | IQFSC2 = 0 | |
7853 | IQBSC1 = 1 + KHELP | |
7854 | IQBSC2 = 2 | |
7855 | * | | | |
7856 | * | +----------------------------------------------------------------* | |
7857 | * | | K0's: (actually only K0bar) | |
7858 | ELSE | |
7859 | KHELP = KTARG / 8 | |
7860 | * | | +-------------------------------------------------------------* | |
7861 | * | | | Proton target: (K0bar p)in supposed to be given by | |
7862 | * | | | (K- p)in - Sig_diagr | |
7863 | IF ( KHELP .EQ. 0 ) THEN | |
7864 | SHNCIN = SKMPIN - SIGDIA | |
7865 | * | | | Number of diagrams: | |
7866 | NDIAGR = 1 | |
7867 | * | | | | |
7868 | * | | +-------------------------------------------------------------* | |
7869 | * | | | Neutron target: (K0bar n)in supposed to be given by | |
7870 | * | | | (K- n)in + Sig_diagr | |
7871 | * | | | besides isospin consideration it is supposed | |
7872 | * | | | that (K- n)el is almost equal to (K- p)el | |
7873 | * | | | (reasonable above 5 GeV/c) | |
7874 | ELSE | |
7875 | ACOF = SGTCOE (1,10) | |
7876 | BCOF = SGTCOE (2,10) | |
7877 | ENNE = SGTCOE (3,10) | |
7878 | CCOF = SGTCOE (4,10) | |
7879 | DCOF = SGTCOE (5,10) | |
7880 | * | | | Compute the total cross section: | |
7881 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7882 | & + DCOF * ALGPLA | |
7883 | * | | | Compute the elastic cross section: | |
7884 | SHNCEL = SKMPEL | |
7885 | * | | | Compute the inelastic cross section: | |
7886 | SHNCIN = SHNCTT - SHNCEL + SIGDIA | |
7887 | * | | | Number of diagrams: | |
7888 | NDIAGR = 2 | |
7889 | END IF | |
7890 | * | | | | |
7891 | * | | +-------------------------------------------------------------* | |
7892 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7893 | IQFSC1 = 3 | |
7894 | IQFSC2 = 0 | |
7895 | IQBSC1 = 1 | |
7896 | IQBSC2 = 1 + KHELP | |
7897 | END IF | |
7898 | * | | | |
7899 | * | +----------------------------------------------------------------* | |
7900 | * | end Kaon's | |
7901 | * +-------------------------------------------------------------------* | |
7902 | * | Antinucleons: | |
7903 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN | |
7904 | * | For momenta between 3 and 5 GeV/c the use of tabulated data | |
7905 | * | should be implemented! | |
7906 | ACOF = SGTCOE (1,15) | |
7907 | BCOF = SGTCOE (2,15) | |
7908 | ENNE = SGTCOE (3,15) | |
7909 | CCOF = SGTCOE (4,15) | |
7910 | DCOF = SGTCOE (5,15) | |
7911 | * | Compute the pbar p total cross section: | |
7912 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7913 | & + DCOF * ALGPLA | |
7914 | IF ( PLA .LT. FIVFIV ) THEN | |
7915 | JREAC = 26 | |
7916 | ELSE | |
7917 | JREAC = 25 | |
7918 | END IF | |
7919 | ACOF = SGTCOE (1,JREAC) | |
7920 | BCOF = SGTCOE (2,JREAC) | |
7921 | ENNE = SGTCOE (3,JREAC) | |
7922 | CCOF = SGTCOE (4,JREAC) | |
7923 | DCOF = SGTCOE (5,JREAC) | |
7924 | * | Compute the pbar p elastic cross section: | |
7925 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7926 | & + DCOF * ALGPLA | |
7927 | * | Compute the pbar p inelastic cross section: | |
7928 | SAPPIN = SAPPTT - SAPPEL | |
7929 | ACOF = SGTCOE (1,12) | |
7930 | BCOF = SGTCOE (2,12) | |
7931 | ENNE = SGTCOE (3,12) | |
7932 | CCOF = SGTCOE (4,12) | |
7933 | DCOF = SGTCOE (5,12) | |
7934 | * | Compute the p p total cross section: | |
7935 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7936 | & + DCOF * ALGPLA | |
7937 | ACOF = SGTCOE (1,23) | |
7938 | BCOF = SGTCOE (2,23) | |
7939 | ENNE = SGTCOE (3,23) | |
7940 | CCOF = SGTCOE (4,23) | |
7941 | DCOF = SGTCOE (5,23) | |
7942 | * | Compute the p p elastic cross section: | |
7943 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7944 | & + DCOF * ALGPLA | |
7945 | * | Compute the K- p inelastic cross section: | |
7946 | SPPINE = SPPTOT - SPPELA | |
7947 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV | |
7948 | KHELP = KTARG / 8 | |
7949 | * | +----------------------------------------------------------------* | |
7950 | * | | Pbar: | |
7951 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7952 | NDIAGR = 5 - KHELP | |
7953 | * | | +-------------------------------------------------------------* | |
7954 | * | | | Proton target: | |
7955 | IF ( KHELP .EQ. 0 ) THEN | |
7956 | * | | | Number of diagrams: | |
7957 | SHNCIN = SAPPIN | |
7958 | PUUBAR = 0.8D+00 | |
7959 | * | | | | |
7960 | * | | +-------------------------------------------------------------* | |
7961 | * | | | Neutron target: it is supposed that (ap n)el is almost equal | |
7962 | * | | | to (ap p)el (reasonable above 5 GeV/c) | |
7963 | ELSE | |
7964 | ACOF = SGTCOE (1,16) | |
7965 | BCOF = SGTCOE (2,16) | |
7966 | ENNE = SGTCOE (3,16) | |
7967 | CCOF = SGTCOE (4,16) | |
7968 | DCOF = SGTCOE (5,16) | |
7969 | * | | | Compute the total cross section: | |
7970 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7971 | & + DCOF * ALGPLA | |
7972 | * | | | Compute the elastic cross section: | |
7973 | SHNCEL = SAPPEL | |
7974 | * | | | Compute the inelastic cross section: | |
7975 | SHNCIN = SHNCTT - SHNCEL | |
7976 | PUUBAR = HLFHLF | |
7977 | END IF | |
7978 | * | | | | |
7979 | * | | +-------------------------------------------------------------* | |
7980 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7981 | * | | there are different possibilities, make a random choiche: | |
7982 | IQFSC1 = -1 | |
7983 | RNCHEN = DT_RNDM(PUUBAR) | |
7984 | IF ( RNCHEN .LT. PUUBAR ) THEN | |
7985 | IQFSC2 = -2 | |
7986 | ELSE | |
7987 | IQFSC2 = -1 | |
7988 | END IF | |
7989 | IQBSC1 = -IQFSC1 + KHELP | |
7990 | IQBSC2 = -IQFSC2 | |
7991 | * | | | |
7992 | * | +----------------------------------------------------------------* | |
7993 | * | | nbar: | |
7994 | ELSE | |
7995 | NDIAGR = 4 + KHELP | |
7996 | * | | +-------------------------------------------------------------* | |
7997 | * | | | Proton target: (nbar p)in supposed to be given by | |
7998 | * | | | (pbar p)in - Sig_diagr | |
7999 | IF ( KHELP .EQ. 0 ) THEN | |
8000 | SHNCIN = SAPPIN - SIGDIA | |
8001 | PDDBAR = HLFHLF | |
8002 | * | | | | |
8003 | * | | +-------------------------------------------------------------* | |
8004 | * | | | Neutron target: (nbar n)el is supposed to be equal to | |
8005 | * | | | (pbar p)el (reasonable above 5 GeV/c) | |
8006 | ELSE | |
8007 | * | | | Compute the total cross section: | |
8008 | SHNCTT = SAPPTT | |
8009 | * | | | Compute the elastic cross section: | |
8010 | SHNCEL = SAPPEL | |
8011 | * | | | Compute the inelastic cross section: | |
8012 | SHNCIN = SHNCTT - SHNCEL | |
8013 | PDDBAR = 0.8D+00 | |
8014 | END IF | |
8015 | * | | | | |
8016 | * | | +-------------------------------------------------------------* | |
8017 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8018 | * | | there are different possibilities, make a random choiche: | |
8019 | IQFSC1 = -2 | |
8020 | RNCHEN = DT_RNDM(RNCHEN) | |
8021 | IF ( RNCHEN .LT. PDDBAR ) THEN | |
8022 | IQFSC2 = -1 | |
8023 | ELSE | |
8024 | IQFSC2 = -2 | |
8025 | END IF | |
8026 | IQBSC1 = -IQFSC1 + KHELP - 1 | |
8027 | IQBSC2 = -IQFSC2 | |
8028 | END IF | |
8029 | * | | | |
8030 | * | +----------------------------------------------------------------* | |
8031 | * | | |
8032 | * +-------------------------------------------------------------------* | |
8033 | * | Others: not yet implemented | |
8034 | ELSE | |
8035 | SIGDIA = ZERZER | |
8036 | SHNCIN = ONEONE | |
8037 | NDIAGR = 0 | |
8038 | DT_PHNSCH = ZERZER | |
8039 | RETURN | |
8040 | END IF | |
8041 | * | end others | |
8042 | * +-------------------------------------------------------------------* | |
8043 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN | |
8044 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) | |
8045 | & + IQECHR (IQBSC2) | |
8046 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) | |
8047 | & + IQBCHR (IQBSC2) | |
8048 | IQECHC = IQECHC / 3 | |
8049 | IQBCHC = IQBCHC / 3 | |
8050 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) | |
8051 | & + IQSCHR (IQBSC2) | |
8052 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) | |
8053 | & + IQSCHR (MQUARK(3,IP)) | |
8054 | * +-------------------------------------------------------------------* | |
8055 | * | Consistency check: | |
8056 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN | |
8057 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', | |
8058 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8059 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', | |
8060 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8061 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) | |
8062 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) | |
8063 | END IF | |
8064 | * | | |
8065 | * +-------------------------------------------------------------------* | |
8066 | * +-------------------------------------------------------------------* | |
8067 | * | Consistency check: | |
8068 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) | |
8069 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN | |
8070 | WRITE (LUNOUT,*) | |
8071 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8072 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8073 | WRITE (LUNERR,*) | |
8074 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8075 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8076 | END IF | |
8077 | * | | |
8078 | * +-------------------------------------------------------------------* | |
8079 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
8080 | IF ( UMORAT .GT. ONEPLS ) | |
8081 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH | |
8082 | & - ONEONE ) * UMORAT + ONEONE ) | |
8083 | RETURN | |
8084 | * | |
8085 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) | |
8086 | DT_SCHQUA = ONEONE | |
8087 | JQFSC1 = IQFSC1 | |
8088 | JQFSC2 = IQFSC2 | |
8089 | JQBSC1 = IQBSC1 | |
8090 | JQBSC2 = IQBSC2 | |
8091 | *=== End of function Phnsch ===========================================* | |
8092 | RETURN | |
8093 | END | |
8094 | ||
8095 | *$ CREATE DT_RESPT.FOR | |
8096 | *COPY DT_RESPT | |
8097 | * | |
8098 | *===respt==============================================================* | |
8099 | * | |
8100 | SUBROUTINE DT_RESPT | |
8101 | ||
8102 | ************************************************************************ | |
8103 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * | |
8104 | * This version dated 18.01.95 is written by S. Roesler * | |
8105 | ************************************************************************ | |
8106 | ||
8107 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8108 | SAVE | |
8109 | PARAMETER ( LINP = 10 , | |
8110 | & LOUT = 6 , | |
8111 | & LDAT = 9 ) | |
8112 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8113 | ||
8114 | * event history | |
8115 | PARAMETER (NMXHKK=200000) | |
8116 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8117 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8118 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8119 | * extended event history | |
8120 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8121 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8122 | & IHIST(2,NMXHKK) | |
8123 | ||
8124 | * get index of first chain | |
8125 | DO 1 I=NPOINT(3),NHKK | |
8126 | IF (IDHKK(I).EQ.88888) THEN | |
8127 | NC = I | |
8128 | GOTO 2 | |
8129 | ENDIF | |
8130 | 1 CONTINUE | |
8131 | ||
8132 | 2 CONTINUE | |
8133 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN | |
8134 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) | |
8135 | * skip VV-,SS- systems | |
8136 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. | |
8137 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN | |
8138 | * check if both "chains" are resonances | |
8139 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN | |
8140 | CALL DT_SAPTRE(NC,NC+3) | |
8141 | ENDIF | |
8142 | ENDIF | |
8143 | ELSE | |
8144 | GOTO 3 | |
8145 | ENDIF | |
8146 | NC = NC+6 | |
8147 | GOTO 2 | |
8148 | ||
8149 | 3 CONTINUE | |
8150 | ||
8151 | RETURN | |
8152 | END | |
8153 | ||
8154 | *$ CREATE DT_EVTRES.FOR | |
8155 | *COPY DT_EVTRES | |
8156 | * | |
8157 | *===evtres=============================================================* | |
8158 | * | |
8159 | SUBROUTINE DT_EVTRES(IREJ) | |
8160 | ||
8161 | ************************************************************************ | |
8162 | * This version dated 14.12.94 is written by S. Roesler * | |
8163 | ************************************************************************ | |
8164 | ||
8165 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8166 | SAVE | |
8167 | PARAMETER ( LINP = 10 , | |
8168 | & LOUT = 6 , | |
8169 | & LDAT = 9 ) | |
8170 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) | |
8171 | ||
8172 | * event history | |
8173 | PARAMETER (NMXHKK=200000) | |
8174 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8175 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8176 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8177 | * extended event history | |
8178 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8179 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8180 | & IHIST(2,NMXHKK) | |
8181 | * flags for input different options | |
8182 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8183 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8184 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8185 | * particle properties (BAMJET index convention) | |
8186 | CHARACTER*8 ANAME | |
8187 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
8188 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
8189 | ||
8190 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) | |
8191 | ||
8192 | IREJ = 0 | |
8193 | ||
8194 | DO 1 I=NPOINT(3),NHKK | |
8195 | IF (ABS(IDRES(I)).GE.100) THEN | |
8196 | AMMX = 0.0D0 | |
8197 | DO 2 J=NPOINT(3),NHKK | |
8198 | IF (IDHKK(J).EQ.88888) THEN | |
8199 | IF (PHKK(5,J).GT.AMMX) THEN | |
8200 | AMMX = PHKK(5,J) | |
8201 | IMMX = J | |
8202 | ENDIF | |
8203 | ENDIF | |
8204 | 2 CONTINUE | |
8205 | IF (IDRES(IMMX).NE.0) THEN | |
8206 | IF (IOULEV(3).GT.0) THEN | |
8207 | WRITE(LOUT,'(1X,A)') | |
8208 | & 'EVTRES: no chain for correc. found' | |
8209 | C GOTO 6 | |
8210 | GOTO 9999 | |
8211 | ELSE | |
8212 | GOTO 9999 | |
8213 | ENDIF | |
8214 | ENDIF | |
8215 | IMO11 = JMOHKK(1,I) | |
8216 | IMO12 = JMOHKK(2,I) | |
8217 | IF (PHKK(3,IMO11).LT.0.0D0) THEN | |
8218 | IMO11 = JMOHKK(2,I) | |
8219 | IMO12 = JMOHKK(1,I) | |
8220 | ENDIF | |
8221 | IMO21 = JMOHKK(1,IMMX) | |
8222 | IMO22 = JMOHKK(2,IMMX) | |
8223 | IF (PHKK(3,IMO21).LT.0.0D0) THEN | |
8224 | IMO21 = JMOHKK(2,IMMX) | |
8225 | IMO22 = JMOHKK(1,IMMX) | |
8226 | ENDIF | |
8227 | AMCH1 = PHKK(5,I) | |
8228 | AMCH1N = AAM(IDXRES(I)) | |
8229 | ||
8230 | IFPR1 = IDHKK(IMO11) | |
8231 | IFPR2 = IDHKK(IMO21) | |
8232 | IFTA1 = IDHKK(IMO12) | |
8233 | IFTA2 = IDHKK(IMO22) | |
8234 | DO 4 J=1,4 | |
8235 | PP1(J) = PHKK(J,IMO11) | |
8236 | PP2(J) = PHKK(J,IMO21) | |
8237 | PT1(J) = PHKK(J,IMO12) | |
8238 | PT2(J) = PHKK(J,IMO22) | |
8239 | 4 CONTINUE | |
8240 | * store initial configuration for energy-momentum cons. check | |
8241 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) | |
8242 | * correct kinematics of second chain | |
8243 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
8244 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
8245 | IF (IREJ1.NE.0) GOTO 9999 | |
8246 | * check now this chain for resonance mass | |
8247 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) | |
8248 | IFP(2) = 0 | |
8249 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) | |
8250 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) | |
8251 | IFT(2) = 0 | |
8252 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) | |
8253 | IDCH2 = 2 | |
8254 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 | |
8255 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 | |
8256 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, | |
8257 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
8258 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN | |
8259 | IF (IOULEV(1).GT.0) | |
8260 | & WRITE(LOUT,*) ' correction for resonance not poss.' | |
8261 | **sr test | |
8262 | C GOTO 1 | |
8263 | C GOTO 9999 | |
8264 | ** | |
8265 | ENDIF | |
8266 | * store final configuration for energy-momentum cons. check | |
8267 | IF (LEMCCK) THEN | |
8268 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) | |
8269 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
8270 | IF (IREJ1.NE.0) GOTO 9999 | |
8271 | ENDIF | |
8272 | DO 5 J=1,4 | |
8273 | PHKK(J,IMO11) = PP1(J) | |
8274 | PHKK(J,IMO21) = PP2(J) | |
8275 | PHKK(J,IMO12) = PT1(J) | |
8276 | PHKK(J,IMO22) = PT2(J) | |
8277 | 5 CONTINUE | |
8278 | * correct entries of chains | |
8279 | DO 3 K=1,4 | |
8280 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) | |
8281 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) | |
8282 | 3 CONTINUE | |
8283 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 | |
8284 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- | |
8285 | & PHKK(3,IMMX)**2 | |
8286 | * ?? the following should now be obsolete | |
8287 | **sr test | |
8288 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN | |
8289 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8290 | ** | |
8291 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8292 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 | |
8293 | C GOTO 9999 | |
8294 | GOTO 1 | |
8295 | ENDIF | |
8296 | PHKK(5,I) = SQRT(AM1) | |
8297 | PHKK(5,IMMX) = SQRT(AM2) | |
8298 | IDRES(I) = IDRES(I)/100 | |
8299 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. | |
8300 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN | |
8301 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8302 | & 'EVTRES: inconsistent chain-masses', | |
8303 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 | |
8304 | GOTO 9999 | |
8305 | ENDIF | |
8306 | ENDIF | |
8307 | 1 CONTINUE | |
8308 | 6 CONTINUE | |
8309 | RETURN | |
8310 | ||
8311 | 9999 CONTINUE | |
8312 | IREJ = 1 | |
8313 | RETURN | |
8314 | END | |
8315 | ||
8316 | *$ CREATE DT_GETSPT.FOR | |
8317 | *COPY DT_GETSPT | |
8318 | * | |
8319 | *===getspt=============================================================* | |
8320 | * | |
8321 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, | |
8322 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, | |
8323 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) | |
8324 | ||
8325 | ************************************************************************ | |
8326 | * This version dated 12.12.94 is written by S. Roesler * | |
8327 | ************************************************************************ | |
8328 | ||
8329 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8330 | SAVE | |
8331 | PARAMETER ( LINP = 10 , | |
8332 | & LOUT = 6 , | |
8333 | & LDAT = 9 ) | |
8334 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) | |
8335 | ||
8336 | * various options for treatment of partons (DTUNUC 1.x) | |
8337 | * (chain recombination, Cronin,..) | |
8338 | LOGICAL LCO2CR,LINTPT | |
8339 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8340 | & LCO2CR,LINTPT | |
8341 | * flags for input different options | |
8342 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8343 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8344 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8345 | * flags for diffractive interactions (DTUNUC 1.x) | |
8346 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
8347 | ||
8348 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), | |
8349 | & PT2(4),PT2I(4),P1(4),P2(4), | |
8350 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), | |
8351 | & PTOTI(4),PTOTF(4),DIFF(4) | |
8352 | ||
8353 | IC = 0 | |
8354 | IREJ = 0 | |
8355 | C B33P = 4.0D0 | |
8356 | C B33T = 4.0D0 | |
8357 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 | |
8358 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 | |
8359 | REDU = 1.0D0 | |
8360 | C B33P = 3.5D0 | |
8361 | C B33T = 3.5D0 | |
8362 | B33P = 4.0D0 | |
8363 | B33T = 4.0D0 | |
8364 | IF (IDIFF.NE.0) THEN | |
8365 | B33P = 16.0D0 | |
8366 | B33T = 16.0D0 | |
8367 | ENDIF | |
8368 | ||
8369 | DO 1 I=1,4 | |
8370 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) | |
8371 | PP1(I) = PP1I(I) | |
8372 | PP2(I) = PP2I(I) | |
8373 | PT1(I) = PT1I(I) | |
8374 | PT2(I) = PT2I(I) | |
8375 | 1 CONTINUE | |
8376 | * get initial chain masses | |
8377 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8378 | & +(PP1(3)+PT1(3))**2) | |
8379 | ECH = PP1(4)+PT1(4) | |
8380 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
8381 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8382 | & +(PP2(3)+PT2(3))**2) | |
8383 | ECH = PP2(4)+PT2(4) | |
8384 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
8385 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8386 | IF (IOULEV(1).GT.0) | |
8387 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', | |
8388 | & AM1,AM2 | |
8389 | GOTO 9999 | |
8390 | ENDIF | |
8391 | AM1 = SQRT(AM1) | |
8392 | AM2 = SQRT(AM2) | |
8393 | AM1N = ZERO | |
8394 | AM2N = ZERO | |
8395 | ||
8396 | MODE = 0 | |
8397 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN | |
8398 | C MODE = 0 | |
8399 | C ELSE | |
8400 | C MODE = 1 | |
8401 | C IF (AM1.LT.0.6) THEN | |
8402 | C B33P = 10.0D0 | |
8403 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN | |
8404 | CC B33P = 4.0D0 | |
8405 | C ENDIF | |
8406 | C IF (AM2.LT.0.6) THEN | |
8407 | C B33T = 10.0D0 | |
8408 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN | |
8409 | CC B33T = 4.0D0 | |
8410 | C ENDIF | |
8411 | C ENDIF | |
8412 | ||
8413 | * check chain masses for very low mass chains | |
8414 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8415 | C & AM1,DUM,-IDCH1,IREJ1) | |
8416 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8417 | C & AM2,DUM,-IDCH2,IREJ2) | |
8418 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN | |
8419 | C B33P = 20.0D0 | |
8420 | C B33T = 20.0D0 | |
8421 | C ENDIF | |
8422 | ||
8423 | JMSHL = IMSHL | |
8424 | ||
8425 | 2 CONTINUE | |
8426 | IC = IC+1 | |
8427 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P | |
8428 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T | |
8429 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 | |
8430 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 | |
8431 | IF (MOD(IC,20).EQ.0) GOTO 7 | |
8432 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' | |
8433 | C RETURN | |
8434 | C GOTO 9999 | |
8435 | C ENDIF | |
8436 | ||
8437 | * get transverse momentum | |
8438 | IF (LINTPT) THEN | |
8439 | ES = -2.0D0/(B33P**2) | |
8440 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8441 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8442 | HPSP = HPSP*REDU | |
8443 | ES = -2.0D0/(B33T**2) | |
8444 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8445 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8446 | HPST = HPST*REDU | |
8447 | ELSE | |
8448 | HPSP = ZERO | |
8449 | HPST = ZERO | |
8450 | ENDIF | |
8451 | CALL DT_DSFECF(SFE1,CFE1) | |
8452 | CALL DT_DSFECF(SFE2,CFE2) | |
8453 | IF (MODE.EQ.0) THEN | |
8454 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8455 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8456 | PP2(1) = PP2I(1)-HPSP*CFE1 | |
8457 | PP2(2) = PP2I(2)-HPSP*SFE1 | |
8458 | PT1(1) = PT1I(1)+HPST*CFE2 | |
8459 | PT1(2) = PT1I(2)+HPST*SFE2 | |
8460 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8461 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8462 | ELSE | |
8463 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8464 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8465 | PT1(1) = PT1I(1)-HPSP*CFE1 | |
8466 | PT1(2) = PT1I(2)-HPSP*SFE1 | |
8467 | PP2(1) = PP2I(1)+HPST*CFE2 | |
8468 | PP2(2) = PP2I(2)+HPST*SFE2 | |
8469 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8470 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8471 | ENDIF | |
8472 | ||
8473 | * put partons on mass shell | |
8474 | XMP1 = 0.0D0 | |
8475 | XMT1 = 0.0D0 | |
8476 | IF (JMSHL.EQ.1) THEN | |
8477 | XMP1 = PYMASS(IFPR1) | |
8478 | XMT1 = PYMASS(IFTA1) | |
8479 | ENDIF | |
8480 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) | |
8481 | IF (IREJ1.NE.0) GOTO 2 | |
8482 | DO 3 I=1,4 | |
8483 | PTOTF(I) = P1(I)+P2(I) | |
8484 | PP1(I) = P1(I) | |
8485 | PT1(I) = P2(I) | |
8486 | 3 CONTINUE | |
8487 | XMP2 = 0.0D0 | |
8488 | XMT2 = 0.0D0 | |
8489 | IF (JMSHL.EQ.1) THEN | |
8490 | XMP2 = PYMASS(IFPR2) | |
8491 | XMT2 = PYMASS(IFTA2) | |
8492 | ENDIF | |
8493 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) | |
8494 | IF (IREJ1.NE.0) GOTO 2 | |
8495 | DO 4 I=1,4 | |
8496 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) | |
8497 | PP2(I) = P1(I) | |
8498 | PT2(I) = P2(I) | |
8499 | 4 CONTINUE | |
8500 | ||
8501 | * check consistency | |
8502 | DO 5 I=1,4 | |
8503 | DIFF(I) = PTOTI(I)-PTOTF(I) | |
8504 | 5 CONTINUE | |
8505 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. | |
8506 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN | |
8507 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF | |
8508 | GOTO 9999 | |
8509 | ENDIF | |
8510 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) | |
8511 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) | |
8512 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) | |
8513 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) | |
8514 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) | |
8515 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) | |
8516 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) | |
8517 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) | |
8518 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. | |
8519 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) | |
8520 | & THEN | |
8521 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') | |
8522 | & 'GETSPT: inconsistent masses', | |
8523 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 | |
8524 | * sr 22.11.00: commented. It should only have inconsistent masses for | |
8525 | * ultrahigh energies due to rounding problems | |
8526 | C GOTO 9999 | |
8527 | ENDIF | |
8528 | ||
8529 | * get chain masses | |
8530 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8531 | & +(PP1(3)+PT1(3))**2) | |
8532 | ECH = PP1(4)+PT1(4) | |
8533 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) | |
8534 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8535 | & +(PP2(3)+PT2(3))**2) | |
8536 | ECH = PP2(4)+PT2(4) | |
8537 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) | |
8538 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN | |
8539 | IF (IOULEV(1).GT.0) | |
8540 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', | |
8541 | & AM1N,AM2N | |
8542 | GOTO 2 | |
8543 | ENDIF | |
8544 | AM1N = SQRT(AM1N) | |
8545 | AM2N = SQRT(AM2N) | |
8546 | ||
8547 | * check chain masses for very low mass chains | |
8548 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8549 | & AM1N,DUM,-IDCH1,IREJ1) | |
8550 | IF (IREJ1.NE.0) GOTO 2 | |
8551 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8552 | & AM2N,DUM,-IDCH2,IREJ2) | |
8553 | IF (IREJ2.NE.0) GOTO 2 | |
8554 | ||
8555 | 7 CONTINUE | |
8556 | IF (AM1N.GT.ZERO) THEN | |
8557 | AM1 = AM1N | |
8558 | AM2 = AM2N | |
8559 | ENDIF | |
8560 | DO 6 I=1,4 | |
8561 | PP1I(I) = PP1(I) | |
8562 | PP2I(I) = PP2(I) | |
8563 | PT1I(I) = PT1(I) | |
8564 | PT2I(I) = PT2(I) | |
8565 | 6 CONTINUE | |
8566 | ||
8567 | RETURN | |
8568 | ||
8569 | 9999 CONTINUE | |
8570 | IREJ = 1 | |
8571 | RETURN | |
8572 | END | |
8573 | ||
8574 | *$ CREATE DT_SAPTRE.FOR | |
8575 | *COPY DT_SAPTRE | |
8576 | * | |
8577 | *===saptre=============================================================* | |
8578 | * | |
8579 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) | |
8580 | ||
8581 | ************************************************************************ | |
8582 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * | |
8583 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * | |
8584 | * Adopted from the original SAPTRE written by J. Ranft. * | |
8585 | * This version dated 18.01.95 is written by S. Roesler * | |
8586 | ************************************************************************ | |
8587 | ||
8588 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8589 | SAVE | |
8590 | PARAMETER ( LINP = 10 , | |
8591 | & LOUT = 6 , | |
8592 | & LDAT = 9 ) | |
8593 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8594 | ||
8595 | * event history | |
8596 | PARAMETER (NMXHKK=200000) | |
8597 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8598 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8599 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8600 | * extended event history | |
8601 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8602 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8603 | & IHIST(2,NMXHKK) | |
8604 | * flags for input different options | |
8605 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8606 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8607 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8608 | ||
8609 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
8610 | ||
8611 | DATA B3 /4.0D0/ | |
8612 | ||
8613 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) | |
8614 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) | |
8615 | ESMAX = MIN(ESMAX1,ESMAX2) | |
8616 | IF (ESMAX.LE.0.05D0) RETURN | |
8617 | ||
8618 | HMA = PHKK(5,IDX1) | |
8619 | DO 1 K=1,4 | |
8620 | PA1(K) = PHKK(K,IDX1) | |
8621 | PA2(K) = PHKK(K,IDX2) | |
8622 | 1 CONTINUE | |
8623 | ||
8624 | IF (LEMCCK) THEN | |
8625 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) | |
8626 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) | |
8627 | ENDIF | |
8628 | ||
8629 | EXEB = 0.0D0 | |
8630 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) | |
8631 | BEXP = HMA*(1.0D0-EXEB)/B3 | |
8632 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 | |
8633 | WA = AXEXP/(BEXP+AXEXP) | |
8634 | XAB = DT_RNDM(WA) | |
8635 | 10 CONTINUE | |
8636 | * ES is the transverse kinetic energy | |
8637 | IF (XAB.LT.WA)THEN | |
8638 | X = DT_RNDM(WA) | |
8639 | Y = DT_RNDM(WA) | |
8640 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) | |
8641 | ELSE | |
8642 | X = DT_RNDM(Y) | |
8643 | ES = ABS(-LOG(X+TINY7)/B3) | |
8644 | ENDIF | |
8645 | IF (ES.GT.ESMAX) GOTO 10 | |
8646 | ES = ES+HMA | |
8647 | * transverse momentum | |
8648 | HPS = SQRT((ES-HMA)*(ES+HMA)) | |
8649 | ||
8650 | CALL DT_DSFECF(SFE,CFE) | |
8651 | HPX = HPS*CFE | |
8652 | HPY = HPS*SFE | |
8653 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY | |
8654 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY | |
8655 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN | |
8656 | ||
8657 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) | |
8658 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) | |
8659 | PA1(1) = PA1(1)+HPX | |
8660 | PA1(2) = PA1(2)+HPY | |
8661 | PA2(1) = PA2(1)-HPX | |
8662 | PA2(2) = PA2(2)-HPY | |
8663 | ||
8664 | * put resonances on mass-shell again | |
8665 | XM1 = PHKK(5,IDX1) | |
8666 | XM2 = PHKK(5,IDX2) | |
8667 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) | |
8668 | IF (IREJ1.NE.0) RETURN | |
8669 | ||
8670 | IF (LEMCCK) THEN | |
8671 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) | |
8672 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) | |
8673 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) | |
8674 | IF (IREJ1.NE.0) RETURN | |
8675 | ENDIF | |
8676 | ||
8677 | DO 2 K=1,4 | |
8678 | PHKK(K,IDX1) = P1(K) | |
8679 | PHKK(K,IDX2) = P2(K) | |
8680 | 2 CONTINUE | |
8681 | ||
8682 | RETURN | |
8683 | END | |
8684 | ||
8685 | *$ CREATE DT_CRONIN.FOR | |
8686 | *COPY DT_CRONIN | |
8687 | * | |
8688 | *===cronin=============================================================* | |
8689 | * | |
8690 | SUBROUTINE DT_CRONIN(INCL) | |
8691 | ||
8692 | ************************************************************************ | |
8693 | * Cronin-Effect. Multiple scattering of partons at chain ends. * | |
8694 | * INCL = 1 multiple sc. in projectile * | |
8695 | * = 2 multiple sc. in target * | |
8696 | * This version dated 05.01.96 is written by S. Roesler. * | |
8697 | ************************************************************************ | |
8698 | ||
8699 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8700 | SAVE | |
8701 | PARAMETER ( LINP = 10 , | |
8702 | & LOUT = 6 , | |
8703 | & LDAT = 9 ) | |
8704 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8705 | ||
8706 | * event history | |
8707 | PARAMETER (NMXHKK=200000) | |
8708 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8709 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8710 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8711 | * extended event history | |
8712 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8713 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8714 | & IHIST(2,NMXHKK) | |
8715 | * rejection counter | |
8716 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8717 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8718 | & IREXCI(3),IRDIFF(2),IRINC | |
8719 | * Glauber formalism: collision properties | |
8720 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
8721 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
8722 | ||
8723 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) | |
8724 | ||
8725 | DO 1 K=1,4 | |
8726 | DEV(K) = ZERO | |
8727 | 1 CONTINUE | |
8728 | ||
8729 | DO 2 I=NPOINT(2),NHKK | |
8730 | IF (ISTHKK(I).LT.0) THEN | |
8731 | * get z-position of the chain | |
8732 | R(1) = VHKK(1,I)*1.0D12 | |
8733 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC | |
8734 | R(2) = VHKK(2,I)*1.0D12 | |
8735 | IDXNU = JMOHKK(1,I) | |
8736 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) | |
8737 | & IDXNU = JMOHKK(1,I-1) | |
8738 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) | |
8739 | & IDXNU = JMOHKK(1,I+1) | |
8740 | R(3) = VHKK(3,IDXNU)*1.0D12 | |
8741 | * position of target parton the chain is connected to | |
8742 | DO 3 K=1,4 | |
8743 | PIN(K) = PHKK(K,I) | |
8744 | 3 CONTINUE | |
8745 | * multiple scattering of parton with DTEVT1-index I | |
8746 | CALL DT_CROMSC(PIN,R,POUT,INCL) | |
8747 | **testprint | |
8748 | C IF (NEVHKK.EQ.5) THEN | |
8749 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 | |
8750 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 | |
8751 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) | |
8752 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) | |
8753 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU | |
8754 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN | |
8755 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT | |
8756 | C ENDIF | |
8757 | ** | |
8758 | * increase accumulator by energy-momentum difference | |
8759 | DO 4 K=1,4 | |
8760 | DEV(K) = DEV(K)+POUT(K)-PIN(K) | |
8761 | PHKK(K,I) = POUT(K) | |
8762 | 4 CONTINUE | |
8763 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8764 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8765 | ENDIF | |
8766 | 2 CONTINUE | |
8767 | ||
8768 | * dump accumulator to momenta of valence partons | |
8769 | NVAL = 0 | |
8770 | ETOT = 0.0D0 | |
8771 | DO 5 I=NPOINT(2),NHKK | |
8772 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8773 | NVAL = NVAL+1 | |
8774 | ETOT = ETOT+PHKK(4,I) | |
8775 | ENDIF | |
8776 | 5 CONTINUE | |
8777 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) | |
8778 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, | |
8779 | & 9X,4E12.4) | |
8780 | DO 6 I=NPOINT(2),NHKK | |
8781 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8782 | E = PHKK(4,I) | |
8783 | DO 7 K=1,4 | |
8784 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) | |
8785 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT | |
8786 | 7 CONTINUE | |
8787 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8788 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8789 | ENDIF | |
8790 | 6 CONTINUE | |
8791 | ||
8792 | RETURN | |
8793 | END | |
8794 | ||
8795 | *$ CREATE DT_CROMSC.FOR | |
8796 | *COPY DT_CROMSC | |
8797 | * | |
8798 | *===cromsc=============================================================* | |
8799 | * | |
8800 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) | |
8801 | ||
8802 | ************************************************************************ | |
8803 | * Cronin-Effect. Multiple scattering of one parton passing through * | |
8804 | * nuclear matter. * | |
8805 | * PIN(4) input 4-momentum of parton * | |
8806 | * POUT(4) 4-momentum of parton after mult. scatt. * | |
8807 | * R(3) spatial position of parton in target nucleus * | |
8808 | * INCL = 1 multiple sc. in projectile * | |
8809 | * = 2 multiple sc. in target * | |
8810 | * This is a revised version of the original version written by J. Ranft* | |
8811 | * This version dated 17.01.95 is written by S. Roesler. * | |
8812 | ************************************************************************ | |
8813 | ||
8814 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8815 | SAVE | |
8816 | PARAMETER ( LINP = 10 , | |
8817 | & LOUT = 6 , | |
8818 | & LDAT = 9 ) | |
8819 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8820 | ||
8821 | LOGICAL LSTART | |
8822 | ||
8823 | * rejection counter | |
8824 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8825 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8826 | & IREXCI(3),IRDIFF(2),IRINC | |
8827 | * Glauber formalism: collision properties | |
8828 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
8829 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
8830 | * various options for treatment of partons (DTUNUC 1.x) | |
8831 | * (chain recombination, Cronin,..) | |
8832 | LOGICAL LCO2CR,LINTPT | |
8833 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8834 | & LCO2CR,LINTPT | |
8835 | ||
8836 | DIMENSION PIN(4),POUT(4),R(3) | |
8837 | ||
8838 | DATA LSTART /.TRUE./ | |
8839 | ||
8840 | IRCRON(1) = IRCRON(1)+1 | |
8841 | ||
8842 | IF (LSTART) THEN | |
8843 | WRITE(LOUT,1000) CRONCO | |
8844 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', | |
8845 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) | |
8846 | LSTART = .FALSE. | |
8847 | ENDIF | |
8848 | ||
8849 | NCBACK = 0 | |
8850 | RNCL = RPROJ | |
8851 | IF (INCL.EQ.2) RNCL = RTARG | |
8852 | ||
8853 | * Lorentz-transformation into Lab. | |
8854 | MODE = -(INCL+1) | |
8855 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) | |
8856 | ||
8857 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) | |
8858 | IF (PTOT.LE.8.0D0) GOTO 9997 | |
8859 | ||
8860 | * direction cosines of parton before mult. scattering | |
8861 | COSX = PIN(1)/PTOT | |
8862 | COSY = PIN(2)/PTOT | |
8863 | COSZ = PZ/PTOT | |
8864 | ||
8865 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 | |
8866 | IF (RTESQ.GE.-TINY3) GOTO 9999 | |
8867 | ||
8868 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) | |
8869 | * in the direction of particle motion | |
8870 | ||
8871 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) | |
8872 | TMP = A**2-RTESQ | |
8873 | IF (TMP.LT.ZERO) GOTO 9998 | |
8874 | DIST = -A+SQRT(TMP) | |
8875 | ||
8876 | * multiple scattering angle | |
8877 | THETO = CRONCO*SQRT(DIST)/PTOT | |
8878 | IF (THETO.GT.0.1D0) THETO=0.1D0 | |
8879 | ||
8880 | 1 CONTINUE | |
8881 | * Gaussian sampling of spatial angle | |
8882 | CALL DT_RANNOR(R1,R2) | |
8883 | THETA = ABS(R1*THETO) | |
8884 | IF (THETA.GT.0.3D0) GOTO 9997 | |
8885 | CALL DT_DSFECF(SFE,CFE) | |
8886 | COSTH = COS(THETA) | |
8887 | SINTH = SIN(THETA) | |
8888 | ||
8889 | * new direction cosines | |
8890 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, | |
8891 | & COSXN,COSYN,COSZN) | |
8892 | ||
8893 | POUT(1) = COSXN*PTOT | |
8894 | POUT(2) = COSYN*PTOT | |
8895 | PZ = COSZN*PTOT | |
8896 | * Lorentz-transformation into nucl.-nucl. cms | |
8897 | MODE = INCL+1 | |
8898 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) | |
8899 | ||
8900 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN | |
8901 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN | |
8902 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN | |
8903 | THETO = THETO/2.0D0 | |
8904 | NCBACK = NCBACK+1 | |
8905 | IF (MOD(NCBACK,200).EQ.0) THEN | |
8906 | WRITE(LOUT,1001) THETO,PIN,POUT | |
8907 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', | |
8908 | & E12.4,/,1X,' PIN :',4E12.4,/, | |
8909 | & 1X,' POUT:',4E12.4) | |
8910 | GOTO 9997 | |
8911 | ENDIF | |
8912 | GOTO 1 | |
8913 | ENDIF | |
8914 | ||
8915 | RETURN | |
8916 | ||
8917 | 9997 IRCRON(2) = IRCRON(2)+1 | |
8918 | GOTO 9999 | |
8919 | 9998 IRCRON(3) = IRCRON(3)+1 | |
8920 | ||
8921 | 9999 CONTINUE | |
8922 | DO 100 K=1,4 | |
8923 | POUT(K) = PIN(K) | |
8924 | 100 CONTINUE | |
8925 | RETURN | |
8926 | END | |
8927 | ||
8928 | *$ CREATE DT_COM2CR.FOR | |
8929 | *COPY DT_COM2CR | |
8930 | * | |
8931 | *===com2sr=============================================================* | |
8932 | * | |
8933 | SUBROUTINE DT_COM2CR | |
8934 | ||
8935 | ************************************************************************ | |
8936 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * | |
8937 | * CUTOF parameter determining minimum number of not * | |
8938 | * combined q-aq chains * | |
8939 | * This subroutine replaces KKEVCC etc. * | |
8940 | * This version dated 11.01.95 is written by S. Roesler. * | |
8941 | ************************************************************************ | |
8942 | ||
8943 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8944 | SAVE | |
8945 | PARAMETER ( LINP = 10 , | |
8946 | & LOUT = 6 , | |
8947 | & LDAT = 9 ) | |
8948 | ||
8949 | * event history | |
8950 | PARAMETER (NMXHKK=200000) | |
8951 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8952 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8953 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8954 | * extended event history | |
8955 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8956 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8957 | & IHIST(2,NMXHKK) | |
8958 | * statistics | |
8959 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
8960 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
8961 | & ICEVTG(8,0:30) | |
8962 | * various options for treatment of partons (DTUNUC 1.x) | |
8963 | * (chain recombination, Cronin,..) | |
8964 | LOGICAL LCO2CR,LINTPT | |
8965 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8966 | & LCO2CR,LINTPT | |
8967 | ||
8968 | DIMENSION IDXQA(248),IDXAQ(248) | |
8969 | ||
8970 | ICCHAI(1,9) = ICCHAI(1,9)+1 | |
8971 | NQA = 0 | |
8972 | NAQ = 0 | |
8973 | * scan DTEVT1 for q-aq, aq-q chains | |
8974 | DO 10 I=NPOINT(3),NHKK | |
8975 | * skip "chains" which are resonances | |
8976 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN | |
8977 | MO1 = JMOHKK(1,I) | |
8978 | MO2 = JMOHKK(2,I) | |
8979 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN | |
8980 | * q-aq, aq-q chain found, keep index | |
8981 | IF (IDHKK(MO1).GT.0) THEN | |
8982 | NQA = NQA+1 | |
8983 | IDXQA(NQA) = I | |
8984 | ELSE | |
8985 | NAQ = NAQ+1 | |
8986 | IDXAQ(NAQ) = I | |
8987 | ENDIF | |
8988 | ENDIF | |
8989 | ENDIF | |
8990 | 10 CONTINUE | |
8991 | ||
8992 | * minimum number of q-aq chains requested for the same projectile/ | |
8993 | * target | |
8994 | NCHMIN = IDT_NPOISS(CUTOF) | |
8995 | ||
8996 | * combine q-aq chains of the same projectile | |
8997 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) | |
8998 | * combine q-aq chains of the same target | |
8999 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) | |
9000 | * combine aq-q chains of the same projectile | |
9001 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) | |
9002 | * combine aq-q chains of the same target | |
9003 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) | |
9004 | ||
9005 | RETURN | |
9006 | END | |
9007 | ||
9008 | *$ CREATE DT_SCN4CR.FOR | |
9009 | *COPY DT_SCN4CR | |
9010 | * | |
9011 | *===scn4cr=============================================================* | |
9012 | * | |
9013 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) | |
9014 | ||
9015 | ************************************************************************ | |
9016 | * SCan q-aq chains for Color Ropes. * | |
9017 | * This version dated 11.01.95 is written by S. Roesler. * | |
9018 | ************************************************************************ | |
9019 | ||
9020 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9021 | SAVE | |
9022 | PARAMETER ( LINP = 10 , | |
9023 | & LOUT = 6 , | |
9024 | & LDAT = 9 ) | |
9025 | ||
9026 | * event history | |
9027 | PARAMETER (NMXHKK=200000) | |
9028 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9029 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9030 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9031 | * extended event history | |
9032 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9033 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9034 | & IHIST(2,NMXHKK) | |
9035 | ||
9036 | DIMENSION IDXCH(248),IDXJN(248) | |
9037 | ||
9038 | DO 1 I=1,NCH | |
9039 | IF (IDXCH(I).GT.0) THEN | |
9040 | NJOIN = 1 | |
9041 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) | |
9042 | IDXJN(NJOIN) = I | |
9043 | IF (I.LT.NCH) THEN | |
9044 | DO 2 J=I+1,NCH | |
9045 | IF (IDXCH(J).GT.0) THEN | |
9046 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) | |
9047 | IF (IDXMO.EQ.IDXMO1) THEN | |
9048 | NJOIN = NJOIN+1 | |
9049 | IDXJN(NJOIN) = J | |
9050 | ENDIF | |
9051 | ENDIF | |
9052 | 2 CONTINUE | |
9053 | ENDIF | |
9054 | IF (NJOIN.GE.NCHMIN+2) THEN | |
9055 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) | |
9056 | DO 3 J=1,2*NJ,2 | |
9057 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) | |
9058 | IF (IREJ1.NE.0) GOTO 3 | |
9059 | IDXCH(IDXJN(J)) = 0 | |
9060 | IDXCH(IDXJN(J+1)) = 0 | |
9061 | 3 CONTINUE | |
9062 | ENDIF | |
9063 | ENDIF | |
9064 | 1 CONTINUE | |
9065 | ||
9066 | RETURN | |
9067 | END | |
9068 | ||
9069 | *$ CREATE DT_JOIN.FOR | |
9070 | *COPY DT_JOIN | |
9071 | * | |
9072 | *===join===============================================================* | |
9073 | * | |
9074 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) | |
9075 | ||
9076 | ************************************************************************ | |
9077 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * | |
9078 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * | |
9079 | * This version dated 11.01.95 is written by S. Roesler. * | |
9080 | ************************************************************************ | |
9081 | ||
9082 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9083 | SAVE | |
9084 | PARAMETER ( LINP = 10 , | |
9085 | & LOUT = 6 , | |
9086 | & LDAT = 9 ) | |
9087 | ||
9088 | * event history | |
9089 | PARAMETER (NMXHKK=200000) | |
9090 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9091 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9092 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9093 | * extended event history | |
9094 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9095 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9096 | & IHIST(2,NMXHKK) | |
9097 | * flags for input different options | |
9098 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
9099 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
9100 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
9101 | * statistics | |
9102 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
9103 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
9104 | & ICEVTG(8,0:30) | |
9105 | ||
9106 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) | |
9107 | ||
9108 | IREJ = 0 | |
9109 | ||
9110 | IDX(1) = IDX1 | |
9111 | IDX(2) = IDX2 | |
9112 | DO 1 I=1,2 | |
9113 | DO 2 J=1,2 | |
9114 | MO(I,J) = JMOHKK(J,IDX(I)) | |
9115 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) | |
9116 | 2 CONTINUE | |
9117 | 1 CONTINUE | |
9118 | ||
9119 | * check consistency | |
9120 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. | |
9121 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. | |
9122 | & ((ID(1,1)*ID(2,1)).LT.0).OR. | |
9123 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN | |
9124 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), | |
9125 | & MO(2,2) | |
9126 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', | |
9127 | & 2I5,' chain ',I4,':',2I5) | |
9128 | ENDIF | |
9129 | ||
9130 | * join chains | |
9131 | DO 3 K=1,4 | |
9132 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) | |
9133 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) | |
9134 | 3 CONTINUE | |
9135 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) | |
9136 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) | |
9137 | IST1 = ISTHKK(MO(1,1)) | |
9138 | IST2 = ISTHKK(MO(1,2)) | |
9139 | ||
9140 | * put partons again on mass shell | |
9141 | XM1 = 0.0D0 | |
9142 | XM2 = 0.0D0 | |
9143 | IF (IMSHL.EQ.1) THEN | |
9144 | XM1 = PYMASS(IF1) | |
9145 | XM2 = PYMASS(IF2) | |
9146 | ENDIF | |
9147 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) | |
9148 | IF (IREJ1.NE.0) GOTO 9999 | |
9149 | DO 4 I=1,4 | |
9150 | PP(I) = P1(I) | |
9151 | PT(I) = P2(I) | |
9152 | 4 CONTINUE | |
9153 | ||
9154 | * store new partons in DTEVT1 | |
9155 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), | |
9156 | & 0,0,0) | |
9157 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), | |
9158 | & 0,0,0) | |
9159 | DO 5 K=1,4 | |
9160 | PCH(K) = PP(K)+PT(K) | |
9161 | 5 CONTINUE | |
9162 | ||
9163 | * check new chain for lower mass limit | |
9164 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
9165 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) | |
9166 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, | |
9167 | & AMCH,AMCHN,3,IREJ1) | |
9168 | IF (IREJ1.NE.0) THEN | |
9169 | NHKK = NHKK-2 | |
9170 | GOTO 9999 | |
9171 | ENDIF | |
9172 | ENDIF | |
9173 | ||
9174 | ICCHAI(2,9) = ICCHAI(2,9)+1 | |
9175 | * store new chain in DTEVT1 | |
9176 | KCH = 191 | |
9177 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) | |
9178 | IDHKK(IDX(1)) = 22222 | |
9179 | IDHKK(IDX(2)) = 22222 | |
9180 | * special treatment for space-time coordinates | |
9181 | DO 6 K=1,4 | |
9182 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 | |
9183 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 | |
9184 | 6 CONTINUE | |
9185 | RETURN | |
9186 | ||
9187 | 9999 CONTINUE | |
9188 | IREJ = 1 | |
9189 | RETURN | |
9190 | END | |
9191 | ||
9192 | *$ CREATE DT_XSGLAU.FOR | |
9193 | *COPY DT_XSGLAU | |
9194 | * | |
9195 | *===xsglau=============================================================* | |
9196 | * | |
9197 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) | |
9198 | ||
9199 | ************************************************************************ | |
9200 | * Total, elastic, quasi-elastic, inelastic cross sections according to * | |
9201 | * Glauber's approach. * | |
9202 | * NA / NB mass numbers of proj./target nuclei * | |
9203 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * | |
9204 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * | |
9205 | * IE,IQ indices of energy and virtuality (the latter for gamma * | |
9206 | * projectiles only) * | |
9207 | * NIDX index of projectile/target nucleus * | |
9208 | * This version dated 17.3.98 is written by S. Roesler * | |
9209 | ************************************************************************ | |
9210 | ||
9211 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9212 | SAVE | |
9213 | PARAMETER ( LINP = 10 , | |
9214 | & LOUT = 6 , | |
9215 | & LDAT = 9 ) | |
9216 | ||
9217 | COMPLEX*16 CZERO,CONE,CTWO | |
9218 | CHARACTER*12 CFILE | |
9219 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9220 | & ONETHI=ONE/THREE,TINY25=1.0D-25) | |
9221 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
9222 | & PI = TWOPI/TWO, | |
9223 | & GEV2MB = 0.38938D0, | |
9224 | & GEV2FM = 0.1972D0, | |
9225 | & ALPHEM = ONE/137.0D0, | |
9226 | * proton mass | |
9227 | & AMP = 0.938D0, | |
9228 | & AMP2 = AMP**2, | |
9229 | * approx. nucleon radius | |
9230 | & RNUCLE = 1.12D0) | |
9231 | ||
9232 | * particle properties (BAMJET index convention) | |
9233 | CHARACTER*8 ANAME | |
9234 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
9235 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
9236 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9237 | PARAMETER ( MAXNCL = 260, | |
9238 | & MAXVQU = MAXNCL, | |
9239 | & MAXSQU = 20*MAXVQU, | |
9240 | & MAXINT = MAXVQU+MAXSQU) | |
9241 | * Glauber formalism: parameters | |
9242 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9243 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9244 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9245 | & NSITEB,NSTATB | |
9246 | * Glauber formalism: cross sections | |
9247 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
9248 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
9249 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
9250 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
9251 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
9252 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
9253 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
9254 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
9255 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
9256 | & BSLOPE,NEBINI,NQBINI | |
9257 | * Glauber formalism: flags and parameters for statistics | |
9258 | LOGICAL LPROD | |
9259 | CHARACTER*8 CGLB | |
9260 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
9261 | * nucleon-nucleon event-generator | |
9262 | CHARACTER*8 CMODEL | |
9263 | LOGICAL LPHOIN | |
9264 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
9265 | * VDM parameter for photon-nucleus interactions | |
9266 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
9267 | * parameters for hA-diffraction | |
9268 | COMMON /DTDIHA/ DIBETA,DIALPH | |
9269 | ||
9270 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), | |
9271 | & OMPP11,OMPP12,OMPP21,OMPP22, | |
9272 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, | |
9273 | & PPTMP1,PPTMP2 | |
9274 | COMPLEX*16 C,CA,CI | |
9275 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), | |
9276 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), | |
9277 | & BPROD(KSITEB) | |
9278 | ||
9279 | PARAMETER (NPOINT=16) | |
9280 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
9281 | ||
9282 | LOGICAL LFIRST,LOPEN | |
9283 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ | |
9284 | ||
9285 | NTARG = ABS(NIDX) | |
9286 | * for quasi-elastic neutrino scattering set projectile to proton | |
9287 | * it should not have an effect since the whole Glauber-formalism is | |
9288 | * not needed for these interactions.. | |
9289 | IF (MCGENE.EQ.4) THEN | |
9290 | IJPROJ = 1 | |
9291 | ELSE | |
9292 | IJPROJ = JJPROJ | |
9293 | ENDIF | |
9294 | ||
9295 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN | |
9296 | I = INDEX(CGLB,' ') | |
9297 | IF (I.EQ.0) THEN | |
9298 | CFILE = CGLB//'.glb' | |
9299 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') | |
9300 | ELSEIF (I.GT.1) THEN | |
9301 | CFILE = CGLB(1:I-1)//'.glb' | |
9302 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') | |
9303 | ELSE | |
9304 | STOP 'XSGLAU 1' | |
9305 | ENDIF | |
9306 | LOPEN = .TRUE. | |
9307 | ENDIF | |
9308 | ||
9309 | CZERO = DCMPLX(ZERO,ZERO) | |
9310 | CONE = DCMPLX(ONE,ZERO) | |
9311 | CTWO = DCMPLX(TWO,ZERO) | |
9312 | NEBINI = IE | |
9313 | NQBINI = IQ | |
9314 | ||
9315 | * re-define kinematics | |
9316 | S = ECMI**2 | |
9317 | Q2 = Q2I | |
9318 | X = XI | |
9319 | * g(Q2=0)-A, h-A, A-A scattering | |
9320 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9321 | Q2 = 0.0001D0 | |
9322 | X = Q2/(S+Q2-AMP2) | |
9323 | * g(Q2>0)-A scattering | |
9324 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN | |
9325 | X = Q2/(S+Q2-AMP2) | |
9326 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9327 | Q2 = (S-AMP2)*X/(ONE-X) | |
9328 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
9329 | S = Q2*(ONE-X)/X+AMP2 | |
9330 | ELSE | |
9331 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X | |
9332 | STOP | |
9333 | ENDIF | |
9334 | ECMNN(IE) = SQRT(S) | |
9335 | Q2G(IQ) = Q2 | |
9336 | XNU = (S+Q2-AMP2)/(TWO*AMP) | |
9337 | ||
9338 | * parameters determining statistics in evaluating Glauber-xsection | |
9339 | NSTATB = JSTATB | |
9340 | NSITEB = JBINSB | |
9341 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB | |
9342 | ||
9343 | * set up interaction geometry (common /DTGLAM/) | |
9344 | * projectile/target radii | |
9345 | RPRNCL = DT_RNCLUS(NA) | |
9346 | RTANCL = DT_RNCLUS(NB) | |
9347 | IF (IJPROJ.EQ.7) THEN | |
9348 | RASH(1) = ZERO | |
9349 | RBSH(NTARG) = RTANCL | |
9350 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9351 | ELSE | |
9352 | IF (NIDX.LE.-1) THEN | |
9353 | RASH(1) = RPRNCL | |
9354 | RBSH(NTARG) = RTANCL | |
9355 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9356 | ELSE | |
9357 | RASH(NTARG) = RPRNCL | |
9358 | RBSH(1) = RTANCL | |
9359 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) | |
9360 | ENDIF | |
9361 | ENDIF | |
9362 | * maximum impact-parameter | |
9363 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) | |
9364 | ||
9365 | * slope, rho ( Re(f(0))/Im(f(0)) ) | |
9366 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
9367 | IF (MCGENE.EQ.2) THEN | |
9368 | ZERO1 = ZERO | |
9369 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, | |
9370 | & BSLOPE,0) | |
9371 | ELSE | |
9372 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
9373 | ENDIF | |
9374 | IF (ECMNN(IE).LE.3.0D0) THEN | |
9375 | ROSH = -0.43D0 | |
9376 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN | |
9377 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) | |
9378 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN | |
9379 | ROSH = 0.1D0 | |
9380 | ENDIF | |
9381 | ELSEIF (IJPROJ.EQ.7) THEN | |
9382 | ROSH = 0.1D0 | |
9383 | ELSE | |
9384 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
9385 | ROSH = 0.01D0 | |
9386 | ENDIF | |
9387 | ||
9388 | * projectile-nucleon xsection (in fm) | |
9389 | IF (IJPROJ.EQ.7) THEN | |
9390 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 | |
9391 | ELSE | |
9392 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
9393 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
9394 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
9395 | DUMZER = ZERO | |
9396 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
9397 | SIGSH = SIGSH/10.0D0 | |
9398 | ENDIF | |
9399 | ||
9400 | * parameters for projectile diffraction (hA scattering only) | |
9401 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) | |
9402 | & .AND.(DIBETA.GE.ZERO)) THEN | |
9403 | ZERO1 = ZERO | |
9404 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) | |
9405 | C DIBETA = SDIF1/STOT | |
9406 | DIBETA = 0.2D0 | |
9407 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) | |
9408 | IF (DIBETA.LE.ZERO) THEN | |
9409 | ALPGAM = ONE | |
9410 | ELSE | |
9411 | ALPGAM = DIALPH/DIGAMM | |
9412 | ENDIF | |
9413 | FACDI1 = ONE-ALPGAM | |
9414 | FACDI2 = ONE+ALPGAM | |
9415 | FACDI = SQRT(FACDI1*FACDI2) | |
9416 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM | |
9417 | ELSE | |
9418 | DIBETA = -1.0D0 | |
9419 | DIALPH = ZERO | |
9420 | DIGAMM = ZERO | |
9421 | FACDI1 = ZERO | |
9422 | FACDI2 = 2.0D0 | |
9423 | FACDI = ZERO | |
9424 | ENDIF | |
9425 | ||
9426 | * initializations | |
9427 | DO 10 I=1,NSITEB | |
9428 | BSITE( 0,IQ,NTARG,I) = ZERO | |
9429 | BSITE(IE,IQ,NTARG,I) = ZERO | |
9430 | BPROD(I) = ZERO | |
9431 | 10 CONTINUE | |
9432 | STOT = ZERO | |
9433 | STOT2 = ZERO | |
9434 | SELA = ZERO | |
9435 | SELA2 = ZERO | |
9436 | SQEP = ZERO | |
9437 | SQEP2 = ZERO | |
9438 | SQET = ZERO | |
9439 | SQET2 = ZERO | |
9440 | SQE2 = ZERO | |
9441 | SQE22 = ZERO | |
9442 | SPRO = ZERO | |
9443 | SPRO2 = ZERO | |
9444 | SDEL = ZERO | |
9445 | SDEL2 = ZERO | |
9446 | SDQE = ZERO | |
9447 | SDQE2 = ZERO | |
9448 | FACN = ONE/DBLE(NSTATB) | |
9449 | ||
9450 | IPNT = 0 | |
9451 | RPNT = ZERO | |
9452 | ||
9453 | * initialize Gauss-integration for photon-proj. | |
9454 | JPOINT = 1 | |
9455 | IF (IJPROJ.EQ.7) THEN | |
9456 | IF (INTRGE(1).EQ.1) THEN | |
9457 | AMLO2 = (3.0D0*AAM(13))**2 | |
9458 | ELSEIF (INTRGE(1).EQ.2) THEN | |
9459 | AMLO2 = AAM(33)**2 | |
9460 | ELSE | |
9461 | AMLO2 = AAM(96)**2 | |
9462 | ENDIF | |
9463 | IF (INTRGE(2).EQ.1) THEN | |
9464 | AMHI2 = S/TWO | |
9465 | ELSEIF (INTRGE(2).EQ.2) THEN | |
9466 | AMHI2 = S/4.0D0 | |
9467 | ELSE | |
9468 | AMHI2 = S | |
9469 | ENDIF | |
9470 | AMHI20 = (ECMNN(IE)-AMP)**2 | |
9471 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
9472 | XAMLO = LOG( AMLO2+Q2 ) | |
9473 | XAMHI = LOG( AMHI2+Q2 ) | |
9474 | **PHOJET105a | |
9475 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9476 | **PHOJET112 | |
9477 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9478 | ** | |
9479 | JPOINT = NPOINT | |
9480 | * ratio direct/total photon-nucleon xsection | |
9481 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) | |
9482 | ENDIF | |
9483 | ||
9484 | * read pre-initialized profile-function from file | |
9485 | IF (IOGLB.EQ.1) THEN | |
9486 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM | |
9487 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN | |
9488 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, | |
9489 | & NA,NB,NSTATB,NSITEB | |
9490 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, | |
9491 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, | |
9492 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) | |
9493 | STOP | |
9494 | ENDIF | |
9495 | IF (LFIRST) WRITE(LOUT,1001) CFILE | |
9496 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', | |
9497 | & 'file ',A12,/) | |
9498 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), | |
9499 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), | |
9500 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9501 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), | |
9502 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), | |
9503 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9504 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9505 | IF (NLINES.GT.0) THEN | |
9506 | DO 21 I=1,NLINES | |
9507 | ISTART = 7*I-6 | |
9508 | READ(LDAT,'(7E11.4)') | |
9509 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9510 | 21 CONTINUE | |
9511 | ENDIF | |
9512 | ISTART = 7*NLINES+1 | |
9513 | IF (ISTART.LE.NSITEB) THEN | |
9514 | READ(LDAT,'(7E11.4)') | |
9515 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9516 | ENDIF | |
9517 | LFIRST = .FALSE. | |
9518 | GOTO 100 | |
9519 | * variable projectile/target/energy runs: | |
9520 | * read pre-initialized profile-functions from file | |
9521 | ELSEIF (IOGLB.EQ.100) THEN | |
9522 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) | |
9523 | GOTO 100 | |
9524 | ENDIF | |
9525 | ||
9526 | * cross sections averaged over NSTATB nucleon configurations | |
9527 | DO 11 IS=1,NSTATB | |
9528 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS | |
9529 | STOTN = ZERO | |
9530 | SELAN = ZERO | |
9531 | SQEPN = ZERO | |
9532 | SQETN = ZERO | |
9533 | SQE2N = ZERO | |
9534 | SPRON = ZERO | |
9535 | SDELN = ZERO | |
9536 | SDQEN = ZERO | |
9537 | ||
9538 | IF (NIDX.LE.-1) THEN | |
9539 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) | |
9540 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) | |
9541 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9542 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) | |
9543 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) | |
9544 | ENDIF | |
9545 | ELSE | |
9546 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) | |
9547 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) | |
9548 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9549 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) | |
9550 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) | |
9551 | ENDIF | |
9552 | ENDIF | |
9553 | ||
9554 | * integration over impact parameter B | |
9555 | DO 12 IB=1,NSITEB-1 | |
9556 | STOTB = ZERO | |
9557 | SELAB = ZERO | |
9558 | SQEPB = ZERO | |
9559 | SQETB = ZERO | |
9560 | SQE2B = ZERO | |
9561 | SPROB = ZERO | |
9562 | SDIR = ZERO | |
9563 | SDELB = ZERO | |
9564 | SDQEB = ZERO | |
9565 | B = DBLE(IB)*BSTEP(NTARG) | |
9566 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) | |
9567 | ||
9568 | * integration over M_V^2 for photon-proj. | |
9569 | DO 14 IM=1,JPOINT | |
9570 | PP11(1) = CONE | |
9571 | PP12(1) = CONE | |
9572 | PP21(1) = CONE | |
9573 | PP22(1) = CONE | |
9574 | IF (IJPROJ.EQ.7) THEN | |
9575 | DO 13 K=2,NB | |
9576 | PP11(K) = CONE | |
9577 | PP12(K) = CONE | |
9578 | PP21(K) = CONE | |
9579 | PP22(K) = CONE | |
9580 | 13 CONTINUE | |
9581 | ENDIF | |
9582 | SHI = ZERO | |
9583 | FACM = ONE | |
9584 | DCOH = 1.0D10 | |
9585 | ||
9586 | IF (IJPROJ.EQ.7) THEN | |
9587 | AMV2 = EXP(ABSZX(IM))-Q2 | |
9588 | AMV = SQRT(AMV2) | |
9589 | IF (AMV2.LT.16.0D0) THEN | |
9590 | R = TWO | |
9591 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN | |
9592 | R = 10.0D0/3.0D0 | |
9593 | ELSE | |
9594 | R = 11.0D0/3.0D0 | |
9595 | ENDIF | |
9596 | * define M_V dependent properties of nucleon scattering amplitude | |
9597 | * V_M-nucleon xsection | |
9598 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 | |
9599 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) | |
9600 | * slope-parametrisation a la Kaidalov | |
9601 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
9602 | & +0.25D0*LOG(S/(AMV2+Q2))) | |
9603 | * coherence length | |
9604 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM | |
9605 | * integration weight factor | |
9606 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* | |
9607 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) | |
9608 | ENDIF | |
9609 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
9610 | GAM = GSH | |
9611 | IF (IJPROJ.EQ.7) THEN | |
9612 | RCA = GAM*SIGMV/TWOPI | |
9613 | ELSE | |
9614 | RCA = GAM*SIGSH/TWOPI | |
9615 | ENDIF | |
9616 | FCA = -ROSH*RCA | |
9617 | CA = DCMPLX(RCA,FCA) | |
9618 | CI = CONE | |
9619 | ||
9620 | DO 15 INA=1,NA | |
9621 | KK1 = 1 | |
9622 | INT1 = 1 | |
9623 | KK2 = 1 | |
9624 | INT2 = 1 | |
9625 | DO 16 INB=1,NB | |
9626 | * photon-projectile: check for supression by coherence length | |
9627 | IF (IJPROJ.EQ.7) THEN | |
9628 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN | |
9629 | KK1 = INB | |
9630 | INT1 = INT1+1 | |
9631 | ENDIF | |
9632 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN | |
9633 | KK2 = INB | |
9634 | INT2 = INT2+1 | |
9635 | ENDIF | |
9636 | ENDIF | |
9637 | ||
9638 | X11 = B+COOT1(1,INB)-COOP1(1,INA) | |
9639 | Y11 = COOT1(2,INB)-COOP1(2,INA) | |
9640 | XY11 = GAM*(X11*X11+Y11*Y11) | |
9641 | IF (XY11.LE.15.0D0) THEN | |
9642 | C = CONE-CA*EXP(-XY11) | |
9643 | AR = DBLE(PP11(INT1)) | |
9644 | AI = DIMAG(PP11(INT1)) | |
9645 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9646 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9647 | PP11(INT1) = DCMPLX(AR,AI) | |
9648 | PP11(INT1) = PP11(INT1)*C | |
9649 | AR = DBLE(C) | |
9650 | AI = DIMAG(C) | |
9651 | SHI = SHI+LOG(AR*AR+AI*AI) | |
9652 | ENDIF | |
9653 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9654 | X12 = B+COOT2(1,INB)-COOP1(1,INA) | |
9655 | Y12 = COOT2(2,INB)-COOP1(2,INA) | |
9656 | XY12 = GAM*(X12*X12+Y12*Y12) | |
9657 | IF (XY12.LE.15.0D0) THEN | |
9658 | C = CONE-CA*EXP(-XY12) | |
9659 | AR = DBLE(PP12(INT2)) | |
9660 | AI = DIMAG(PP12(INT2)) | |
9661 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9662 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9663 | PP12(INT2) = DCMPLX(AR,AI) | |
9664 | PP12(INT2) = PP12(INT2)*C | |
9665 | ENDIF | |
9666 | X21 = B+COOT1(1,INB)-COOP2(1,INA) | |
9667 | Y21 = COOT1(2,INB)-COOP2(2,INA) | |
9668 | XY21 = GAM*(X21*X21+Y21*Y21) | |
9669 | IF (XY21.LE.15.0D0) THEN | |
9670 | C = CONE-CA*EXP(-XY21) | |
9671 | AR = DBLE(PP21(INT1)) | |
9672 | AI = DIMAG(PP21(INT1)) | |
9673 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9674 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9675 | PP21(INT1) = DCMPLX(AR,AI) | |
9676 | PP21(INT1) = PP21(INT1)*C | |
9677 | ENDIF | |
9678 | X22 = B+COOT2(1,INB)-COOP2(1,INA) | |
9679 | Y22 = COOT2(2,INB)-COOP2(2,INA) | |
9680 | XY22 = GAM*(X22*X22+Y22*Y22) | |
9681 | IF (XY22.LE.15.0D0) THEN | |
9682 | C = CONE-CA*EXP(-XY22) | |
9683 | AR = DBLE(PP22(INT2)) | |
9684 | AI = DIMAG(PP22(INT2)) | |
9685 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9686 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9687 | PP22(INT2) = DCMPLX(AR,AI) | |
9688 | PP22(INT2) = PP22(INT2)*C | |
9689 | ENDIF | |
9690 | ENDIF | |
9691 | 16 CONTINUE | |
9692 | 15 CONTINUE | |
9693 | ||
9694 | OMPP11 = CZERO | |
9695 | OMPP21 = CZERO | |
9696 | DIPP11 = CZERO | |
9697 | DIPP21 = CZERO | |
9698 | DO 17 K=1,INT1 | |
9699 | IF (PP11(K).EQ.CZERO) THEN | |
9700 | PPTMP1 = CZERO | |
9701 | PPTMP2 = CZERO | |
9702 | ELSE | |
9703 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) | |
9704 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) | |
9705 | ENDIF | |
9706 | AVDIPP = 0.5D0* | |
9707 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9708 | OMPP11 = OMPP11+AVDIPP | |
9709 | C OMPP11 = OMPP11+(CONE-PP11(K)) | |
9710 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9711 | DIPP11 = DIPP11+AVDIPP | |
9712 | IF (PP21(K).EQ.CZERO) THEN | |
9713 | PPTMP1 = CZERO | |
9714 | PPTMP2 = CZERO | |
9715 | ELSE | |
9716 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) | |
9717 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) | |
9718 | ENDIF | |
9719 | AVDIPP = 0.5D0* | |
9720 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9721 | OMPP21 = OMPP21+AVDIPP | |
9722 | C OMPP21 = OMPP21+(CONE-PP21(K)) | |
9723 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9724 | DIPP21 = DIPP21+AVDIPP | |
9725 | 17 CONTINUE | |
9726 | OMPP12 = CZERO | |
9727 | OMPP22 = CZERO | |
9728 | DIPP12 = CZERO | |
9729 | DIPP22 = CZERO | |
9730 | DO 18 K=1,INT2 | |
9731 | IF (PP12(K).EQ.CZERO) THEN | |
9732 | PPTMP1 = CZERO | |
9733 | PPTMP2 = CZERO | |
9734 | ELSE | |
9735 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) | |
9736 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) | |
9737 | ENDIF | |
9738 | AVDIPP = 0.5D0* | |
9739 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9740 | OMPP12 = OMPP12+AVDIPP | |
9741 | C OMPP12 = OMPP12+(CONE-PP12(K)) | |
9742 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9743 | DIPP12 = DIPP12+AVDIPP | |
9744 | IF (PP22(K).EQ.CZERO) THEN | |
9745 | PPTMP1 = CZERO | |
9746 | PPTMP2 = CZERO | |
9747 | ELSE | |
9748 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) | |
9749 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) | |
9750 | ENDIF | |
9751 | AVDIPP = 0.5D0* | |
9752 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9753 | OMPP22 = OMPP22+AVDIPP | |
9754 | C OMPP22 = OMPP22+(CONE-PP22(K)) | |
9755 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9756 | DIPP22 = DIPP22+AVDIPP | |
9757 | 18 CONTINUE | |
9758 | ||
9759 | SPROM = ONE-EXP(SHI) | |
9760 | SPROB = SPROB+FACM*SPROM | |
9761 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9762 | STOTM = DBLE(OMPP11+OMPP22) | |
9763 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) | |
9764 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM | |
9765 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM | |
9766 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM | |
9767 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) | |
9768 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM | |
9769 | STOTB = STOTB+FACM*STOTM | |
9770 | SELAB = SELAB+FACM*SELAM | |
9771 | SDELB = SDELB+FACM*SDELM | |
9772 | IF (NB.GT.1) THEN | |
9773 | SQEPB = SQEPB+FACM*SQEPM | |
9774 | SDQEB = SDQEB+FACM*SDQEM | |
9775 | ENDIF | |
9776 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM | |
9777 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M | |
9778 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD | |
9779 | ENDIF | |
9780 | ||
9781 | 14 CONTINUE | |
9782 | ||
9783 | STOTN = STOTN+FACB*STOTB | |
9784 | SELAN = SELAN+FACB*SELAB | |
9785 | SQEPN = SQEPN+FACB*SQEPB | |
9786 | SQETN = SQETN+FACB*SQETB | |
9787 | SQE2N = SQE2N+FACB*SQE2B | |
9788 | SPRON = SPRON+FACB*SPROB | |
9789 | SDELN = SDELN+FACB*SDELB | |
9790 | SDQEN = SDQEN+FACB*SDQEB | |
9791 | ||
9792 | IF (IJPROJ.EQ.7) THEN | |
9793 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) | |
9794 | ELSE | |
9795 | IF (DIBETA.GT.ZERO) THEN | |
9796 | BPROD(IB+1)= BPROD(IB+1) | |
9797 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) | |
9798 | ELSE | |
9799 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB | |
9800 | ENDIF | |
9801 | ENDIF | |
9802 | ||
9803 | 12 CONTINUE | |
9804 | ||
9805 | STOT = STOT +FACN*STOTN | |
9806 | STOT2 = STOT2+FACN*STOTN**2 | |
9807 | SELA = SELA +FACN*SELAN | |
9808 | SELA2 = SELA2+FACN*SELAN**2 | |
9809 | SQEP = SQEP +FACN*SQEPN | |
9810 | SQEP2 = SQEP2+FACN*SQEPN**2 | |
9811 | SQET = SQET +FACN*SQETN | |
9812 | SQET2 = SQET2+FACN*SQETN**2 | |
9813 | SQE2 = SQE2 +FACN*SQE2N | |
9814 | SQE22 = SQE22+FACN*SQE2N**2 | |
9815 | SPRO = SPRO +FACN*SPRON | |
9816 | SPRO2 = SPRO2+FACN*SPRON**2 | |
9817 | SDEL = SDEL +FACN*SDELN | |
9818 | SDEL2 = SDEL2+FACN*SDELN**2 | |
9819 | SDQE = SDQE +FACN*SDQEN | |
9820 | SDQE2 = SDQE2+FACN*SDQEN**2 | |
9821 | ||
9822 | 11 CONTINUE | |
9823 | ||
9824 | * final cross sections | |
9825 | * 1) total | |
9826 | XSTOT(IE,IQ,NTARG) = STOT | |
9827 | IF (IJPROJ.EQ.7) | |
9828 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR | |
9829 | * 2) elastic | |
9830 | XSELA(IE,IQ,NTARG) = SELA | |
9831 | * 3) quasi-el.: A+B-->A+X (excluding 2) | |
9832 | XSQEP(IE,IQ,NTARG) = SQEP | |
9833 | * 4) quasi-el.: A+B-->X+B (excluding 2) | |
9834 | XSQET(IE,IQ,NTARG) = SQET | |
9835 | * 5) quasi-el.: A+B-->X (excluding 2-4) | |
9836 | XSQE2(IE,IQ,NTARG) = SQE2 | |
9837 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) | |
9838 | IF (SDEL.GT.ZERO) THEN | |
9839 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 | |
9840 | ELSE | |
9841 | XSPRO(IE,IQ,NTARG) = SPRO | |
9842 | ENDIF | |
9843 | * 7) projectile diffraction (el. scatt. off target) | |
9844 | XSDEL(IE,IQ,NTARG) = SDEL | |
9845 | * 8) projectile diffraction (quasi-el. scatt. off target) | |
9846 | XSDQE(IE,IQ,NTARG) = SDQE | |
9847 | * stat. errors | |
9848 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) | |
9849 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) | |
9850 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) | |
9851 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) | |
9852 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) | |
9853 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) | |
9854 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) | |
9855 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) | |
9856 | ||
9857 | IF (IJPROJ.EQ.7) THEN | |
9858 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) | |
9859 | & -XSQEP(IE,IQ,NTARG) | |
9860 | ELSE | |
9861 | BNORM = XSPRO(IE,IQ,NTARG) | |
9862 | ENDIF | |
9863 | DO 19 I=2,NSITEB | |
9864 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) | |
9865 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) | |
9866 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) | |
9867 | 19 CONTINUE | |
9868 | ||
9869 | * write profile function data into file | |
9870 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN | |
9871 | WRITE(LDAT,'(5I10,1P,E15.5)') | |
9872 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) | |
9873 | WRITE(LDAT,'(1P,6E12.5)') | |
9874 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), | |
9875 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9876 | WRITE(LDAT,'(1P,6E12.5)') | |
9877 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), | |
9878 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9879 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9880 | IF (NLINES.GT.0) THEN | |
9881 | DO 20 I=1,NLINES | |
9882 | ISTART = 7*I-6 | |
9883 | WRITE(LDAT,'(1P,7E11.4)') | |
9884 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9885 | 20 CONTINUE | |
9886 | ENDIF | |
9887 | ISTART = 7*NLINES+1 | |
9888 | IF (ISTART.LE.NSITEB) THEN | |
9889 | WRITE(LDAT,'(1P,7E11.4)') | |
9890 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9891 | ENDIF | |
9892 | ENDIF | |
9893 | ||
9894 | 100 CONTINUE | |
9895 | ||
9896 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) | |
9897 | ||
9898 | RETURN | |
9899 | END | |
9900 | ||
9901 | *$ CREATE DT_GETBXS.FOR | |
9902 | *COPY DT_GETBXS | |
9903 | * | |
9904 | *===getbxs=============================================================* | |
9905 | * | |
9906 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) | |
9907 | ||
9908 | ************************************************************************ | |
9909 | * Biasing in impact parameter space. * | |
9910 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * | |
9911 | * BHI - maximum impact parameter (input) * | |
9912 | * XSFRAC - fraction of cross section corresponding * | |
9913 | * to impact parameter range (BLO,BHI) * | |
9914 | * (output) * | |
9915 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * | |
9916 | * BHI - maximum impact parameter giving requested * | |
9917 | * fraction of cross section in impact * | |
9918 | * parameter range (0,BMAX) (output) * | |
9919 | * This version dated 17.03.00 is written by S. Roesler * | |
9920 | ************************************************************************ | |
9921 | ||
9922 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9923 | SAVE | |
9924 | PARAMETER ( LINP = 10 , | |
9925 | & LOUT = 6 , | |
9926 | & LDAT = 9 ) | |
9927 | ||
9928 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9929 | * Glauber formalism: parameters | |
9930 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9931 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9932 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9933 | & NSITEB,NSTATB | |
9934 | ||
9935 | NTARG = ABS(NIDX) | |
9936 | IF (XSFRAC.LE.0.0D0) THEN | |
9937 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) | |
9938 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) | |
9939 | IF (ILO.GE.IHI) THEN | |
9940 | XSFRAC = 0.0D0 | |
9941 | RETURN | |
9942 | ENDIF | |
9943 | IF (ILO.EQ.NSITEB-1) THEN | |
9944 | FRCLO = BSITE(0,1,NTARG,NSITEB) | |
9945 | ELSE | |
9946 | FRCLO = BSITE(0,1,NTARG,ILO+1) | |
9947 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) | |
9948 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) | |
9949 | ENDIF | |
9950 | IF (IHI.EQ.NSITEB-1) THEN | |
9951 | FRCHI = BSITE(0,1,NTARG,NSITEB) | |
9952 | ELSE | |
9953 | FRCHI = BSITE(0,1,NTARG,IHI+1) | |
9954 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) | |
9955 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) | |
9956 | ENDIF | |
9957 | XSFRAC = FRCHI-FRCLO | |
9958 | ELSE | |
9959 | BLO = 0.0D0 | |
9960 | BHI = BMAX(NTARG) | |
9961 | DO 1 I=1,NSITEB-1 | |
9962 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN | |
9963 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ | |
9964 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) | |
9965 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC | |
9966 | GOTO 2 | |
9967 | ENDIF | |
9968 | 1 CONTINUE | |
9969 | 2 CONTINUE | |
9970 | ENDIF | |
9971 | ||
9972 | RETURN | |
9973 | END | |
9974 | ||
9975 | *$ CREATE DT_CONUCL.FOR | |
9976 | *COPY DT_CONUCL | |
9977 | * | |
9978 | *===conucl=============================================================* | |
9979 | * | |
9980 | SUBROUTINE DT_CONUCL(X,N,R,MODE) | |
9981 | ||
9982 | ************************************************************************ | |
9983 | * Calculation of coordinates of nucleons within nuclei. * | |
9984 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
9985 | * N / R number of nucleons / radius of nucleus (input) * | |
9986 | * MODE = 0 coordinates not sorted * | |
9987 | * = 1 coordinates sorted with increasing X(3,i) * | |
9988 | * = 2 coordinates sorted with decreasing X(3,i) * | |
9989 | * This version dated 26.10.95 is revised by S. Roesler * | |
9990 | ************************************************************************ | |
9991 | ||
9992 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9993 | SAVE | |
9994 | PARAMETER ( LINP = 10 , | |
9995 | & LOUT = 6 , | |
9996 | & LDAT = 9 ) | |
9997 | ||
9998 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9999 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10000 | ||
10001 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10002 | ||
10003 | PARAMETER (NSRT=10) | |
10004 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10005 | DIMENSION X(3,N),XTMP(3,260) | |
10006 | ||
10007 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) | |
10008 | ||
10009 | IF ((MODE.NE.0).AND.(N.GT.4)) THEN | |
10010 | K = 0 | |
10011 | DO 1 I=1,NSRT | |
10012 | IF (MODE.EQ.2) THEN | |
10013 | ISRT = NSRT+1-I | |
10014 | ELSE | |
10015 | ISRT = I | |
10016 | ENDIF | |
10017 | K1 = K | |
10018 | DO 2 J=1,ICSRT(ISRT) | |
10019 | K = K+1 | |
10020 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) | |
10021 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) | |
10022 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) | |
10023 | 2 CONTINUE | |
10024 | IF (ICSRT(ISRT).GT.1) THEN | |
10025 | I0 = K1+1 | |
10026 | I1 = K | |
10027 | CALL DT_SORT(X,N,I0,I1,MODE) | |
10028 | ENDIF | |
10029 | 1 CONTINUE | |
10030 | ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN | |
10031 | DO 3 I=1,N | |
10032 | X(1,I) = XTMP(1,I) | |
10033 | X(2,I) = XTMP(2,I) | |
10034 | X(3,I) = XTMP(3,I) | |
10035 | 3 CONTINUE | |
10036 | CALL DT_SORT(X,N,1,N,MODE) | |
10037 | ELSE | |
10038 | DO 4 I=1,N | |
10039 | X(1,I) = XTMP(1,I) | |
10040 | X(2,I) = XTMP(2,I) | |
10041 | X(3,I) = XTMP(3,I) | |
10042 | 4 CONTINUE | |
10043 | ENDIF | |
10044 | ||
10045 | RETURN | |
10046 | END | |
10047 | ||
10048 | *$ CREATE DT_COORDI.FOR | |
10049 | *COPY DT_COORDI | |
10050 | * | |
10051 | *===coordi=============================================================* | |
10052 | * | |
10053 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) | |
10054 | ||
10055 | ************************************************************************ | |
10056 | * Calculation of coordinates of nucleons within nuclei. * | |
10057 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
10058 | * N / R number of nucleons / radius of nucleus (input) * | |
10059 | * Based on the original version by Shmakov et al. * | |
10060 | * This version dated 26.10.95 is revised by S. Roesler * | |
10061 | ************************************************************************ | |
10062 | ||
10063 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10064 | SAVE | |
10065 | PARAMETER ( LINP = 10 , | |
10066 | & LOUT = 6 , | |
10067 | & LDAT = 9 ) | |
10068 | ||
10069 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10070 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10071 | ||
10072 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10073 | ||
10074 | LOGICAL LSTART | |
10075 | ||
10076 | PARAMETER (NSRT=10) | |
10077 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10078 | DIMENSION X(3,260),WD(4),RD(3) | |
10079 | ||
10080 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ | |
10081 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ | |
10082 | DATA RD /2.09D0, 0.935D0, 0.697D0/ | |
10083 | ||
10084 | X1SUM = ZERO | |
10085 | X2SUM = ZERO | |
10086 | X3SUM = ZERO | |
10087 | ||
10088 | IF (N.EQ.1) THEN | |
10089 | X(1,1) = ZERO | |
10090 | X(2,1) = ZERO | |
10091 | X(3,1) = ZERO | |
10092 | ELSEIF (N.EQ.2) THEN | |
10093 | EPS = DT_RNDM(RD(1)) | |
10094 | DO 30 I=1,3 | |
10095 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 | |
10096 | 30 CONTINUE | |
10097 | 40 CONTINUE | |
10098 | DO 50 J=1,3 | |
10099 | CALL DT_RANNOR(X1,X2) | |
10100 | X(J,1) = RD(I)*X1 | |
10101 | X(J,2) = -X(J,1) | |
10102 | 50 CONTINUE | |
10103 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN | |
10104 | SIGMA = R/SQRTWO | |
10105 | LSTART = .TRUE. | |
10106 | CALL DT_RANNOR(X3,X4) | |
10107 | DO 100 I=1,N | |
10108 | CALL DT_RANNOR(X1,X2) | |
10109 | X(1,I) = SIGMA*X1 | |
10110 | X(2,I) = SIGMA*X2 | |
10111 | IF (LSTART) GOTO 80 | |
10112 | X(3,I) = SIGMA*X4 | |
10113 | CALL DT_RANNOR(X3,X4) | |
10114 | GOTO 90 | |
10115 | 80 CONTINUE | |
10116 | X(3,I) = SIGMA*X3 | |
10117 | 90 CONTINUE | |
10118 | LSTART = .NOT.LSTART | |
10119 | X1SUM = X1SUM+X(1,I) | |
10120 | X2SUM = X2SUM+X(2,I) | |
10121 | X3SUM = X3SUM+X(3,I) | |
10122 | 100 CONTINUE | |
10123 | X1SUM = X1SUM/DBLE(N) | |
10124 | X2SUM = X2SUM/DBLE(N) | |
10125 | X3SUM = X3SUM/DBLE(N) | |
10126 | DO 101 I=1,N | |
10127 | X(1,I) = X(1,I)-X1SUM | |
10128 | X(2,I) = X(2,I)-X2SUM | |
10129 | X(3,I) = X(3,I)-X3SUM | |
10130 | 101 CONTINUE | |
10131 | ELSE | |
10132 | ||
10133 | * maximum nuclear radius for coordinate sampling | |
10134 | RMAX = R+4.605D0*PDIF | |
10135 | ||
10136 | * initialize pre-sorting | |
10137 | DO 121 I=1,NSRT | |
10138 | ICSRT(I) = 0 | |
10139 | 121 CONTINUE | |
10140 | DR = TWO*RMAX/DBLE(NSRT) | |
10141 | ||
10142 | * sample coordinates for N nucleons | |
10143 | DO 140 I=1,N | |
10144 | 120 CONTINUE | |
10145 | RAD = RMAX*(DT_RNDM(DR))**ONETHI | |
10146 | F = DT_DENSIT(N,RAD,R) | |
10147 | IF (DT_RNDM(RAD).GT.F) GOTO 120 | |
10148 | * theta, phi uniformly distributed | |
10149 | CT = ONE-TWO*DT_RNDM(F) | |
10150 | ST = SQRT((ONE-CT)*(ONE+CT)) | |
10151 | CALL DT_DSFECF(SFE,CFE) | |
10152 | X(1,I) = RAD*ST*CFE | |
10153 | X(2,I) = RAD*ST*SFE | |
10154 | X(3,I) = RAD*CT | |
10155 | * ensure that distance between two nucleons is greater than R2MIN | |
10156 | IF (I.LT.2) GOTO 122 | |
10157 | I1 = I-1 | |
10158 | DO 130 I2=1,I1 | |
10159 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ | |
10160 | & (X(3,I)-X(3,I2))**2 | |
10161 | IF (DIST2.LE.R2MIN) GOTO 120 | |
10162 | 130 CONTINUE | |
10163 | 122 CONTINUE | |
10164 | * save index according to z-bin | |
10165 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 | |
10166 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 | |
10167 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I | |
10168 | X1SUM = X1SUM+X(1,I) | |
10169 | X2SUM = X2SUM+X(2,I) | |
10170 | X3SUM = X3SUM+X(3,I) | |
10171 | 140 CONTINUE | |
10172 | X1SUM = X1SUM/DBLE(N) | |
10173 | X2SUM = X2SUM/DBLE(N) | |
10174 | X3SUM = X3SUM/DBLE(N) | |
10175 | DO 141 I=1,N | |
10176 | X(1,I) = X(1,I)-X1SUM | |
10177 | X(2,I) = X(2,I)-X2SUM | |
10178 | X(3,I) = X(3,I)-X3SUM | |
10179 | 141 CONTINUE | |
10180 | ||
10181 | ENDIF | |
10182 | ||
10183 | RETURN | |
10184 | END | |
10185 | ||
10186 | *$ CREATE DT_DENSIT.FOR | |
10187 | *COPY DT_DENSIT | |
10188 | * | |
10189 | *===densit=============================================================* | |
10190 | * | |
10191 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) | |
10192 | ||
10193 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10194 | SAVE | |
10195 | ||
10196 | PARAMETER ( LINP = 10 , | |
10197 | & LOUT = 6 , | |
10198 | & LDAT = 9 ) | |
10199 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10200 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
10201 | & PI = TWOPI/TWO) | |
10202 | ||
10203 | DIMENSION R0(18),FNORM(18) | |
10204 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, | |
10205 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, | |
10206 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, | |
10207 | & 2.72D0, 2.66D0, 2.79D0/ | |
10208 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10209 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10210 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, | |
10211 | & .1214D+01,.1265D+01,.1318D+01/ | |
10212 | DATA PDIF /0.545D0/ | |
10213 | ||
10214 | DT_DENSIT = ZERO | |
10215 | * shell model | |
10216 | IF (NA.LE.4) THEN | |
10217 | STOP 'DT_DENSIT-0' | |
10218 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN | |
10219 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) | |
10220 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) | |
10221 | & *EXP(-(R/R1)**2)/FNORM(NA) | |
10222 | * Woods-Saxon | |
10223 | ELSEIF (NA.GT.18) THEN | |
10224 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) | |
10225 | ENDIF | |
10226 | ||
10227 | RETURN | |
10228 | END | |
10229 | ||
10230 | *$ CREATE DT_RNCLUS.FOR | |
10231 | *COPY DT_RNCLUS | |
10232 | * | |
10233 | *===rnclus=============================================================* | |
10234 | * | |
10235 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) | |
10236 | ||
10237 | ************************************************************************ | |
10238 | * Nuclear radius for nucleus with mass number N. * | |
10239 | * This version dated 26.9.00 is written by S. Roesler * | |
10240 | ************************************************************************ | |
10241 | ||
10242 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10243 | SAVE | |
10244 | ||
10245 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) | |
10246 | ||
10247 | * nucleon radius | |
10248 | PARAMETER (RNUCLE = 1.12D0) | |
10249 | ||
10250 | * nuclear radii for selected nuclei | |
10251 | DIMENSION RADNUC(18) | |
10252 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, | |
10253 | & 2.58D0,2.71D0,2.66D0,2.71D0/ | |
10254 | ||
10255 | IF (N.LE.18) THEN | |
10256 | IF (RADNUC(N).GT.0.0D0) THEN | |
10257 | DT_RNCLUS = RADNUC(N) | |
10258 | ELSE | |
10259 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10260 | ENDIF | |
10261 | ELSE | |
10262 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10263 | ENDIF | |
10264 | ||
10265 | RETURN | |
10266 | END | |
10267 | ||
10268 | *$ CREATE DT_DENTST.FOR | |
10269 | *COPY DT_DENTST | |
10270 | * | |
10271 | *===dentst=============================================================* | |
10272 | * | |
10273 | C PROGRAM DT_DENTST | |
10274 | SUBROUTINE DT_DENTST | |
10275 | ||
10276 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10277 | SAVE | |
10278 | ||
10279 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') | |
10280 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') | |
10281 | ||
10282 | RMIN = 0.0D0 | |
10283 | RMAX = 8.0D0 | |
10284 | NBINS = 500.0D0 | |
10285 | DR = (RMAX-RMIN)/DBLE(NBINS) | |
10286 | DO 1 IA=5,18 | |
10287 | FMAX = 0.0D0 | |
10288 | DO 2 IR=1,NBINS+1 | |
10289 | R = RMIN+DBLE(IR-1)*DR | |
10290 | F = DT_DENSIT(IA,R,R) | |
10291 | IF (F.GT.FMAX) FMAX = F | |
10292 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F | |
10293 | 2 CONTINUE | |
10294 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX | |
10295 | 1 CONTINUE | |
10296 | ||
10297 | CLOSE(40) | |
10298 | CLOSE(41) | |
10299 | ||
10300 | END | |
10301 | ||
10302 | *$ CREATE DT_SHMAKI.FOR | |
10303 | *COPY DT_SHMAKI | |
10304 | * | |
10305 | *===shmaki=============================================================* | |
10306 | * | |
10307 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) | |
10308 | ||
10309 | ************************************************************************ | |
10310 | * Initialisation of Glauber formalism. This subroutine has to be * | |
10311 | * called once (in case of target emulsions as often as many different * | |
10312 | * target nuclei are considered) before events are sampled. * | |
10313 | * NA / NCA mass number/charge of projectile nucleus * | |
10314 | * NB / NCB mass number/charge of target nucleus * | |
10315 | * IJP identity of projectile (hadrons/leptons/photons) * | |
10316 | * PPN projectile momentum (for projectile nuclei: * | |
10317 | * momentum per nucleon) in target rest system * | |
10318 | * MODE = 0 Glauber formalism invoked * | |
10319 | * = 1 fitted results are loaded from data-file * | |
10320 | * = 99 NTARG is forced to be 1 * | |
10321 | * (used in connection with GLAUBERI-card only) * | |
10322 | * This version dated 22.03.96 is based on the original SHMAKI-routine * | |
10323 | * and revised by S. Roesler. * | |
10324 | ************************************************************************ | |
10325 | ||
10326 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10327 | SAVE | |
10328 | PARAMETER ( LINP = 10 , | |
10329 | & LOUT = 6 , | |
10330 | & LDAT = 9 ) | |
10331 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
10332 | & THREE=3.0D0) | |
10333 | ||
10334 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10335 | * Glauber formalism: parameters | |
10336 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10337 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10338 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10339 | & NSITEB,NSTATB | |
10340 | * Lorentz-parameters of the current interaction | |
10341 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10342 | & UMO,PPCM,EPROJ,PPROJ | |
10343 | * properties of photon/lepton projectiles | |
10344 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10345 | * kinematical cuts for lepton-nucleus interactions | |
10346 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
10347 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
10348 | * Glauber formalism: cross sections | |
10349 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10350 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10351 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10352 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10353 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10354 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10355 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10356 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10357 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10358 | & BSLOPE,NEBINI,NQBINI | |
10359 | * cuts for variable energy runs | |
10360 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
10361 | * nucleon-nucleon event-generator | |
10362 | CHARACTER*8 CMODEL | |
10363 | LOGICAL LPHOIN | |
10364 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10365 | * Glauber formalism: flags and parameters for statistics | |
10366 | LOGICAL LPROD | |
10367 | CHARACTER*8 CGLB | |
10368 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10369 | ||
10370 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ | |
10371 | ||
10372 | C CALL DT_HISHAD | |
10373 | C STOP | |
10374 | ||
10375 | NTARG = NTARG+1 | |
10376 | IF (MODE.EQ.99) NTARG = 1 | |
10377 | NIDX = -NTARG | |
10378 | IF (MODE.EQ.-1) NIDX = NTARG | |
10379 | ||
10380 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 | |
10381 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) | |
10382 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', | |
10383 | & ' initialization',/,12X,'--------------------------', | |
10384 | & '-------------------------',/) | |
10385 | ||
10386 | IF (MODE.EQ.2) THEN | |
10387 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10388 | CALL DT_SHFAST(MODE,PPN,IBACK) | |
10389 | STOP ' Glauber pre-initialization done' | |
10390 | ENDIF | |
10391 | IF (MODE.EQ.1) THEN | |
10392 | CALL DT_PROFBI(NA,NB,PPN,NTARG) | |
10393 | ELSE | |
10394 | IBACK = 1 | |
10395 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) | |
10396 | IF (IBACK.EQ.1) THEN | |
10397 | * lepton-nucleus (variable energy runs) | |
10398 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. | |
10399 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
10400 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10401 | & WRITE(LOUT,1002) NB,NCB | |
10402 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', | |
10403 | & ' target A/Z: ',I3,' /',I3,/,/,8X, | |
10404 | & 'E_cm (GeV) Q^2 (GeV^2)', | |
10405 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, | |
10406 | & '--------------------------------', | |
10407 | & '------------------------------') | |
10408 | AECMLO = LOG10(MIN(UMO,ECMLI)) | |
10409 | AECMHI = LOG10(MIN(UMO,ECMHI)) | |
10410 | IESTEP = NEB-1 | |
10411 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10412 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10413 | DO 1 I=1,IESTEP+1 | |
10414 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10415 | IF (Q2HI.GT.0.1D0) THEN | |
10416 | IF (Q2LI.LT.0.01D0) THEN | |
10417 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10418 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10419 | & WRITE(LOUT,1003) | |
10420 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10421 | Q2LI = 0.01D0 | |
10422 | IBIN = 2 | |
10423 | ELSE | |
10424 | IBIN = 1 | |
10425 | ENDIF | |
10426 | IQSTEP = NQB-IBIN | |
10427 | AQ2LO = LOG10(Q2LI) | |
10428 | AQ2HI = LOG10(Q2HI) | |
10429 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) | |
10430 | DO 2 J=IBIN,IQSTEP+IBIN | |
10431 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) | |
10432 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) | |
10433 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10434 | & WRITE(LOUT,1003) ECMNN(I), | |
10435 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) | |
10436 | 2 CONTINUE | |
10437 | ELSE | |
10438 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10439 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10440 | & WRITE(LOUT,1003) | |
10441 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10442 | ENDIF | |
10443 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) | |
10444 | 1 CONTINUE | |
10445 | IVEOUT = 1 | |
10446 | ELSE | |
10447 | * hadron/photon/nucleus-nucleus | |
10448 | IF ((ABS(VAREHI).GT.ZERO).AND. | |
10449 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN | |
10450 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN | |
10451 | WRITE(LOUT,1004) NA,NB,NCB | |
10452 | 1004 FORMAT(1X,'variable energy run: projectile-id:', | |
10453 | & I3,' target A/Z: ',I3,' /',I3,/) | |
10454 | WRITE(LOUT,1005) | |
10455 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' | |
10456 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, | |
10457 | & ' -------------------------------------', | |
10458 | & '--------------------------------------') | |
10459 | ENDIF | |
10460 | AECMLO = LOG10(VARCLO) | |
10461 | AECMHI = LOG10(VARCHI) | |
10462 | IESTEP = NEB-1 | |
10463 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10464 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10465 | DO 3 I=1,IESTEP+1 | |
10466 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10467 | AMP = 0.938D0 | |
10468 | AMT = 0.938D0 | |
10469 | AMP2 = AMP**2 | |
10470 | AMT2 = AMT**2 | |
10471 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
10472 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) | |
10473 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) | |
10474 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10475 | & WRITE(LOUT,1006) | |
10476 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10477 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) | |
10478 | 3 CONTINUE | |
10479 | IVEOUT = 1 | |
10480 | ELSE | |
10481 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10482 | ENDIF | |
10483 | ENDIF | |
10484 | ENDIF | |
10485 | ENDIF | |
10486 | ||
10487 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. | |
10488 | & (IOGLB.NE.100)) THEN | |
10489 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, | |
10490 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) | |
10491 | 1001 FORMAT(38X,'projectile', | |
10492 | & ' target',/,1X,'Mass number / charge', | |
10493 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, | |
10494 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, | |
10495 | & 'Parameters of elastic scattering amplitude:',/,5X, | |
10496 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', | |
10497 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, | |
10498 | & 'statistics at each b-step',4X,I5,/,/,1X, | |
10499 | & 'Prod. cross section ',5X,F10.4,' mb',/) | |
10500 | ENDIF | |
10501 | ||
10502 | RETURN | |
10503 | END | |
10504 | ||
10505 | *$ CREATE DT_PROFBI.FOR | |
10506 | *COPY DT_PROFBI | |
10507 | * | |
10508 | *===profbi=============================================================* | |
10509 | * | |
10510 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) | |
10511 | ||
10512 | ************************************************************************ | |
10513 | * Integral over profile function (to be used for impact-parameter * | |
10514 | * sampling during event generation). * | |
10515 | * Fitted results are used. * | |
10516 | * NA / NB mass numbers of proj./target nuclei * | |
10517 | * PPN projectile momentum (for projectile nuclei: * | |
10518 | * momentum per nucleon) in target rest system * | |
10519 | * NTARG index of target material (i.e. kind of nucleus) * | |
10520 | * This version dated 31.05.95 is revised by S. Roesler * | |
10521 | ************************************************************************ | |
10522 | ||
10523 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10524 | SAVE | |
10525 | PARAMETER ( LINP = 10 , | |
10526 | & LOUT = 6 , | |
10527 | & LDAT = 9 ) | |
454792a9 | 10528 | CPH SAVE |
9aaba0d6 | 10529 | |
10530 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
10531 | ||
10532 | LOGICAL LSTART | |
10533 | CHARACTER CNAME*80 | |
10534 | ||
10535 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10536 | * Glauber formalism: parameters | |
10537 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10538 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10539 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10540 | & NSITEB,NSTATB | |
10541 | * Glauber formalism: cross sections | |
10542 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10543 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10544 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10545 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10546 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10547 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10548 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10549 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10550 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10551 | & BSLOPE,NEBINI,NQBINI | |
10552 | ||
10553 | PARAMETER (NGLMAX=8000) | |
10554 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), | |
10555 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) | |
10556 | ||
10557 | DATA LSTART /.TRUE./ | |
10558 | ||
10559 | IF (LSTART) THEN | |
10560 | * read fit-parameters from file | |
10561 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') | |
10562 | I = 0 | |
10563 | 1 CONTINUE | |
10564 | READ(47,'(A80)') CNAME | |
10565 | IF (CNAME.EQ.'STOP') GOTO 2 | |
10566 | I = I+1 | |
10567 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), | |
10568 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), | |
10569 | & GLAFIT(4,I),GLAFIT(5,I) | |
10570 | IF (I+1.GT.NGLMAX) THEN | |
10571 | WRITE(LOUT,1000) | |
10572 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', | |
10573 | & 'program stopped') | |
10574 | STOP | |
10575 | ENDIF | |
10576 | GOTO 1 | |
10577 | 2 CONTINUE | |
10578 | NGLPAR = I | |
10579 | LSTART = .FALSE. | |
10580 | ENDIF | |
10581 | ||
10582 | NNA = NA | |
10583 | NNB = NB | |
10584 | IF (NA.GT.NB) THEN | |
10585 | NNA = NB | |
10586 | NNB = NA | |
10587 | ENDIF | |
10588 | IDXGLA = 0 | |
10589 | DO 3 J=1,NGLPAR | |
10590 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN | |
10591 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) | |
10592 | DO 4 K=1,J-1 | |
10593 | IPOINT = J-K | |
10594 | IF (J.EQ.NGLPAR) IPOINT = J+1-K | |
10595 | IF ((NNA.GT.NGLIP(IPOINT)).OR. | |
10596 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN | |
10597 | IF (IPOINT.EQ.1) IPOINT = 0 | |
10598 | NATMP = NGLIP(IPOINT+1) | |
10599 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN | |
10600 | IDXGLA = IPOINT+1 | |
10601 | GOTO 6 | |
10602 | ELSE | |
10603 | J1BEG = IPOINT+1 | |
10604 | J1END = J | |
10605 | C IF (J.EQ.NGLPAR) THEN | |
10606 | C J1BEG = IPOINT | |
10607 | C J1END = J | |
10608 | C ENDIF | |
10609 | DO 5 J1=J1BEG,J1END | |
10610 | IF (NGLIP(J1).EQ.NATMP) THEN | |
10611 | IF (PPN.LT.GLAPPN(J1)) THEN | |
10612 | IDXGLA = J1 | |
10613 | GOTO 6 | |
10614 | ENDIF | |
10615 | ELSE | |
10616 | IDXGLA = J1-1 | |
10617 | GOTO 6 | |
10618 | ENDIF | |
10619 | 5 CONTINUE | |
10620 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) | |
10621 | & IDXGLA = NGLPAR | |
10622 | ENDIF | |
10623 | ENDIF | |
10624 | 4 CONTINUE | |
10625 | ENDIF | |
10626 | 3 CONTINUE | |
10627 | ||
10628 | 6 CONTINUE | |
10629 | IF (IDXGLA.EQ.0) THEN | |
10630 | WRITE(LOUT,1001) NNA,NNB,PPN | |
10631 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', | |
10632 | & 2I4,F6.0,') not found ') | |
10633 | STOP | |
10634 | ENDIF | |
10635 | ||
10636 | * no interpolation yet available | |
10637 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) | |
10638 | ||
10639 | BSITE(1,1,NTARG,1) = ZERO | |
10640 | DO 10 I=2,NSITEB | |
10641 | XX = DBLE(I) | |
10642 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ | |
10643 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ | |
10644 | & GLAFIT(5,IDXGLA)*XX**4 | |
10645 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) | |
10646 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) | |
10647 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO | |
10648 | 10 CONTINUE | |
10649 | ||
10650 | RETURN | |
10651 | END | |
10652 | ||
10653 | *$ CREATE DT_GLAUBE.FOR | |
10654 | *COPY DT_GLAUBE | |
10655 | * | |
10656 | *===glaube=============================================================* | |
10657 | * | |
10658 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) | |
10659 | ||
10660 | ************************************************************************ | |
10661 | * Calculation of configuartion of interacting nucleons for one event. * | |
10662 | * NB / NB mass numbers of proj./target nuclei (input) * | |
10663 | * B impact parameter (output) * | |
10664 | * INTT total number of wounded nucleons " * | |
10665 | * INTA / INTB number of wounded nucleons in proj. / target " * | |
10666 | * JS / JT(i) number of collisions proj. / target nucleon i is * | |
10667 | * involved (output) * | |
10668 | * NIDX index of projectile/target material (input) * | |
10669 | * = -2 call within FLUKA transport calculation * | |
10670 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * | |
10671 | * This version dated 22.03.96 is revised by S. Roesler * | |
10672 | * * | |
10673 | * Last change 27.12.2006 by S. Roesler. * | |
10674 | ************************************************************************ | |
10675 | ||
10676 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10677 | SAVE | |
10678 | PARAMETER ( LINP = 10 , | |
10679 | & LOUT = 6 , | |
10680 | & LDAT = 9 ) | |
10681 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
10682 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
10683 | ||
10684 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10685 | PARAMETER ( MAXNCL = 260, | |
10686 | & MAXVQU = MAXNCL, | |
10687 | & MAXSQU = 20*MAXVQU, | |
10688 | & MAXINT = MAXVQU+MAXSQU) | |
10689 | * Glauber formalism: parameters | |
10690 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10691 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10692 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10693 | & NSITEB,NSTATB | |
10694 | * Glauber formalism: cross sections | |
10695 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10696 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10697 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10698 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10699 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10700 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10701 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10702 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10703 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10704 | & BSLOPE,NEBINI,NQBINI | |
10705 | * Lorentz-parameters of the current interaction | |
10706 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10707 | & UMO,PPCM,EPROJ,PPROJ | |
10708 | * properties of photon/lepton projectiles | |
10709 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10710 | * Glauber formalism: collision properties | |
10711 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
10712 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
10713 | * Glauber formalism: flags and parameters for statistics | |
10714 | LOGICAL LPROD | |
10715 | CHARACTER*8 CGLB | |
10716 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10717 | ||
10718 | DIMENSION JS(MAXNCL),JT(MAXNCL) | |
10719 | ||
10720 | NTARG = ABS(NIDX) | |
10721 | ||
10722 | * get actual energy from /DTLTRA/ | |
10723 | ECMNOW = UMO | |
10724 | Q2 = VIRT | |
10725 | * | |
10726 | * new patch for pre-initialized variable projectile/target/energy runs, | |
10727 | * bypassed for use within FLUKA (Nidx=-2) | |
10728 | IF (IOGLB.EQ.100) THEN | |
10729 | IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) | |
10730 | * | |
10731 | * variable energy run, interpolate profile function | |
10732 | ELSE | |
10733 | I1 = 1 | |
10734 | I2 = 1 | |
10735 | RATE = ONE | |
10736 | IF (NEBINI.GT.1) THEN | |
10737 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN | |
10738 | I1 = NEBINI | |
10739 | I2 = NEBINI | |
10740 | RATE = ONE | |
10741 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN | |
10742 | DO 1 I=2,NEBINI | |
10743 | IF (ECMNOW.LT.ECMNN(I)) THEN | |
10744 | I1 = I-1 | |
10745 | I2 = I | |
10746 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
10747 | GOTO 2 | |
10748 | ENDIF | |
10749 | 1 CONTINUE | |
10750 | 2 CONTINUE | |
10751 | ENDIF | |
10752 | ENDIF | |
10753 | J1 = 1 | |
10754 | J2 = 1 | |
10755 | RATQ = ONE | |
10756 | IF (NQBINI.GT.1) THEN | |
10757 | IF (Q2.GE.Q2G(NQBINI)) THEN | |
10758 | J1 = NQBINI | |
10759 | J2 = NQBINI | |
10760 | RATQ = ONE | |
10761 | ELSEIF (Q2.GT.Q2G(1)) THEN | |
10762 | DO 3 I=2,NQBINI | |
10763 | IF (Q2.LT.Q2G(I)) THEN | |
10764 | J1 = I-1 | |
10765 | J2 = I | |
10766 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ | |
10767 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
10768 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
10769 | GOTO 4 | |
10770 | ENDIF | |
10771 | 3 CONTINUE | |
10772 | 4 CONTINUE | |
10773 | ENDIF | |
10774 | ENDIF | |
10775 | ||
10776 | DO 5 I=1,KSITEB | |
10777 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ | |
10778 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10779 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10780 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ | |
10781 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) | |
10782 | 5 CONTINUE | |
10783 | ENDIF | |
10784 | ||
10785 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) | |
10786 | IF (NIDX.LE.-1) THEN | |
10787 | RPROJ = RASH(1) | |
10788 | RTARG = RBSH(NTARG) | |
10789 | ELSE | |
10790 | RPROJ = RASH(NTARG) | |
10791 | RTARG = RBSH(1) | |
10792 | ENDIF | |
10793 | ||
10794 | RETURN | |
10795 | END | |
10796 | ||
10797 | *$ CREATE DT_DIAGR.FOR | |
10798 | *COPY DT_DIAGR | |
10799 | * | |
10800 | *===diagr==============================================================* | |
10801 | * | |
10802 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, | |
10803 | & NIDX) | |
10804 | ||
10805 | ************************************************************************ | |
10806 | * Based on the original version by Shmakov et al. * | |
10807 | * This version dated 21.04.95 is revised by S. Roesler * | |
10808 | ************************************************************************ | |
10809 | ||
10810 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10811 | SAVE | |
10812 | PARAMETER ( LINP = 10 , | |
10813 | & LOUT = 6 , | |
10814 | & LDAT = 9 ) | |
10815 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10816 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
10817 | & PI = TWOPI/TWO, | |
10818 | & GEV2MB = 0.38938D0, | |
10819 | & GEV2FM = 0.1972D0, | |
10820 | & ALPHEM = ONE/137.0D0, | |
10821 | * proton mass | |
10822 | & AMP = 0.938D0, | |
10823 | & AMP2 = AMP**2, | |
10824 | * rho0 mass | |
10825 | & AMRHO0 = 0.77D0) | |
10826 | ||
10827 | COMPLEX*16 C,CA,CI | |
10828 | PARAMETER ( MAXNCL = 260, | |
10829 | & MAXVQU = MAXNCL, | |
10830 | & MAXSQU = 20*MAXVQU, | |
10831 | & MAXINT = MAXVQU+MAXSQU) | |
10832 | * particle properties (BAMJET index convention) | |
10833 | CHARACTER*8 ANAME | |
10834 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
10835 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
10836 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10837 | * emulsion treatment | |
10838 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
10839 | & NCOMPO,IEMUL | |
10840 | * Glauber formalism: parameters | |
10841 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10842 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10843 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10844 | & NSITEB,NSTATB | |
10845 | * Glauber formalism: cross sections | |
10846 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10847 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10848 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10849 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10850 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10851 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10852 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10853 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10854 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10855 | & BSLOPE,NEBINI,NQBINI | |
10856 | * VDM parameter for photon-nucleus interactions | |
10857 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
10858 | * nucleon-nucleon event-generator | |
10859 | CHARACTER*8 CMODEL | |
10860 | LOGICAL LPHOIN | |
10861 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10862 | **PHOJET105a | |
10863 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10864 | **PHOJET112 | |
10865 | C obsolete cut-off information | |
10866 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN | |
10867 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10868 | ** | |
10869 | * coordinates of nucleons | |
10870 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
10871 | * interface between Glauber formalism and DPM | |
10872 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
10873 | & INTER1(MAXINT),INTER2(MAXINT) | |
10874 | * statistics: Glauber-formalism | |
10875 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
10876 | * n-n cross section fluctuations | |
10877 | PARAMETER (NBINS = 1000) | |
10878 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
10879 | ||
10880 | DIMENSION JS(MAXNCL),JT(MAXNCL), | |
10881 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), | |
10882 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) | |
10883 | DIMENSION NWA(0:210),NWB(0:210) | |
10884 | ||
10885 | LOGICAL LFIRST | |
10886 | DATA LFIRST /.TRUE./ | |
10887 | ||
10888 | DATA NTARGO,ICNT /0,0/ | |
10889 | ||
10890 | NTARG = ABS(NIDX) | |
10891 | ||
10892 | IF (LFIRST) THEN | |
10893 | LFIRST = .FALSE. | |
10894 | IF (NCOMPO.EQ.0) THEN | |
10895 | NCALL = 0 | |
10896 | NWAMAX = NA | |
10897 | NWBMAX = NB | |
10898 | DO 17 I=0,210 | |
10899 | NWA(I) = 0 | |
10900 | NWB(I) = 0 | |
10901 | 17 CONTINUE | |
10902 | ENDIF | |
10903 | ENDIF | |
10904 | IF (NTARG.EQ.-1) THEN | |
10905 | IF (NCOMPO.EQ.0) THEN | |
10906 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' | |
10907 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', | |
10908 | & NCALL,NWAMAX,NWBMAX | |
10909 | DO 18 I=1,MAX(NWAMAX,NWBMAX) | |
10910 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') | |
10911 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), | |
10912 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) | |
10913 | 18 CONTINUE | |
10914 | ENDIF | |
10915 | RETURN | |
10916 | ENDIF | |
10917 | ||
10918 | DCOH = 1.0D10 | |
10919 | IPNT = 0 | |
10920 | ||
10921 | SQ2 = Q2 | |
10922 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 | |
10923 | S = ECMNOW**2 | |
10924 | X = SQ2/(S+SQ2-AMP2) | |
10925 | XNU = (S+SQ2-AMP2)/(TWO*AMP) | |
10926 | * photon projectiles: recalculate photon-nucleon amplitude | |
10927 | IF (IJPROJ.EQ.7) THEN | |
10928 | 15 CONTINUE | |
10929 | * VDM assumption: mass of V-meson | |
10930 | AMV2 = DT_SAM2(SQ2,ECMNOW) | |
10931 | AMV = SQRT(AMV2) | |
10932 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 | |
10933 | * check for pointlike interaction | |
10934 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) | |
10935 | **sr 27.10. | |
10936 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10937 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10938 | ** | |
10939 | ROSH = 0.1D0 | |
10940 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) | |
10941 | & +0.25D0*LOG(S/(AMV2+SQ2))) | |
10942 | * coherence length | |
10943 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM | |
10944 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
10945 | IF (MCGENE.EQ.2) THEN | |
10946 | ZERO1 = ZERO | |
10947 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, | |
10948 | & BSLOPE,0) | |
10949 | ELSE | |
10950 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
10951 | ENDIF | |
10952 | IF (ECMNOW.LE.3.0D0) THEN | |
10953 | ROSH = -0.43D0 | |
10954 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN | |
10955 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) | |
10956 | ELSEIF (ECMNOW.GT.50.0D0) THEN | |
10957 | ROSH = 0.1D0 | |
10958 | ENDIF | |
10959 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10960 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10961 | IF (MCGENE.EQ.2) THEN | |
10962 | ZERO1 = ZERO | |
10963 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, | |
10964 | & BDUM,0) | |
10965 | SIGSH = SIGSH/10.0D0 | |
10966 | ELSE | |
10967 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10968 | DUMZER = ZERO | |
10969 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10970 | SIGSH = SIGSH/10.0D0 | |
10971 | ENDIF | |
10972 | ELSE | |
10973 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
10974 | ROSH = 0.01D0 | |
10975 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10976 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10977 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10978 | DUMZER = ZERO | |
10979 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10980 | SIGSH = SIGSH/10.0D0 | |
10981 | ENDIF | |
10982 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
10983 | GAM = GSH | |
10984 | RCA = GAM*SIGSH/TWOPI | |
10985 | FCA = -ROSH*RCA | |
10986 | CA = DCMPLX(RCA,FCA) | |
10987 | CI = DCMPLX(ONE,ZERO) | |
10988 | ||
10989 | 16 CONTINUE | |
10990 | * impact parameter | |
10991 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) | |
10992 | ||
10993 | NTRY = 0 | |
10994 | 3 CONTINUE | |
10995 | NTRY = NTRY+1 | |
10996 | * initializations | |
10997 | JNT = 0 | |
10998 | DO 1 I=1,NA | |
10999 | JS(I) = 0 | |
11000 | 1 CONTINUE | |
11001 | DO 2 I=1,NB | |
11002 | JT(I) = 0 | |
11003 | 2 CONTINUE | |
11004 | IF (IJPROJ.EQ.7) THEN | |
11005 | DO 8 I=1,MAXNCL | |
11006 | JS0(I) = 0 | |
11007 | JNT0(I)= 0 | |
11008 | DO 9 J=1,NB | |
11009 | JT0(I,J) = 0 | |
11010 | 9 CONTINUE | |
11011 | 8 CONTINUE | |
11012 | ENDIF | |
11013 | ||
11014 | * nucleon configuration | |
11015 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN | |
11016 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN | |
11017 | C CALL DT_CONUCL(PKOO,NA,RASH,2) | |
11018 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) | |
11019 | IF (NIDX.LE.-1) THEN | |
11020 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) | |
11021 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) | |
11022 | ELSE | |
11023 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) | |
11024 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) | |
11025 | ENDIF | |
11026 | NTARGO = NTARG | |
11027 | ENDIF | |
11028 | ICNT = ICNT+1 | |
11029 | ||
11030 | * LEPTO: pick out one struck nucleon | |
11031 | IF (MCGENE.EQ.3) THEN | |
11032 | JNT = 1 | |
11033 | JS(1) = 1 | |
11034 | IDX = INT(DT_RNDM(X)*NB)+1 | |
11035 | JT(IDX) = 1 | |
11036 | B = ZERO | |
11037 | GOTO 19 | |
11038 | ENDIF | |
11039 | ||
11040 | DO 4 INA=1,NA | |
11041 | * cross section fluctuations | |
11042 | AFLUC = ONE | |
11043 | IF (IFLUCT.EQ.1) THEN | |
11044 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) | |
11045 | AFLUC = FLUIXX(IFLUK) | |
11046 | ENDIF | |
11047 | KK1 = 1 | |
11048 | KINT = 1 | |
11049 | DO 5 INB=1,NB | |
11050 | * photon-projectile: check for supression by coherence length | |
11051 | IF (IJPROJ.EQ.7) THEN | |
11052 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN | |
11053 | KK1 = INB | |
11054 | KINT = KINT+1 | |
11055 | ENDIF | |
11056 | ENDIF | |
11057 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) | |
11058 | QQ2 = TKOO(2,INB)-PKOO(2,INA) | |
11059 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) | |
11060 | IF (XY.LE.15.0D0) THEN | |
11061 | C = CI-CA*AFLUC*EXP(-XY) | |
11062 | AR = DBLE(C) | |
11063 | AI = DIMAG(C) | |
11064 | P = AR*AR+AI*AI | |
11065 | IF (DT_RNDM(XY).GE.P) THEN | |
11066 | JNT = JNT+1 | |
11067 | IF (IJPROJ.EQ.7) THEN | |
11068 | JNT0(KINT) = JNT0(KINT)+1 | |
11069 | IF (JNT0(KINT).GT.MAXNCL) THEN | |
11070 | WRITE(LOUT,1001) MAXNCL | |
11071 | 1001 FORMAT(1X, | |
11072 | & 'DIAGR: no. of requested interactions', | |
11073 | & ' exceeds array dimensions ',I4) | |
11074 | STOP | |
11075 | ENDIF | |
11076 | JS0(KINT) = JS0(KINT)+1 | |
11077 | JT0(KINT,INB) = JT0(KINT,INB)+1 | |
11078 | JI1(KINT,JNT0(KINT)) = INA | |
11079 | JI2(KINT,JNT0(KINT)) = INB | |
11080 | ELSE | |
11081 | IF (JNT.GT.MAXINT) THEN | |
11082 | WRITE(LOUT,1000) JNT, MAXINT | |
11083 | 1000 FORMAT(1X, | |
11084 | & 'DIAGR: no. of requested interactions (' | |
11085 | & ,I4,') exceeds array dimensions (',I4,')') | |
11086 | STOP | |
11087 | ENDIF | |
11088 | JS(INA) = JS(INA)+1 | |
11089 | JT(INB) = JT(INB)+1 | |
11090 | INTER1(JNT) = INA | |
11091 | INTER2(JNT) = INB | |
11092 | ENDIF | |
11093 | ENDIF | |
11094 | ENDIF | |
11095 | 5 CONTINUE | |
11096 | 4 CONTINUE | |
11097 | ||
11098 | IF (JNT.EQ.0) THEN | |
11099 | IF (NTRY.LT.500) THEN | |
11100 | GOTO 3 | |
11101 | ELSE | |
11102 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' | |
11103 | GOTO 16 | |
11104 | ENDIF | |
11105 | ENDIF | |
11106 | ||
11107 | IDIREC = 0 | |
11108 | IF (IJPROJ.EQ.7) THEN | |
11109 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) | |
11110 | 10 CONTINUE | |
11111 | IF (JNT0(K).EQ.0) THEN | |
11112 | K = K+1 | |
11113 | IF (K.GT.KINT) K = 1 | |
11114 | GOTO 10 | |
11115 | ENDIF | |
11116 | * supress Glauber-cascade by direct photon processes | |
11117 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) | |
11118 | IF (IPNT.GT.0) THEN | |
11119 | JNT = 1 | |
11120 | JS(1) = 1 | |
11121 | DO 11 INB=1,NB | |
11122 | JT(INB) = JT0(K,INB) | |
11123 | IF (JT(INB).GT.0) GOTO 12 | |
11124 | 11 CONTINUE | |
11125 | 12 CONTINUE | |
11126 | INTER1(1) = 1 | |
11127 | INTER2(1) = INB | |
11128 | IDIREC = IPNT | |
11129 | ELSE | |
11130 | JNT = JNT0(K) | |
11131 | JS(1) = JS0(K) | |
11132 | DO 13 INB=1,NB | |
11133 | JT(INB) = JT0(K,INB) | |
11134 | 13 CONTINUE | |
11135 | DO 14 I=1,JNT | |
11136 | INTER1(I) = JI1(K,I) | |
11137 | INTER2(I) = JI2(K,I) | |
11138 | 14 CONTINUE | |
11139 | ENDIF | |
11140 | ENDIF | |
11141 | ||
11142 | 19 CONTINUE | |
11143 | INTA = 0 | |
11144 | INTB = 0 | |
11145 | DO 6 I=1,NA | |
11146 | IF (JS(I).NE.0) INTA=INTA+1 | |
11147 | 6 CONTINUE | |
11148 | DO 7 I=1,NB | |
11149 | IF (JT(I).NE.0) INTB=INTB+1 | |
11150 | 7 CONTINUE | |
11151 | ICWPG = INTA | |
11152 | ICWTG = INTB | |
11153 | ICIG = JNT | |
11154 | IPGLB = IPGLB+INTA | |
11155 | ITGLB = ITGLB+INTB | |
11156 | NGLB = NGLB+1 | |
11157 | ||
11158 | IF (NCOMPO.EQ.0) THEN | |
11159 | NCALL = NCALL+1 | |
11160 | NWA(INTA) = NWA(INTA)+1 | |
11161 | NWB(INTB) = NWB(INTB)+1 | |
11162 | ENDIF | |
11163 | ||
11164 | RETURN | |
11165 | END | |
11166 | ||
11167 | *$ CREATE DT_MODB.FOR | |
11168 | *COPY DT_MODB | |
11169 | * | |
11170 | *===modb===============================================================* | |
11171 | * | |
11172 | SUBROUTINE DT_MODB(B,NIDX) | |
11173 | ||
11174 | ************************************************************************ | |
11175 | * Sampling of impact parameter of collision. * | |
11176 | * B impact parameter (output) * | |
11177 | * NIDX index of projectile/target material (input)* | |
11178 | * Based on the original version by Shmakov et al. * | |
11179 | * This version dated 21.04.95 is revised by S. Roesler * | |
11180 | * * | |
11181 | * Last change 27.12.2006 by S. Roesler. * | |
11182 | ************************************************************************ | |
11183 | ||
11184 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11185 | SAVE | |
11186 | PARAMETER ( LINP = 10 , | |
11187 | & LOUT = 6 , | |
11188 | & LDAT = 9 ) | |
11189 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) | |
11190 | ||
11191 | LOGICAL LEFT,LFIRST | |
11192 | ||
11193 | * central particle production, impact parameter biasing | |
11194 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
11195 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11196 | * Glauber formalism: parameters | |
11197 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11198 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11199 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11200 | & NSITEB,NSTATB | |
11201 | * Glauber formalism: cross sections | |
11202 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11203 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11204 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11205 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11206 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11207 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11208 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11209 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11210 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11211 | & BSLOPE,NEBINI,NQBINI | |
11212 | ||
11213 | DATA LFIRST /.TRUE./ | |
11214 | ||
11215 | NTARG = ABS(NIDX) | |
11216 | IF (NIDX.LE.-1) THEN | |
11217 | RA = RASH(1) | |
11218 | RB = RBSH(NTARG) | |
11219 | ELSE | |
11220 | RA = RASH(NTARG) | |
11221 | RB = RBSH(1) | |
11222 | ENDIF | |
11223 | ||
11224 | IF (ICENTR.EQ.2) THEN | |
11225 | IF (RA.EQ.RB) THEN | |
11226 | BB = DT_RNDM(B)*(0.3D0*RA)**2 | |
11227 | B = SQRT(BB) | |
11228 | ELSEIF(RA.LT.RB)THEN | |
11229 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 | |
11230 | B = SQRT(BB) | |
11231 | ELSEIF(RA.GT.RB)THEN | |
11232 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 | |
11233 | B = SQRT(BB) | |
11234 | ENDIF | |
11235 | ELSE | |
11236 | 9 CONTINUE | |
11237 | Y = DT_RNDM(BB) | |
11238 | I0 = 1 | |
11239 | I2 = NSITEB | |
11240 | 10 CONTINUE | |
11241 | I1 = (I0+I2)/2 | |
11242 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) | |
11243 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO | |
11244 | IF (LEFT) GOTO 20 | |
11245 | I0 = I1 | |
11246 | GOTO 30 | |
11247 | 20 CONTINUE | |
11248 | I2 = I1 | |
11249 | 30 CONTINUE | |
11250 | IF (I2-I0-2) 40,50,60 | |
11251 | 40 CONTINUE | |
11252 | I1 = I2+1 | |
11253 | IF (I1.GT.NSITEB) I1 = I0-1 | |
11254 | GOTO 70 | |
11255 | 50 CONTINUE | |
11256 | I1 = I0+1 | |
11257 | GOTO 70 | |
11258 | 60 CONTINUE | |
11259 | GOTO 10 | |
11260 | 70 CONTINUE | |
11261 | X0 = DBLE(I0-1)*BSTEP(NTARG) | |
11262 | X1 = DBLE(I1-1)*BSTEP(NTARG) | |
11263 | X2 = DBLE(I2-1)*BSTEP(NTARG) | |
11264 | Y0 = BSITE(0,1,NTARG,I0) | |
11265 | Y1 = BSITE(0,1,NTARG,I1) | |
11266 | Y2 = BSITE(0,1,NTARG,I2) | |
11267 | 80 CONTINUE | |
11268 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ | |
11269 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ | |
11270 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) | |
11271 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD | |
11272 | B = B+0.5D0*BSTEP(NTARG) | |
11273 | IF (B.LT.ZERO) B = X1 | |
11274 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) | |
11275 | IF (ICENTR.LT.0) THEN | |
11276 | IF (LFIRST) THEN | |
11277 | LFIRST = .FALSE. | |
11278 | IF (ICENTR.LE.-100) THEN | |
11279 | BIMIN = 0.0D0 | |
11280 | ELSE | |
11281 | XSFRAC = 0.0D0 | |
11282 | ENDIF | |
11283 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) | |
11284 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), | |
11285 | & BIMIN,BIMAX,XSFRAC*100.0D0, | |
11286 | & XSFRAC*XSPRO(1,1,NTARG) | |
11287 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', | |
11288 | & /,15X,'---------------------------'/,/,4X, | |
11289 | & 'average radii of proj / targ :',F10.3,' fm /', | |
11290 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', | |
11291 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', | |
11292 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', | |
11293 | & ' cross section :',F10.3,' %',/,5X, | |
11294 | & 'corresponding cross section :',F10.3,' mb',/) | |
11295 | ENDIF | |
11296 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN | |
11297 | B = BIMIN | |
11298 | ELSE | |
11299 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 | |
11300 | ENDIF | |
11301 | ENDIF | |
11302 | ENDIF | |
11303 | ||
11304 | RETURN | |
11305 | END | |
11306 | ||
11307 | *$ CREATE DT_SHFAST.FOR | |
11308 | *COPY DT_SHFAST | |
11309 | * | |
11310 | *===shfast=============================================================* | |
11311 | * | |
11312 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) | |
11313 | ||
11314 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11315 | SAVE | |
11316 | PARAMETER ( LINP = 10 , | |
11317 | & LOUT = 6 , | |
11318 | & LDAT = 9 ) | |
11319 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, | |
11320 | & ONE=1.0D0,TWO=2.0D0) | |
11321 | ||
11322 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11323 | * Glauber formalism: parameters | |
11324 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11325 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11326 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11327 | & NSITEB,NSTATB | |
11328 | * properties of interacting particles | |
11329 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11330 | * Glauber formalism: cross sections | |
11331 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11332 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11333 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11334 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11335 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11336 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11337 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11338 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11339 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11340 | & BSLOPE,NEBINI,NQBINI | |
11341 | ||
11342 | IBACK = 0 | |
11343 | ||
11344 | IF (MODE.EQ.2) THEN | |
11345 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11346 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN | |
11347 | 1000 FORMAT(1X,8I5,E15.5) | |
11348 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11349 | 1001 FORMAT(1X,4E15.5) | |
11350 | WRITE(47,1002) SIGSH,ROSH,GSH | |
11351 | 1002 FORMAT(1X,3E15.5) | |
11352 | DO 10 I=1,100 | |
11353 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11354 | 10 CONTINUE | |
11355 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11356 | 1003 FORMAT(1X,2I10,3E15.5) | |
11357 | CLOSE(47) | |
11358 | ELSE | |
11359 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11360 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP | |
11361 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. | |
11362 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) | |
11363 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. | |
11364 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN | |
11365 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11366 | READ(47,1002) SIGSH,ROSH,GSH | |
11367 | DO 11 I=1,100 | |
11368 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11369 | 11 CONTINUE | |
11370 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11371 | ELSE | |
11372 | IBACK = 1 | |
11373 | ENDIF | |
11374 | CLOSE(47) | |
11375 | ENDIF | |
11376 | ||
11377 | RETURN | |
11378 | END | |
11379 | ||
11380 | *$ CREATE DT_POILIK.FOR | |
11381 | *COPY DT_POILIK | |
11382 | * | |
11383 | *===poilik=============================================================* | |
11384 | * | |
11385 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) | |
11386 | ||
11387 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
11388 | SAVE | |
11389 | ||
11390 | PARAMETER ( LINP = 10 , | |
11391 | & LOUT = 6 , | |
11392 | & LDAT = 9 ) | |
11393 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) | |
11394 | PARAMETER (NE = 8) | |
11395 | ||
11396 | **PHOJET105a | |
11397 | C CHARACTER*8 MDLNA | |
11398 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
11399 | C PARAMETER (IEETAB=10) | |
11400 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
11401 | **PHOJET110 | |
11402 | C model switches and parameters | |
11403 | CHARACTER*8 MDLNA | |
11404 | INTEGER ISWMDL,IPAMDL | |
11405 | DOUBLE PRECISION PARMDL | |
11406 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
11407 | C energy-interpolation table | |
11408 | INTEGER IEETA2 | |
11409 | PARAMETER ( IEETA2 = 20 ) | |
11410 | INTEGER ISIMAX | |
11411 | DOUBLE PRECISION SIGTAB,SIGECM | |
11412 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
11413 | ** | |
11414 | * VDM parameter for photon-nucleus interactions | |
11415 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
11416 | **sr 22.7.97 | |
11417 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11418 | * Glauber formalism: cross sections | |
11419 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11420 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11421 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11422 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11423 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11424 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11425 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11426 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11427 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11428 | & BSLOPE,NEBINI,NQBINI | |
11429 | ** | |
11430 | ||
11431 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ | |
11432 | ||
11433 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 | |
11434 | ||
11435 | * load cross sections from interpolation table | |
11436 | IP = 1 | |
11437 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
11438 | I1 = 1 | |
11439 | I2 = 1 | |
11440 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
11441 | DO 50 I=2,ISIMAX | |
11442 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 | |
11443 | 50 CONTINUE | |
11444 | 200 CONTINUE | |
11445 | I1 = I-1 | |
11446 | I2 = I | |
11447 | ELSE | |
11448 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
11449 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
11450 | I1 = ISIMAX | |
11451 | I2 = ISIMAX | |
11452 | ENDIF | |
11453 | FAC2 = ZERO | |
11454 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) | |
11455 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
11456 | FAC1 = ONE-FAC2 | |
11457 | ||
11458 | SIGANO = DT_SANO(ECM) | |
11459 | ||
11460 | * cross section dependence on photon virtuality | |
11461 | FSUP1 = ZERO | |
11462 | DO 150 I=1,3 | |
11463 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) | |
11464 | & /(ONE+VIRT/PARMDL(30+I))**2 | |
11465 | 150 CONTINUE | |
11466 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) | |
11467 | FAC1 = FAC1*FSUP1 | |
11468 | FAC2 = FAC2*FSUP1 | |
11469 | FSUP2 = ONE | |
11470 | ||
11471 | ECMOLD = ECM | |
11472 | Q2OLD = VIRT | |
11473 | ||
11474 | 3 CONTINUE | |
11475 | ||
11476 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
11477 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) | |
11478 | IF (ISHAD(1).EQ.1) THEN | |
11479 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
11480 | ELSE | |
11481 | SIGDIR = ZERO | |
11482 | ENDIF | |
11483 | SIGANO = FSUP1*FSUP2*SIGANO | |
11484 | SIGTOT = SIGTOT-SIGDIR-SIGANO | |
11485 | SIGDIR = SIGDIR/(FSUP1*FSUP2) | |
11486 | SIGANO = SIGANO/(FSUP1*FSUP2) | |
11487 | SIGTOT = SIGTOT+SIGDIR+SIGANO | |
11488 | ||
11489 | RR = DT_RNDM(SIGTOT) | |
11490 | IF (RR.LT.SIGDIR/SIGTOT) THEN | |
11491 | IPNT = 1 | |
11492 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. | |
11493 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN | |
11494 | IPNT = 2 | |
11495 | ELSE | |
11496 | IPNT = 0 | |
11497 | ENDIF | |
11498 | RPNT = (SIGDIR+SIGANO)/SIGTOT | |
11499 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 | |
11500 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO | |
11501 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM | |
11502 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT | |
11503 | IF (MODE.EQ.1) RETURN | |
11504 | ||
11505 | **sr 22.7.97 | |
11506 | K1 = 1 | |
11507 | K2 = 1 | |
11508 | RATE = ZERO | |
11509 | IF (ECM.GE.ECMNN(NEBINI)) THEN | |
11510 | K1 = NEBINI | |
11511 | K2 = NEBINI | |
11512 | RATE = ONE | |
11513 | ELSEIF (ECM.GT.ECMNN(1)) THEN | |
11514 | DO 10 I=2,NEBINI | |
11515 | IF (ECM.LT.ECMNN(I)) THEN | |
11516 | K1 = I-1 | |
11517 | K2 = I | |
11518 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) | |
11519 | GOTO 11 | |
11520 | ENDIF | |
11521 | 10 CONTINUE | |
11522 | 11 CONTINUE | |
11523 | ENDIF | |
11524 | J1 = 1 | |
11525 | J2 = 1 | |
11526 | RATQ = ZERO | |
11527 | IF (NQBINI.GT.1) THEN | |
11528 | IF (VIRT.GE.Q2G(NQBINI)) THEN | |
11529 | J1 = NQBINI | |
11530 | J2 = NQBINI | |
11531 | RATQ = ONE | |
11532 | ELSEIF (VIRT.GT.Q2G(1)) THEN | |
11533 | DO 12 I=2,NQBINI | |
11534 | IF (VIRT.LT.Q2G(I)) THEN | |
11535 | J1 = I-1 | |
11536 | J2 = I | |
11537 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ | |
11538 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
11539 | GOTO 13 | |
11540 | ENDIF | |
11541 | 12 CONTINUE | |
11542 | 13 CONTINUE | |
11543 | ENDIF | |
11544 | ENDIF | |
11545 | SGA = XSPRO(K1,J1,NTARG)+ | |
11546 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11547 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11548 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ | |
11549 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) | |
11550 | SDI = DBLE(NB)*SIGDIR | |
11551 | SAN = DBLE(NB)*SIGANO | |
11552 | SPL = SDI+SAN | |
11553 | RR = DT_RNDM(SPL) | |
11554 | IF (RR.LT.SDI/SGA) THEN | |
11555 | IPNT = 1 | |
11556 | ELSEIF ((RR.GE.SDI/SGA).AND. | |
11557 | & (RR.LT.SPL/SGA)) THEN | |
11558 | IPNT = 2 | |
11559 | ELSE | |
11560 | IPNT = 0 | |
11561 | ENDIF | |
11562 | RPNT = SPL/SGA | |
11563 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM | |
11564 | ** | |
11565 | ||
11566 | RETURN | |
11567 | END | |
11568 | ||
11569 | *$ CREATE DT_GLBINI.FOR | |
11570 | *COPY DT_GLBINI | |
11571 | * | |
11572 | *===glbini=============================================================* | |
11573 | * | |
11574 | SUBROUTINE DT_GLBINI(WHAT) | |
11575 | ||
11576 | ************************************************************************ | |
11577 | * Pre-initialization of profile function * | |
11578 | * This version dated 28.11.00 is written by S. Roesler. * | |
11579 | * * | |
11580 | * Last change 27.12.2006 by S. Roesler. * | |
11581 | ************************************************************************ | |
11582 | ||
11583 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11584 | SAVE | |
11585 | ||
11586 | PARAMETER ( LINP = 10 , | |
11587 | & LOUT = 6 , | |
11588 | & LDAT = 9 ) | |
11589 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) | |
11590 | ||
11591 | LOGICAL LCMS | |
11592 | ||
11593 | * particle properties (BAMJET index convention) | |
11594 | CHARACTER*8 ANAME | |
11595 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11596 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11597 | * properties of interacting particles | |
11598 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11599 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11600 | * emulsion treatment | |
11601 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11602 | & NCOMPO,IEMUL | |
11603 | * Glauber formalism: flags and parameters for statistics | |
11604 | LOGICAL LPROD | |
11605 | CHARACTER*8 CGLB | |
11606 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11607 | * number of data sets other than protons and nuclei | |
11608 | * at the moment = 2 (pions and kaons) | |
11609 | PARAMETER (MAXOFF=2) | |
11610 | DIMENSION IJPINI(5),IOFFST(25) | |
11611 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11612 | * Glauber data-set to be used for hadron projectiles | |
11613 | * (0=proton, 1=pion, 2=kaon) | |
11614 | DATA (IOFFST(K),K=1,25) / | |
11615 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11616 | & 0, 0, 1, 2, 2/ | |
11617 | * Acceptance interval for target nucleus mass | |
11618 | PARAMETER (KBACC = 6) | |
11619 | * flags for input different options | |
11620 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
11621 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
11622 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
11623 | ||
11624 | PARAMETER (MAXMSS = 100) | |
11625 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) | |
11626 | DIMENSION WHAT(6) | |
11627 | ||
11628 | DATA JPEACH,JPSTEP / 18, 5 / | |
11629 | ||
11630 | * temporary patch until fix has been implemented in phojet: | |
11631 | * maximum energy for pion projectile | |
11632 | DATA ECMXPI / 100000.0D0 / | |
11633 | * | |
11634 | *-------------------------------------------------------------------------- | |
11635 | * general initializations | |
11636 | * | |
11637 | * steps in projectile mass number for initialization | |
11638 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) | |
11639 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) | |
11640 | * | |
11641 | * energy range and binning | |
11642 | ELO = ABS(WHAT(1)) | |
11643 | EHI = ABS(WHAT(2)) | |
11644 | IF (ELO.GT.EHI) ELO = EHI | |
11645 | NEBIN = MAX(INT(WHAT(3)),1) | |
11646 | IF (ELO.EQ.EHI) NEBIN = 0 | |
11647 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) | |
11648 | IF (LCMS) THEN | |
11649 | ECMINI = EHI | |
11650 | ELSE | |
11651 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 | |
11652 | & +2.0D0*AAM(IJTARG)*EHI) | |
11653 | ENDIF | |
11654 | * | |
11655 | * default arguments for Glauber-routine | |
11656 | XI = ZERO | |
11657 | Q2I = ZERO | |
11658 | * | |
11659 | * initialize nuclear parameters, etc. | |
11660 | CALL DT_BERTTP | |
11661 | CALL DT_INCINI | |
11662 | * | |
11663 | * open Glauber-data output file | |
11664 | IDX = INDEX(CGLB,' ') | |
11665 | K = 12 | |
11666 | IF (IDX.GT.1) K = IDX-1 | |
11667 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11668 | * | |
11669 | *-------------------------------------------------------------------------- | |
11670 | * Glauber-initialization for proton and nuclei projectiles | |
11671 | * | |
11672 | * initialize phojet for proton-proton interactions | |
11673 | ELAB = ZERO | |
11674 | PLAB = ZERO | |
11675 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11676 | CALL DT_PHOINI | |
11677 | * | |
11678 | * record projectile masses | |
11679 | NASAV = 0 | |
11680 | NPROJ = MIN(IP,JPEACH) | |
11681 | DO 10 KPROJ=1,NPROJ | |
11682 | NASAV = NASAV+1 | |
11683 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11684 | IASAV(NASAV) = KPROJ | |
11685 | 10 CONTINUE | |
11686 | IF (IP.GT.JPEACH) THEN | |
11687 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) | |
11688 | IF (NPROJ.EQ.0) THEN | |
11689 | NASAV = NASAV+1 | |
11690 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11691 | IASAV(NASAV) = IP | |
11692 | ELSE | |
11693 | DO 11 IPROJ=1,NPROJ | |
11694 | KPROJ = JPEACH+IPROJ*JPSTEP | |
11695 | NASAV = NASAV+1 | |
11696 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11697 | IASAV(NASAV) = KPROJ | |
11698 | 11 CONTINUE | |
11699 | IF (KPROJ.LT.IP) THEN | |
11700 | NASAV = NASAV+1 | |
11701 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11702 | IASAV(NASAV) = IP | |
11703 | ENDIF | |
11704 | ENDIF | |
11705 | ENDIF | |
11706 | * | |
11707 | * record target masses | |
11708 | NBSAV = 0 | |
11709 | NTARG = 1 | |
11710 | IF (NCOMPO.GT.0) NTARG = NCOMPO | |
11711 | DO 12 ITARG=1,NTARG | |
11712 | NBSAV = NBSAV+1 | |
11713 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' | |
11714 | IF (NCOMPO.GT.0) THEN | |
11715 | IBSAV(NBSAV) = IEMUMA(ITARG) | |
11716 | ELSE | |
11717 | IBSAV(NBSAV) = IT | |
11718 | ENDIF | |
11719 | 12 CONTINUE | |
11720 | * | |
11721 | * print masses | |
11722 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) | |
11723 | 1000 FORMAT(I4,A,1P,2E13.5) | |
11724 | NLINES = DBLE(NASAV)/18.0D0 | |
11725 | IF (NLINES.GT.0) THEN | |
11726 | DO 13 I=1,NLINES | |
11727 | IF (I.EQ.1) THEN | |
11728 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) | |
11729 | ELSE | |
11730 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) | |
11731 | ENDIF | |
11732 | 13 CONTINUE | |
11733 | ENDIF | |
11734 | I0 = 18*NLINES+1 | |
11735 | IF (I0.LE.NASAV) THEN | |
11736 | IF (I0.EQ.1) THEN | |
11737 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) | |
11738 | ELSE | |
11739 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) | |
11740 | ENDIF | |
11741 | ENDIF | |
11742 | NLINES = DBLE(NBSAV)/18.0D0 | |
11743 | IF (NLINES.GT.0) THEN | |
11744 | DO 14 I=1,NLINES | |
11745 | IF (I.EQ.1) THEN | |
11746 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) | |
11747 | ELSE | |
11748 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) | |
11749 | ENDIF | |
11750 | 14 CONTINUE | |
11751 | ENDIF | |
11752 | I0 = 18*NLINES+1 | |
11753 | IF (I0.LE.NBSAV) THEN | |
11754 | IF (I0.EQ.1) THEN | |
11755 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) | |
11756 | ELSE | |
11757 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) | |
11758 | ENDIF | |
11759 | ENDIF | |
11760 | * | |
11761 | * calculate Glauber-data for each energy and mass combination | |
11762 | * | |
11763 | * loop over energy bins | |
11764 | ELO = LOG10(ELO) | |
11765 | EHI = LOG10(EHI) | |
11766 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) | |
11767 | DO 1 IE=1,NEBIN+1 | |
11768 | E = ELO+DBLE(IE-1)*DEBIN | |
11769 | E = 10**E | |
11770 | IF (LCMS) THEN | |
11771 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) | |
11772 | ECM = E | |
11773 | ELSE | |
11774 | PLAB = ZERO | |
11775 | ECM = ZERO | |
11776 | E = MAX(AAM(IJPROJ)+0.1D0,E) | |
11777 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11778 | ENDIF | |
11779 | * | |
11780 | * loop over projectile and target masses | |
11781 | DO 2 ITARG=1,NBSAV | |
11782 | DO 3 IPROJ=1,NASAV | |
11783 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, | |
11784 | & XI,Q2I,ECM,1,1,-1) | |
11785 | 3 CONTINUE | |
11786 | 2 CONTINUE | |
11787 | * | |
11788 | 1 CONTINUE | |
11789 | * | |
11790 | *-------------------------------------------------------------------------- | |
11791 | * Glauber-initialization for pion, kaon, ... projectiles | |
11792 | * | |
11793 | DO 6 IJ=1,MAXOFF | |
11794 | * | |
11795 | * initialize phojet for this interaction | |
11796 | ELAB = ZERO | |
11797 | PLAB = ZERO | |
11798 | IJPROJ = IJPINI(IJ) | |
11799 | IP = 1 | |
11800 | IPZ = 1 | |
11801 | * | |
11802 | * temporary patch until fix has been implemented in phojet: | |
11803 | IF (ECMINI.GT.ECMXPI) THEN | |
11804 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) | |
11805 | ELSE | |
11806 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11807 | ENDIF | |
11808 | CALL DT_PHOINI | |
11809 | * | |
11810 | * calculate Glauber-data for each energy and mass combination | |
11811 | * | |
11812 | * loop over energy bins | |
11813 | DO 4 IE=1,NEBIN+1 | |
11814 | E = ELO+DBLE(IE-1)*DEBIN | |
11815 | E = 10**E | |
11816 | IF (LCMS) THEN | |
11817 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) | |
11818 | ECM = E | |
11819 | ELSE | |
11820 | PLAB = ZERO | |
11821 | ECM = ZERO | |
11822 | E = MAX(AAM(IJPROJ)+TINY14,E) | |
11823 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11824 | ENDIF | |
11825 | * | |
11826 | * loop over projectile and target masses | |
11827 | DO 5 ITARG=1,NBSAV | |
11828 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) | |
11829 | 5 CONTINUE | |
11830 | * | |
11831 | 4 CONTINUE | |
11832 | * | |
11833 | 6 CONTINUE | |
11834 | ||
11835 | *-------------------------------------------------------------------------- | |
11836 | * close output unit(s), etc. | |
11837 | * | |
11838 | CLOSE(LDAT) | |
11839 | ||
11840 | RETURN | |
11841 | END | |
11842 | ||
11843 | *$ CREATE DT_GLBSET.FOR | |
11844 | *COPY DT_GLBSET | |
11845 | * | |
11846 | *===glbset=============================================================* | |
11847 | * | |
11848 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) | |
11849 | ************************************************************************ | |
11850 | * Interpolation of pre-initialized profile functions * | |
11851 | * This version dated 28.11.00 is written by S. Roesler. * | |
11852 | ************************************************************************ | |
11853 | ||
11854 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11855 | SAVE | |
11856 | ||
11857 | PARAMETER ( LINP = 10 , | |
11858 | & LOUT = 6 , | |
11859 | & LDAT = 9 ) | |
11860 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
11861 | ||
11862 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 | |
11863 | ||
11864 | * particle properties (BAMJET index convention) | |
11865 | CHARACTER*8 ANAME | |
11866 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11867 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11868 | * Glauber formalism: flags and parameters for statistics | |
11869 | LOGICAL LPROD | |
11870 | CHARACTER*8 CGLB | |
11871 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11872 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11873 | * Glauber formalism: parameters | |
11874 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11875 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11876 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11877 | & NSITEB,NSTATB | |
11878 | * Glauber formalism: cross sections | |
11879 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11880 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11881 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11882 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11883 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11884 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11885 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11886 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11887 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11888 | & BSLOPE,NEBINI,NQBINI | |
11889 | * number of data sets other than protons and nuclei | |
11890 | * at the moment = 2 (pions and kaons) | |
11891 | PARAMETER (MAXOFF=2) | |
11892 | DIMENSION IJPINI(5),IOFFST(25) | |
11893 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11894 | * Glauber data-set to be used for hadron projectiles | |
11895 | * (0=proton, 1=pion, 2=kaon) | |
11896 | DATA (IOFFST(K),K=1,25) / | |
11897 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11898 | & 0, 0, 1, 2, 2/ | |
11899 | * Acceptance interval for target nucleus mass | |
11900 | PARAMETER (KBACC = 6) | |
11901 | * emulsion treatment | |
11902 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11903 | & NCOMPO,IEMUL | |
11904 | ||
11905 | PARAMETER (MAXSET=5000, | |
11906 | & MAXBIN=100) | |
11907 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) | |
11908 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), | |
11909 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), | |
11910 | & IAIDX(10) | |
11911 | ||
11912 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ | |
11913 | * | |
11914 | * read data from file | |
11915 | * | |
11916 | IF (MODE.EQ.0) THEN | |
11917 | ||
11918 | IF (LREAD) RETURN | |
11919 | ||
11920 | DO 1 I=1,MAXSET | |
11921 | DO 2 J=1,6 | |
11922 | XSIG(I,J) = ZERO | |
11923 | XERR(I,J) = ZERO | |
11924 | 2 CONTINUE | |
11925 | DO 3 J=1,KSITEB | |
11926 | BPROFL(I,J) = ZERO | |
11927 | 3 CONTINUE | |
11928 | 1 CONTINUE | |
11929 | DO 4 I=1,MAXBIN | |
11930 | IABIN(I) = 0 | |
11931 | IBBIN(I) = 0 | |
11932 | 4 CONTINUE | |
11933 | DO 5 I=1,KSITEB | |
11934 | BPRO0(I) = ZERO | |
11935 | BPRO1(I) = ZERO | |
11936 | BPRO(I) = ZERO | |
11937 | 5 CONTINUE | |
11938 | ||
11939 | IDX = INDEX(CGLB,' ') | |
11940 | K = 12 | |
11941 | IF (IDX.GT.1) K = IDX-1 | |
11942 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11943 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' | |
11944 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', | |
11945 | & 'file ',A12,/) | |
11946 | * | |
11947 | * read binning information | |
11948 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI | |
11949 | * return lower energy threshold to Fluka-interface | |
11950 | ELAB = ELO | |
11951 | LCMS = ELO.LT.ZERO | |
11952 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' | |
11953 | IF (LCMS) THEN | |
11954 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN | |
11955 | ELSE | |
11956 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN | |
11957 | ENDIF | |
11958 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, | |
11959 | & 'No. of bins:',I5,/) | |
11960 | ELO = LOG10(ABS(ELO)) | |
11961 | EHI = LOG10(ABS(EHI)) | |
11962 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) | |
11963 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' | |
11964 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) | |
11965 | IF (NABIN.LT.18) THEN | |
11966 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) | |
11967 | ELSE | |
11968 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) | |
11969 | ENDIF | |
11970 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' | |
11971 | IF (NABIN.GT.18) THEN | |
11972 | NLINES = DBLE(NABIN-18)/18.0D0 | |
11973 | IF (NLINES.GT.0) THEN | |
11974 | DO 7 I=1,NLINES | |
11975 | I0 = 18*(I+1)-17 | |
11976 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11977 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11978 | 7 CONTINUE | |
11979 | ENDIF | |
11980 | I0 = 18*(NLINES+1)+1 | |
11981 | IF (I0.LE.NABIN) THEN | |
11982 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11983 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11984 | ENDIF | |
11985 | ENDIF | |
11986 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' | |
11987 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) | |
11988 | IF (NBBIN.LT.18) THEN | |
11989 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) | |
11990 | ELSE | |
11991 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) | |
11992 | ENDIF | |
11993 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' | |
11994 | IF (NBBIN.GT.18) THEN | |
11995 | NLINES = DBLE(NBBIN-18)/18.0D0 | |
11996 | IF (NLINES.GT.0) THEN | |
11997 | DO 8 I=1,NLINES | |
11998 | I0 = 18*(I+1)-17 | |
11999 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12000 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12001 | 8 CONTINUE | |
12002 | ENDIF | |
12003 | I0 = 18*(NLINES+1)+1 | |
12004 | IF (I0.LE.NBBIN) THEN | |
12005 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12006 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12007 | ENDIF | |
12008 | ENDIF | |
12009 | * number of data sets to follow in the Glauber data file | |
12010 | * this variable is used for checks of consistency of projectile | |
12011 | * and target mass configurations given in header of Glauber data | |
12012 | * file and the data-sets which follow in this file | |
12013 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN | |
12014 | * | |
12015 | * read profile function data | |
12016 | NSET = 0 | |
12017 | NAIDX = 0 | |
12018 | IPOLD = 0 | |
12019 | 10 CONTINUE | |
12020 | NSET = NSET+1 | |
12021 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' | |
12022 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM | |
12023 | 1002 FORMAT(5I10,E15.5) | |
12024 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN | |
12025 | NAIDX = NAIDX+1 | |
12026 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' | |
12027 | IAIDX(NAIDX) = IP | |
12028 | IPOLD = IP | |
12029 | ENDIF | |
12030 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) | |
12031 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) | |
12032 | NLINES = INT(DBLE(ISITEB)/7.0D0) | |
12033 | IF (NLINES.GT.0) THEN | |
12034 | DO 11 I=1,NLINES | |
12035 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) | |
12036 | 11 CONTINUE | |
12037 | ENDIF | |
12038 | I0 = 7*NLINES+1 | |
12039 | IF (I0.LE.ISITEB) | |
12040 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) | |
12041 | GOTO 10 | |
12042 | 100 CONTINUE | |
12043 | NSET = NSET-1 | |
12044 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' | |
12045 | WRITE(LOUT,'(/,1X,A)') | |
12046 | & ' projectiles other than protons and nuclei: (particle index)' | |
12047 | IF (NAIDX.GT.0) THEN | |
12048 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) | |
12049 | ELSE | |
12050 | WRITE(LOUT,'(6X,A)') 'none' | |
12051 | ENDIF | |
12052 | * | |
12053 | CLOSE(LDAT) | |
12054 | WRITE(LOUT,*) | |
12055 | LREAD = .TRUE. | |
12056 | ||
12057 | IF (NCOMPO.EQ.0) THEN | |
12058 | DO 12 J=1,NBBIN | |
12059 | NCOMPO = NCOMPO+1 | |
12060 | IEMUMA(NCOMPO) = IBBIN(J) | |
12061 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 | |
12062 | EMUFRA(NCOMPO) = 1.0D0 | |
12063 | 12 CONTINUE | |
12064 | IEMUL = 1 | |
12065 | ENDIF | |
12066 | * | |
12067 | * calculate profile function for certain set of parameters | |
12068 | * | |
12069 | ELSE | |
12070 | ||
12071 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE | |
12072 | * | |
12073 | * check for type of projectile and set index-offset to entry in | |
12074 | * Glauber data array correspondingly | |
12075 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' | |
12076 | IF (IOFFST(IDPROJ).EQ.-1) THEN | |
12077 | STOP ' GLBSET: no data for this projectile !' | |
12078 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN | |
12079 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN | |
12080 | ELSE | |
12081 | IDXOFF = 0 | |
12082 | ENDIF | |
12083 | * | |
12084 | * get energy bin and interpolation factor | |
12085 | IF (LCMS) THEN | |
12086 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) | |
12087 | ELSE | |
12088 | E = ELAB | |
12089 | ENDIF | |
12090 | E = LOG10(E) | |
12091 | IF (E.LT.ELO) THEN | |
12092 | IF (LFRST1) THEN | |
12093 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E | |
12094 | LFRST1 = .FALSE. | |
12095 | ENDIF | |
12096 | E = ELO | |
12097 | ENDIF | |
12098 | IF (E.GT.EHI) THEN | |
12099 | IF (LFRST2) THEN | |
12100 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E | |
12101 | LFRST2 = .FALSE. | |
12102 | ENDIF | |
12103 | E = EHI | |
12104 | ENDIF | |
12105 | IE0 = (E-ELO)/DEBIN+1 | |
12106 | IE1 = IE0+1 | |
12107 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN | |
12108 | * | |
12109 | * get target nucleus index | |
12110 | KB = 0 | |
12111 | NBACC = KBACC | |
12112 | DO 20 I=1,NBBIN | |
12113 | NBDIFF = ABS(NB-IBBIN(I)) | |
12114 | IF (NB.EQ.IBBIN(I)) THEN | |
12115 | KB = I | |
12116 | GOTO 21 | |
12117 | ELSEIF (NBDIFF.LE.NBACC) THEN | |
12118 | KB = I | |
12119 | NBACC = NBDIFF | |
12120 | ENDIF | |
12121 | 20 CONTINUE | |
12122 | IF (KB.NE.0) GOTO 21 | |
12123 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB | |
12124 | STOP | |
12125 | 21 CONTINUE | |
12126 | * | |
12127 | * get projectile nucleus bin and interpolation factor | |
12128 | KA0 = 0 | |
12129 | KA1 = 0 | |
12130 | FACNA = 0 | |
12131 | IF (IDXOFF.GT.0) THEN | |
12132 | KA0 = 1 | |
12133 | KA1 = 1 | |
12134 | KABIN = 1 | |
12135 | ELSE | |
12136 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' | |
12137 | DO 22 I=1,NABIN | |
12138 | IF (NA.EQ.IABIN(I)) THEN | |
12139 | KA0 = I | |
12140 | KA1 = I | |
12141 | GOTO 23 | |
12142 | ELSEIF (NA.LT.IABIN(I)) THEN | |
12143 | KA0 = I-1 | |
12144 | KA1 = I | |
12145 | GOTO 23 | |
12146 | ENDIF | |
12147 | 22 CONTINUE | |
12148 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA | |
12149 | STOP | |
12150 | 23 CONTINUE | |
12151 | IF (KA0.NE.KA1) | |
12152 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) | |
12153 | KABIN = NABIN | |
12154 | ENDIF | |
12155 | * | |
12156 | * interpolate profile functions for interactions ka0-kb and ka1-kb | |
12157 | * for energy E separately | |
12158 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12159 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12160 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12161 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12162 | DO 30 I=1,ISITEB | |
12163 | BPRO0(I) = BPROFL(IDX0,I) | |
12164 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) | |
12165 | BPRO1(I) = BPROFL(IDY0,I) | |
12166 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) | |
12167 | 30 CONTINUE | |
12168 | RADB = DT_RNCLUS(NB) | |
12169 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) | |
12170 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) | |
12171 | * | |
12172 | * interpolate cross sections for energy E and projectile mass | |
12173 | DO 31 I=1,6 | |
12174 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) | |
12175 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) | |
12176 | XS(I) = XS0+FACNA*(XS1-XS0) | |
12177 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) | |
12178 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) | |
12179 | XE(I) = XE0+FACNA*(XE1-XE0) | |
12180 | 31 CONTINUE | |
12181 | * | |
12182 | * interpolate between ka0 and ka1 | |
12183 | RADA = DT_RNCLUS(NA) | |
12184 | BMX = 2.0D0*(RADA+RADB) | |
12185 | BSTP = BMX/DBLE(ISITEB-1) | |
12186 | BPRO(1) = ZERO | |
12187 | DO 32 I=1,ISITEB-1 | |
12188 | B = DBLE(I)*BSTP | |
12189 | * | |
12190 | * calculate values of profile functions at B | |
12191 | IDX0 = B/BSTP0+1 | |
12192 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12193 | IDX1 = MIN(IDX0+1,ISITEB) | |
12194 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 | |
12195 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) | |
12196 | IDX0 = B/BSTP1+1 | |
12197 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12198 | IDX1 = MIN(IDX0+1,ISITEB) | |
12199 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 | |
12200 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) | |
12201 | * | |
12202 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) | |
12203 | 32 CONTINUE | |
12204 | * | |
12205 | * fill common dtglam | |
12206 | NSITEB = ISITEB | |
12207 | RASH(1) = RADA | |
12208 | RBSH(1) = RADB | |
12209 | BMAX(1) = BMX | |
12210 | BSTEP(1) = BSTP | |
12211 | DO 33 I=1,KSITEB | |
12212 | BSITE(0,1,1,I) = BPRO(I) | |
12213 | 33 CONTINUE | |
12214 | * | |
12215 | * fill common dtglxs | |
12216 | XSTOT(1,1,1) = XS(1) | |
12217 | XSELA(1,1,1) = XS(2) | |
12218 | XSQEP(1,1,1) = XS(3) | |
12219 | XSQET(1,1,1) = XS(4) | |
12220 | XSQE2(1,1,1) = XS(5) | |
12221 | XSPRO(1,1,1) = XS(6) | |
12222 | XETOT(1,1,1) = XE(1) | |
12223 | XEELA(1,1,1) = XE(2) | |
12224 | XEQEP(1,1,1) = XE(3) | |
12225 | XEQET(1,1,1) = XE(4) | |
12226 | XEQE2(1,1,1) = XE(5) | |
12227 | XEPRO(1,1,1) = XE(6) | |
12228 | ||
12229 | ENDIF | |
12230 | ||
12231 | RETURN | |
12232 | END | |
12233 | ||
12234 | *$ CREATE DT_XKSAMP.FOR | |
12235 | *COPY DT_XKSAMP | |
12236 | * | |
12237 | *===xksamp=============================================================* | |
12238 | * | |
12239 | SUBROUTINE DT_XKSAMP(NN,ECM) | |
12240 | ||
12241 | ************************************************************************ | |
12242 | * Sampling of parton x-values and chain system for one interaction. * | |
12243 | * processed by S. Roesler, 9.8.95 * | |
12244 | ************************************************************************ | |
12245 | ||
12246 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12247 | SAVE | |
12248 | PARAMETER ( LINP = 10 , | |
12249 | & LOUT = 6 , | |
12250 | & LDAT = 9 ) | |
12251 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
454792a9 | 12252 | CPH SAVE |
9aaba0d6 | 12253 | |
12254 | PARAMETER ( | |
12255 | * lower cuts for (valence-sea/sea-valence) chain masses | |
12256 | * antiquark-quark (u/d-sea quark) (s-sea quark) | |
12257 | & AMIU = 0.5D0, AMIS = 0.8D0, | |
12258 | * quark-diquark (u/d-sea quark) (s-sea quark) | |
12259 | & AMAU = 2.6D0, AMAS = 2.6D0, | |
12260 | * maximum lower valence-x threshold | |
12261 | & XVMAX = 0.98D0, | |
12262 | * fraction of sea-diquarks sampled out of sea-partons | |
12263 | **test | |
12264 | C & FRCDIQ = 0.9D0, | |
12265 | ** | |
12266 | * | |
12267 | & SQMA = 0.7D0, | |
12268 | * | |
12269 | * maximum number of trials to generate x's for the required number | |
12270 | * of sea quark pairs for a given hadron | |
12271 | & NSEATY = 12 | |
12272 | C & NSEATY = 3 | |
12273 | & ) | |
12274 | ||
12275 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO | |
12276 | ||
12277 | PARAMETER ( MAXNCL = 260, | |
12278 | & MAXVQU = MAXNCL, | |
12279 | & MAXSQU = 20*MAXVQU, | |
12280 | & MAXINT = MAXVQU+MAXSQU) | |
12281 | * event history | |
12282 | PARAMETER (NMXHKK=200000) | |
12283 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
12284 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
12285 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
12286 | * particle properties (BAMJET index convention) | |
12287 | CHARACTER*8 ANAME | |
12288 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12289 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12290 | * interface between Glauber formalism and DPM | |
12291 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
12292 | & INTER1(MAXINT),INTER2(MAXINT) | |
12293 | * properties of interacting particles | |
12294 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
12295 | * threshold values for x-sampling (DTUNUC 1.x) | |
12296 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
12297 | & SSMIMQ,VVMTHR | |
12298 | * x-values of partons (DTUNUC 1.x) | |
12299 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
12300 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
12301 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
12302 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
12303 | * flavors of partons (DTUNUC 1.x) | |
12304 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
12305 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
12306 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
12307 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
12308 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
12309 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
12310 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
12311 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12312 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
12313 | & IXPV,IXPS,IXTV,IXTS, | |
12314 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
12315 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
12316 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
12317 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
12318 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
12319 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
12320 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
12321 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
12322 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12323 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
12324 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
12325 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
12326 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
12327 | * flags for input different options | |
12328 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
12329 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
12330 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
12331 | * various options for treatment of partons (DTUNUC 1.x) | |
12332 | * (chain recombination, Cronin,..) | |
12333 | LOGICAL LCO2CR,LINTPT | |
12334 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
12335 | & LCO2CR,LINTPT | |
12336 | ||
12337 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), | |
12338 | & INTLO(MAXINT) | |
12339 | ||
12340 | * (1) initializations | |
12341 | *----------------------------------------------------------------------- | |
12342 | ||
12343 | **test | |
12344 | IF (ECM.LT.4.5D0) THEN | |
12345 | C FRCDIQ = 0.6D0 | |
12346 | FRCDIQ = 0.4D0 | |
12347 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN | |
12348 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12349 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12350 | ELSE | |
12351 | C FRCDIQ = 0.9D0 | |
12352 | FRCDIQ = 0.7D0 | |
12353 | ENDIF | |
12354 | ** | |
12355 | DO 30 I=1,MAXSQU | |
12356 | ZUOSP(I) = .FALSE. | |
12357 | ZUOST(I) = .FALSE. | |
12358 | IF (I.LE.MAXVQU) THEN | |
12359 | ZUOVP(I) = .FALSE. | |
12360 | ZUOVT(I) = .FALSE. | |
12361 | ENDIF | |
12362 | 30 CONTINUE | |
12363 | ||
12364 | * lower thresholds for x-selection | |
12365 | * sea-quarks (default: CSEA=0.2) | |
12366 | IF (ECM.LT.10.0D0) THEN | |
12367 | **!!test | |
12368 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM | |
12369 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 | |
12370 | NSEA = NSEATY | |
12371 | C XSTHR = ONE/ECM**2 | |
12372 | ELSE | |
12373 | **sr 30.3.98 | |
12374 | C XSTHR = CSEA/ECM | |
12375 | XSTHR = CSEA/ECM**2 | |
12376 | C XSTHR = ONE/ECM**2 | |
12377 | ** | |
12378 | IF ((IP.GE.150).AND.(IT.GE.150)) | |
12379 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) | |
12380 | NSEA = NSEATY | |
12381 | ENDIF | |
12382 | * (default: SSMIMA=0.14) used for sea-diquarks (?) | |
12383 | XSSTHR = SSMIMA/ECM | |
12384 | BSQMA = SQMA/ECM | |
12385 | * valence-quarks (default: CVQ=1.0) | |
12386 | XVTHR = CVQ/ECM | |
12387 | * valence-diquarks (default: CDQ=2.0) | |
12388 | XDTHR = CDQ/ECM | |
12389 | ||
12390 | * maximum-x for sea-quarks | |
12391 | XVCUT = XVTHR+XDTHR | |
12392 | IF (XVCUT.GT.XVMAX) THEN | |
12393 | XVCUT = XVMAX | |
12394 | XVTHR = XVCUT/3.0D0 | |
12395 | XDTHR = XVCUT-XVTHR | |
12396 | ENDIF | |
12397 | XXSEAM = ONE-XVCUT | |
12398 | **sr 18.4. test: DPMJET | |
12399 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) | |
12400 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) | |
12401 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) | |
12402 | ** | |
12403 | * maximum number of sea-pairs allowed kinematically | |
12404 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12405 | RNSMAX = OHALF*XXSEAM/XSTHR | |
12406 | IF (RNSMAX.GT.10000.0D0) THEN | |
12407 | NSMAX = 10000 | |
12408 | ELSE | |
12409 | NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12410 | ENDIF | |
12411 | * check kinematical limit for valence-x thresholds | |
12412 | * (should be obsolete now) | |
12413 | IF (XVCUT.GT.XVMAX) THEN | |
12414 | WRITE(LOUT,1000) XVCUT,ECM | |
12415 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', | |
12416 | & ' thresholds not allowed (',2E9.3,')') | |
12417 | C XVTHR = XVMAX-XDTHR | |
12418 | C IF (XVTHR.LT.ZERO) STOP | |
12419 | STOP | |
12420 | ENDIF | |
12421 | ||
12422 | * set eta for valence-x sampling (BETREJ) | |
12423 | * (UNON per default, UNOM used for projectile mesons only) | |
12424 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN | |
12425 | UNOPRV = UNOM | |
12426 | ELSE | |
12427 | UNOPRV = UNON | |
12428 | ENDIF | |
12429 | ||
12430 | * (2) select parton x-values of interacting projectile nucleons | |
12431 | *----------------------------------------------------------------------- | |
12432 | ||
12433 | IXPV = 0 | |
12434 | IXPS = 0 | |
12435 | ||
12436 | DO 100 IPP=1,IP | |
12437 | * get interacting projectile nucleon as sampled by Glauber | |
12438 | IF (JSSH(IPP).NE.0) THEN | |
12439 | IXSTMP = IXPS | |
12440 | IXVTMP = IXPV | |
12441 | 99 CONTINUE | |
12442 | IXPS = IXSTMP | |
12443 | IXPV = IXVTMP | |
12444 | * JIPP is the actual number of sea-pairs sampled for this nucleon | |
12445 | JIPP = MIN(JSSH(IPP)-1,NSMAX) | |
12446 | 41 CONTINUE | |
12447 | XXSEA = ZERO | |
12448 | IF (JIPP.GT.0) THEN | |
12449 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR | |
12450 | *??? | |
12451 | IF (XSTHR.GE.XSMAX) THEN | |
12452 | JIPP = JIPP-1 | |
12453 | GOTO 41 | |
12454 | ENDIF | |
12455 | ||
12456 | *>>>get x-values of sea-quark pairs | |
12457 | NSCOUN = 0 | |
12458 | PLW = 0.5D0 | |
12459 | 40 CONTINUE | |
12460 | * accumulator for sea x-values | |
12461 | XXSEA = ZERO | |
12462 | NSCOUN = NSCOUN+1 | |
12463 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12464 | IF (NSCOUN.GT.NSEA) THEN | |
12465 | * decrease the number of interactions after NSEA trials | |
12466 | JIPP = JIPP-1 | |
12467 | NSCOUN = 0 | |
12468 | ENDIF | |
12469 | DO 70 ISQ=1,JIPP | |
12470 | * sea-quarks | |
12471 | IF (IPSQ(IXPS+1).LE.2) THEN | |
12472 | **sr 8.4.98 (1/sqrt(x)) | |
12473 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12474 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12475 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12476 | ** | |
12477 | ELSE | |
12478 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12479 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12480 | ELSE | |
12481 | **sr 8.4.98 (1/sqrt(x)) | |
12482 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12483 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12484 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12485 | ** | |
12486 | ENDIF | |
12487 | ENDIF | |
12488 | * sea-antiquarks | |
12489 | IF (IPSAQ(IXPS+1).GE.-2) THEN | |
12490 | **sr 8.4.98 (1/sqrt(x)) | |
12491 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12492 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12493 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12494 | ** | |
12495 | ELSE | |
12496 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12497 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12498 | ELSE | |
12499 | **sr 8.4.98 (1/sqrt(x)) | |
12500 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12501 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12502 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12503 | ** | |
12504 | ENDIF | |
12505 | ENDIF | |
12506 | XXSEA = XXSEA+XPSQI+XPSAQI | |
12507 | * check for maximum allowed sea x-value | |
12508 | IF (XXSEA.GE.XXSEAM) THEN | |
12509 | IXPS = IXPS-ISQ+1 | |
12510 | GOTO 40 | |
12511 | ENDIF | |
12512 | * accept this sea-quark pair | |
12513 | IXPS = IXPS+1 | |
12514 | XPSQ(IXPS) = XPSQI | |
12515 | XPSAQ(IXPS) = XPSAQI | |
12516 | IFROSP(IXPS) = IPP | |
12517 | ZUOSP(IXPS) = .TRUE. | |
12518 | 70 CONTINUE | |
12519 | ENDIF | |
12520 | ||
12521 | *>>>get x-values of valence partons | |
12522 | * valence quark | |
12523 | IF (XVTHR.GT.0.05D0) THEN | |
12524 | XVHI = ONE-XXSEA-XDTHR | |
12525 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) | |
12526 | ELSE | |
12527 | 90 CONTINUE | |
12528 | XPVQI = DT_DBETAR(OHALF,UNOPRV) | |
12529 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) | |
12530 | & GOTO 90 | |
12531 | ENDIF | |
12532 | * valence diquark | |
12533 | XPVDI = ONE-XPVQI-XXSEA | |
12534 | * reject according to x**1.5 | |
12535 | XDTMP = XPVDI**1.5D0 | |
12536 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 | |
12537 | * accept these valence partons | |
12538 | IXPV = IXPV+1 | |
12539 | XPVQ(IXPV) = XPVQI | |
12540 | XPVD(IXPV) = XPVDI | |
12541 | IFROVP(IXPV) = IPP | |
12542 | ITOVP(IPP) = IXPV | |
12543 | ZUOVP(IXPV) = .TRUE. | |
12544 | ||
12545 | ENDIF | |
12546 | 100 CONTINUE | |
12547 | ||
12548 | * (3) select parton x-values of interacting target nucleons | |
12549 | *----------------------------------------------------------------------- | |
12550 | ||
12551 | IXTV = 0 | |
12552 | IXTS = 0 | |
12553 | ||
12554 | DO 170 ITT=1,IT | |
12555 | * get interacting target nucleon as sampled by Glauber | |
12556 | IF (JTSH(ITT).NE.0) THEN | |
12557 | IXSTMP = IXTS | |
12558 | IXVTMP = IXTV | |
12559 | 169 CONTINUE | |
12560 | IXTS = IXSTMP | |
12561 | IXTV = IXVTMP | |
12562 | * JITT is the actual number of sea-pairs sampled for this nucleon | |
12563 | JITT = MIN(JTSH(ITT)-1,NSMAX) | |
12564 | 111 CONTINUE | |
12565 | XXSEA = ZERO | |
12566 | IF (JITT.GT.0) THEN | |
12567 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR | |
12568 | *??? | |
12569 | IF (XSTHR.GE.XSMAX) THEN | |
12570 | JITT = JITT-1 | |
12571 | GOTO 111 | |
12572 | ENDIF | |
12573 | ||
12574 | *>>>get x-values of sea-quark pairs | |
12575 | NSCOUN = 0 | |
12576 | PLW = 0.5D0 | |
12577 | 110 CONTINUE | |
12578 | * accumulator for sea x-values | |
12579 | XXSEA = ZERO | |
12580 | NSCOUN = NSCOUN+1 | |
12581 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12582 | IF (NSCOUN.GT.NSEA)THEN | |
12583 | * decrease the number of interactions after NSEA trials | |
12584 | JITT = JITT-1 | |
12585 | NSCOUN = 0 | |
12586 | ENDIF | |
12587 | DO 140 ISQ=1,JITT | |
12588 | * sea-quarks | |
12589 | IF (ITSQ(IXTS+1).LE.2) THEN | |
12590 | **sr 8.4.98 (1/sqrt(x)) | |
12591 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12592 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12593 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12594 | ** | |
12595 | ELSE | |
12596 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12597 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12598 | ELSE | |
12599 | **sr 8.4.98 (1/sqrt(x)) | |
12600 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12601 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12602 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12603 | ** | |
12604 | ENDIF | |
12605 | ENDIF | |
12606 | * sea-antiquarks | |
12607 | IF (ITSAQ(IXTS+1).GE.-2) THEN | |
12608 | **sr 8.4.98 (1/sqrt(x)) | |
12609 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12610 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12611 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12612 | ** | |
12613 | ELSE | |
12614 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12615 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12616 | ELSE | |
12617 | **sr 8.4.98 (1/sqrt(x)) | |
12618 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12619 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12620 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12621 | ** | |
12622 | ENDIF | |
12623 | ENDIF | |
12624 | XXSEA = XXSEA+XTSQI+XTSAQI | |
12625 | * check for maximum allowed sea x-value | |
12626 | IF (XXSEA.GE.XXSEAM) THEN | |
12627 | IXTS = IXTS-ISQ+1 | |
12628 | GOTO 110 | |
12629 | ENDIF | |
12630 | * accept this sea-quark pair | |
12631 | IXTS = IXTS+1 | |
12632 | XTSQ(IXTS) = XTSQI | |
12633 | XTSAQ(IXTS) = XTSAQI | |
12634 | IFROST(IXTS) = ITT | |
12635 | ZUOST(IXTS) = .TRUE. | |
12636 | 140 CONTINUE | |
12637 | ENDIF | |
12638 | ||
12639 | *>>>get x-values of valence partons | |
12640 | * valence quark | |
12641 | IF (XVTHR.GT.0.05D0) THEN | |
12642 | XVHI = ONE-XXSEA-XDTHR | |
12643 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) | |
12644 | ELSE | |
12645 | 160 CONTINUE | |
12646 | XTVQI = DT_DBETAR(OHALF,UNON) | |
12647 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) | |
12648 | & GOTO 160 | |
12649 | ENDIF | |
12650 | * valence diquark | |
12651 | XTVDI = ONE-XTVQI-XXSEA | |
12652 | * reject according to x**1.5 | |
12653 | XDTMP = XTVDI**1.5D0 | |
12654 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 | |
12655 | * accept these valence partons | |
12656 | IXTV = IXTV+1 | |
12657 | XTVQ(IXTV) = XTVQI | |
12658 | XTVD(IXTV) = XTVDI | |
12659 | IFROVT(IXTV) = ITT | |
12660 | ITOVT(ITT) = IXTV | |
12661 | ZUOVT(IXTV) = .TRUE. | |
12662 | ||
12663 | ENDIF | |
12664 | 170 CONTINUE | |
12665 | ||
12666 | * (4) get valence-valence chains | |
12667 | *----------------------------------------------------------------------- | |
12668 | ||
12669 | NVV = 0 | |
12670 | DO 240 I=1,NN | |
12671 | INTLO(I) = .TRUE. | |
12672 | IPVAL = ITOVP(INTER1(I)) | |
12673 | ITVAL = ITOVT(INTER2(I)) | |
12674 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN | |
12675 | INTLO(I) = .FALSE. | |
12676 | ZUOVP(IPVAL) = .FALSE. | |
12677 | ZUOVT(ITVAL) = .FALSE. | |
12678 | NVV = NVV+1 | |
12679 | ISKPCH(8,NVV) = 0 | |
12680 | INTVV1(NVV) = IPVAL | |
12681 | INTVV2(NVV) = ITVAL | |
12682 | ENDIF | |
12683 | 240 CONTINUE | |
12684 | ||
12685 | * (5) get sea-valence chains | |
12686 | *----------------------------------------------------------------------- | |
12687 | ||
12688 | NSV = 0 | |
12689 | NDV = 0 | |
12690 | PLW = 0.5D0 | |
12691 | DO 270 I=1,NN | |
12692 | IF (INTLO(I)) THEN | |
12693 | IPVAL = ITOVP(INTER1(I)) | |
12694 | ITVAL = ITOVT(INTER2(I)) | |
12695 | DO 250 J=1,IXPS | |
12696 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. | |
12697 | & ZUOVT(ITVAL)) THEN | |
12698 | ZUOSP(J) = .FALSE. | |
12699 | ZUOVT(ITVAL) = .FALSE. | |
12700 | INTLO(I) = .FALSE. | |
12701 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN | |
12702 | * sample sea-diquark pair | |
12703 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) | |
12704 | IF (IREJ1.EQ.0) GOTO 260 | |
12705 | ENDIF | |
12706 | NSV = NSV+1 | |
12707 | ISKPCH(4,NSV) = 0 | |
12708 | INTSV1(NSV) = J | |
12709 | INTSV2(NSV) = ITVAL | |
12710 | ||
12711 | *>>>correct chain kinematics according to minimum chain masses | |
12712 | * the actual chain masses | |
12713 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 | |
12714 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 | |
12715 | * get lower mass cuts | |
12716 | IF (IPSQ(J).EQ.3) THEN | |
12717 | * q being s-quark | |
12718 | AMCHK1 = AMAS | |
12719 | AMCHK2 = AMIS | |
12720 | ELSE | |
12721 | * q being u/d-quark | |
12722 | AMCHK1 = AMAU | |
12723 | AMCHK2 = AMIU | |
12724 | ENDIF | |
12725 | * q-qq chain | |
12726 | * chain mass above minimum - resampling of sea-q x-value | |
12727 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12728 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12729 | **sr 8.4.98 (1/sqrt(x)) | |
12730 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) | |
12731 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) | |
12732 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) | |
12733 | ** | |
12734 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX | |
12735 | XPSQ(J) = XPSQXX | |
12736 | * chain mass below minimum - reset sea-q x-value and correct | |
12737 | * diquark-x of the same nucleon | |
12738 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12739 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12740 | DXPSQ = XPSQW-XPSQ(J) | |
12741 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12742 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12743 | XPSQ(J) = XPSQW | |
12744 | ENDIF | |
12745 | ENDIF | |
12746 | * aq-q chain | |
12747 | * chain mass below minimum - reset sea-aq x-value and correct | |
12748 | * diquark-x of the same nucleon | |
12749 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12750 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) | |
12751 | DXPSQ = XPSQW-XPSAQ(J) | |
12752 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12753 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12754 | XPSAQ(J) = XPSQW | |
12755 | ENDIF | |
12756 | ENDIF | |
12757 | *>>>end of chain mass correction | |
12758 | ||
12759 | GOTO 260 | |
12760 | ENDIF | |
12761 | 250 CONTINUE | |
12762 | ENDIF | |
12763 | 260 CONTINUE | |
12764 | 270 CONTINUE | |
12765 | ||
12766 | * (6) get valence-sea chains | |
12767 | *----------------------------------------------------------------------- | |
12768 | ||
12769 | NVS = 0 | |
12770 | NVD = 0 | |
12771 | DO 300 I=1,NN | |
12772 | IF (INTLO(I)) THEN | |
12773 | IPVAL = ITOVP(INTER1(I)) | |
12774 | ITVAL = ITOVT(INTER2(I)) | |
12775 | DO 280 J=1,IXTS | |
12776 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. | |
12777 | & (IFROST(J).EQ.INTER2(I))) THEN | |
12778 | ZUOST(J) = .FALSE. | |
12779 | ZUOVP(IPVAL) = .FALSE. | |
12780 | INTLO(I) = .FALSE. | |
12781 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
12782 | * sample sea-diquark pair | |
12783 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) | |
12784 | IF (IREJ1.EQ.0) GOTO 290 | |
12785 | ENDIF | |
12786 | NVS = NVS + 1 | |
12787 | ISKPCH(6,NVS) = 0 | |
12788 | INTVS1(NVS) = IPVAL | |
12789 | INTVS2(NVS) = J | |
12790 | ||
12791 | *>>>correct chain kinematics according to minimum chain masses | |
12792 | * the actual chain masses | |
12793 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 | |
12794 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 | |
12795 | * get lower mass cuts | |
12796 | IF (ITSQ(J).EQ.3) THEN | |
12797 | * q being s-quark | |
12798 | AMCHK1 = AMIS | |
12799 | AMCHK2 = AMAS | |
12800 | ELSE | |
12801 | * q being u/d-quark | |
12802 | AMCHK1 = AMIU | |
12803 | AMCHK2 = AMAU | |
12804 | ENDIF | |
12805 | * q-aq chain | |
12806 | * chain mass below minimum - reset sea-aq x-value and correct | |
12807 | * diquark-x of the same nucleon | |
12808 | IF (AMVSQ1.LT.AMCHK1) THEN | |
12809 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) | |
12810 | DXTSQ = XTSQW-XTSAQ(J) | |
12811 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12812 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12813 | XTSAQ(J) = XTSQW | |
12814 | ENDIF | |
12815 | ENDIF | |
12816 | * qq-q chain | |
12817 | * chain mass above minimum - resampling of sea-q x-value | |
12818 | IF (AMVSQ2.GT.AMCHK2) THEN | |
12819 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12820 | **sr 8.4.98 (1/sqrt(x)) | |
12821 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) | |
12822 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) | |
12823 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
12824 | ** | |
12825 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
12826 | XTSQ(J) = XTSQXX | |
12827 | * chain mass below minimum - reset sea-q x-value and correct | |
12828 | * diquark-x of the same nucleon | |
12829 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
12830 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12831 | DXTSQ = XTSQW-XTSQ(J) | |
12832 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12833 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12834 | XTSQ(J) = XTSQW | |
12835 | ENDIF | |
12836 | ENDIF | |
12837 | *>>>end of chain mass correction | |
12838 | ||
12839 | GOTO 290 | |
12840 | ENDIF | |
12841 | 280 CONTINUE | |
12842 | ENDIF | |
12843 | 290 CONTINUE | |
12844 | 300 CONTINUE | |
12845 | ||
12846 | * (7) get sea-sea chains | |
12847 | *----------------------------------------------------------------------- | |
12848 | ||
12849 | NSS = 0 | |
12850 | NDS = 0 | |
12851 | NSD = 0 | |
12852 | DO 420 I=1,NN | |
12853 | IF (INTLO(I)) THEN | |
12854 | IPVAL = ITOVP(INTER1(I)) | |
12855 | ITVAL = ITOVT(INTER2(I)) | |
12856 | * loop over target partons not yet matched | |
12857 | DO 400 J=1,IXTS | |
12858 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN | |
12859 | * loop over projectile partons not yet matched | |
12860 | DO 390 JJ=1,IXPS | |
12861 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN | |
12862 | ZUOSP(JJ) = .FALSE. | |
12863 | ZUOST(J) = .FALSE. | |
12864 | INTLO(I) = .FALSE. | |
12865 | NSS = NSS+1 | |
12866 | ISKPCH(1,NSS) = 0 | |
12867 | INTSS1(NSS) = JJ | |
12868 | INTSS2(NSS) = J | |
12869 | ||
12870 | *---->chain recombination option | |
12871 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) | |
12872 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) | |
12873 | & THEN | |
12874 | * sea-sea chains may recombine with valence-valence chains | |
12875 | * only if they have the same projectile or target nucleon | |
12876 | DO 4201 IVV=1,NVV | |
12877 | IF (ISKPCH(8,IVV).NE.99) THEN | |
12878 | IXVPR = INTVV1(IVV) | |
12879 | IXVTA = INTVV2(IVV) | |
12880 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. | |
12881 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN | |
12882 | * recombination possible, drop old v-v and s-s chains | |
12883 | ISKPCH(1,NSS) = 99 | |
12884 | ISKPCH(8,IVV) = 99 | |
12885 | ||
12886 | * (a) assign new s-v chains | |
12887 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12888 | IF (LSEADI.AND. | |
12889 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) | |
12890 | & THEN | |
12891 | * sample sea-diquark pair | |
12892 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, | |
12893 | & IREJ1) | |
12894 | IF (IREJ1.EQ.0) GOTO 4202 | |
12895 | ENDIF | |
12896 | NSV = NSV+1 | |
12897 | ISKPCH(4,NSV) = 0 | |
12898 | INTSV1(NSV) = JJ | |
12899 | INTSV2(NSV) = IXVTA | |
12900 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12901 | * the actual chain masses | |
12902 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) | |
12903 | & *ECM**2 | |
12904 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) | |
12905 | & *ECM**2 | |
12906 | * get lower mass cuts | |
12907 | IF (IPSQ(JJ).EQ.3) THEN | |
12908 | * q being s-quark | |
12909 | AMCHK1 = AMAS | |
12910 | AMCHK2 = AMIS | |
12911 | ELSE | |
12912 | * q being u/d-quark | |
12913 | AMCHK1 = AMAU | |
12914 | AMCHK2 = AMIU | |
12915 | ENDIF | |
12916 | * q-qq chain | |
12917 | * chain mass above minimum - resampling of sea-q x-value | |
12918 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12919 | XPSQTH = | |
12920 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12921 | **sr 8.4.98 (1/sqrt(x)) | |
12922 | XPSQXX = | |
12923 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) | |
12924 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) | |
12925 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) | |
12926 | ** | |
12927 | XPVD(IPVAL) = | |
12928 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX | |
12929 | XPSQ(JJ) = XPSQXX | |
12930 | * chain mass below minimum - reset sea-q x-value and correct | |
12931 | * diquark-x of the same nucleon | |
12932 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12933 | XPSQW = | |
12934 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12935 | DXPSQ = XPSQW-XPSQ(JJ) | |
12936 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12937 | & THEN | |
12938 | XPVD(IPVAL) = | |
12939 | & XPVD(IPVAL)-DXPSQ | |
12940 | XPSQ(JJ) = XPSQW | |
12941 | ENDIF | |
12942 | ENDIF | |
12943 | * aq-q chain | |
12944 | * chain mass below minimum - reset sea-aq x-value and correct | |
12945 | * diquark-x of the same nucleon | |
12946 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12947 | XPSQW = | |
12948 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) | |
12949 | DXPSQ = XPSQW-XPSAQ(JJ) | |
12950 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12951 | & THEN | |
12952 | XPVD(IPVAL) = | |
12953 | & XPVD(IPVAL)-DXPSQ | |
12954 | XPSAQ(JJ) = XPSQW | |
12955 | ENDIF | |
12956 | ENDIF | |
12957 | *>>>>>>>>>>>end of chain mass correction | |
12958 | 4202 CONTINUE | |
12959 | ||
12960 | * (b) assign new v-s chains | |
12961 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12962 | IF (LSEADI.AND.( | |
12963 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) | |
12964 | & THEN | |
12965 | * sample sea-diquark pair | |
12966 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, | |
12967 | & IREJ1) | |
12968 | IF (IREJ1.EQ.0) GOTO 4203 | |
12969 | ENDIF | |
12970 | NVS = NVS+1 | |
12971 | ISKPCH(6,NVS) = 0 | |
12972 | INTVS1(NVS) = IXVPR | |
12973 | INTVS2(NVS) = J | |
12974 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12975 | * the actual chain masses | |
12976 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 | |
12977 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 | |
12978 | * get lower mass cuts | |
12979 | IF (ITSQ(J).EQ.3) THEN | |
12980 | * q being s-quark | |
12981 | AMCHK1 = AMIS | |
12982 | AMCHK2 = AMAS | |
12983 | ELSE | |
12984 | * q being u/d-quark | |
12985 | AMCHK1 = AMIU | |
12986 | AMCHK2 = AMAU | |
12987 | ENDIF | |
12988 | * q-aq chain | |
12989 | * chain mass below minimum - reset sea-aq x-value and correct | |
12990 | * diquark-x of the same nucleon | |
12991 | IF (AMVSQ1.LT.AMCHK1) THEN | |
12992 | XTSQW = | |
12993 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) | |
12994 | DXTSQ = XTSQW-XTSAQ(J) | |
12995 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
12996 | & THEN | |
12997 | XTVD(ITVAL) = | |
12998 | & XTVD(ITVAL)-DXTSQ | |
12999 | XTSAQ(J) = XTSQW | |
13000 | ENDIF | |
13001 | ENDIF | |
13002 | IF (AMVSQ2.GT.AMCHK2) THEN | |
13003 | XTSQTH = | |
13004 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13005 | **sr 8.4.98 (1/sqrt(x)) | |
13006 | XTSQXX = | |
13007 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
13008 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) | |
13009 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) | |
13010 | ** | |
13011 | XTVD(ITVAL) = | |
13012 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
13013 | XTSQ(J) = XTSQXX | |
13014 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
13015 | XTSQW = | |
13016 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13017 | DXTSQ = XTSQW-XTSQ(J) | |
13018 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
13019 | & THEN | |
13020 | XTVD(ITVAL) = | |
13021 | & XTVD(ITVAL)-DXTSQ | |
13022 | XTSQ(J) = XTSQW | |
13023 | ENDIF | |
13024 | ENDIF | |
13025 | *>>>>>>>>>end of chain mass correction | |
13026 | 4203 CONTINUE | |
13027 | * jump out of s-s chain loop | |
13028 | GOTO 420 | |
13029 | ENDIF | |
13030 | ENDIF | |
13031 | 4201 CONTINUE | |
13032 | ENDIF | |
13033 | *---->end of chain recombination option | |
13034 | ||
13035 | * sample sea-diquark pair (projectile) | |
13036 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN | |
13037 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) | |
13038 | IF (IREJ1.EQ.0) THEN | |
13039 | ISKPCH(1,NSS) = 99 | |
13040 | GOTO 410 | |
13041 | ENDIF | |
13042 | ENDIF | |
13043 | * sample sea-diquark pair (target) | |
13044 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
13045 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) | |
13046 | IF (IREJ1.EQ.0) THEN | |
13047 | ISKPCH(1,NSS) = 99 | |
13048 | GOTO 410 | |
13049 | ENDIF | |
13050 | ENDIF | |
13051 | *>>>>>correct chain kinematics according to minimum chain masses | |
13052 | * the actual chain masses | |
13053 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 | |
13054 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 | |
13055 | * check for lower mass cuts | |
13056 | IF ((SSMA1Q.LT.SSMIMQ).OR. | |
13057 | & (SSMA2Q.LT.SSMIMQ)) THEN | |
13058 | IPVAL = ITOVP(INTER1(I)) | |
13059 | ITVAL = ITOVT(INTER2(I)) | |
13060 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. | |
13061 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN | |
13062 | * maximum allowed x values for sea quarks | |
13063 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- | |
13064 | & 1.2D0*XSSTHR | |
13065 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- | |
13066 | & 1.2D0*XSSTHR | |
13067 | * resampling of x values not possible - skip sea-sea chains | |
13068 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. | |
13069 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 | |
13070 | * resampling of x for projectile sea quark pair | |
13071 | ICOUS = 0 | |
13072 | 310 CONTINUE | |
13073 | ICOUS = ICOUS+1 | |
13074 | IF (XSSTHR.GT.0.05D0) THEN | |
13075 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13076 | & XSPMAX) | |
13077 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13078 | & XSPMAX) | |
13079 | ELSE | |
13080 | 320 CONTINUE | |
13081 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13082 | IF ((XPSQI.LT.XSSTHR).OR. | |
13083 | & (XPSQI.GT.XSPMAX)) GOTO 320 | |
13084 | 330 CONTINUE | |
13085 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13086 | IF ((XPSAQI.LT.XSSTHR).OR. | |
13087 | & (XPSAQI.GT.XSPMAX)) GOTO 330 | |
13088 | ENDIF | |
13089 | * final test of remaining x for projectile diquark | |
13090 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI | |
13091 | & +XPSQ(JJ)+XPSAQ(JJ) | |
13092 | IF (XPVDCO.LE.XDTHR) THEN | |
13093 | *!!! | |
13094 | C IF (ICOUS.LT.5) GOTO 310 | |
13095 | IF (ICOUS.LT.0.5D0) GOTO 310 | |
13096 | GOTO 380 | |
13097 | ENDIF | |
13098 | * resampling of x for target sea quark pair | |
13099 | ICOUS = 0 | |
13100 | 350 CONTINUE | |
13101 | ICOUS = ICOUS+1 | |
13102 | IF (XSSTHR.GT.0.05D0) THEN | |
13103 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13104 | & XSTMAX) | |
13105 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13106 | & XSTMAX) | |
13107 | ELSE | |
13108 | 360 CONTINUE | |
13109 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13110 | IF ((XTSQI.LT.XSSTHR).OR. | |
13111 | & (XTSQI.GT.XSTMAX)) GOTO 360 | |
13112 | 370 CONTINUE | |
13113 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13114 | IF ((XTSAQI.LT.XSSTHR).OR. | |
13115 | & (XTSAQI.GT.XSTMAX)) GOTO 370 | |
13116 | ENDIF | |
13117 | * final test of remaining x for target diquark | |
13118 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI | |
13119 | & +XTSQ(J)+XTSAQ(J) | |
13120 | IF (XTVDCO.LT.XDTHR) THEN | |
13121 | IF (ICOUS.LT.5) GOTO 350 | |
13122 | GOTO 380 | |
13123 | ENDIF | |
13124 | XPVD(IPVAL) = XPVDCO | |
13125 | XTVD(ITVAL) = XTVDCO | |
13126 | XPSQ(JJ) = XPSQI | |
13127 | XPSAQ(JJ) = XPSAQI | |
13128 | XTSQ(J) = XTSQI | |
13129 | XTSAQ(J) = XTSAQI | |
13130 | *>>>>>end of chain mass correction | |
13131 | GOTO 410 | |
13132 | ENDIF | |
13133 | * come here to discard s-s interaction | |
13134 | * resampling of x values not allowed or unsuccessful | |
13135 | 380 CONTINUE | |
13136 | INTLO(I) = .FALSE. | |
13137 | ZUOST(J) = .TRUE. | |
13138 | ZUOSP(JJ) = .TRUE. | |
13139 | NSS = NSS-1 | |
13140 | ENDIF | |
13141 | * consider next s-s interaction | |
13142 | GOTO 410 | |
13143 | ENDIF | |
13144 | 390 CONTINUE | |
13145 | ENDIF | |
13146 | 400 CONTINUE | |
13147 | ENDIF | |
13148 | 410 CONTINUE | |
13149 | 420 CONTINUE | |
13150 | ||
13151 | * correct x-values of valence quarks for non-matching sea quarks | |
13152 | DO 430 I=1,IXPS | |
13153 | IF (ZUOSP(I)) THEN | |
13154 | IPVAL = ITOVP(IFROSP(I)) | |
13155 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) | |
13156 | XPSQ(I) = ZERO | |
13157 | XPSAQ(I) = ZERO | |
13158 | ZUOSP(I) = .FALSE. | |
13159 | ENDIF | |
13160 | 430 CONTINUE | |
13161 | DO 440 I=1,IXTS | |
13162 | IF (ZUOST(I)) THEN | |
13163 | ITVAL = ITOVT(IFROST(I)) | |
13164 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) | |
13165 | XTSQ(I) = ZERO | |
13166 | XTSAQ(I) = ZERO | |
13167 | ZUOST(I) = .FALSE. | |
13168 | ENDIF | |
13169 | 440 CONTINUE | |
13170 | DO 450 I=1,IXPV | |
13171 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 | |
13172 | 450 CONTINUE | |
13173 | DO 460 I=1,IXTV | |
13174 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 | |
13175 | 460 CONTINUE | |
13176 | ||
13177 | RETURN | |
13178 | END | |
13179 | ||
13180 | *$ CREATE DT_SAMSDQ.FOR | |
13181 | *COPY DT_SAMSDQ | |
13182 | * | |
13183 | *===samsdq=============================================================* | |
13184 | * | |
13185 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) | |
13186 | ||
13187 | ************************************************************************ | |
13188 | * SAMpling of Sea-DiQuarks * | |
13189 | * ECM cm-energy of the nucleon-nucleon system * | |
13190 | * IDX1,2 indices of x-values of the participating * | |
13191 | * partons (IDX2 is always the sea-q-pair to be * | |
13192 | * changed to sea-qq-pair) * | |
13193 | * MODE = 1 valence-q - sea-diq * | |
13194 | * = 2 sea-diq - valence-q * | |
13195 | * = 3 sea-q - sea-diq * | |
13196 | * = 4 sea-diq - sea-q * | |
13197 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * | |
13198 | * This version dated 17.10.95 is written by S. Roesler * | |
13199 | ************************************************************************ | |
13200 | ||
13201 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13202 | SAVE | |
13203 | ||
13204 | PARAMETER (ZERO=0.0D0) | |
13205 | ||
13206 | * threshold values for x-sampling (DTUNUC 1.x) | |
13207 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
13208 | & SSMIMQ,VVMTHR | |
13209 | * various options for treatment of partons (DTUNUC 1.x) | |
13210 | * (chain recombination, Cronin,..) | |
13211 | LOGICAL LCO2CR,LINTPT | |
13212 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
13213 | & LCO2CR,LINTPT | |
13214 | PARAMETER ( MAXNCL = 260, | |
13215 | & MAXVQU = MAXNCL, | |
13216 | & MAXSQU = 20*MAXVQU, | |
13217 | & MAXINT = MAXVQU+MAXSQU) | |
13218 | * x-values of partons (DTUNUC 1.x) | |
13219 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
13220 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
13221 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
13222 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
13223 | * flavors of partons (DTUNUC 1.x) | |
13224 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
13225 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
13226 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
13227 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
13228 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
13229 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
13230 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
13231 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13232 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
13233 | & IXPV,IXPS,IXTV,IXTS, | |
13234 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
13235 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
13236 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
13237 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
13238 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
13239 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
13240 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
13241 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
13242 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13243 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
13244 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
13245 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
13246 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
13247 | ||
13248 | IREJ = 0 | |
13249 | * threshold-x for valence diquarks | |
13250 | XDTHR = CDQ/ECM | |
13251 | ||
13252 | GOTO (1,2,3,4) MODE | |
13253 | ||
13254 | *--------------------------------------------------------------------- | |
13255 | * proj. valence partons - targ. sea partons | |
13256 | * get x-values and flavors for target sea-diquark pair | |
13257 | ||
13258 | 1 CONTINUE | |
13259 | IDXVP = IDX1 | |
13260 | IDXST = IDX2 | |
13261 | ||
13262 | * index of corr. val-diquark-x in target nucleon | |
13263 | IDXVT = ITOVT(IFROST(IDXST)) | |
13264 | * available x above diquark thresholds for valence- and sea-diquarks | |
13265 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13266 | ||
13267 | IF (XXD.GE.ZERO) THEN | |
13268 | * x-values for the three diquarks of the target nucleon | |
13269 | RR1 = DT_RNDM(XXD) | |
13270 | RR2 = DT_RNDM(RR1) | |
13271 | RR3 = DT_RNDM(RR2) | |
13272 | SR123 = RR1+RR2+RR3 | |
13273 | XXTV = XDTHR+RR1*XXD/SR123 | |
13274 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13275 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13276 | ELSE | |
13277 | XXTV = XTVD(IDXVT) | |
13278 | XXTSQ = XTSQ(IDXST) | |
13279 | XXTSAQ = XTSAQ(IDXST) | |
13280 | ENDIF | |
13281 | * flavor of the second quarks in the sea-diquark pair | |
13282 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13283 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13284 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains | |
13285 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 | |
13286 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 | |
13287 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13288 | * ss-asas pair | |
13289 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13290 | IREJ = 1 | |
13291 | RETURN | |
13292 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13293 | * at least one strange quark | |
13294 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13295 | IREJ = 1 | |
13296 | RETURN | |
13297 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13298 | IREJ = 1 | |
13299 | RETURN | |
13300 | ENDIF | |
13301 | * accept the new sea-diquark | |
13302 | XTVD(IDXVT) = XXTV | |
13303 | XTSQ(IDXST) = XXTSQ | |
13304 | XTSAQ(IDXST) = XXTSAQ | |
13305 | NVD = NVD+1 | |
13306 | INTVD1(NVD) = IDXVP | |
13307 | INTVD2(NVD) = IDXST | |
13308 | ISKPCH(7,NVD) = 0 | |
13309 | RETURN | |
13310 | ||
13311 | *--------------------------------------------------------------------- | |
13312 | * proj. sea partons - targ. valence partons | |
13313 | * get x-values and flavors for projectile sea-diquark pair | |
13314 | ||
13315 | 2 CONTINUE | |
13316 | IDXSP = IDX2 | |
13317 | IDXVT = IDX1 | |
13318 | ||
13319 | * index of corr. val-diquark-x in projectile nucleon | |
13320 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13321 | * available x above diquark thresholds for valence- and sea-diquarks | |
13322 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13323 | ||
13324 | IF (XXD.GE.ZERO) THEN | |
13325 | * x-values for the three diquarks of the projectile nucleon | |
13326 | RR1 = DT_RNDM(XXD) | |
13327 | RR2 = DT_RNDM(RR1) | |
13328 | RR3 = DT_RNDM(RR2) | |
13329 | SR123 = RR1+RR2+RR3 | |
13330 | XXPV = XDTHR+RR1*XXD/SR123 | |
13331 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13332 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13333 | ELSE | |
13334 | XXPV = XPVD(IDXVP) | |
13335 | XXPSQ = XPSQ(IDXSP) | |
13336 | XXPSAQ = XPSAQ(IDXSP) | |
13337 | ENDIF | |
13338 | * flavor of the second quarks in the sea-diquark pair | |
13339 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13340 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13341 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains | |
13342 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 | |
13343 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 | |
13344 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13345 | * ss-asas pair | |
13346 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13347 | IREJ = 1 | |
13348 | RETURN | |
13349 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13350 | * at least one strange quark | |
13351 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13352 | IREJ = 1 | |
13353 | RETURN | |
13354 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13355 | IREJ = 1 | |
13356 | RETURN | |
13357 | ENDIF | |
13358 | * accept the new sea-diquark | |
13359 | XPVD(IDXVP) = XXPV | |
13360 | XPSQ(IDXSP) = XXPSQ | |
13361 | XPSAQ(IDXSP) = XXPSAQ | |
13362 | NDV = NDV+1 | |
13363 | INTDV1(NDV) = IDXSP | |
13364 | INTDV2(NDV) = IDXVT | |
13365 | ISKPCH(5,NDV) = 0 | |
13366 | RETURN | |
13367 | ||
13368 | *--------------------------------------------------------------------- | |
13369 | * proj. sea partons - targ. sea partons | |
13370 | * get x-values and flavors for target sea-diquark pair | |
13371 | ||
13372 | 3 CONTINUE | |
13373 | IDXSP = IDX1 | |
13374 | IDXST = IDX2 | |
13375 | ||
13376 | * index of corr. val-diquark-x in target nucleon | |
13377 | IDXVT = ITOVT(IFROST(IDXST)) | |
13378 | * available x above diquark thresholds for valence- and sea-diquarks | |
13379 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13380 | ||
13381 | IF (XXD.GE.ZERO) THEN | |
13382 | * x-values for the three diquarks of the target nucleon | |
13383 | RR1 = DT_RNDM(XXD) | |
13384 | RR2 = DT_RNDM(RR1) | |
13385 | RR3 = DT_RNDM(RR2) | |
13386 | SR123 = RR1+RR2+RR3 | |
13387 | XXTV = XDTHR+RR1*XXD/SR123 | |
13388 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13389 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13390 | ELSE | |
13391 | XXTV = XTVD(IDXVT) | |
13392 | XXTSQ = XTSQ(IDXST) | |
13393 | XXTSAQ = XTSAQ(IDXST) | |
13394 | ENDIF | |
13395 | * flavor of the second quarks in the sea-diquark pair | |
13396 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13397 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13398 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains | |
13399 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 | |
13400 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 | |
13401 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13402 | * ss-asas pair | |
13403 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13404 | IREJ = 1 | |
13405 | RETURN | |
13406 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13407 | * at least one strange quark | |
13408 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13409 | IREJ = 1 | |
13410 | RETURN | |
13411 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13412 | IREJ = 1 | |
13413 | RETURN | |
13414 | ENDIF | |
13415 | * accept the new sea-diquark | |
13416 | XTVD(IDXVT) = XXTV | |
13417 | XTSQ(IDXST) = XXTSQ | |
13418 | XTSAQ(IDXST) = XXTSAQ | |
13419 | NSD = NSD+1 | |
13420 | INTSD1(NSD) = IDXSP | |
13421 | INTSD2(NSD) = IDXST | |
13422 | ISKPCH(3,NSD) = 0 | |
13423 | RETURN | |
13424 | ||
13425 | *--------------------------------------------------------------------- | |
13426 | * proj. sea partons - targ. sea partons | |
13427 | * get x-values and flavors for projectile sea-diquark pair | |
13428 | ||
13429 | 4 CONTINUE | |
13430 | IDXSP = IDX2 | |
13431 | IDXST = IDX1 | |
13432 | ||
13433 | * index of corr. val-diquark-x in projectile nucleon | |
13434 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13435 | * available x above diquark thresholds for valence- and sea-diquarks | |
13436 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13437 | ||
13438 | IF (XXD.GE.ZERO) THEN | |
13439 | * x-values for the three diquarks of the projectile nucleon | |
13440 | RR1 = DT_RNDM(XXD) | |
13441 | RR2 = DT_RNDM(RR1) | |
13442 | RR3 = DT_RNDM(RR2) | |
13443 | SR123 = RR1+RR2+RR3 | |
13444 | XXPV = XDTHR+RR1*XXD/SR123 | |
13445 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13446 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13447 | ELSE | |
13448 | XXPV = XPVD(IDXVP) | |
13449 | XXPSQ = XPSQ(IDXSP) | |
13450 | XXPSAQ = XPSAQ(IDXSP) | |
13451 | ENDIF | |
13452 | * flavor of the second quarks in the sea-diquark pair | |
13453 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13454 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13455 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains | |
13456 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 | |
13457 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 | |
13458 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13459 | * ss-asas pair | |
13460 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13461 | IREJ = 1 | |
13462 | RETURN | |
13463 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13464 | * at least one strange quark | |
13465 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13466 | IREJ = 1 | |
13467 | RETURN | |
13468 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13469 | IREJ = 1 | |
13470 | RETURN | |
13471 | ENDIF | |
13472 | * accept the new sea-diquark | |
13473 | XPVD(IDXVP) = XXPV | |
13474 | XPSQ(IDXSP) = XXPSQ | |
13475 | XPSAQ(IDXSP) = XXPSAQ | |
13476 | NDS = NDS+1 | |
13477 | INTDS1(NDS) = IDXSP | |
13478 | INTDS2(NDS) = IDXST | |
13479 | ISKPCH(2,NDS) = 0 | |
13480 | RETURN | |
13481 | END | |
13482 | ||
13483 | *$ CREATE DT_DIFEVT.FOR | |
13484 | *COPY DT_DIFEVT | |
13485 | * | |
13486 | *===difevt=============================================================* | |
13487 | * | |
13488 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
13489 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) | |
13490 | ||
13491 | ************************************************************************ | |
13492 | * Interface to treatment of diffractive interactions. * | |
13493 | * (input) IFP1/2 PDG-indizes of projectile partons * | |
13494 | * (baryon: IFP2 - adiquark) * | |
13495 | * PP(4) projectile 4-momentum * | |
13496 | * IFT1/2 PDG-indizes of target partons * | |
13497 | * (baryon: IFT1 - adiquark) * | |
13498 | * PT(4) target 4-momentum * | |
13499 | * (output) JDIFF = 0 no diffraction * | |
13500 | * = 1/-1 LMSD/LMDD * | |
13501 | * = 2/-2 HMSD/HMDD * | |
13502 | * NCSY counter for two-chain systems * | |
13503 | * dumped to DTEVT1 * | |
13504 | * This version dated 14.02.95 is written by S. Roesler * | |
13505 | ************************************************************************ | |
13506 | ||
13507 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13508 | SAVE | |
13509 | PARAMETER ( LINP = 10 , | |
13510 | & LOUT = 6 , | |
13511 | & LDAT = 9 ) | |
13512 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, | |
13513 | & OHALF=0.5D0) | |
13514 | ||
13515 | * event history | |
13516 | PARAMETER (NMXHKK=200000) | |
13517 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
13518 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
13519 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
13520 | * extended event history | |
13521 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
13522 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
13523 | & IHIST(2,NMXHKK) | |
13524 | * flags for diffractive interactions (DTUNUC 1.x) | |
13525 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
13526 | ||
13527 | DIMENSION PP(4),PT(4) | |
13528 | ||
13529 | LOGICAL LFIRST | |
13530 | DATA LFIRST /.TRUE./ | |
13531 | ||
13532 | IREJ = 0 | |
13533 | JDIFF = 0 | |
13534 | IFLAGD = JDIFF | |
13535 | ||
13536 | * cm. energy | |
13537 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
13538 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
13539 | * identities of projectile hadron / target nucleon | |
13540 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) | |
13541 | KTARG = IDT_ICIHAD(IDHKK(MOT)) | |
13542 | ||
13543 | * single diffractive xsections | |
13544 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) | |
13545 | * double diffractive xsections | |
13546 | **!! no double diff yet | |
13547 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) | |
13548 | DDTOT = 0.0D0 | |
13549 | DDHM = 0.0D0 | |
13550 | **!! | |
13551 | * total inelastic xsection | |
13552 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) | |
13553 | DUMZER = ZERO | |
13554 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) | |
13555 | SIGIN = MAX(SIGTO-SIGEL,ZERO) | |
13556 | ||
13557 | * fraction of diffractive processes | |
13558 | FRADIF = (SDTOT+DDTOT)/SIGIN | |
13559 | ||
13560 | IF (LFIRST) THEN | |
13561 | WRITE(LOUT,1000) XM,SDTOT,SIGIN | |
13562 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', | |
13563 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', | |
13564 | & F5.1,' mb',/) | |
13565 | LFIRST = .FALSE. | |
13566 | ENDIF | |
13567 | ||
13568 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. | |
13569 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN | |
13570 | * diffractive interaction requested by x-section or by user | |
13571 | FRASD = SDTOT/(SDTOT+DDTOT) | |
13572 | FRASDH = SDHM/SDTOT | |
13573 | **sr needs to be specified!! | |
13574 | C FRADDH = DDHM/DDTOT | |
13575 | FRADDH = 1.0D0 | |
13576 | ** | |
13577 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN | |
13578 | * single diffraction | |
13579 | KDIFF = 1 | |
13580 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN | |
13581 | KP = 2 | |
13582 | KT = 0 | |
13583 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. | |
13584 | & ISINGD.NE.3) THEN | |
13585 | KP = 0 | |
13586 | KT = 2 | |
13587 | ENDIF | |
13588 | ELSE | |
13589 | KP = 1 | |
13590 | KT = 0 | |
13591 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. | |
13592 | & ISINGD.NE.3) THEN | |
13593 | KP = 0 | |
13594 | KT = 1 | |
13595 | ENDIF | |
13596 | ENDIF | |
13597 | ELSE | |
13598 | * double diffraction | |
13599 | KDIFF = -1 | |
13600 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN | |
13601 | KP = 2 | |
13602 | KT = 2 | |
13603 | ELSE | |
13604 | KP = 1 | |
13605 | KT = 1 | |
13606 | ENDIF | |
13607 | ENDIF | |
13608 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13609 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13610 | IF (IREJ1.EQ.0) THEN | |
13611 | IFLAGD = 2*KDIFF | |
13612 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF | |
13613 | ELSE | |
13614 | GOTO 9999 | |
13615 | ENDIF | |
13616 | ENDIF | |
13617 | JDIFF = IFLAGD | |
13618 | ||
13619 | RETURN | |
13620 | ||
13621 | 9999 CONTINUE | |
13622 | IREJ = 1 | |
13623 | RETURN | |
13624 | END | |
13625 | ||
13626 | *$ CREATE DT_DIFFKI.FOR | |
13627 | *COPY DT_DIFFKI | |
13628 | * | |
13629 | *===difkin=============================================================* | |
13630 | * | |
13631 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13632 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) | |
13633 | ||
13634 | ************************************************************************ | |
13635 | * Kinematics of diffractive nucleon-nucleon interaction. * | |
13636 | * IFP1/2 PDG-indizes of projectile partons * | |
13637 | * (baryon: IFP2 - adiquark) * | |
13638 | * PP(4) projectile 4-momentum * | |
13639 | * IFT1/2 PDG-indizes of target partons * | |
13640 | * (baryon: IFT1 - adiquark) * | |
13641 | * PT(4) target 4-momentum * | |
13642 | * KP = 0 projectile quasi-elastically scattered * | |
13643 | * = 1 excited to low-mass diff. state * | |
13644 | * = 2 excited to high-mass diff. state * | |
13645 | * KT = 0 target quasi-elastically scattered * | |
13646 | * = 1 excited to low-mass diff. state * | |
13647 | * = 2 excited to high-mass diff. state * | |
13648 | * This version dated 12.02.95 is written by S. Roesler * | |
13649 | ************************************************************************ | |
13650 | ||
13651 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13652 | SAVE | |
13653 | PARAMETER ( LINP = 10 , | |
13654 | & LOUT = 6 , | |
13655 | & LDAT = 9 ) | |
13656 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) | |
13657 | ||
13658 | LOGICAL LSTART | |
13659 | ||
13660 | * particle properties (BAMJET index convention) | |
13661 | CHARACTER*8 ANAME | |
13662 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
13663 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
13664 | * flags for input different options | |
13665 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
13666 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
13667 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
13668 | * rejection counter | |
13669 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
13670 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
13671 | & IREXCI(3),IRDIFF(2),IRINC | |
13672 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13673 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13674 | & PPF(4),PTF(4), | |
13675 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13676 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13677 | ||
13678 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), | |
13679 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) | |
13680 | ||
13681 | DATA LSTART /.TRUE./ | |
13682 | ||
13683 | IF (LSTART) THEN | |
13684 | WRITE(LOUT,2000) | |
13685 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') | |
13686 | LSTART = .FALSE. | |
13687 | ENDIF | |
13688 | ||
13689 | IREJ = 0 | |
13690 | ||
13691 | * initialize common /DTDIKI/ | |
13692 | CALL DT_DIFINI | |
13693 | * store momenta of initial incoming particles for emc-check | |
13694 | IF (LEMCCK) THEN | |
13695 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) | |
13696 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) | |
13697 | ENDIF | |
13698 | ||
13699 | * masses of initial particles | |
13700 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 | |
13701 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 | |
13702 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 | |
13703 | XMP = SQRT(XMP2) | |
13704 | XMT = SQRT(XMT2) | |
13705 | * check quark-input (used to adjust coherence cond. for M-selection) | |
13706 | IBP = 0 | |
13707 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 | |
13708 | IBT = 0 | |
13709 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 | |
13710 | ||
13711 | * parameter for Lorentz-transformation into nucleon-nucleon cms | |
13712 | DO 3 K=1,4 | |
13713 | PITOT(K) = PP(K)+PT(K) | |
13714 | 3 CONTINUE | |
13715 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 | |
13716 | IF (XMTOT2.LE.ZERO) THEN | |
13717 | WRITE(LOUT,1000) XMTOT2 | |
13718 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', | |
13719 | & 'XMTOT2 = ',E12.3) | |
13720 | GOTO 9999 | |
13721 | ENDIF | |
13722 | XMTOT = SQRT(XMTOT2) | |
13723 | DO 4 K=1,4 | |
13724 | BGTOT(K) = PITOT(K)/XMTOT | |
13725 | 4 CONTINUE | |
13726 | * transformation of nucleons into cms | |
13727 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), | |
13728 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) | |
13729 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), | |
13730 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) | |
13731 | * rotation angles | |
13732 | COD = PP1(3)/PPTOT | |
13733 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
13734 | PPT = SQRT(PP1(1)**2+PP1(2)**2) | |
13735 | SID = PPT/PPTOT | |
13736 | COF = ONE | |
13737 | SIF = ZERO | |
13738 | IF(PPTOT*SID.GT.TINY10) THEN | |
13739 | COF = PP1(1)/(SID*PPTOT) | |
13740 | SIF = PP1(2)/(SID*PPTOT) | |
13741 | ANORF = SQRT(COF*COF+SIF*SIF) | |
13742 | COF = COF/ANORF | |
13743 | SIF = SIF/ANORF | |
13744 | ENDIF | |
13745 | * check consistency | |
13746 | DO 5 K=1,4 | |
13747 | DEV1(K) = ABS(PP1(K)+PT1(K)) | |
13748 | 5 CONTINUE | |
13749 | DEV1(4) = ABS(DEV1(4)-XMTOT) | |
13750 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. | |
13751 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN | |
13752 | WRITE(LOUT,1001) DEV1 | |
13753 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', | |
13754 | & /,8X,4E12.3) | |
13755 | GOTO 9999 | |
13756 | ENDIF | |
13757 | ||
13758 | * select x-fractions in high-mass diff. interactions | |
13759 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) | |
13760 | ||
13761 | * select diffractive masses | |
13762 | * - projectile | |
13763 | IF (KP.EQ.1) THEN | |
13764 | XMPF = DT_XMLMD(XMTOT) | |
13765 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) | |
13766 | IF (IREJ1.GT.0) GOTO 9999 | |
13767 | ELSEIF (KP.EQ.2) THEN | |
13768 | XMPF = DT_XMHMD(XMTOT,IBP,1) | |
13769 | ELSE | |
13770 | XMPF = XMP | |
13771 | ENDIF | |
13772 | * - target | |
13773 | IF (KT.EQ.1) THEN | |
13774 | XMTF = DT_XMLMD(XMTOT) | |
13775 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) | |
13776 | IF (IREJ1.GT.0) GOTO 9999 | |
13777 | ELSEIF (KT.EQ.2) THEN | |
13778 | XMTF = DT_XMHMD(XMTOT,IBT,2) | |
13779 | ELSE | |
13780 | XMTF = XMT | |
13781 | ENDIF | |
13782 | ||
13783 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) | |
13784 | XMPF2 = XMPF**2 | |
13785 | XMTF2 = XMTF**2 | |
13786 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) | |
13787 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) | |
13788 | ||
13789 | * select momentum transfer (all t-values used here are <0) | |
13790 | * minimum absolute value to produce diffractive masses | |
13791 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) | |
13792 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) | |
13793 | IF (IREJ1.GT.0) GOTO 9999 | |
13794 | ||
13795 | * longitudinal momentum of excited/elastically scattered projectile | |
13796 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) | |
13797 | * total transverse momentum due to t-selection | |
13798 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 | |
13799 | IF (PPBLT2.LT.ZERO) THEN | |
13800 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT | |
13801 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', | |
13802 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) | |
13803 | GOTO 9999 | |
13804 | ENDIF | |
13805 | CALL DT_DSFECF(SINPHI,COSPHI) | |
13806 | PPBLT = SQRT(PPBLT2) | |
13807 | PPBLOB(1) = COSPHI*PPBLT | |
13808 | PPBLOB(2) = SINPHI*PPBLT | |
13809 | ||
13810 | * rotate excited/elastically scattered projectile into n-n cms. | |
13811 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, | |
13812 | & XX,YY,ZZ) | |
13813 | PPBLOB(1) = XX | |
13814 | PPBLOB(2) = YY | |
13815 | PPBLOB(3) = ZZ | |
13816 | ||
13817 | * 4-momentum of excited/elastically scattered target and of exchanged | |
13818 | * Pomeron | |
13819 | DO 6 K=1,4 | |
13820 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) | |
13821 | PPOM1(K) = PP1(K)-PPBLOB(K) | |
13822 | 6 CONTINUE | |
13823 | PTBLOB(4) = XMTOT-PPBLOB(4) | |
13824 | ||
13825 | * Lorentz-transformation back into system of initial diff. collision | |
13826 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13827 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), | |
13828 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) | |
13829 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13830 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), | |
13831 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) | |
13832 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13833 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), | |
13834 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) | |
13835 | ||
13836 | * store 4-momentum of elastically scattered particle (in single diff. | |
13837 | * events) | |
13838 | IF (KP.EQ.0) THEN | |
13839 | DO 7 K=1,4 | |
13840 | PSC(K) = PPF(K) | |
13841 | 7 CONTINUE | |
13842 | ELSEIF (KT.EQ.0) THEN | |
13843 | DO 8 K=1,4 | |
13844 | PSC(K) = PTF(K) | |
13845 | 8 CONTINUE | |
13846 | ENDIF | |
13847 | ||
13848 | * check consistency of kinematical treatment so far | |
13849 | IF (LEMCCK) THEN | |
13850 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) | |
13851 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) | |
13852 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) | |
13853 | IF (IREJ1.NE.0) GOTO 9999 | |
13854 | ENDIF | |
13855 | DO 9 K=1,4 | |
13856 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) | |
13857 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) | |
13858 | 9 CONTINUE | |
13859 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. | |
13860 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. | |
13861 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. | |
13862 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN | |
13863 | WRITE(LOUT,1003) DEV1,DEV2 | |
13864 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', | |
13865 | & 2(/,8X,4E12.3)) | |
13866 | GOTO 9999 | |
13867 | ENDIF | |
13868 | ||
13869 | * kinematical treatment for low-mass diffraction | |
13870 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) | |
13871 | IF (IREJ1.NE.0) GOTO 9999 | |
13872 | ||
13873 | * dump diffractive chains into DTEVT1 | |
13874 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13875 | IF (IREJ1.NE.0) GOTO 9999 | |
13876 | ||
13877 | RETURN | |
13878 | ||
13879 | 9999 CONTINUE | |
13880 | IRDIFF(1) = IRDIFF(1)+1 | |
13881 | IREJ = 1 | |
13882 | RETURN | |
13883 | END | |
13884 | ||
13885 | *$ CREATE DT_XMHMD.FOR | |
13886 | *COPY DT_XMHMD | |
13887 | * | |
13888 | *===xmhmd==============================================================* | |
13889 | * | |
13890 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) | |
13891 | ||
13892 | ************************************************************************ | |
13893 | * Diffractive mass in high mass single/double diffractive events. * | |
13894 | * This version dated 11.02.95 is written by S. Roesler * | |
13895 | ************************************************************************ | |
13896 | ||
13897 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13898 | SAVE | |
13899 | PARAMETER ( LINP = 10 , | |
13900 | & LOUT = 6 , | |
13901 | & LDAT = 9 ) | |
13902 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) | |
13903 | ||
13904 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13905 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13906 | & PPF(4),PTF(4), | |
13907 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13908 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13909 | ||
13910 | C DATA XCOLOW /0.05D0/ | |
13911 | DATA XCOLOW /0.15D0/ | |
13912 | ||
13913 | DT_XMHMD = ZERO | |
13914 | XH = XPH(2) | |
13915 | IF (MODE.EQ.2) XH = XTH(2) | |
13916 | ||
13917 | * minimum Pomeron-x for high-mass diffraction | |
13918 | * (adjusted to get a smooth transition between HM and LM component) | |
13919 | R = DT_RNDM(XH) | |
13920 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) | |
13921 | IF (ECM.LE.300.0D0) THEN | |
13922 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) | |
13923 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) | |
13924 | ENDIF | |
13925 | * maximum Pomeron-x for high-mass diffraction | |
13926 | * (coherence condition, adjusted to fit to experimental data) | |
13927 | IF (IB.NE.0) THEN | |
13928 | * baryon-diffraction | |
13929 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) | |
13930 | ELSE | |
13931 | * meson-diffraction | |
13932 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) | |
13933 | ENDIF | |
13934 | * check boundaries | |
13935 | IF (XDIMIN.GE.XDIMAX) THEN | |
13936 | XDIMIN = OHALF*XDIMAX | |
13937 | ENDIF | |
13938 | ||
13939 | KLOOP = 0 | |
13940 | 1 CONTINUE | |
13941 | KLOOP = KLOOP+1 | |
13942 | IF (KLOOP.GT.20) RETURN | |
13943 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) | |
13944 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) | |
13945 | * corr. diffr. mass | |
13946 | DT_XMHMD = ECM*SQRT(XDIFF) | |
13947 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 | |
13948 | ||
13949 | RETURN | |
13950 | END | |
13951 | ||
13952 | *$ CREATE DT_XMLMD.FOR | |
13953 | *COPY DT_XMLMD | |
13954 | * | |
13955 | *===xmlmd==============================================================* | |
13956 | * | |
13957 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) | |
13958 | ||
13959 | ************************************************************************ | |
13960 | * Diffractive mass in high mass single/double diffractive events. * | |
13961 | * This version dated 11.02.95 is written by S. Roesler * | |
13962 | ************************************************************************ | |
13963 | ||
13964 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13965 | SAVE | |
13966 | PARAMETER ( LINP = 10 , | |
13967 | & LOUT = 6 , | |
13968 | & LDAT = 9 ) | |
13969 | ||
13970 | * minimum Pomeron-x for low-mass diffraction | |
13971 | C AMO = 1.5D0 | |
13972 | AMO = 2.0D0 | |
13973 | * maximum Pomeron-x for low-mass diffraction | |
13974 | * (adjusted to get a smooth transition between HM and LM component) | |
13975 | R = DT_RNDM(AMO) | |
13976 | SAM = 1.0D0 | |
13977 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) | |
13978 | R = DT_RNDM(AMO)*SAM | |
13979 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) | |
13980 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX | |
13981 | ||
13982 | * selection of diffractive mass | |
13983 | * (adjusted to get a smooth transition between HM and LM component) | |
13984 | R = DT_RNDM(AMU) | |
13985 | IF (ECM.LE.50.0D0) THEN | |
13986 | DT_XMLMD = AMO*(AMU/AMO)**R | |
13987 | ELSE | |
13988 | A = 0.7D0 | |
13989 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) | |
13990 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) | |
13991 | ENDIF | |
13992 | ||
13993 | RETURN | |
13994 | END | |
13995 | ||
13996 | *$ CREATE DT_TDIFF.FOR | |
13997 | *COPY DT_TDIFF | |
13998 | * | |
13999 | *===tdiff==============================================================* | |
14000 | * | |
14001 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) | |
14002 | ||
14003 | ************************************************************************ | |
14004 | * t-selection for single/double diffractive interactions. * | |
14005 | * ECM cm. energy * | |
14006 | * TMIN minimum momentum transfer to produce diff. masses * | |
14007 | * XM1/XM2 diffractively produced masses * | |
14008 | * (for single diffraction XM2 is obsolete) * | |
14009 | * K1/K2= 0 not excited * | |
14010 | * = 1 low-mass excitation * | |
14011 | * = 2 high-mass excitation * | |
14012 | * This version dated 11.02.95 is written by S. Roesler * | |
14013 | ************************************************************************ | |
14014 | ||
14015 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14016 | SAVE | |
14017 | PARAMETER ( LINP = 10 , | |
14018 | & LOUT = 6 , | |
14019 | & LDAT = 9 ) | |
14020 | PARAMETER (ZERO=0.0D0) | |
14021 | ||
14022 | PARAMETER ( BTP0 = 3.7D0, | |
14023 | & ALPHAP = 0.24D0 ) | |
14024 | ||
14025 | IREJ = 0 | |
14026 | NCLOOP = 0 | |
14027 | DT_TDIFF = ZERO | |
14028 | ||
14029 | IF (K1.GT.0) THEN | |
14030 | XM1 = XM1I | |
14031 | XM2 = XM2I | |
14032 | ELSE | |
14033 | XM1 = XM2I | |
14034 | ENDIF | |
14035 | XDI = (XM1/ECM)**2 | |
14036 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN | |
14037 | * slope for single diffraction | |
14038 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) | |
14039 | ELSE | |
14040 | * slope for double diffraction | |
14041 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) | |
14042 | ENDIF | |
14043 | ||
14044 | 1 CONTINUE | |
14045 | NCLOOP = NCLOOP+1 | |
14046 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 | |
14047 | Y = DT_RNDM(XDI) | |
14048 | T = -LOG(1.0D0-Y)/SLOPE | |
14049 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 | |
14050 | DT_TDIFF = -ABS(T) | |
14051 | ||
14052 | RETURN | |
14053 | ||
14054 | 9999 CONTINUE | |
14055 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 | |
14056 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, | |
14057 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', | |
14058 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) | |
14059 | IREJ = 1 | |
14060 | RETURN | |
14061 | END | |
14062 | ||
14063 | *$ CREATE DT_XVALHM.FOR | |
14064 | *COPY DT_XVALHM | |
14065 | * | |
14066 | *===xvalhm=============================================================* | |
14067 | * | |
14068 | SUBROUTINE DT_XVALHM(KP,KT) | |
14069 | ||
14070 | ************************************************************************ | |
14071 | * Sampling of parton x-values in high-mass diffractive interactions. * | |
14072 | * This version dated 12.02.95 is written by S. Roesler * | |
14073 | ************************************************************************ | |
14074 | ||
14075 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14076 | SAVE | |
14077 | PARAMETER ( LINP = 10 , | |
14078 | & LOUT = 6 , | |
14079 | & LDAT = 9 ) | |
14080 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) | |
14081 | ||
14082 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14083 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14084 | & PPF(4),PTF(4), | |
14085 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14086 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14087 | * various options for treatment of partons (DTUNUC 1.x) | |
14088 | * (chain recombination, Cronin,..) | |
14089 | LOGICAL LCO2CR,LINTPT | |
14090 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
14091 | & LCO2CR,LINTPT | |
14092 | ||
14093 | DATA UNON,XVQTHR /2.0D0,0.8D0/ | |
14094 | ||
14095 | IF (KP.EQ.2) THEN | |
14096 | * x-fractions of projectile valence partons | |
14097 | 1 CONTINUE | |
14098 | XPH(1) = DT_DBETAR(OHALF,UNON) | |
14099 | IF (XPH(1).GE.XVQTHR) GOTO 1 | |
14100 | XPH(2) = ONE-XPH(1) | |
14101 | * x-fractions of Pomeron q-aq-pair | |
14102 | XPOLO = TINY2 | |
14103 | XPOHI = ONE-TINY2 | |
14104 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14105 | XPPO(2) = ONE-XPPO(1) | |
14106 | * flavors of Pomeron q-aq-pair | |
14107 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) | |
14108 | IFPPO(1) = IFLAV | |
14109 | IFPPO(2) = -IFLAV | |
14110 | IF (DT_RNDM(UNON).GT.OHALF) THEN | |
14111 | IFPPO(1) = -IFLAV | |
14112 | IFPPO(2) = IFLAV | |
14113 | ENDIF | |
14114 | ENDIF | |
14115 | ||
14116 | IF (KT.EQ.2) THEN | |
14117 | * x-fractions of projectile target partons | |
14118 | 2 CONTINUE | |
14119 | XTH(1) = DT_DBETAR(OHALF,UNON) | |
14120 | IF (XTH(1).GE.XVQTHR) GOTO 2 | |
14121 | XTH(2) = ONE-XTH(1) | |
14122 | * x-fractions of Pomeron q-aq-pair | |
14123 | XPOLO = TINY2 | |
14124 | XPOHI = ONE-TINY2 | |
14125 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14126 | XTPO(2) = ONE-XTPO(1) | |
14127 | * flavors of Pomeron q-aq-pair | |
14128 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) | |
14129 | IFTPO(1) = IFLAV | |
14130 | IFTPO(2) = -IFLAV | |
14131 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN | |
14132 | IFTPO(1) = -IFLAV | |
14133 | IFTPO(2) = IFLAV | |
14134 | ENDIF | |
14135 | ENDIF | |
14136 | ||
14137 | RETURN | |
14138 | END | |
14139 | ||
14140 | *$ CREATE DT_LM2RES.FOR | |
14141 | *COPY DT_LM2RES | |
14142 | * | |
14143 | *===lm2res=============================================================* | |
14144 | * | |
14145 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) | |
14146 | ||
14147 | ************************************************************************ | |
14148 | * Check low-mass diffractive excitation for resonance mass. * | |
14149 | * (input) IF1/2 PDG-indizes of valence partons * | |
14150 | * (in/out) XM diffractive mass requested/corrected * | |
14151 | * (output) IDR/IDXR id./BAMJET-index of resonance * | |
14152 | * This version dated 12.02.95 is written by S. Roesler * | |
14153 | ************************************************************************ | |
14154 | ||
14155 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14156 | SAVE | |
14157 | PARAMETER ( LINP = 10 , | |
14158 | & LOUT = 6 , | |
14159 | & LDAT = 9 ) | |
14160 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14161 | ||
14162 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14163 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14164 | & PPF(4),PTF(4), | |
14165 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14166 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14167 | ||
14168 | IREJ = 0 | |
14169 | IF1B = 0 | |
14170 | IF2B = 0 | |
14171 | XMI = XM | |
14172 | ||
14173 | * BAMJET indices of partons | |
14174 | IF1A = IDT_IPDG2B(IF1,1,2) | |
14175 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) | |
14176 | IF2A = IDT_IPDG2B(IF2,1,2) | |
14177 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) | |
14178 | ||
14179 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) | |
14180 | IDCH = 2 | |
14181 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 | |
14182 | ||
14183 | * check for resonance mass | |
14184 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) | |
14185 | IF (IREJ1.NE.0) GOTO 9999 | |
14186 | ||
14187 | XM = XMN | |
14188 | RETURN | |
14189 | ||
14190 | 9999 CONTINUE | |
14191 | IREJ = 1 | |
14192 | RETURN | |
14193 | END | |
14194 | ||
14195 | *$ CREATE DT_LMKINE.FOR | |
14196 | *COPY DT_LMKINE | |
14197 | * | |
14198 | *===lmkine=============================================================* | |
14199 | * | |
14200 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) | |
14201 | ||
14202 | ************************************************************************ | |
14203 | * Kinematical treatment of low-mass excitations. * | |
14204 | * This version dated 12.02.95 is written by S. Roesler * | |
14205 | ************************************************************************ | |
14206 | ||
14207 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14208 | SAVE | |
14209 | PARAMETER ( LINP = 10 , | |
14210 | & LOUT = 6 , | |
14211 | & LDAT = 9 ) | |
14212 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14213 | ||
14214 | * flags for input different options | |
14215 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14216 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14217 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14218 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14219 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14220 | & PPF(4),PTF(4), | |
14221 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14222 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14223 | ||
14224 | DIMENSION P1(4),P2(4) | |
14225 | ||
14226 | IREJ = 0 | |
14227 | ||
14228 | IF (KP.EQ.1) THEN | |
14229 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) | |
14230 | POE = PPF(4)/PABS | |
14231 | FAC1 = OHALF*(POE+ONE) | |
14232 | FAC2 = -OHALF*(POE-ONE) | |
14233 | DO 1 K=1,3 | |
14234 | PPLM1(K) = FAC1*PPF(K) | |
14235 | PPLM2(K) = FAC2*PPF(K) | |
14236 | 1 CONTINUE | |
14237 | PPLM1(4) = FAC1*PABS | |
14238 | PPLM2(4) = -FAC2*PABS | |
14239 | IF (IMSHL.EQ.1) THEN | |
14240 | XM1 = PYMASS(IFP1) | |
14241 | XM2 = PYMASS(IFP2) | |
14242 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) | |
14243 | IF (IREJ1.NE.0) GOTO 9999 | |
14244 | DO 2 K=1,4 | |
14245 | PPLM1(K) = P1(K) | |
14246 | PPLM2(K) = P2(K) | |
14247 | 2 CONTINUE | |
14248 | ENDIF | |
14249 | ENDIF | |
14250 | ||
14251 | IF (KT.EQ.1) THEN | |
14252 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) | |
14253 | POE = PTF(4)/PABS | |
14254 | FAC1 = OHALF*(POE+ONE) | |
14255 | FAC2 = -OHALF*(POE-ONE) | |
14256 | DO 3 K=1,3 | |
14257 | PTLM2(K) = FAC1*PTF(K) | |
14258 | PTLM1(K) = FAC2*PTF(K) | |
14259 | 3 CONTINUE | |
14260 | PTLM2(4) = FAC1*PABS | |
14261 | PTLM1(4) = -FAC2*PABS | |
14262 | IF (IMSHL.EQ.1) THEN | |
14263 | XM1 = PYMASS(IFT1) | |
14264 | XM2 = PYMASS(IFT2) | |
14265 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) | |
14266 | IF (IREJ1.NE.0) GOTO 9999 | |
14267 | DO 4 K=1,4 | |
14268 | PTLM1(K) = P1(K) | |
14269 | PTLM2(K) = P2(K) | |
14270 | 4 CONTINUE | |
14271 | ENDIF | |
14272 | ENDIF | |
14273 | ||
14274 | RETURN | |
14275 | ||
14276 | 9999 CONTINUE | |
14277 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' | |
14278 | IREJ = 1 | |
14279 | RETURN | |
14280 | END | |
14281 | ||
14282 | *$ CREATE DT_DIFINI.FOR | |
14283 | *COPY DT_DIFINI | |
14284 | * | |
14285 | *===difini=============================================================* | |
14286 | * | |
14287 | SUBROUTINE DT_DIFINI | |
14288 | ||
14289 | ************************************************************************ | |
14290 | * Initialization of common /DTDIKI/ * | |
14291 | * This version dated 12.02.95 is written by S. Roesler * | |
14292 | ************************************************************************ | |
14293 | ||
14294 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14295 | SAVE | |
14296 | PARAMETER ( LINP = 10 , | |
14297 | & LOUT = 6 , | |
14298 | & LDAT = 9 ) | |
14299 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14300 | ||
14301 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14302 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14303 | & PPF(4),PTF(4), | |
14304 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14305 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14306 | ||
14307 | DO 1 K=1,4 | |
14308 | PPOM(K) = ZERO | |
14309 | PSC(K) = ZERO | |
14310 | PPF(K) = ZERO | |
14311 | PTF(K) = ZERO | |
14312 | PPLM1(K) = ZERO | |
14313 | PPLM2(K) = ZERO | |
14314 | PTLM1(K) = ZERO | |
14315 | PTLM2(K) = ZERO | |
14316 | 1 CONTINUE | |
14317 | DO 2 K=1,2 | |
14318 | XPH(K) = ZERO | |
14319 | XPPO(K) = ZERO | |
14320 | XTH(K) = ZERO | |
14321 | XTPO(K) = ZERO | |
14322 | IFPPO(K) = 0 | |
14323 | IFTPO(K) = 0 | |
14324 | 2 CONTINUE | |
14325 | IDPR = 0 | |
14326 | IDXPR = 0 | |
14327 | IDTR = 0 | |
14328 | IDXTR = 0 | |
14329 | ||
14330 | RETURN | |
14331 | END | |
14332 | ||
14333 | *$ CREATE DT_DIFPUT.FOR | |
14334 | *COPY DT_DIFPUT | |
14335 | * | |
14336 | *===difput=============================================================* | |
14337 | * | |
14338 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, | |
14339 | & IREJ) | |
14340 | ||
14341 | ************************************************************************ | |
14342 | * Dump diffractive chains into DTEVT1 * | |
14343 | * This version dated 12.02.95 is written by S. Roesler * | |
14344 | ************************************************************************ | |
14345 | ||
14346 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14347 | SAVE | |
14348 | PARAMETER ( LINP = 10 , | |
14349 | & LOUT = 6 , | |
14350 | & LDAT = 9 ) | |
14351 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14352 | ||
14353 | LOGICAL LCHK | |
14354 | ||
14355 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14356 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14357 | & PPF(4),PTF(4), | |
14358 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14359 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14360 | * event history | |
14361 | PARAMETER (NMXHKK=200000) | |
14362 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14363 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14364 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14365 | * extended event history | |
14366 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14367 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14368 | & IHIST(2,NMXHKK) | |
14369 | * rejection counter | |
14370 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
14371 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
14372 | & IREXCI(3),IRDIFF(2),IRINC | |
14373 | ||
14374 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), | |
14375 | & P1(4),P2(4),P3(4),P4(4) | |
14376 | ||
14377 | IREJ = 0 | |
14378 | ||
14379 | IF (KP.EQ.1) THEN | |
14380 | DO 1 K=1,4 | |
14381 | PCH(K) = PPLM1(K)+PPLM2(K) | |
14382 | 1 CONTINUE | |
14383 | ID1 = IFP1 | |
14384 | ID2 = IFP2 | |
14385 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14386 | ID1 = IFP2 | |
14387 | ID2 = IFP1 | |
14388 | ENDIF | |
14389 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), | |
14390 | & PPLM1(4),0,0,0) | |
14391 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), | |
14392 | & PPLM2(4),0,0,0) | |
14393 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14394 | & IDPR,IDXPR,8) | |
14395 | ELSEIF (KP.EQ.2) THEN | |
14396 | DO 2 K=1,4 | |
14397 | PP1(K) = XPH(1)*PP(K) | |
14398 | PP2(K) = XPH(2)*PP(K) | |
14399 | PT1(K) = -XPPO(1)*PPOM(K) | |
14400 | PT2(K) = -XPPO(2)*PPOM(K) | |
14401 | 2 CONTINUE | |
14402 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) | |
14403 | XM1 = ZERO | |
14404 | XM2 = ZERO | |
14405 | IF (LCHK) THEN | |
14406 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14407 | IF (IREJ1.NE.0) GOTO 9999 | |
14408 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14409 | IF (IREJ1.NE.0) GOTO 9999 | |
14410 | DO 3 K=1,4 | |
14411 | PP1(K) = P1(K) | |
14412 | PT1(K) = P2(K) | |
14413 | PP2(K) = P3(K) | |
14414 | PT2(K) = P4(K) | |
14415 | 3 CONTINUE | |
14416 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14417 | & 0,0,8) | |
14418 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14419 | & PT1(4),0,0,8) | |
14420 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14421 | & 0,0,8) | |
14422 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14423 | & PT2(4),0,0,8) | |
14424 | ELSE | |
14425 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14426 | IF (IREJ1.NE.0) GOTO 9999 | |
14427 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14428 | IF (IREJ1.NE.0) GOTO 9999 | |
14429 | DO 4 K=1,4 | |
14430 | PP1(K) = P1(K) | |
14431 | PT2(K) = P2(K) | |
14432 | PP2(K) = P3(K) | |
14433 | PT1(K) = P4(K) | |
14434 | 4 CONTINUE | |
14435 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14436 | & 0,0,8) | |
14437 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14438 | & PT2(4),0,0,8) | |
14439 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14440 | & 0,0,8) | |
14441 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14442 | & PT1(4),0,0,8) | |
14443 | ENDIF | |
14444 | NCSY = NCSY+1 | |
14445 | ELSE | |
14446 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14447 | & 0,0,0) | |
14448 | ENDIF | |
14449 | ||
14450 | IF (KT.EQ.1) THEN | |
14451 | DO 5 K=1,4 | |
14452 | PCH(K) = PTLM1(K)+PTLM2(K) | |
14453 | 5 CONTINUE | |
14454 | ID1 = IFT1 | |
14455 | ID2 = IFT2 | |
14456 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14457 | ID1 = IFT2 | |
14458 | ID2 = IFT1 | |
14459 | ENDIF | |
14460 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), | |
14461 | & PTLM1(4),0,0,0) | |
14462 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), | |
14463 | & PTLM2(4),0,0,0) | |
14464 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14465 | & IDTR,IDXTR,8) | |
14466 | ELSEIF (KT.EQ.2) THEN | |
14467 | DO 6 K=1,4 | |
14468 | PP1(K) = XTPO(1)*PPOM(K) | |
14469 | PP2(K) = XTPO(2)*PPOM(K) | |
14470 | PT1(K) = XTH(2)*PT(K) | |
14471 | PT2(K) = XTH(1)*PT(K) | |
14472 | 6 CONTINUE | |
14473 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) | |
14474 | XM1 = ZERO | |
14475 | XM2 = ZERO | |
14476 | IF (LCHK) THEN | |
14477 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14478 | IF (IREJ1.NE.0) GOTO 9999 | |
14479 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14480 | IF (IREJ1.NE.0) GOTO 9999 | |
14481 | DO 7 K=1,4 | |
14482 | PP1(K) = P1(K) | |
14483 | PT1(K) = P2(K) | |
14484 | PP2(K) = P3(K) | |
14485 | PT2(K) = P4(K) | |
14486 | 7 CONTINUE | |
14487 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14488 | & PP1(4),0,0,8) | |
14489 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14490 | & 0,0,8) | |
14491 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14492 | & PP2(4),0,0,8) | |
14493 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14494 | & 0,0,8) | |
14495 | ELSE | |
14496 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14497 | IF (IREJ1.NE.0) GOTO 9999 | |
14498 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14499 | IF (IREJ1.NE.0) GOTO 9999 | |
14500 | DO 8 K=1,4 | |
14501 | PP1(K) = P1(K) | |
14502 | PT2(K) = P2(K) | |
14503 | PP2(K) = P3(K) | |
14504 | PT1(K) = P4(K) | |
14505 | 8 CONTINUE | |
14506 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14507 | & PP1(4),0,0,8) | |
14508 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14509 | & 0,0,8) | |
14510 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14511 | & PP2(4),0,0,8) | |
14512 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14513 | & 0,0,8) | |
14514 | ENDIF | |
14515 | NCSY = NCSY+1 | |
14516 | ELSE | |
14517 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14518 | & 0,0,0) | |
14519 | ENDIF | |
14520 | ||
14521 | RETURN | |
14522 | ||
14523 | 9999 CONTINUE | |
14524 | IRDIFF(2) = IRDIFF(2)+1 | |
14525 | IREJ = 1 | |
14526 | RETURN | |
14527 | END | |
14528 | ||
14529 | *$ CREATE DT_EVTFRG.FOR | |
14530 | *COPY DT_EVTFRG | |
14531 | * | |
14532 | *===evtfrg=============================================================* | |
14533 | * | |
14534 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) | |
14535 | ||
14536 | ************************************************************************ | |
14537 | * Hadronization of chains in DTEVT1. * | |
14538 | * * | |
14539 | * Input: * | |
14540 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * | |
14541 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * | |
14542 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * | |
14543 | * hadronized with one PYEXEC call * | |
14544 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * | |
14545 | * with one PYEXEC call * | |
14546 | * Output: * | |
14547 | * NPYMEM number of entries in JETSET-common after hadronization * | |
14548 | * IREJ rejection flag * | |
14549 | * * | |
14550 | * This version dated 17.09.00 is written by S. Roesler * | |
14551 | ************************************************************************ | |
14552 | ||
14553 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14554 | SAVE | |
14555 | PARAMETER ( LINP = 10 , | |
14556 | & LOUT = 6 , | |
14557 | & LDAT = 9 ) | |
14558 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) | |
14559 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) | |
14560 | ||
14561 | LOGICAL LACCEP | |
14562 | ||
14563 | PARAMETER (MXJOIN=200) | |
14564 | ||
14565 | * event history | |
14566 | PARAMETER (NMXHKK=200000) | |
14567 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14568 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14569 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14570 | * extended event history | |
14571 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14572 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14573 | & IHIST(2,NMXHKK) | |
14574 | * flags for input different options | |
14575 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14576 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14577 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14578 | * statistics | |
14579 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
14580 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
14581 | & ICEVTG(8,0:30) | |
14582 | * flags for diffractive interactions (DTUNUC 1.x) | |
14583 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
14584 | * nucleon-nucleon event-generator | |
14585 | CHARACTER*8 CMODEL | |
14586 | LOGICAL LPHOIN | |
14587 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
14588 | * phojet | |
14589 | C model switches and parameters | |
14590 | CHARACTER*8 MDLNA | |
14591 | INTEGER ISWMDL,IPAMDL | |
14592 | DOUBLE PRECISION PARMDL | |
14593 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
14594 | * jetset | |
14595 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
1ddc441c | 14596 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 14597 | PARAMETER (MAXLND=4000) |
14598 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
14599 | INTEGER PYK | |
14600 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) | |
1ddc441c | 14601 | INTEGER PYCOMP |
9aaba0d6 | 14602 | MODE = KMODE |
14603 | ISTSTG = 7 | |
14604 | IF (MODE.NE.1) ISTSTG = 8 | |
14605 | IREJ = 0 | |
14606 | ||
14607 | IP = 0 | |
14608 | ISH = 0 | |
14609 | INIEMC = 1 | |
14610 | NEND = NHKK | |
14611 | NACCEP = 0 | |
14612 | IFRG = 0 | |
14613 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
14614 | DO 10 I=NPOINT(3),NEND | |
14615 | * sr 14.02.00: seems to be not necessary anymore, commented | |
14616 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. | |
14617 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) | |
14618 | LACCEP = .TRUE. | |
14619 | * pick up chains from dtevt1 | |
14620 | IDCHK = IDHKK(I)/10000 | |
14621 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN | |
14622 | IF (IDCHK.EQ.7) THEN | |
14623 | IPJE = IDHKK(I)-IDCHK*10000 | |
14624 | IF (IPJE.NE.IFRG) THEN | |
14625 | IFRG = IPJE | |
14626 | IF (IFRG.GT.NFRG) GOTO 16 | |
14627 | ENDIF | |
14628 | ELSE | |
14629 | IPJE = 1 | |
14630 | IFRG = IFRG+1 | |
14631 | IF (IFRG.GT.NFRG) THEN | |
14632 | NFRG = -1 | |
14633 | GOTO 16 | |
14634 | ENDIF | |
14635 | ENDIF | |
14636 | * statistics counter | |
14637 | c IF (IDCH(I).LE.8) | |
14638 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 | |
14639 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 | |
14640 | * special treatment for small chains already corrected to hadrons | |
14641 | IF (IDRES(I).NE.0) THEN | |
14642 | IF (IDRES(I).EQ.11) THEN | |
14643 | ID = IDXRES(I) | |
14644 | ELSE | |
14645 | ID = IDT_IPDGHA(IDXRES(I)) | |
14646 | ENDIF | |
14647 | IF (LEMCCK) THEN | |
14648 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
14649 | & PHKK(4,I),INIEMC,IDUM,IDUM) | |
14650 | INIEMC = 2 | |
14651 | ENDIF | |
14652 | IP = IP+1 | |
14653 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' | |
14654 | P(IP,1) = PHKK(1,I) | |
14655 | P(IP,2) = PHKK(2,I) | |
14656 | P(IP,3) = PHKK(3,I) | |
14657 | P(IP,4) = PHKK(4,I) | |
14658 | P(IP,5) = PHKK(5,I) | |
14659 | K(IP,1) = 1 | |
14660 | K(IP,2) = ID | |
14661 | K(IP,3) = 0 | |
14662 | K(IP,4) = 0 | |
14663 | K(IP,5) = 0 | |
14664 | IHIST(2,I) = 10000*IPJE+IP | |
14665 | IF (IHIST(1,I).LE.-100) THEN | |
14666 | ISH = ISH+1 | |
14667 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14668 | ISJOIN(ISH) = I | |
14669 | ENDIF | |
14670 | N = IP | |
14671 | IHISMO(IP) = I | |
14672 | ELSE | |
14673 | IJ = 0 | |
14674 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) | |
14675 | IF (LEMCCK) THEN | |
14676 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), | |
14677 | & PHKK(4,KK),INIEMC,IDUM,IDUM) | |
14678 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) | |
14679 | INIEMC = 2 | |
14680 | ENDIF | |
14681 | ID = IDHKK(KK) | |
14682 | IF (ID.EQ.0) ID = 21 | |
14683 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) | |
14684 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) | |
14685 | c AMRQ = PYMASS(ID) | |
14686 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
14687 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. | |
14688 | c & (ABS(IDIFF).EQ.0)) THEN | |
14689 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ | |
14690 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) | |
14691 | c PHKK(4,KK) = PHKK(4,KK)+DELTA | |
14692 | c PTOT1 = PTOT-DELTA | |
14693 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT | |
14694 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT | |
14695 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT | |
14696 | c PHKK(5,KK) = AMRQ | |
14697 | c ENDIF | |
14698 | IP = IP+1 | |
14699 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' | |
14700 | P(IP,1) = PHKK(1,KK) | |
14701 | P(IP,2) = PHKK(2,KK) | |
14702 | P(IP,3) = PHKK(3,KK) | |
14703 | P(IP,4) = PHKK(4,KK) | |
14704 | P(IP,5) = PHKK(5,KK) | |
14705 | K(IP,1) = 1 | |
14706 | K(IP,2) = ID | |
14707 | K(IP,3) = 0 | |
14708 | K(IP,4) = 0 | |
14709 | K(IP,5) = 0 | |
14710 | IHIST(2,KK) = 10000*IPJE+IP | |
14711 | IF (IHIST(1,KK).LE.-100) THEN | |
14712 | ISH = ISH+1 | |
14713 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14714 | ISJOIN(ISH) = KK | |
14715 | ENDIF | |
14716 | IJ = IJ+1 | |
14717 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' | |
14718 | IJOIN(IJ) = IP | |
14719 | IHISMO(IP) = I | |
14720 | 11 CONTINUE | |
14721 | N = IP | |
14722 | * join the two-parton system | |
14723 | CALL PYJOIN(IJ,IJOIN) | |
14724 | ENDIF | |
14725 | IDHKK(I) = 99999 | |
14726 | ENDIF | |
14727 | 10 CONTINUE | |
14728 | 16 CONTINUE | |
14729 | N = IP | |
14730 | ||
14731 | IF (IP.GT.0) THEN | |
14732 | ||
14733 | * final state parton shower | |
14734 | DO 136 NPJE=1,IPJE | |
14735 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN | |
14736 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN | |
14737 | DO 130 K1=1,ISH | |
14738 | IF (ISJOIN(K1).EQ.0) GOTO 130 | |
14739 | I = ISJOIN(K1) | |
14740 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) | |
14741 | & GOTO 130 | |
14742 | IH1 = IHIST(2,I)/10000 | |
14743 | IF (IH1.NE.NPJE) GOTO 130 | |
14744 | IH1 = IHIST(2,I)-IH1*10000 | |
14745 | DO 135 K2=K1+1,ISH | |
14746 | IF (ISJOIN(K2).EQ.0) GOTO 135 | |
14747 | II = ISJOIN(K2) | |
14748 | IH2 = IHIST(2,II)/10000 | |
14749 | IF (IH2.NE.NPJE) GOTO 135 | |
14750 | IH2 = IHIST(2,II)-IH2*10000 | |
14751 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN | |
14752 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) | |
14753 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) | |
14754 | RQLUN = MIN(PT1,PT2) | |
14755 | CALL PYSHOW(IH1,IH2,RQLUN) | |
14756 | ||
14757 | ISJOIN(K1) = 0 | |
14758 | ISJOIN(K2) = 0 | |
14759 | GOTO 130 | |
14760 | ENDIF | |
14761 | 135 CONTINUE | |
14762 | 130 CONTINUE | |
14763 | ENDIF | |
14764 | ENDIF | |
14765 | 136 CONTINUE | |
14766 | ||
14767 | CALL DT_INITJS(MODE) | |
14768 | * hadronization | |
14769 | ||
14770 | CALL PYEXEC | |
14771 | ||
14772 | IF (MSTU(24).NE.0) THEN | |
14773 | WRITE(LOUT,*) ' JETSET-reject at event', | |
14774 | & NEVHKK,MSTU(24),KMODE | |
14775 | C CALL DT_EVTOUT(4) | |
14776 | ||
14777 | C CALL PYLIST(2) | |
14778 | ||
14779 | GOTO 9999 | |
14780 | ENDIF | |
14781 | ||
14782 | * number of entries in LUJETS | |
14783 | ||
14784 | NLINES = PYK(0,1) | |
14785 | ||
14786 | NPYMEM = NLINES | |
14787 | ||
14788 | DO 12 I=1,NLINES | |
14789 | IFLG(I) = 0 | |
14790 | 12 CONTINUE | |
14791 | ||
14792 | DO 13 II=1,NLINES | |
14793 | ||
14794 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN | |
14795 | ||
14796 | * pick up mother resonance if possible and put it together with | |
14797 | * their decay-products into the common | |
14798 | IDXMOR = K(II,3) | |
14799 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN | |
14800 | KFMOR = K(IDXMOR,2) | |
14801 | ISMOR = K(IDXMOR,1) | |
14802 | ELSE | |
14803 | KFMOR = 91 | |
14804 | ISMOR = 1 | |
14805 | ENDIF | |
14806 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. | |
14807 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN | |
14808 | ID = K(IDXMOR,2) | |
14809 | MO = IHISMO(PYK(IDXMOR,15)) | |
14810 | PX = PYP(IDXMOR,1) | |
14811 | PY = PYP(IDXMOR,2) | |
14812 | PZ = PYP(IDXMOR,3) | |
14813 | PE = PYP(IDXMOR,4) | |
14814 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14815 | IFLG(IDXMOR) = 1 | |
14816 | MO = NHKK | |
14817 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) | |
14818 | IF (PYK(JDAUG,7).EQ.1) THEN | |
14819 | ID = PYK(JDAUG,8) | |
14820 | PX = PYP(JDAUG,1) | |
14821 | PY = PYP(JDAUG,2) | |
14822 | PZ = PYP(JDAUG,3) | |
14823 | PE = PYP(JDAUG,4) | |
14824 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14825 | IF (LEMCCK) THEN | |
14826 | PX = -PYP(JDAUG,1) | |
14827 | PY = -PYP(JDAUG,2) | |
14828 | PZ = -PYP(JDAUG,3) | |
14829 | PE = -PYP(JDAUG,4) | |
14830 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14831 | ENDIF | |
14832 | IFLG(JDAUG) = 1 | |
14833 | ENDIF | |
14834 | 15 CONTINUE | |
14835 | ELSE | |
14836 | * there was no mother resonance | |
14837 | MO = IHISMO(PYK(II,15)) | |
14838 | ID = PYK(II,8) | |
14839 | PX = PYP(II,1) | |
14840 | PY = PYP(II,2) | |
14841 | PZ = PYP(II,3) | |
14842 | PE = PYP(II,4) | |
14843 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14844 | IF (LEMCCK) THEN | |
14845 | PX = -PYP(II,1) | |
14846 | PY = -PYP(II,2) | |
14847 | PZ = -PYP(II,3) | |
14848 | PE = -PYP(II,4) | |
14849 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14850 | ENDIF | |
14851 | ENDIF | |
14852 | ENDIF | |
14853 | 13 CONTINUE | |
14854 | IF (LEMCCK) THEN | |
14855 | CHKLEV = TINY1 | |
14856 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) | |
14857 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
14858 | ENDIF | |
14859 | ||
14860 | * global energy-momentum & flavor conservation check | |
14861 | **sr 16.5. this check is skipped in case of phojet-treatment | |
14862 | IF (MCGENE.EQ.1) | |
14863 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) | |
14864 | ||
14865 | * update statistics-counter for diffraction | |
14866 | c IF (IFLAGD.NE.0) THEN | |
14867 | c ICDIFF(1) = ICDIFF(1)+1 | |
14868 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 | |
14869 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 | |
14870 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 | |
14871 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 | |
14872 | c ENDIF | |
14873 | ||
14874 | ENDIF | |
14875 | ||
14876 | RETURN | |
14877 | ||
14878 | 9999 CONTINUE | |
14879 | IREJ = 1 | |
14880 | RETURN | |
14881 | END | |
14882 | ||
14883 | *$ CREATE DT_DECAYS.FOR | |
14884 | *COPY DT_DECAYS | |
14885 | * | |
14886 | *===decay==============================================================* | |
14887 | * | |
14888 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
14889 | ||
14890 | ************************************************************************ | |
14891 | * Resonance-decay. * | |
14892 | * This subroutine replaces DDECAY/DECHKK. * | |
14893 | * PIN(4) 4-momentum of resonance (input) * | |
14894 | * IDXIN BAMJET-index of resonance (input) * | |
14895 | * POUT(20,4) 4-momenta of decay-products (output) * | |
14896 | * IDXOUT(20) BAMJET-indices of decay-products (output) * | |
14897 | * NSEC number of secondaries (output) * | |
14898 | * Adopted from the original version DECHKK. * | |
14899 | * This version dated 09.01.95 is written by S. Roesler * | |
14900 | ************************************************************************ | |
14901 | ||
14902 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14903 | SAVE | |
14904 | PARAMETER ( LINP = 10 , | |
14905 | & LOUT = 6 , | |
14906 | & LDAT = 9 ) | |
14907 | PARAMETER (TINY17=1.0D-17) | |
14908 | ||
14909 | * HADRIN: decay channel information | |
14910 | PARAMETER (IDMAX9=602) | |
14911 | CHARACTER*8 ZKNAME | |
14912 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
14913 | * particle properties (BAMJET index convention) | |
14914 | CHARACTER*8 ANAME | |
14915 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
14916 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
14917 | * flags for input different options | |
14918 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14919 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14920 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14921 | ||
14922 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), | |
14923 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), | |
14924 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) | |
14925 | ||
14926 | * ISTAB = 1 strong and weak decays | |
14927 | * = 2 strong decays only | |
14928 | * = 3 strong decays, weak decays for charmed particles and tau | |
14929 | * leptons only | |
14930 | DATA ISTAB /2/ | |
14931 | ||
14932 | IREJ = 0 | |
14933 | NSEC = 0 | |
14934 | * put initial resonance to stack | |
14935 | NSTK = 1 | |
14936 | IDXSTK(NSTK) = IDXIN | |
14937 | DO 5 I=1,4 | |
14938 | PI(NSTK,I) = PIN(I) | |
14939 | 5 CONTINUE | |
14940 | ||
14941 | * store initial configuration for energy-momentum cons. check | |
14942 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), | |
14943 | & PI(NSTK,4),1,IDUM,IDUM) | |
14944 | ||
14945 | 100 CONTINUE | |
14946 | * get particle from stack | |
14947 | IDXI = IDXSTK(NSTK) | |
14948 | * skip stable particles | |
14949 | IF (ISTAB.EQ.1) THEN | |
14950 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 | |
14951 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 | |
14952 | ELSEIF (ISTAB.EQ.2) THEN | |
14953 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 | |
14954 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14955 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 | |
14956 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 | |
14957 | IF ( IDXI.EQ.109) GOTO 10 | |
14958 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 | |
14959 | ELSEIF (ISTAB.EQ.3) THEN | |
14960 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 | |
14961 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14962 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 | |
14963 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 | |
14964 | ENDIF | |
14965 | ||
14966 | * calculate direction cosines and Lorentz-parameter of decaying part. | |
14967 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) | |
14968 | PTOT = MAX(PTOT,TINY17) | |
14969 | DO 1 I=1,3 | |
14970 | DCOS(I) = PI(NSTK,I)/PTOT | |
14971 | 1 CONTINUE | |
14972 | GAM = PI(NSTK,4)/AAM(IDXI) | |
14973 | BGAM = PTOT/AAM(IDXI) | |
14974 | ||
14975 | * get decay-channel | |
14976 | KCHAN = K1(IDXI)-1 | |
14977 | 2 CONTINUE | |
14978 | KCHAN = KCHAN+1 | |
14979 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 | |
14980 | ||
14981 | * identities of secondaries | |
14982 | IDX(1) = NZK(KCHAN,1) | |
14983 | IDX(2) = NZK(KCHAN,2) | |
14984 | IF (IDX(2).LT.1) GOTO 9999 | |
14985 | IDX(3) = NZK(KCHAN,3) | |
14986 | ||
14987 | * handle decay in rest system of decaying particle | |
14988 | IF (IDX(3).EQ.0) THEN | |
14989 | * two-particle decay | |
14990 | NDEC = 2 | |
14991 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), | |
14992 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
14993 | & AAM(IDX(1)),AAM(IDX(2))) | |
14994 | ELSE | |
14995 | * three-particle decay | |
14996 | NDEC = 3 | |
14997 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), | |
14998 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
14999 | & CODF(3),COFF(3),SIFF(3), | |
15000 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) | |
15001 | ENDIF | |
15002 | NSTK = NSTK-1 | |
15003 | ||
15004 | * transform decay products back | |
15005 | DO 3 I=1,NDEC | |
15006 | NSTK = NSTK+1 | |
15007 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), | |
15008 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), | |
15009 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) | |
15010 | * add particle to stack | |
15011 | IDXSTK(NSTK) = IDX(I) | |
15012 | DO 4 J=1,3 | |
15013 | PI(NSTK,J) = DCOSF(J)*PFF(I) | |
15014 | 4 CONTINUE | |
15015 | 3 CONTINUE | |
15016 | GOTO 100 | |
15017 | ||
15018 | 10 CONTINUE | |
15019 | * stable particle, put to output-arrays | |
15020 | NSEC = NSEC+1 | |
15021 | DO 6 I=1,4 | |
15022 | POUT(NSEC,I) = PI(NSTK,I) | |
15023 | 6 CONTINUE | |
15024 | IDXOUT(NSEC) = IDXSTK(NSTK) | |
15025 | * store secondaries for energy-momentum conservation check | |
15026 | IF (LEMCCK) | |
15027 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), | |
15028 | & -POUT(NSEC,4),2,IDUM,IDUM) | |
15029 | NSTK = NSTK-1 | |
15030 | IF (NSTK.GT.0) GOTO 100 | |
15031 | ||
15032 | * check energy-momentum conservation | |
15033 | IF (LEMCCK) THEN | |
15034 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) | |
15035 | IF (IREJ1.NE.0) GOTO 9999 | |
15036 | ENDIF | |
15037 | ||
15038 | RETURN | |
15039 | ||
15040 | 9999 CONTINUE | |
15041 | IREJ = 1 | |
15042 | RETURN | |
15043 | END | |
15044 | ||
15045 | *$ CREATE DT_DECAY1.FOR | |
15046 | *COPY DT_DECAY1 | |
15047 | * | |
15048 | *===decay1=============================================================* | |
15049 | * | |
15050 | SUBROUTINE DT_DECAY1 | |
15051 | ||
15052 | ************************************************************************ | |
15053 | * Decay of resonances stored in DTEVT1. * | |
15054 | * This version dated 20.01.95 is written by S. Roesler * | |
15055 | ************************************************************************ | |
15056 | ||
15057 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15058 | SAVE | |
15059 | PARAMETER ( LINP = 10 , | |
15060 | & LOUT = 6 , | |
15061 | & LDAT = 9 ) | |
15062 | ||
15063 | * event history | |
15064 | PARAMETER (NMXHKK=200000) | |
15065 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15066 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15067 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15068 | * extended event history | |
15069 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15070 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15071 | & IHIST(2,NMXHKK) | |
15072 | ||
15073 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) | |
15074 | ||
15075 | NEND = NHKK | |
15076 | C DO 1 I=NPOINT(5),NEND | |
15077 | DO 1 I=NPOINT(4),NEND | |
15078 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
15079 | DO 2 K=1,4 | |
15080 | PIN(K) = PHKK(K,I) | |
15081 | 2 CONTINUE | |
15082 | IDXIN = IDBAM(I) | |
15083 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
15084 | IF (NSEC.GT.1) THEN | |
15085 | DO 3 N=1,NSEC | |
15086 | IDHAD = IDT_IPDGHA(IDXOUT(N)) | |
15087 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), | |
15088 | & POUT(N,3),POUT(N,4),0,0,0) | |
15089 | 3 CONTINUE | |
15090 | ENDIF | |
15091 | ENDIF | |
15092 | 1 CONTINUE | |
15093 | ||
15094 | RETURN | |
15095 | END | |
15096 | ||
15097 | *$ CREATE DT_DECPI0.FOR | |
15098 | *COPY DT_DECPI0 | |
15099 | * | |
15100 | *===decpi0=============================================================* | |
15101 | * | |
15102 | SUBROUTINE DT_DECPI0 | |
15103 | ||
15104 | ************************************************************************ | |
15105 | * Decay of pi0 handled with JETSET. * | |
15106 | * This version dated 18.02.96 is written by S. Roesler * | |
15107 | ************************************************************************ | |
15108 | ||
15109 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15110 | SAVE | |
15111 | PARAMETER ( LINP = 10 , | |
15112 | & LOUT = 6 , | |
15113 | & LDAT = 9 ) | |
15114 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) | |
15115 | ||
15116 | * event history | |
15117 | PARAMETER (NMXHKK=200000) | |
15118 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15119 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15120 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15121 | * extended event history | |
15122 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15123 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15124 | & IHIST(2,NMXHKK) | |
bd378884 | 15125 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 15126 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
15127 | PARAMETER (MAXLND=4000) | |
15128 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
15129 | * flags for input different options | |
15130 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15131 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15132 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15133 | ||
15134 | INTEGER PYCOMP,PYK | |
15135 | ||
15136 | DIMENSION IHISMO(NMXHKK),P1(4) | |
15137 | ||
15138 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) | |
15139 | ||
15140 | CALL DT_INITJS(2) | |
15141 | * allow pi0 decay | |
15142 | KC = PYCOMP(111) | |
15143 | MDCY(KC,1) = 1 | |
15144 | ||
15145 | NN = 0 | |
15146 | INI = 0 | |
15147 | DO 1 I=1,NHKK | |
15148 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN | |
15149 | IF (INI.EQ.0) THEN | |
15150 | INI = 1 | |
15151 | ELSE | |
15152 | INI = 2 | |
15153 | ENDIF | |
15154 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
15155 | & PHKK(4,I),INI,IDUM,IDUM) | |
15156 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) | |
15157 | PTOT = SQRT(PT**2+PHKK(3,I)**2) | |
15158 | COSTH = PHKK(3,I)/(PTOT+TINY10) | |
15159 | IF (COSTH.GT.ONE) THEN | |
15160 | THETA = ZERO | |
15161 | ELSEIF (COSTH.LT.-ONE) THEN | |
15162 | THETA = TWOPI/2.0D0 | |
15163 | ELSE | |
15164 | THETA = ACOS(COSTH) | |
15165 | ENDIF | |
15166 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) | |
15167 | IF (PHKK(1,I).LT.0.0D0) | |
15168 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) | |
15169 | ENER = PHKK(4,I) | |
15170 | NN = NN+1 | |
15171 | KTEMP = MSTU(10) | |
15172 | MSTU(10)= 1 | |
15173 | P(NN,5) = PHKK(5,I) | |
15174 | CALL PY1ENT(NN,111,ENER,THETA,PHI) | |
15175 | MSTU(10) = KTEMP | |
15176 | IHISMO(NN)= I | |
15177 | ENDIF | |
15178 | 1 CONTINUE | |
15179 | IF (NN.GT.0) THEN | |
15180 | CALL PYEXEC | |
15181 | NLINES = PYK(0,1) | |
15182 | DO 2 II=1,NLINES | |
15183 | IF (PYK(II,7).EQ.1) THEN | |
15184 | DO 3 KK=1,4 | |
15185 | P1(KK) = PYP(II,KK) | |
15186 | 3 CONTINUE | |
15187 | ID = PYK(II,8) | |
15188 | MO = IHISMO(PYK(II,15)) | |
15189 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) | |
15190 | IF (LEMCCK) | |
15191 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, | |
15192 | & IDUM,IDUM) | |
15193 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) | |
15194 | ISTHKK(MO) = -2 | |
15195 | ENDIF | |
15196 | 2 CONTINUE | |
15197 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) | |
15198 | ENDIF | |
15199 | MDCY(KC,1) = 0 | |
15200 | ||
15201 | RETURN | |
15202 | END | |
15203 | ||
15204 | *$ CREATE DT_DTWOPD.FOR | |
15205 | *COPY DT_DTWOPD | |
15206 | * | |
15207 | *===dtwopd=============================================================* | |
15208 | * | |
15209 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, | |
15210 | & COF2,SIF2,AM1,AM2) | |
15211 | ||
15212 | ************************************************************************ | |
15213 | * Two-particle decay. * | |
15214 | * UMO cm-energy of the decaying system (input) * | |
15215 | * AM1/AM2 masses of the decay products (input) * | |
15216 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * | |
15217 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15218 | * Revised by S. Roesler, 20.11.95 * | |
15219 | ************************************************************************ | |
15220 | ||
15221 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15222 | SAVE | |
15223 | PARAMETER ( LINP = 10 , | |
15224 | & LOUT = 6 , | |
15225 | & LDAT = 9 ) | |
15226 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) | |
15227 | ||
15228 | IF (UMO.LT.(AM1+AM2)) THEN | |
15229 | WRITE(LOUT,1000) UMO,AM1,AM2 | |
15230 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', | |
15231 | & 3E12.3) | |
15232 | STOP | |
15233 | ENDIF | |
15234 | ||
15235 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) | |
15236 | ECM2 = UMO-ECM1 | |
15237 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) | |
15238 | PCM2 = PCM1 | |
15239 | CALL DT_DSFECF(SIF1,COF1) | |
15240 | COD1 = TWO*DT_RNDM(PCM2)-ONE | |
15241 | COD2 = -COD1 | |
15242 | COF2 = -COF1 | |
15243 | SIF2 = -SIF1 | |
15244 | ||
15245 | RETURN | |
15246 | END | |
15247 | ||
15248 | *$ CREATE DT_DTHREP.FOR | |
15249 | *COPY DT_DTHREP | |
15250 | * | |
15251 | *===dthrep=============================================================* | |
15252 | * | |
15253 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, | |
15254 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
15255 | ||
15256 | ************************************************************************ | |
15257 | * Three-particle decay. * | |
15258 | * UMO cm-energy of the decaying system (input) * | |
15259 | * AM1/2/3 masses of the decay products (input) * | |
15260 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * | |
15261 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15262 | * * | |
15263 | * Threpd89: slight revision by A. Ferrari * | |
15264 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * | |
15265 | * Revised by S. Roesler, 20.11.95 * | |
15266 | ************************************************************************ | |
15267 | ||
15268 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15269 | SAVE | |
15270 | PARAMETER ( LINP = 10 , | |
15271 | & LOUT = 6 , | |
15272 | & LDAT = 9 ) | |
15273 | ||
15274 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
15275 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
15276 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
15277 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
15278 | PARAMETER ( ONEONE = 1.D+00 ) | |
15279 | PARAMETER ( TWOTWO = 2.D+00 ) | |
15280 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
15281 | ||
15282 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
15283 | * flags for input different options | |
15284 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15285 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15286 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15287 | ||
15288 | DIMENSION F(5),XX(5) | |
15289 | DATA EPS /AZRZRZ/ | |
15290 | ||
15291 | UMOO=UMO+UMO | |
15292 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 | |
15293 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 | |
15294 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION | |
15295 | UUMO=UMO | |
15296 | AAM1=AM1 | |
15297 | AAM2=AM2 | |
15298 | AAM3=AM3 | |
15299 | GU=(AM2+AM3)**2 | |
15300 | GO=(UMO-AM1)**2 | |
15301 | * UFAK=1.0000000000001D0 | |
15302 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 | |
15303 | IF (GU.GT.GO) THEN | |
15304 | UFAK=ONEMNS | |
15305 | ELSE | |
15306 | UFAK=ONEPLS | |
15307 | END IF | |
15308 | OFAK=2.D0-UFAK | |
15309 | GU=GU*UFAK | |
15310 | GO=GO*OFAK | |
15311 | DS2=(GO-GU)/99.D0 | |
15312 | AM11=AM1*AM1 | |
15313 | AM22=AM2*AM2 | |
15314 | AM33=AM3*AM3 | |
15315 | UMO2=UMO*UMO | |
15316 | RHO2=0.D0 | |
15317 | S22=GU | |
15318 | DO 124 I=1,100 | |
15319 | S21=S22 | |
15320 | S22=GU+(I-1.D0)*DS2 | |
15321 | RHO1=RHO2 | |
15322 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ | |
15323 | * (S22+EPS) | |
15324 | IF(RHO2.LT.RHO1) GO TO 125 | |
15325 | 124 CONTINUE | |
15326 | 125 S2SUP=(S22-S21)*.5D0+S21 | |
15327 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ | |
15328 | * (S2SUP+EPS) | |
15329 | SUPRHO=SUPRHO*1.05D0 | |
15330 | XO=S21-DS2 | |
15331 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU | |
15332 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU | |
15333 | XX(1)=XO | |
15334 | XX(3)=S22 | |
15335 | X1=(XO+S22)*0.5D0 | |
15336 | XX(2)=X1 | |
15337 | F(3)=RHO2 | |
15338 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) | |
15339 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) | |
15340 | DO 126 I=1,16 | |
15341 | X4=(XX(1)+XX(2))*0.5D0 | |
15342 | X5=(XX(2)+XX(3))*0.5D0 | |
15343 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ | |
15344 | * (X4+EPS) | |
15345 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ | |
15346 | * (X5+EPS) | |
15347 | XX(4)=X4 | |
15348 | XX(5)=X5 | |
15349 | DO 128 II=1,5 | |
15350 | IA=II | |
15351 | DO 128 III=IA,5 | |
15352 | IF (F (II).GE.F (III)) GO TO 128 | |
15353 | FH=F(II) | |
15354 | F(II)=F(III) | |
15355 | F(III)=FH | |
15356 | FH=XX(II) | |
15357 | XX(II)=XX(III) | |
15358 | XX(III)=FH | |
15359 | 128 CONTINUE | |
15360 | SUPRHO=F(1) | |
15361 | S2SUP=XX(1) | |
15362 | DO 129 II=1,3 | |
15363 | IA=II | |
15364 | DO 129 III=IA,3 | |
15365 | IF (XX(II).GE.XX(III)) GO TO 129 | |
15366 | FH=F(II) | |
15367 | F(II)=F(III) | |
15368 | F(III)=FH | |
15369 | FH=XX(II) | |
15370 | XX(II)=XX(III) | |
15371 | XX(III)=FH | |
15372 | 129 CONTINUE | |
15373 | 126 CONTINUE | |
15374 | AM23=(AM2+AM3)**2 | |
15375 | ITH=0 | |
15376 | REDU=2.D0 | |
15377 | 1 CONTINUE | |
15378 | ITH=ITH+1 | |
15379 | IF (ITH.GT.200) REDU=-9.D0 | |
15380 | IF (ITH.GT.200) GO TO 400 | |
15381 | C=DT_RNDM(REDU) | |
15382 | * S2=AM23+C*((UMO-AM1)**2-AM23) | |
15383 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) | |
15384 | Y=DT_RNDM(S2) | |
15385 | Y=Y*SUPRHO | |
15386 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 | |
15387 | IF(Y.GT.RHO) GO TO 1 | |
15388 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 | |
15389 | S1=DT_RNDM(S2) | |
15390 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- | |
15391 | &RHO*.5D0 | |
15392 | S3=UMO2+AM11+AM22+AM33-S1-S2 | |
15393 | ECM1=(UMO2+AM11-S2)/UMOO | |
15394 | ECM2=(UMO2+AM22-S3)/UMOO | |
15395 | ECM3=(UMO2+AM33-S1)/UMOO | |
15396 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) | |
15397 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) | |
15398 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) | |
15399 | CALL DT_DSFECF(SFE,CFE) | |
15400 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 | |
15401 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF | |
15402 | PCM12 = PCM1 * PCM2 | |
15403 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 | |
15404 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 | |
15405 | GO TO 300 | |
15406 | 200 CONTINUE | |
15407 | UW=DT_RNDM(S1) | |
15408 | COSTH=(UW-0.5D+00)*2.D+00 | |
15409 | 300 CONTINUE | |
15410 | * IF(ABS(COSTH).GT.0.9999999999999999D0) | |
15411 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) | |
15412 | IF(ABS(COSTH).GT.ONEONE) | |
15413 | &COSTH=SIGN(ONEONE,COSTH) | |
15414 | IF (REDU.LT.1.D+00) RETURN | |
15415 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) | |
15416 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) | |
15417 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) | |
15418 | IF(ABS(COSTH2).GT.ONEONE) | |
15419 | &COSTH2=SIGN(ONEONE,COSTH2) | |
15420 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) | |
15421 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) | |
15422 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 | |
15423 | COSTH1=COSTH*COSTH2+SINTH2*SINTH | |
15424 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA | |
15425 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR | |
15426 | C***THE DIRECTION OF PARTICLE 3 | |
15427 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 | |
15428 | CX11=-COSTH1 | |
15429 | CY11=SINTH1*CFE | |
15430 | CZ11=SINTH1*SFE | |
15431 | CX22=-COSTH2 | |
15432 | CY22=-SINTH2*CFE | |
15433 | CZ22=-SINTH2*SFE | |
15434 | CALL DT_DSFECF(SIF3,COF3) | |
15435 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE | |
15436 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) | |
15437 | 2 FORMAT(5F20.15) | |
15438 | COD1=CX11*COD3+CZ11*SID3 | |
15439 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) | |
15440 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, | |
15441 | &CX11,CZ11 | |
15442 | SID1=SQRT(CHLP) | |
15443 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 | |
15444 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 | |
15445 | COD2=CX22*COD3+CZ22*SID3 | |
15446 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) | |
15447 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 | |
15448 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 | |
15449 | 400 CONTINUE | |
15450 | * === Energy conservation check: === * | |
15451 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 | |
15452 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) | |
15453 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) | |
15454 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) | |
15455 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 | |
15456 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 | |
15457 | & + PCM3 * COF3 * SID3 | |
15458 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 | |
15459 | & + PCM3 * SIF3 * SID3 | |
15460 | EOCMPR = 1.D-12 * UMO | |
15461 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) | |
15462 | & .GT. EOCMPR ) THEN | |
15463 | **sr 5.5.95 output-unit changed | |
15464 | IF (IOULEV(1).GT.0) THEN | |
15465 | WRITE(LOUT,*) | |
15466 | & ' *** Threpd: energy/momentum conservation failure! ***', | |
15467 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK | |
15468 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 | |
15469 | ENDIF | |
15470 | ** | |
15471 | END IF | |
15472 | RETURN | |
15473 | END | |
15474 | ||
15475 | *$ CREATE DT_DBKLAS.FOR | |
15476 | *COPY DT_DBKLAS | |
15477 | * | |
15478 | *===dbklas=============================================================* | |
15479 | * | |
15480 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) | |
15481 | ||
15482 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15483 | SAVE | |
15484 | PARAMETER ( LINP = 10 , | |
15485 | & LOUT = 6 , | |
15486 | & LDAT = 9 ) | |
15487 | ||
15488 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15489 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15490 | & IA08(6,21),IA10(6,21) | |
15491 | ||
15492 | IF (I) 20,20,10 | |
15493 | * baryons | |
15494 | 10 CONTINUE | |
15495 | CALL DT_INDEXD(J,K,IND) | |
15496 | I8 = IB08(I,IND) | |
15497 | I10 = IB10(I,IND) | |
15498 | IF (I8.LE.0) I8 = I10 | |
15499 | RETURN | |
15500 | * antibaryons | |
15501 | 20 CONTINUE | |
15502 | II = IABS(I) | |
15503 | JJ = IABS(J) | |
15504 | KK = IABS(K) | |
15505 | CALL DT_INDEXD(JJ,KK,IND) | |
15506 | I8 = IA08(II,IND) | |
15507 | I10 = IA10(II,IND) | |
15508 | IF (I8.LE.0) I8 = I10 | |
15509 | ||
15510 | RETURN | |
15511 | END | |
15512 | ||
15513 | *$ CREATE DT_INDEXD.FOR | |
15514 | *COPY DT_INDEXD | |
15515 | * | |
15516 | *===indexd=============================================================* | |
15517 | * | |
15518 | SUBROUTINE DT_INDEXD(KA,KB,IND) | |
15519 | ||
15520 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15521 | SAVE | |
15522 | PARAMETER ( LINP = 10 , | |
15523 | & LOUT = 6 , | |
15524 | & LDAT = 9 ) | |
15525 | ||
15526 | KP = KA*KB | |
15527 | KS = KA+KB | |
15528 | IF (KP.EQ.1) IND=1 | |
15529 | IF (KP.EQ.2) IND=2 | |
15530 | IF (KP.EQ.3) IND=3 | |
15531 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 | |
15532 | IF (KP.EQ.5) IND=5 | |
15533 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 | |
15534 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 | |
15535 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 | |
15536 | IF (KP.EQ.8) IND=9 | |
15537 | IF (KP.EQ.10) IND=10 | |
15538 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 | |
15539 | IF (KP.EQ.9) IND=12 | |
15540 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 | |
15541 | IF (KP.EQ.15) IND=14 | |
15542 | IF (KP.EQ.18) IND=15 | |
15543 | IF (KP.EQ.16) IND=16 | |
15544 | IF (KP.EQ.20) IND=17 | |
15545 | IF (KP.EQ.24) IND=18 | |
15546 | IF (KP.EQ.25) IND=19 | |
15547 | IF (KP.EQ.30) IND=20 | |
15548 | IF (KP.EQ.36) IND=21 | |
15549 | ||
15550 | RETURN | |
15551 | END | |
15552 | ||
15553 | *$ CREATE DT_DCHANT.FOR | |
15554 | *COPY DT_DCHANT | |
15555 | * | |
15556 | *===dchant=============================================================* | |
15557 | * | |
15558 | SUBROUTINE DT_DCHANT | |
15559 | ||
15560 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15561 | SAVE | |
15562 | PARAMETER ( LINP = 10 , | |
15563 | & LOUT = 6 , | |
15564 | & LDAT = 9 ) | |
15565 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15566 | ||
15567 | * HADRIN: decay channel information | |
15568 | PARAMETER (IDMAX9=602) | |
15569 | CHARACTER*8 ZKNAME | |
15570 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
15571 | * particle properties (BAMJET index convention) | |
15572 | CHARACTER*8 ANAME | |
15573 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
15574 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
15575 | ||
15576 | DIMENSION HWT(IDMAX9) | |
15577 | ||
15578 | * change of weights wt from absolut values into the sum of wt of a dec. | |
15579 | DO 10 J=1,IDMAX9 | |
15580 | HWT(J) = ZERO | |
15581 | 10 CONTINUE | |
15582 | C DO 999 KKK=1,210 | |
15583 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') | |
15584 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), | |
15585 | C & K1(KKK),K2(KKK) | |
15586 | C 999 CONTINUE | |
15587 | C STOP | |
15588 | DO 30 I=1,210 | |
15589 | IK1 = K1(I) | |
15590 | IK2 = K2(I) | |
15591 | HV = ZERO | |
15592 | DO 20 J=IK1,IK2 | |
15593 | HV = HV+WT(J) | |
15594 | HWT(J) = HV | |
15595 | **sr 13.1.95 | |
15596 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 | |
15597 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) | |
15598 | 20 CONTINUE | |
15599 | 30 CONTINUE | |
15600 | DO 40 J=1,IDMAX9 | |
15601 | WT(J) = HWT(J) | |
15602 | 40 CONTINUE | |
15603 | ||
15604 | RETURN | |
15605 | END | |
15606 | ||
15607 | *$ CREATE DT_DDATAR.FOR | |
15608 | *COPY DT_DDATAR | |
15609 | * | |
15610 | *===ddatar=============================================================* | |
15611 | * | |
15612 | SUBROUTINE DT_DDATAR | |
15613 | ||
15614 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15615 | SAVE | |
15616 | PARAMETER ( LINP = 10 , | |
15617 | & LOUT = 6 , | |
15618 | & LDAT = 9 ) | |
15619 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15620 | ||
15621 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15622 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15623 | & IA08(6,21),IA10(6,21) | |
15624 | ||
15625 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) | |
15626 | ||
15627 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, | |
15628 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, | |
15629 | & 128,129,14*0/ | |
15630 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, | |
15631 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, | |
15632 | & 121,122,14*0/ | |
15633 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, | |
15634 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, | |
15635 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, | |
15636 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, | |
15637 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, | |
15638 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, | |
15639 | & 0, 0, 0,140,137,138,146, 0, 0,142, | |
15640 | & 139,147, 0, 0,145,148, 50*0/ | |
15641 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, | |
15642 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, | |
15643 | & 0, 54, 55,105,162, 0, 0, 56,106,163, | |
15644 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, | |
15645 | & 0, 0,104,105,107,164, 0, 0,106,108, | |
15646 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, | |
15647 | & 0, 0, 0,161,162,164,167, 0, 0,163, | |
15648 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ | |
15649 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, | |
15650 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, | |
15651 | & 0, 2, 9,100,149, 0, 0, 0,101,154, | |
15652 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, | |
15653 | & 0, 0, 99,100,102,150, 0, 0,101,103, | |
15654 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, | |
15655 | & 0, 0, 0,152,149,150,158, 0, 0,154, | |
15656 | & 151,159, 0, 0,157,160, 50*0/ | |
15657 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, | |
15658 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, | |
15659 | & 0, 68, 69,111,172, 0, 0, 70,112,173, | |
15660 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, | |
15661 | & 0, 0,110,111,113,174, 0, 0,112,114, | |
15662 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, | |
15663 | & 0, 0, 0,171,172,174,177, 0, 0,173, | |
15664 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ | |
15665 | ||
15666 | L=0 | |
15667 | DO 2 I=1,6 | |
15668 | DO 1 J=1,6 | |
15669 | L = L+1 | |
15670 | IMPS(I,J) = IP(L) | |
15671 | IMVE(I,J) = IV(L) | |
15672 | 1 CONTINUE | |
15673 | 2 CONTINUE | |
15674 | L=0 | |
15675 | DO 4 I=1,6 | |
15676 | DO 3 J=1,21 | |
15677 | L = L+1 | |
15678 | IB08(I,J) = IB(L) | |
15679 | IB10(I,J) = IBB(L) | |
15680 | IA08(I,J) = IA(L) | |
15681 | IA10(I,J) = IAA(L) | |
15682 | 3 CONTINUE | |
15683 | 4 CONTINUE | |
15684 | C A1 = 0.88D0 | |
15685 | C B1 = 3.0D0 | |
15686 | C B2 = 3.0D0 | |
15687 | C B3 = 8.0D0 | |
15688 | C LT = 0 | |
15689 | C LB = 0 | |
15690 | C BET = 12.0D0 | |
15691 | C AS = 0.25D0 | |
15692 | C B8 = 0.33D0 | |
15693 | C AME = 0.95D0 | |
15694 | C DIQ = 0.375D0 | |
15695 | C ISU = 4 | |
15696 | ||
15697 | RETURN | |
15698 | END | |
15699 | ||
15700 | *$ CREATE DT_INITJS.FOR | |
15701 | *COPY DT_INITJS | |
15702 | * | |
15703 | *===initjs=============================================================* | |
15704 | * | |
15705 | SUBROUTINE DT_INITJS(MODE) | |
15706 | ||
15707 | ************************************************************************ | |
15708 | * Initialize JETSET paramters. * | |
15709 | * MODE = 0 default settings * | |
15710 | * = 1 PHOJET settings * | |
15711 | * = 2 DTUNUC settings * | |
15712 | * This version dated 16.02.96 is written by S. Roesler * | |
15713 | * * | |
15714 | * Last change 27.12.2006 by S. Roesler. * | |
15715 | ************************************************************************ | |
15716 | ||
15717 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15718 | SAVE | |
15719 | PARAMETER ( LINP = 10 , | |
15720 | & LOUT = 6 , | |
15721 | & LDAT = 9 ) | |
15722 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15723 | ||
15724 | LOGICAL LFIRST,LFIRDT,LFIRPH | |
15725 | ||
15726 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15727 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) | |
bd378884 | 15728 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 15729 | * flags for particle decays |
15730 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
15731 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
15732 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
15733 | * flags for input different options | |
15734 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15735 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15736 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15737 | ||
15738 | INTEGER PYCOMP | |
15739 | ||
15740 | DIMENSION IDXSTA(40) | |
15741 | DATA IDXSTA | |
15742 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 | |
15743 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, | |
15744 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ | |
15745 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, | |
15746 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ | |
15747 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, | |
15748 | * Ksic0 aKsic+aKsic0 sig0 asig0 | |
15749 | & 4132,-4232,-4132, 3212,-3212, 5*0/ | |
15750 | ||
15751 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ | |
15752 | ||
15753 | IF (LFIRST) THEN | |
15754 | * save default settings | |
15755 | PDEF1 = PARJ(1) | |
15756 | PDEF2 = PARJ(2) | |
15757 | PDEF3 = PARJ(3) | |
15758 | PDEF5 = PARJ(5) | |
15759 | PDEF6 = PARJ(6) | |
15760 | PDEF7 = PARJ(7) | |
15761 | PDEF18 = PARJ(18) | |
15762 | PDEF19 = PARJ(19) | |
15763 | PDEF21 = PARJ(21) | |
15764 | PDEF42 = PARJ(42) | |
15765 | MDEF12 = MSTJ(12) | |
15766 | * LUJETS / PYJETS array-dimensions | |
15767 | MSTU(4) = 4000 | |
15768 | * increase maximum number of JETSET-error prints | |
15769 | MSTU(22) = 50000 | |
15770 | * prevent particles decaying | |
15771 | DO 1 I=1,35 | |
15772 | IF (I.LT.34) THEN | |
15773 | KC = PYCOMP(IDXSTA(I)) | |
15774 | IF (KC.GT.0) THEN | |
15775 | IF (I.EQ.2) THEN | |
15776 | * pi0 decay | |
15777 | C MDCY(KC,1) = 1 | |
15778 | MDCY(KC,1) = 0 | |
15779 | **cr mode | |
15780 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. | |
15781 | C & (I.EQ.8).OR.(I.EQ.10)) THEN | |
15782 | C ELSEIF (I.EQ.4) THEN | |
15783 | C MDCY(KC,1) = 1 | |
15784 | ** | |
15785 | ELSE | |
1ddc441c | 15786 | C AM MDCY(KC,1) = 0 |
9aaba0d6 | 15787 | ENDIF |
15788 | ENDIF | |
15789 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN | |
15790 | KC = PYCOMP(IDXSTA(I)) | |
15791 | IF (KC.GT.0) THEN | |
1ddc441c | 15792 | C AM MDCY(KC,1) = 0 |
9aaba0d6 | 15793 | ENDIF |
15794 | ENDIF | |
15795 | 1 CONTINUE | |
15796 | * | |
15797 | * | |
15798 | * popcorn: | |
15799 | IF (PDB.LE.ZERO) THEN | |
15800 | * no popcorn-mechanism | |
15801 | MSTJ(12) = 1 | |
15802 | ELSE | |
15803 | MSTJ(12) = 3 | |
15804 | PARJ(5) = PDB | |
15805 | ENDIF | |
15806 | * set JETSET-parameter requested by input cards | |
15807 | IF (NMSTU.GT.0) THEN | |
15808 | DO 2 I=1,NMSTU | |
15809 | MSTU(IMSTU(I)) = MSTUX(I) | |
15810 | 2 CONTINUE | |
15811 | ENDIF | |
15812 | IF (NMSTJ.GT.0) THEN | |
15813 | DO 3 I=1,NMSTJ | |
15814 | MSTJ(IMSTJ(I)) = MSTJX(I) | |
15815 | 3 CONTINUE | |
15816 | ENDIF | |
15817 | IF (NPARU.GT.0) THEN | |
15818 | DO 4 I=1,NPARU | |
15819 | PARU(IPARU(I)) = PARUX(I) | |
15820 | 4 CONTINUE | |
15821 | ENDIF | |
15822 | LFIRST = .FALSE. | |
15823 | ENDIF | |
15824 | * | |
15825 | * PARJ(1) suppression of qq-aqaq pair prod. compared to | |
15826 | * q-aq pair prod. (default: 0.1) | |
15827 | * PARJ(2) strangeness suppression (default: 0.3) | |
15828 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) | |
15829 | * PARJ(6) extra suppression of sas-pair shared by B and | |
15830 | * aB in BMaB (default: 0.5) | |
15831 | * PARJ(7) extra suppression of strange meson M in BMaB | |
15832 | * configuration (default: 0.5) | |
15833 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) | |
15834 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse | |
15835 | * momentum distrib. for prim. hadrons (default: 0.35) | |
15836 | * PARJ(42) b-parameter for symmetric Lund-fragmentation | |
15837 | * function (default: 0.9 GeV^-2) | |
15838 | * | |
15839 | * PHOJET settings | |
15840 | IF (MODE.EQ.1) THEN | |
15841 | * JETSET default | |
15842 | C PARJ(1) = PDEF1 | |
15843 | C PARJ(2) = PDEF2 | |
15844 | C PARJ(3) = PDEF3 | |
15845 | C PARJ(6) = PDEF6 | |
15846 | C PARJ(7) = PDEF7 | |
15847 | C PARJ(18) = PDEF18 | |
15848 | C PARJ(21) = PDEF21 | |
15849 | C PARJ(42) = PDEF42 | |
15850 | **sr 18.11.98 parameter tuning | |
15851 | C PARJ(1) = 0.092D0 | |
15852 | C PARJ(2) = 0.25D0 | |
15853 | C PARJ(3) = 0.45D0 | |
15854 | C PARJ(19) = 0.3D0 | |
15855 | C PARJ(21) = 0.45D0 | |
15856 | C PARJ(42) = 1.0D0 | |
15857 | **sr 28.04.99 parameter tuning (May 99 minor modifications) | |
15858 | PARJ(1) = 0.085D0 | |
15859 | PARJ(2) = 0.26D0 | |
15860 | PARJ(3) = 0.8D0 | |
15861 | PARJ(11) = 0.38D0 | |
15862 | PARJ(18) = 0.3D0 | |
15863 | PARJ(19) = 0.4D0 | |
15864 | PARJ(21) = 0.36D0 | |
15865 | PARJ(41) = 0.3D0 | |
15866 | PARJ(42) = 0.86D0 | |
15867 | IF (NPARJ.GT.0) THEN | |
15868 | DO 10 I=1,NPARJ | |
15869 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) | |
15870 | 10 CONTINUE | |
15871 | ENDIF | |
15872 | IF (LFIRPH) THEN | |
15873 | WRITE(LOUT,'(1X,A)') | |
15874 | & 'DT_INITJS: JETSET-parameter for PHOJET' | |
15875 | CALL DT_JSPARA(0) | |
15876 | LFIRPH = .FALSE. | |
15877 | ENDIF | |
15878 | * DTUNUC settings | |
15879 | ELSEIF (MODE.EQ.2) THEN | |
15880 | IF (IFRAG(2).EQ.1) THEN | |
15881 | **sr parameters before 9.3.96 | |
15882 | C PARJ(2) = 0.27D0 | |
15883 | C PARJ(3) = 0.6D0 | |
15884 | C PARJ(6) = 0.75D0 | |
15885 | C PARJ(7) = 0.75D0 | |
15886 | C PARJ(21) = 0.55D0 | |
15887 | C PARJ(42) = 1.3D0 | |
15888 | **sr 18.11.98 parameter tuning | |
15889 | C PARJ(1) = 0.05D0 | |
15890 | C PARJ(2) = 0.27D0 | |
15891 | C PARJ(3) = 0.4D0 | |
15892 | C PARJ(19) = 0.2D0 | |
15893 | C PARJ(21) = 0.45D0 | |
15894 | C PARJ(42) = 1.0D0 | |
15895 | **sr 28.04.99 parameter tuning | |
15896 | PARJ(1) = 0.11D0 | |
15897 | PARJ(2) = 0.36D0 | |
15898 | PARJ(3) = 0.8D0 | |
15899 | PARJ(19) = 0.2D0 | |
15900 | PARJ(21) = 0.3D0 | |
15901 | PARJ(41) = 0.3D0 | |
15902 | PARJ(42) = 0.58D0 | |
15903 | IF (NPARJ.GT.0) THEN | |
15904 | DO 20 I=1,NPARJ | |
15905 | IF (IPARJ(I).LT.0) THEN | |
15906 | IDX = ABS(IPARJ(I)) | |
15907 | PARJ(IDX) = PARJX(I) | |
15908 | ENDIF | |
15909 | 20 CONTINUE | |
15910 | ENDIF | |
15911 | IF (LFIRDT) THEN | |
15912 | WRITE(LOUT,'(1X,A)') | |
15913 | & 'DT_INITJS: JETSET-parameter for DTUNUC' | |
15914 | CALL DT_JSPARA(0) | |
15915 | LFIRDT = .FALSE. | |
15916 | ENDIF | |
15917 | ELSEIF (IFRAG(2).EQ.2) THEN | |
15918 | PARJ(1) = 0.11D0 | |
15919 | PARJ(2) = 0.27D0 | |
15920 | PARJ(3) = 0.3D0 | |
15921 | PARJ(6) = 0.35D0 | |
15922 | PARJ(7) = 0.45D0 | |
15923 | PARJ(18) = 0.66D0 | |
15924 | C PARJ(21) = 0.55D0 | |
15925 | C PARJ(42) = 1.0D0 | |
15926 | PARJ(21) = 0.60D0 | |
15927 | PARJ(42) = 1.3D0 | |
15928 | ELSE | |
15929 | PARJ(1) = PDEF1 | |
15930 | PARJ(2) = PDEF2 | |
15931 | PARJ(3) = PDEF3 | |
15932 | PARJ(6) = PDEF6 | |
15933 | PARJ(7) = PDEF7 | |
15934 | PARJ(18) = PDEF18 | |
15935 | PARJ(21) = PDEF21 | |
15936 | PARJ(42) = PDEF42 | |
15937 | ENDIF | |
15938 | ELSE | |
15939 | PARJ(1) = PDEF1 | |
15940 | PARJ(2) = PDEF2 | |
15941 | PARJ(3) = PDEF3 | |
15942 | PARJ(5) = PDEF5 | |
15943 | PARJ(6) = PDEF6 | |
15944 | PARJ(7) = PDEF7 | |
15945 | PARJ(18) = PDEF18 | |
15946 | PARJ(19) = PDEF19 | |
15947 | PARJ(21) = PDEF21 | |
15948 | PARJ(42) = PDEF42 | |
15949 | MSTJ(12) = MDEF12 | |
15950 | ENDIF | |
15951 | ||
15952 | RETURN | |
15953 | END | |
15954 | ||
15955 | *$ CREATE DT_JSPARA.FOR | |
15956 | *COPY DT_JSPARA | |
15957 | * | |
15958 | *===jspara=============================================================* | |
15959 | * | |
15960 | SUBROUTINE DT_JSPARA(MODE) | |
15961 | ||
15962 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15963 | SAVE | |
15964 | PARAMETER ( LINP = 10 , | |
15965 | & LOUT = 6 , | |
15966 | & LDAT = 9 ) | |
15967 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, | |
15968 | & ONE=1.0D0,ZERO=0.0D0) | |
15969 | ||
15970 | LOGICAL LFIRST | |
15971 | ||
15972 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15973 | ||
15974 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) | |
15975 | ||
15976 | DATA LFIRST /.TRUE./ | |
15977 | ||
15978 | * save the default JETSET-parameter on the first call | |
15979 | IF (LFIRST) THEN | |
15980 | DO 1 I=1,200 | |
15981 | ISTU(I) = MSTU(I) | |
15982 | QARU(I) = PARU(I) | |
15983 | ISTJ(I) = MSTJ(I) | |
15984 | QARJ(I) = PARJ(I) | |
15985 | 1 CONTINUE | |
15986 | LFIRST = .FALSE. | |
15987 | ENDIF | |
15988 | ||
15989 | WRITE(LOUT,1000) | |
15990 | 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') | |
15991 | ||
15992 | * compare the default JETSET-parameter with the present values | |
15993 | DO 2 I=1,200 | |
15994 | IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN | |
15995 | WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) | |
15996 | C ISTU(I) = MSTU(I) | |
15997 | ENDIF | |
15998 | DIFF = ABS(PARU(I)-QARU(I)) | |
15999 | IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN | |
16000 | WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) | |
16001 | C QARU(I) = PARU(I) | |
16002 | ENDIF | |
16003 | IF (MSTJ(I).NE.ISTJ(I)) THEN | |
16004 | WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) | |
16005 | C ISTJ(I) = MSTJ(I) | |
16006 | ENDIF | |
16007 | DIFF = ABS(PARJ(I)-QARJ(I)) | |
16008 | IF (DIFF.GE.1.0D-5) THEN | |
16009 | WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) | |
16010 | C QARJ(I) = PARJ(I) | |
16011 | ENDIF | |
16012 | 2 CONTINUE | |
16013 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') | |
16014 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') | |
16015 | ||
16016 | RETURN | |
16017 | END | |
16018 | ||
16019 | *$ CREATE DT_FOZOCA.FOR | |
16020 | *COPY DT_FOZOCA | |
16021 | * | |
16022 | *===fozoca=============================================================* | |
16023 | * | |
16024 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) | |
16025 | ||
16026 | ************************************************************************ | |
16027 | * This subroutine treats the complete FOrmation ZOne supressed intra- * | |
16028 | * nuclear CAscade. * | |
16029 | * LFZC = .true. cascade has been treated * | |
16030 | * = .false. cascade skipped * | |
16031 | * This is a completely revised version of the original FOZOKL. * | |
16032 | * This version dated 18.11.95 is written by S. Roesler * | |
16033 | ************************************************************************ | |
16034 | ||
16035 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16036 | SAVE | |
16037 | PARAMETER ( LINP = 10 , | |
16038 | & LOUT = 6 , | |
16039 | & LDAT = 9 ) | |
16040 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) | |
16041 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16042 | ||
16043 | LOGICAL LSTART,LCAS,LFZC | |
16044 | ||
16045 | * event history | |
16046 | PARAMETER (NMXHKK=200000) | |
16047 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16048 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16049 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16050 | * extended event history | |
16051 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16052 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16053 | & IHIST(2,NMXHKK) | |
16054 | * rejection counter | |
16055 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
16056 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
16057 | & IREXCI(3),IRDIFF(2),IRINC | |
16058 | * properties of interacting particles | |
16059 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
16060 | * Glauber formalism: collision properties | |
16061 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
16062 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
16063 | * flags for input different options | |
16064 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16065 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16066 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16067 | * final state after intranuclear cascade step | |
16068 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16069 | * parameter for intranuclear cascade | |
16070 | LOGICAL LPAULI | |
16071 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16072 | ||
16073 | DIMENSION NCWOUN(2) | |
16074 | ||
16075 | DATA LSTART /.TRUE./ | |
16076 | ||
16077 | LFZC = .TRUE. | |
16078 | IREJ = 0 | |
16079 | ||
16080 | * skip cascade if hadron-hadron interaction or if supressed by user | |
16081 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 | |
16082 | * skip cascade if not all possible chains systems are hadronized | |
16083 | DO 1 I=1,8 | |
16084 | IF (.NOT.LHADRO(I)) GOTO 9999 | |
16085 | 1 CONTINUE | |
16086 | ||
16087 | IF (LSTART) THEN | |
16088 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD | |
16089 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', | |
16090 | & 'maximum of',I4,' generations',/,10X,'formation time ', | |
16091 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) | |
16092 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) | |
16093 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) | |
16094 | 1001 FORMAT(10X,'p_t dependent formation zone',/) | |
16095 | 1002 FORMAT(10X,'constant formation zone',/) | |
16096 | LSTART = .FALSE. | |
16097 | ENDIF | |
16098 | ||
16099 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons | |
16100 | * which may interact with final state particles are stored in a seperate | |
16101 | * array - here all proj./target nucleon-indices (just for simplicity) | |
16102 | NOINC = 0 | |
16103 | DO 9 I=1,NPOINT(1)-1 | |
16104 | NOINC = NOINC+1 | |
16105 | IDXINC(NOINC) = I | |
16106 | 9 CONTINUE | |
16107 | ||
16108 | * initialize Pauli-principle treatment (find wounded nucleons) | |
16109 | NWOUND(1) = 0 | |
16110 | NWOUND(2) = 0 | |
16111 | NCWOUN(1) = 0 | |
16112 | NCWOUN(2) = 0 | |
16113 | DO 2 J=1,NPOINT(1) | |
16114 | DO 3 I=1,2 | |
16115 | IF (ISTHKK(J).EQ.10+I) THEN | |
16116 | NWOUND(I) = NWOUND(I)+1 | |
16117 | EWOUND(I,NWOUND(I)) = PHKK(4,J) | |
16118 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 | |
16119 | ENDIF | |
16120 | 3 CONTINUE | |
16121 | 2 CONTINUE | |
16122 | ||
16123 | * modify nuclear potential for wounded nucleons | |
16124 | IPRCL = IP -NWOUND(1) | |
16125 | IPZRCL = IPZ-NCWOUN(1) | |
16126 | ITRCL = IT -NWOUND(2) | |
16127 | ITZRCL = ITZ-NCWOUN(2) | |
16128 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
16129 | ||
16130 | NSTART = NPOINT(4) | |
16131 | NEND = NHKK | |
16132 | ||
16133 | 7 CONTINUE | |
16134 | DO 8 I=NSTART,NEND | |
16135 | ||
16136 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN | |
16137 | * select nucleus the cascade starts first (proj. - 1, target - -1) | |
16138 | NCAS = 1 | |
16139 | * projectile/target with probab. 1/2 | |
16140 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN | |
16141 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16142 | * in the nucleus with highest mass | |
16143 | ELSEIF (INCMOD.EQ.2) THEN | |
16144 | IF (IP.GT.IT) THEN | |
16145 | NCAS = -NCAS | |
16146 | ELSEIF (IP.EQ.IT) THEN | |
16147 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16148 | ENDIF | |
16149 | * the nucleus the cascade starts first is requested to be the one | |
16150 | * moving in the direction of the secondary | |
16151 | ELSEIF (INCMOD.EQ.3) THEN | |
16152 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) | |
16153 | ENDIF | |
16154 | * check that the selected "nucleus" is not a hadron | |
16155 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. | |
16156 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS | |
16157 | ||
16158 | * treat intranuclear cascade in the nucleus selected first | |
16159 | LCAS = .FALSE. | |
16160 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16161 | IF (IREJ1.NE.0) GOTO 9998 | |
16162 | * treat intranuclear cascade in the other nucleus if this isn't a had. | |
16163 | NCAS = -NCAS | |
16164 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. | |
16165 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN | |
16166 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16167 | IF (IREJ1.NE.0) GOTO 9998 | |
16168 | ENDIF | |
16169 | ||
16170 | ENDIF | |
16171 | ||
16172 | 8 CONTINUE | |
16173 | NSTART = NEND+1 | |
16174 | NEND = NHKK | |
16175 | IF (NSTART.LE.NEND) GOTO 7 | |
16176 | ||
16177 | RETURN | |
16178 | ||
16179 | 9998 CONTINUE | |
16180 | * reject this event | |
16181 | IRINC = IRINC+1 | |
16182 | IREJ = 1 | |
16183 | ||
16184 | 9999 CONTINUE | |
16185 | * intranucl. cascade not treated because of interaction properties or | |
16186 | * it is supressed by user or it was rejected or... | |
16187 | LFZC = .FALSE. | |
16188 | * reset flag characterizing direction of motion in n-n-cms | |
16189 | **sr14-11-95 | |
16190 | C DO 9990 I=NPOINT(5),NHKK | |
16191 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 | |
16192 | C9990 CONTINUE | |
16193 | ||
16194 | RETURN | |
16195 | END | |
16196 | ||
16197 | *$ CREATE DT_INUCAS.FOR | |
16198 | *COPY DT_INUCAS | |
16199 | * | |
16200 | *===inucas=============================================================* | |
16201 | * | |
16202 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) | |
16203 | ||
16204 | ************************************************************************ | |
16205 | * Formation zone supressed IntraNUclear CAScade for one final state * | |
16206 | * particle. * | |
16207 | * IT, IP mass numbers of target, projectile nuclei * | |
16208 | * IDXCAS index of final state particle in DTEVT1 * | |
16209 | * NCAS = 1 intranuclear cascade in projectile * | |
16210 | * = -1 intranuclear cascade in target * | |
16211 | * This version dated 18.11.95 is written by S. Roesler * | |
16212 | ************************************************************************ | |
16213 | ||
16214 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16215 | SAVE | |
16216 | PARAMETER ( LINP = 10 , | |
16217 | & LOUT = 6 , | |
16218 | & LDAT = 9 ) | |
16219 | ||
16220 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
16221 | & OHALF=0.5D0,ONE=1.0D0) | |
16222 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16223 | PARAMETER (TWOPI=6.283185307179586454D+00) | |
16224 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) | |
16225 | ||
16226 | LOGICAL LABSOR,LCAS | |
16227 | ||
16228 | * event history | |
16229 | PARAMETER (NMXHKK=200000) | |
16230 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16231 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16232 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16233 | * extended event history | |
16234 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16235 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16236 | & IHIST(2,NMXHKK) | |
16237 | * final state after inc step | |
16238 | PARAMETER (MAXFSP=10) | |
16239 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
16240 | * flags for input different options | |
16241 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16242 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16243 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16244 | * particle properties (BAMJET index convention) | |
16245 | CHARACTER*8 ANAME | |
16246 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
16247 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
16248 | * Glauber formalism: collision properties | |
16249 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
16250 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
16251 | * nuclear potential | |
16252 | LOGICAL LFERMI | |
16253 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
16254 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
16255 | & ETACOU(2),ICOUL,LFERMI | |
16256 | * parameter for intranuclear cascade | |
16257 | LOGICAL LPAULI | |
16258 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16259 | * final state after intranuclear cascade step | |
16260 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16261 | * nucleon-nucleon event-generator | |
16262 | CHARACTER*8 CMODEL | |
16263 | LOGICAL LPHOIN | |
16264 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
16265 | * statistics: residual nuclei | |
16266 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
16267 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
16268 | & NINCST(2,4),NINCEV(2), | |
16269 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
16270 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
16271 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
16272 | & NEVAFI(2,2) | |
16273 | ||
16274 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), | |
16275 | & PCAS1(5),PNUC(5),BGTA(4), | |
16276 | & BGCAS(2),GACAS(2),BECAS(2), | |
16277 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) | |
16278 | ||
16279 | DATA PDIF /0.545D0/ | |
16280 | ||
16281 | IREJ = 0 | |
16282 | ||
16283 | * update counter | |
16284 | IF (NINCEV(1).NE.NEVHKK) THEN | |
16285 | NINCEV(1) = NEVHKK | |
16286 | NINCEV(2) = NINCEV(2)+1 | |
16287 | ENDIF | |
16288 | ||
16289 | * "BAMJET-index" of this hadron | |
16290 | IDCAS = IDBAM(IDXCAS) | |
16291 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN | |
16292 | ||
16293 | * skip gammas, electrons, etc.. | |
16294 | IF (AAM(IDCAS).LT.TINY2) RETURN | |
16295 | ||
16296 | * Lorentz-trsf. into projectile rest system | |
16297 | IF (IP.GT.1) THEN | |
16298 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16299 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), | |
16300 | & PCAS(1,4),IDCAS,-2) | |
16301 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) | |
16302 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) | |
16303 | IF (PCAS(1,5).GT.ZERO) THEN | |
16304 | PCAS(1,5) = SQRT(PCAS(1,5)) | |
16305 | ELSE | |
16306 | PCAS(1,5) = AAM(IDCAS) | |
16307 | ENDIF | |
16308 | DO 20 K=1,3 | |
16309 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) | |
16310 | 20 CONTINUE | |
16311 | * Lorentz-parameters | |
16312 | * particle rest system --> projectile rest system | |
16313 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) | |
16314 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) | |
16315 | BECAS(1) = BGCAS(1)/GACAS(1) | |
16316 | ELSE | |
16317 | DO 21 K=1,5 | |
16318 | PCAS(1,K) = ZERO | |
16319 | IF (K.LE.3) COSCAS(1,K) = ZERO | |
16320 | 21 CONTINUE | |
16321 | PTOCAS(1) = ZERO | |
16322 | BGCAS(1) = ZERO | |
16323 | GACAS(1) = ZERO | |
16324 | BECAS(1) = ZERO | |
16325 | ENDIF | |
16326 | * Lorentz-trsf. into target rest system | |
16327 | IF (IT.GT.1) THEN | |
16328 | * LEPTO: final state particles are already in target rest frame | |
16329 | C IF (MCGENE.EQ.3) THEN | |
16330 | C PCAS(2,1) = PHKK(1,IDXCAS) | |
16331 | C PCAS(2,2) = PHKK(2,IDXCAS) | |
16332 | C PCAS(2,3) = PHKK(3,IDXCAS) | |
16333 | C PCAS(2,4) = PHKK(4,IDXCAS) | |
16334 | C ELSE | |
16335 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16336 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), | |
16337 | & PCAS(2,4),IDCAS,-3) | |
16338 | C ENDIF | |
16339 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) | |
16340 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) | |
16341 | IF (PCAS(2,5).GT.ZERO) THEN | |
16342 | PCAS(2,5) = SQRT(PCAS(2,5)) | |
16343 | ELSE | |
16344 | PCAS(2,5) = AAM(IDCAS) | |
16345 | ENDIF | |
16346 | DO 22 K=1,3 | |
16347 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) | |
16348 | 22 CONTINUE | |
16349 | * Lorentz-parameters | |
16350 | * particle rest system --> target rest system | |
16351 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) | |
16352 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) | |
16353 | BECAS(2) = BGCAS(2)/GACAS(2) | |
16354 | ELSE | |
16355 | DO 23 K=1,5 | |
16356 | PCAS(2,K) = ZERO | |
16357 | IF (K.LE.3) COSCAS(2,K) = ZERO | |
16358 | 23 CONTINUE | |
16359 | PTOCAS(2) = ZERO | |
16360 | BGCAS(2) = ZERO | |
16361 | GACAS(2) = ZERO | |
16362 | BECAS(2) = ZERO | |
16363 | ENDIF | |
16364 | ||
16365 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- | |
16366 | * potential (see CONUCL) | |
16367 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM | |
16368 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM | |
16369 | * impact parameter (the projectile moving along z) | |
16370 | BIMPC(1) = ZERO | |
16371 | BIMPC(2) = BIMPAC*FM2MM | |
16372 | ||
16373 | * get position of initial hadron in projectile/target rest-syst. | |
16374 | DO 3 K=1,4 | |
16375 | VTXCAS(1,K) = WHKK(K,IDXCAS) | |
16376 | VTXCAS(2,K) = VHKK(K,IDXCAS) | |
16377 | 3 CONTINUE | |
16378 | ||
16379 | ICAS = 1 | |
16380 | I2 = 2 | |
16381 | IF (NCAS.EQ.-1) THEN | |
16382 | ICAS = 2 | |
16383 | I2 = 1 | |
16384 | ENDIF | |
16385 | ||
16386 | IF (PTOCAS(ICAS).LT.TINY10) THEN | |
16387 | WRITE(LOUT,1000) PTOCAS | |
16388 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', | |
16389 | & ' hadron ',/,20X,2E12.4) | |
16390 | GOTO 9999 | |
16391 | ENDIF | |
16392 | ||
16393 | * reset spectator flags | |
16394 | NSPE = 0 | |
16395 | IDXSPE(1) = 0 | |
16396 | IDXSPE(2) = 0 | |
16397 | IDSPE(1) = 0 | |
16398 | IDSPE(2) = 0 | |
16399 | ||
16400 | * formation length (in fm) | |
16401 | C IF (LCAS) THEN | |
16402 | C DEL0 = ZERO | |
16403 | C ELSE | |
16404 | DEL0 = TAUFOR*BGCAS(ICAS) | |
16405 | IF (ITAUVE.EQ.1) THEN | |
16406 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 | |
16407 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT | |
16408 | ENDIF | |
16409 | C ENDIF | |
16410 | * sample from exp(-del/del0) | |
16411 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) | |
16412 | * save formation time | |
16413 | TAUSA1 = DEL1/BGCAS(ICAS) | |
16414 | REL1 = TAUSA1*BGCAS(I2) | |
16415 | ||
16416 | DEL = DEL1 | |
16417 | TAUSAM = DEL/BGCAS(ICAS) | |
16418 | REL = TAUSAM*BGCAS(I2) | |
16419 | ||
16420 | * special treatment for negative particles unable to escape | |
16421 | * nuclear potential (implemented for ap, pi-, K- only) | |
16422 | LABSOR = .FALSE. | |
16423 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN | |
16424 | * threshold energy = nuclear potential + Coulomb potential | |
16425 | * (nuclear potential for hadron-nucleus interactions only) | |
16426 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) | |
16427 | IF (PCAS(ICAS,4).LT.ETHR) THEN | |
16428 | DO 4 K=1,5 | |
16429 | PCAS1(K) = PCAS(ICAS,K) | |
16430 | 4 CONTINUE | |
16431 | * "absorb" negative particle in nucleus | |
16432 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) | |
16433 | IF (IREJ1.NE.0) GOTO 9999 | |
16434 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16435 | ENDIF | |
16436 | ENDIF | |
16437 | ||
16438 | * if the initial particle has not been absorbed proceed with | |
16439 | * "normal" cascade | |
16440 | IF (.NOT.LABSOR) THEN | |
16441 | ||
16442 | * calculate coordinates of hadron at the end of the formation zone | |
16443 | * transport-time and -step in the rest system where this step is | |
16444 | * treated | |
16445 | DSTEP = DEL*FM2MM | |
16446 | DTIME = DSTEP/BECAS(ICAS) | |
16447 | RSTEP = REL*FM2MM | |
16448 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16449 | RTIME = RSTEP/BECAS(I2) | |
16450 | ELSE | |
16451 | RTIME = ZERO | |
16452 | ENDIF | |
16453 | * save step whithout considering the overlapping region | |
16454 | DSTEP1 = DEL1*FM2MM | |
16455 | DTIME1 = DSTEP1/BECAS(ICAS) | |
16456 | RSTEP1 = REL1*FM2MM | |
16457 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16458 | RTIME1 = RSTEP1/BECAS(I2) | |
16459 | ELSE | |
16460 | RTIME1 = ZERO | |
16461 | ENDIF | |
16462 | * transport to the end of the formation zone in this system | |
16463 | DO 5 K=1,3 | |
16464 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) | |
16465 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) | |
16466 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) | |
16467 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) | |
16468 | 5 CONTINUE | |
16469 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 | |
16470 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 | |
16471 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16472 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME | |
16473 | ||
16474 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16475 | XCAS = VTXCAS(ICAS,1) | |
16476 | YCAS = VTXCAS(ICAS,2) | |
16477 | XNCLTA = BIMPAC*FM2MM | |
16478 | RNCLPR = (RPROJ+RNUCLE)*FM2MM | |
16479 | RNCLTA = (RTARG+RNUCLE)*FM2MM | |
16480 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM | |
16481 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM | |
16482 | C RNCLPR = (RPROJ)*FM2MM | |
16483 | C RNCLTA = (RTARG)*FM2MM | |
16484 | RCASPR = SQRT( XCAS**2 +YCAS**2) | |
16485 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) | |
16486 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN | |
16487 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 | |
16488 | ENDIF | |
16489 | ENDIF | |
16490 | ||
16491 | * check if particle is already outside of the corresp. nucleus | |
16492 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ | |
16493 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) | |
16494 | IF (RDIST.GE.RNUC(ICAS)) THEN | |
16495 | * here: IDCH is the generation of the final state part. starting | |
16496 | * with zero for hadronization products | |
16497 | * flag particles of generation 0 being outside the nuclei after | |
16498 | * formation time (to be used for excitation energy calculation) | |
16499 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) | |
16500 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS | |
16501 | GOTO 9997 | |
16502 | ENDIF | |
16503 | DIST = DLARGE | |
16504 | DISTP = DLARGE | |
16505 | DISTN = DLARGE | |
16506 | IDXP = 0 | |
16507 | IDXN = 0 | |
16508 | ||
16509 | * already here: skip particles being outside HADRIN "energy-window" | |
16510 | * to avoid wasting of time | |
16511 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 | |
16512 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN | |
16513 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 | |
16514 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK | |
16515 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', | |
16516 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', | |
16517 | C & E12.4,', above or below HADRIN-thresholds',I6) | |
16518 | NSPE = 0 | |
16519 | GOTO 9997 | |
16520 | ENDIF | |
16521 | ||
16522 | DO 7 IDXHKK=1,NOINC | |
16523 | I = IDXINC(IDXHKK) | |
16524 | * scan DTEVT1 for unwounded or excited nucleons | |
16525 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN | |
16526 | DO 8 K=1,3 | |
16527 | IF (ICAS.EQ.1) THEN | |
16528 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) | |
16529 | ELSEIF (ICAS.EQ.2) THEN | |
16530 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) | |
16531 | ENDIF | |
16532 | 8 CONTINUE | |
16533 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ | |
16534 | & VTXDST(2)*COSCAS(ICAS,2)+ | |
16535 | & VTXDST(3)*COSCAS(ICAS,3) | |
16536 | * check if nucleon is situated in forward direction | |
16537 | IF (POSNUC.GT.ZERO) THEN | |
16538 | * distance between hadron and this nucleon | |
16539 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16540 | & VTXDST(3)**2) | |
16541 | * impact parameter | |
16542 | BIMNU2 = DISTNU**2-POSNUC**2 | |
16543 | IF (BIMNU2.LT.ZERO) THEN | |
16544 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 | |
16545 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', | |
16546 | & ' parameter ',/,20X,3E12.4) | |
16547 | GOTO 7 | |
16548 | ENDIF | |
16549 | BIMNU = SQRT(BIMNU2) | |
16550 | * maximum impact parameter to have interaction | |
16551 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16552 | IDNUC1 = IDT_MCHAD(IDNUC) | |
16553 | IDCAS1 = IDT_MCHAD(IDCAS) | |
16554 | DO 19 K=1,5 | |
16555 | PCAS1(K) = PCAS(ICAS,K) | |
16556 | PNUC(K) = PHKK(K,I) | |
16557 | 19 CONTINUE | |
16558 | * Lorentz-parameter for trafo into rest-system of target | |
16559 | DO 18 K=1,4 | |
16560 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) | |
16561 | 18 CONTINUE | |
16562 | * transformation of projectile into rest-system of target | |
16563 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
16564 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), | |
16565 | & PPTOT,PX,PY,PZ,PE) | |
16566 | ** | |
16567 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) | |
16568 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) | |
16569 | DUMZER = ZERO | |
16570 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) | |
16571 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) | |
16572 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. | |
16573 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 | |
16574 | SIGIN = SIGTOT-SIGEL-SIGAB | |
16575 | C SIGTOT = SIGIN+SIGEL+SIGAB | |
16576 | ** | |
16577 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM | |
16578 | * check if interaction is possible | |
16579 | IF (BIMNU.LE.BIMMAX) THEN | |
16580 | * get nucleon with smallest distance and kind of interaction | |
16581 | * (elastic/inelastic) | |
16582 | IF (DISTNU.LT.DIST) THEN | |
16583 | DIST = DISTNU | |
16584 | BINT = BIMNU | |
16585 | IF (IDNUC.NE.IDSPE(1)) THEN | |
16586 | IDSPE(2) = IDSPE(1) | |
16587 | IDXSPE(2) = IDXSPE(1) | |
16588 | IDSPE(1) = IDNUC | |
16589 | ENDIF | |
16590 | IDXSPE(1) = I | |
16591 | NSPE = 1 | |
16592 | **sr | |
16593 | SELA = SIGEL | |
16594 | SABS = SIGAB | |
16595 | STOT = SIGTOT | |
16596 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN | |
16597 | C SELA = SIGEL | |
16598 | C STOT = SIGIN+SIGEL | |
16599 | C ELSE | |
16600 | C SELA = SIGEL+0.75D0*SIGIN | |
16601 | C STOT = 0.25D0*SIGIN+SELA | |
16602 | C ENDIF | |
16603 | ** | |
16604 | ENDIF | |
16605 | ENDIf | |
16606 | ENDIF | |
16607 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16608 | & VTXDST(3)**2) | |
16609 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16610 | IF (IDNUC.EQ.1) THEN | |
16611 | IF (DISTNU.LT.DISTP) THEN | |
16612 | DISTP = DISTNU | |
16613 | IDXP = I | |
16614 | POSP = POSNUC | |
16615 | ENDIF | |
16616 | ELSEIF (IDNUC.EQ.8) THEN | |
16617 | IF (DISTNU.LT.DISTN) THEN | |
16618 | DISTN = DISTNU | |
16619 | IDXN = I | |
16620 | POSN = POSNUC | |
16621 | ENDIF | |
16622 | ENDIF | |
16623 | ENDIF | |
16624 | 7 CONTINUE | |
16625 | ||
16626 | * there is no nucleon for a secondary interaction | |
16627 | IF (NSPE.EQ.0) GOTO 9997 | |
16628 | ||
16629 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) | |
16630 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE | |
16631 | IF (IDXSPE(2).EQ.0) THEN | |
16632 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN | |
16633 | C DO 80 K=1,3 | |
16634 | C IF (ICAS.EQ.1) THEN | |
16635 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) | |
16636 | C ELSEIF (ICAS.EQ.2) THEN | |
16637 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) | |
16638 | C ENDIF | |
16639 | C 80 CONTINUE | |
16640 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16641 | C & VTXDST(3)**2) | |
16642 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN | |
16643 | IDXSPE(2) = IDXN | |
16644 | IDSPE(2) = 8 | |
16645 | C ELSE | |
16646 | C STOT = STOT-SABS | |
16647 | C SABS = ZERO | |
16648 | C ENDIF | |
16649 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN | |
16650 | C DO 81 K=1,3 | |
16651 | C IF (ICAS.EQ.1) THEN | |
16652 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) | |
16653 | C ELSEIF (ICAS.EQ.2) THEN | |
16654 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) | |
16655 | C ENDIF | |
16656 | C 81 CONTINUE | |
16657 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16658 | C & VTXDST(3)**2) | |
16659 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN | |
16660 | IDXSPE(2) = IDXP | |
16661 | IDSPE(2) = 1 | |
16662 | C ELSE | |
16663 | C STOT = STOT-SABS | |
16664 | C SABS = ZERO | |
16665 | C ENDIF | |
16666 | ELSE | |
16667 | STOT = STOT-SABS | |
16668 | SABS = ZERO | |
16669 | ENDIF | |
16670 | ENDIF | |
16671 | RR = DT_RNDM(DIST) | |
16672 | IF (RR.LT.SELA/STOT) THEN | |
16673 | IPROC = 2 | |
16674 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN | |
16675 | IPROC = 3 | |
16676 | ELSE | |
16677 | IPROC = 1 | |
16678 | ENDIF | |
16679 | ||
16680 | DO 9 K=1,5 | |
16681 | PCAS1(K) = PCAS(ICAS,K) | |
16682 | PNUC(K) = PHKK(K,IDXSPE(1)) | |
16683 | 9 CONTINUE | |
16684 | IF (IPROC.EQ.3) THEN | |
16685 | * 2-nucleon absorption of pion | |
16686 | NSPE = 2 | |
16687 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) | |
16688 | IF (IREJ1.NE.0) GOTO 9999 | |
16689 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16690 | ELSE | |
16691 | * sample secondary interaction | |
16692 | IDNUC = IDBAM(IDXSPE(1)) | |
16693 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) | |
16694 | IF (IREJ1.EQ.1) GOTO 9999 | |
16695 | IF (IREJ1.GT.1) GOTO 9998 | |
16696 | ENDIF | |
16697 | ENDIF | |
16698 | ||
16699 | * update arrays to include Pauli-principle | |
16700 | DO 10 I=1,NSPE | |
16701 | IF (NWOUND(ICAS).LE.299) THEN | |
16702 | NWOUND(ICAS) = NWOUND(ICAS)+1 | |
16703 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) | |
16704 | ENDIF | |
16705 | 10 CONTINUE | |
16706 | ||
16707 | * dump initial hadron for energy-momentum conservation check | |
16708 | IF (LEMCCK) | |
16709 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), | |
16710 | & PCAS(ICAS,4),1,IDUM,IDUM) | |
16711 | ||
16712 | * dump final state particles into DTEVT1 | |
16713 | ||
16714 | * check if Pauli-principle is fulfilled | |
16715 | NPAULI = 0 | |
16716 | NWTMP(1) = NWOUND(1) | |
16717 | NWTMP(2) = NWOUND(2) | |
16718 | DO 111 I=1,NFSP | |
16719 | NPAULI = 0 | |
16720 | J1 = 2 | |
16721 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16722 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16723 | DO 117 J=1,J1 | |
16724 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 | |
16725 | IF (J.EQ.1) THEN | |
16726 | IDX = ICAS | |
16727 | PE = PFSP(4,I) | |
16728 | ELSE | |
16729 | IDX = I2 | |
16730 | MODE = 1 | |
16731 | IF (IDX.EQ.1) MODE = -1 | |
16732 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) | |
16733 | ENDIF | |
16734 | * first check if cascade step is forbidden due to Pauli-principle | |
16735 | * (in case of absorpion this step is forced) | |
16736 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16737 | & (IDFSP(I).EQ.8))) THEN | |
16738 | * get nuclear potential barrier | |
16739 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16740 | IF (IDFSP(I).EQ.1) THEN | |
16741 | POTLOW = POT-EBINDP(IDX) | |
16742 | ELSE | |
16743 | POTLOW = POT-EBINDN(IDX) | |
16744 | ENDIF | |
16745 | * final state particle not able to escape nucleus | |
16746 | IF (PE.LE.POTLOW) THEN | |
16747 | * check if there are wounded nucleons | |
16748 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16749 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16750 | NPAULI = NPAULI+1 | |
16751 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16752 | ELSE | |
16753 | * interaction prohibited by Pauli-principle | |
16754 | NWOUND(1) = NWTMP(1) | |
16755 | NWOUND(2) = NWTMP(2) | |
16756 | GOTO 9997 | |
16757 | ENDIF | |
16758 | ENDIF | |
16759 | ENDIF | |
16760 | 117 CONTINUE | |
16761 | 111 CONTINUE | |
16762 | ||
16763 | NPAULI = 0 | |
16764 | NWOUND(1) = NWTMP(1) | |
16765 | NWOUND(2) = NWTMP(2) | |
16766 | ||
16767 | DO 11 I=1,NFSP | |
16768 | ||
16769 | IST = ISTHKK(IDXCAS) | |
16770 | ||
16771 | NPAULI = 0 | |
16772 | J1 = 2 | |
16773 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16774 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16775 | DO 17 J=1,J1 | |
16776 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 | |
16777 | IDX = ICAS | |
16778 | PE = PFSP(4,I) | |
16779 | IF (J.EQ.2) THEN | |
16780 | IDX = I2 | |
16781 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) | |
16782 | ENDIF | |
16783 | * first check if cascade step is forbidden due to Pauli-principle | |
16784 | * (in case of absorpion this step is forced) | |
16785 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16786 | & (IDFSP(I).EQ.8))) THEN | |
16787 | * get nuclear potential barrier | |
16788 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16789 | IF (IDFSP(I).EQ.1) THEN | |
16790 | POTLOW = POT-EBINDP(IDX) | |
16791 | ELSE | |
16792 | POTLOW = POT-EBINDN(IDX) | |
16793 | ENDIF | |
16794 | * final state particle not able to escape nucleus | |
16795 | IF (PE.LE.POTLOW) THEN | |
16796 | * check if there are wounded nucleons | |
16797 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16798 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16799 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16800 | NPAULI = NPAULI+1 | |
16801 | IST = 14+IDX | |
16802 | ELSE | |
16803 | * interaction prohibited by Pauli-principle | |
16804 | NWOUND(1) = NWTMP(1) | |
16805 | NWOUND(2) = NWTMP(2) | |
16806 | GOTO 9997 | |
16807 | ENDIF | |
16808 | **sr | |
16809 | c ELSEIF (PE.LE.POT) THEN | |
16810 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN | |
16811 | cC NWOUND(IDX) = NWOUND(IDX)-1 | |
16812 | c** | |
16813 | c NPAULI = NPAULI+1 | |
16814 | c IST = 14+IDX | |
16815 | ENDIF | |
16816 | ENDIF | |
16817 | 17 CONTINUE | |
16818 | ||
16819 | * dump final state particles for energy-momentum conservation check | |
16820 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), | |
16821 | & -PFSP(4,I),2,IDUM,IDUM) | |
16822 | ||
16823 | PX = PFSP(1,I) | |
16824 | PY = PFSP(2,I) | |
16825 | PZ = PFSP(3,I) | |
16826 | PE = PFSP(4,I) | |
16827 | IF (ABS(IST).EQ.1) THEN | |
16828 | * transform particles back into n-n cms | |
16829 | * LEPTO: leave final state particles in target rest frame | |
16830 | C IF (MCGENE.EQ.3) THEN | |
16831 | C PFSP(1,I) = PX | |
16832 | C PFSP(2,I) = PY | |
16833 | C PFSP(3,I) = PZ | |
16834 | C PFSP(4,I) = PE | |
16835 | C ELSE | |
16836 | IMODE = ICAS+1 | |
16837 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16838 | & PFSP(4,I),IDFSP(I),IMODE) | |
16839 | C ENDIF | |
16840 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN | |
16841 | * target cascade but fsp got stuck in proj. --> transform it into | |
16842 | * proj. rest system | |
16843 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16844 | & PFSP(4,I),IDFSP(I),-1) | |
16845 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN | |
16846 | * proj. cascade but fsp got stuck in target --> transform it into | |
16847 | * target rest system | |
16848 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16849 | & PFSP(4,I),IDFSP(I),1) | |
16850 | ENDIF | |
16851 | ||
16852 | * dump final state particles into DTEVT1 | |
16853 | IGEN = IDCH(IDXCAS)+1 | |
16854 | ID = IDT_IPDGHA(IDFSP(I)) | |
16855 | IXR = 0 | |
16856 | IF (LABSOR) IXR = 99 | |
16857 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), | |
16858 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) | |
16859 | ||
16860 | * update the counter for particles which got stuck inside the nucleus | |
16861 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN | |
16862 | NOINC = NOINC+1 | |
16863 | IDXINC(NOINC) = NHKK | |
16864 | ENDIF | |
16865 | IF (LABSOR) THEN | |
16866 | * in case of absorption the spatial treatment is an approximate | |
16867 | * solution anyway (the positions of the nucleons which "absorb" the | |
16868 | * cascade particle are not taken into consideration) therefore the | |
16869 | * particles are produced at the position of the cascade particle | |
16870 | DO 12 K=1,4 | |
16871 | WHKK(K,NHKK) = WHKK(K,IDXCAS) | |
16872 | VHKK(K,NHKK) = VHKK(K,IDXCAS) | |
16873 | 12 CONTINUE | |
16874 | ELSE | |
16875 | * DDISTL - distance the cascade particle moves to the intera. point | |
16876 | * (the position where impact-parameter = distance to the interacting | |
16877 | * nucleon), DIST - distance to the interacting nucleon at the time of | |
16878 | * formation of the cascade particle, BINT - impact-parameter of this | |
16879 | * cascade-interaction | |
16880 | DDISTL = SQRT(DIST**2-BINT**2) | |
16881 | DTIME = DDISTL/BECAS(ICAS) | |
16882 | DTIMEL = DDISTL/BGCAS(ICAS) | |
16883 | RDISTL = DTIMEL*BGCAS(I2) | |
16884 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16885 | RTIME = RDISTL/BECAS(I2) | |
16886 | ELSE | |
16887 | RTIME = ZERO | |
16888 | ENDIF | |
16889 | * RDISTL, RTIME are this step and time in the rest system of the other | |
16890 | * nucleus | |
16891 | DO 13 K=1,3 | |
16892 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL | |
16893 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL | |
16894 | 13 CONTINUE | |
16895 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16896 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME | |
16897 | * position of particle production is half the impact-parameter to | |
16898 | * the interacting nucleon | |
16899 | DO 14 K=1,3 | |
16900 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) | |
16901 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) | |
16902 | 14 CONTINUE | |
16903 | * time of production of secondary = time of interaction | |
16904 | WHKK(4,NHKK) = VTXCA1(1,4) | |
16905 | VHKK(4,NHKK) = VTXCA1(2,4) | |
16906 | ENDIF | |
16907 | ||
16908 | 11 CONTINUE | |
16909 | ||
16910 | * modify status and position of cascade particle (the latter for | |
16911 | * statistics reasons only) | |
16912 | ISTHKK(IDXCAS) = 2 | |
16913 | IF (LABSOR) ISTHKK(IDXCAS) = 19 | |
16914 | IF (.NOT.LABSOR) THEN | |
16915 | DO 15 K=1,4 | |
16916 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16917 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16918 | 15 CONTINUE | |
16919 | ENDIF | |
16920 | ||
16921 | DO 16 I=1,NSPE | |
16922 | IS = IDXSPE(I) | |
16923 | * dump interacting nucleons for energy-momentum conservation check | |
16924 | IF (LEMCCK) | |
16925 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), | |
16926 | & 2,IDUM,IDUM) | |
16927 | * modify entry for interacting nucleons | |
16928 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS | |
16929 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 | |
16930 | IF (I.GE.2) THEN | |
16931 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) | |
16932 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) | |
16933 | ENDIF | |
16934 | 16 CONTINUE | |
16935 | ||
16936 | * check energy-momentum conservation | |
16937 | IF (LEMCCK) THEN | |
16938 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) | |
16939 | IF (IREJ1.NE.0) GOTO 9999 | |
16940 | ENDIF | |
16941 | ||
16942 | * update counter | |
16943 | IF (LABSOR) THEN | |
16944 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 | |
16945 | ELSE | |
16946 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 | |
16947 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 | |
16948 | ENDIF | |
16949 | ||
16950 | RETURN | |
16951 | ||
16952 | 9997 CONTINUE | |
16953 | 9998 CONTINUE | |
16954 | * transport-step but no cascade step due to configuration (i.e. there | |
16955 | * is no nucleon for interaction etc.) | |
16956 | IF (LCAS) THEN | |
16957 | DO 100 K=1,4 | |
16958 | C WHKK(K,IDXCAS) = VTXCAS(1,K) | |
16959 | C VHKK(K,IDXCAS) = VTXCAS(2,K) | |
16960 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16961 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16962 | 100 CONTINUE | |
16963 | ENDIF | |
16964 | ||
16965 | C9998 CONTINUE | |
16966 | * no cascade-step because of configuration | |
16967 | * (i.e. hadron outside nucleus etc.) | |
16968 | LCAS = .TRUE. | |
16969 | RETURN | |
16970 | ||
16971 | 9999 CONTINUE | |
16972 | * rejection | |
16973 | IREJ = 1 | |
16974 | RETURN | |
16975 | END | |
16976 | ||
16977 | *$ CREATE DT_ABSORP.FOR | |
16978 | *COPY DT_ABSORP | |
16979 | * | |
16980 | *===absorp=============================================================* | |
16981 | * | |
16982 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) | |
16983 | ||
16984 | ************************************************************************ | |
16985 | * Two-nucleon absorption of antiprotons, pi-, and K-. * | |
16986 | * Antiproton absorption is handled by HADRIN. * | |
16987 | * The following channels for meson-absorption are considered: * | |
16988 | * pi- + p + p ---> n + p * | |
16989 | * pi- + p + n ---> n + n * | |
16990 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * | |
16991 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * | |
16992 | * K- + p + p ---> sigma- + n * | |
16993 | * IDCAS, PCAS identity, momentum of particle to be absorbed * | |
16994 | * NCAS = 1 intranuclear cascade in projectile * | |
16995 | * = -1 intranuclear cascade in target * | |
16996 | * NSPE number of spectator nucleons involved * | |
16997 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * | |
16998 | * Revised version of the original STOPIK written by HJM and J. Ranft. * | |
16999 | * This version dated 24.02.95 is written by S. Roesler * | |
17000 | ************************************************************************ | |
17001 | ||
17002 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17003 | SAVE | |
17004 | PARAMETER ( LINP = 10 , | |
17005 | & LOUT = 6 , | |
17006 | & LDAT = 9 ) | |
17007 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, | |
17008 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) | |
17009 | ||
17010 | * event history | |
17011 | PARAMETER (NMXHKK=200000) | |
17012 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17013 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17014 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17015 | * extended event history | |
17016 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17017 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17018 | & IHIST(2,NMXHKK) | |
17019 | * flags for input different options | |
17020 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17021 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17022 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17023 | * final state after inc step | |
17024 | PARAMETER (MAXFSP=10) | |
17025 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17026 | * particle properties (BAMJET index convention) | |
17027 | CHARACTER*8 ANAME | |
17028 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17029 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17030 | ||
17031 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), | |
17032 | & PTOT3P(4),BG3P(4), | |
17033 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) | |
17034 | ||
17035 | IREJ = 0 | |
17036 | NFSP = 0 | |
17037 | ||
17038 | * skip particles others than ap, pi-, K- for mode=0 | |
17039 | IF ((MODE.EQ.0).AND. | |
17040 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN | |
17041 | * skip particles others than pions for mode=1 | |
17042 | * (2-nucleon absorption in intranuclear cascade) | |
17043 | IF ((MODE.EQ.1).AND. | |
17044 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN | |
17045 | ||
17046 | NUCAS = NCAS | |
17047 | IF (NUCAS.EQ.-1) NUCAS = 2 | |
17048 | ||
17049 | IF (MODE.EQ.0) THEN | |
17050 | * scan spectator nucleons for nucleons being able to "absorb" | |
17051 | NSPE = 0 | |
17052 | IDXSPE(1) = 0 | |
17053 | IDXSPE(2) = 0 | |
17054 | DO 1 I=1,NHKK | |
17055 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN | |
17056 | NSPE = NSPE+1 | |
17057 | IDXSPE(NSPE) = I | |
17058 | IDSPE(NSPE) = IDBAM(I) | |
17059 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 | |
17060 | IF (NSPE.EQ.2) THEN | |
17061 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. | |
17062 | & (IDSPE(2).EQ.8)) THEN | |
17063 | * there is no pi-+n+n channel | |
17064 | NSPE = 1 | |
17065 | GOTO 1 | |
17066 | ELSE | |
17067 | GOTO 2 | |
17068 | ENDIF | |
17069 | ENDIF | |
17070 | ENDIF | |
17071 | 1 CONTINUE | |
17072 | ||
17073 | 2 CONTINUE | |
17074 | ENDIF | |
17075 | * transform excited projectile nucleons (status=15) into proj. rest s. | |
17076 | DO 3 I=1,NSPE | |
17077 | DO 4 K=1,5 | |
17078 | PSPE(I,K) = PHKK(K,IDXSPE(I)) | |
17079 | 4 CONTINUE | |
17080 | 3 CONTINUE | |
17081 | ||
17082 | * antiproton absorption | |
17083 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN | |
17084 | DO 5 K=1,5 | |
17085 | PSPE1(K) = PSPE(1,K) | |
17086 | 5 CONTINUE | |
17087 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) | |
17088 | IF (IREJ1.NE.0) GOTO 9999 | |
17089 | ||
17090 | * meson absorption | |
17091 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) | |
17092 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN | |
17093 | IF (IDCAS.EQ.14) THEN | |
17094 | * pi- absorption | |
17095 | IDFSP(1) = 8 | |
17096 | IDFSP(2) = 8 | |
17097 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 | |
17098 | ELSEIF (IDCAS.EQ.13) THEN | |
17099 | * pi+ absorption | |
17100 | IDFSP(1) = 1 | |
17101 | IDFSP(2) = 1 | |
17102 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 | |
17103 | ELSEIF (IDCAS.EQ.23) THEN | |
17104 | * pi0 absorption | |
17105 | IDFSP(1) = IDSPE(1) | |
17106 | IDFSP(2) = IDSPE(2) | |
17107 | ELSEIF (IDCAS.EQ.16) THEN | |
17108 | * K- absorption | |
17109 | R = DT_RNDM(PCAS) | |
17110 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN | |
17111 | IF (R.LT.ONETHI) THEN | |
17112 | IDFSP(1) = 21 | |
17113 | IDFSP(2) = 8 | |
17114 | ELSEIF (R.LT.TWOTHI) THEN | |
17115 | IDFSP(1) = 17 | |
17116 | IDFSP(2) = 1 | |
17117 | ELSE | |
17118 | IDFSP(1) = 22 | |
17119 | IDFSP(2) = 1 | |
17120 | ENDIF | |
17121 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN | |
17122 | IDFSP(1) = 20 | |
17123 | IDFSP(2) = 8 | |
17124 | ELSE | |
17125 | IF (R.LT.ONETHI) THEN | |
17126 | IDFSP(1) = 20 | |
17127 | IDFSP(2) = 1 | |
17128 | ELSEIF (R.LT.TWOTHI) THEN | |
17129 | IDFSP(1) = 17 | |
17130 | IDFSP(2) = 8 | |
17131 | ELSE | |
17132 | IDFSP(1) = 22 | |
17133 | IDFSP(2) = 8 | |
17134 | ENDIF | |
17135 | ENDIF | |
17136 | ENDIF | |
17137 | * dump initial particles for energy-momentum cons. check | |
17138 | IF (LEMCCK) THEN | |
17139 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) | |
17140 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, | |
17141 | & IDUM,IDUM) | |
17142 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, | |
17143 | & IDUM,IDUM) | |
17144 | ENDIF | |
17145 | * get Lorentz-parameter of 3 particle initial state | |
17146 | DO 6 K=1,4 | |
17147 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) | |
17148 | 6 CONTINUE | |
17149 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) | |
17150 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) | |
17151 | DO 7 K=1,4 | |
17152 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) | |
17153 | 7 CONTINUE | |
17154 | * 2-particle decay of the 3-particle compound system | |
17155 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), | |
17156 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
17157 | & AAM(IDFSP(1)),AAM(IDFSP(2))) | |
17158 | DO 8 I=1,2 | |
17159 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) | |
17160 | PX = PCMF(I)*COFF(I)*SDF | |
17161 | PY = PCMF(I)*SIFF(I)*SDF | |
17162 | PZ = PCMF(I)*CODF(I) | |
17163 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, | |
17164 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17165 | & PFSP(4,I)) | |
17166 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) | |
17167 | * check consistency of kinematics | |
17168 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN | |
17169 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) | |
17170 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', | |
17171 | & ' tree-particle kinematics',/,20X,'id: ',I3, | |
17172 | & ' AAM = ',E10.4,' MFSP = ',E10.4) | |
17173 | ENDIF | |
17174 | * dump final state particles for energy-momentum cons. check | |
17175 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17176 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17177 | 8 CONTINUE | |
17178 | NFSP = 2 | |
17179 | IF (LEMCCK) THEN | |
17180 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) | |
17181 | IF (IREJ1.NE.0) THEN | |
17182 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), | |
17183 | & AM3P | |
17184 | GOTO 9999 | |
17185 | ENDIF | |
17186 | ENDIF | |
17187 | ELSE | |
17188 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE | |
17189 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, | |
17190 | & ' impossible',/,20X,'too few spectators (',I2,')') | |
17191 | NSPE = 0 | |
17192 | ENDIF | |
17193 | ||
17194 | RETURN | |
17195 | ||
17196 | 9999 CONTINUE | |
17197 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' | |
17198 | IREJ = 1 | |
17199 | RETURN | |
17200 | END | |
17201 | ||
17202 | *$ CREATE DT_HADRIN.FOR | |
17203 | *COPY DT_HADRIN | |
17204 | * | |
17205 | *===hadrin=============================================================* | |
17206 | * | |
17207 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) | |
17208 | ||
17209 | ************************************************************************ | |
17210 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17211 | * scattering. * | |
17212 | * IDPR,PPR(5) identity, momentum of projectile * | |
17213 | * IDTA,PTA(5) identity, momentum of target * | |
17214 | * MODE = 1 inelastic interaction * | |
17215 | * = 2 elastic interaction * | |
17216 | * Revised version of the original FHAD. * | |
17217 | * This version dated 27.10.95 is written by S. Roesler * | |
17218 | ************************************************************************ | |
17219 | ||
17220 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17221 | SAVE | |
17222 | PARAMETER ( LINP = 10 , | |
17223 | & LOUT = 6 , | |
17224 | & LDAT = 9 ) | |
17225 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, | |
17226 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) | |
17227 | ||
17228 | LOGICAL LCORR,LMSSG | |
17229 | ||
17230 | * flags for input different options | |
17231 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17232 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17233 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17234 | * final state after inc step | |
17235 | PARAMETER (MAXFSP=10) | |
17236 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17237 | * particle properties (BAMJET index convention) | |
17238 | CHARACTER*8 ANAME | |
17239 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17240 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17241 | * output-common for DHADRI/ELHAIN | |
17242 | * final state from HADRIN interaction | |
17243 | PARAMETER (MAXFIN=10) | |
17244 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
17245 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
17246 | ||
17247 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), | |
17248 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) | |
17249 | ||
17250 | DATA LMSSG /.TRUE./ | |
17251 | ||
17252 | IREJ = 0 | |
17253 | NFSP = 0 | |
17254 | KCORR = 0 | |
17255 | IMCORR(1) = 0 | |
17256 | IMCORR(2) = 0 | |
17257 | LCORR = .FALSE. | |
17258 | ||
17259 | * dump initial particles for energy-momentum cons. check | |
17260 | IF (LEMCCK) THEN | |
17261 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) | |
17262 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) | |
17263 | ENDIF | |
17264 | ||
17265 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 | |
17266 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 | |
17267 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. | |
17268 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. | |
17269 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN | |
17270 | IF (LMSSG.AND.(IOULEV(3).GT.0)) | |
17271 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 | |
17272 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', | |
17273 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', | |
17274 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) | |
17275 | LMSSG = .FALSE. | |
17276 | LCORR = .TRUE. | |
17277 | ENDIF | |
17278 | ||
17279 | * convert initial state particles into particles which can be | |
17280 | * handled by HADRIN | |
17281 | IDHPR = IDPR | |
17282 | IDHTA = IDTA | |
17283 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN | |
17284 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 | |
17285 | DO 1 K=1,4 | |
17286 | P1IN(K) = PPR(K) | |
17287 | P2IN(K) = PTA(K) | |
17288 | 1 CONTINUE | |
17289 | XM1 = AAM(IDHPR) | |
17290 | XM2 = AAM(IDHTA) | |
17291 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17292 | IF (IREJ1.GT.0) THEN | |
17293 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17294 | GOTO 9999 | |
17295 | ENDIF | |
17296 | DO 2 K=1,4 | |
17297 | PPR(K) = P1OUT(K) | |
17298 | PTA(K) = P2OUT(K) | |
17299 | 2 CONTINUE | |
17300 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) | |
17301 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) | |
17302 | ENDIF | |
17303 | ||
17304 | * Lorentz-parameter for trafo into rest-system of target | |
17305 | DO 3 K=1,4 | |
17306 | BGTA(K) = PTA(K)/PTA(5) | |
17307 | 3 CONTINUE | |
17308 | * transformation of projectile into rest-system of target | |
17309 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), | |
17310 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), | |
17311 | & PPR1(4)) | |
17312 | ||
17313 | * direction cosines of projectile in target rest system | |
17314 | CX = PPR1(1)/PPRTO1 | |
17315 | CY = PPR1(2)/PPRTO1 | |
17316 | CZ = PPR1(3)/PPRTO1 | |
17317 | ||
17318 | * sample inelastic interaction | |
17319 | IF (MODE.EQ.1) THEN | |
17320 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) | |
17321 | IF (IRH.EQ.1) GOTO 9998 | |
17322 | * sample elastic interaction | |
17323 | ELSEIF (MODE.EQ.2) THEN | |
17324 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) | |
17325 | IF (IREJ1.NE.0) THEN | |
17326 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' | |
17327 | GOTO 9999 | |
17328 | ENDIF | |
17329 | IF (IRH.EQ.1) GOTO 9998 | |
17330 | ELSE | |
17331 | WRITE(LOUT,1001) MODE,INTHAD | |
17332 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', | |
17333 | & I4,' (INTHAD =',I4,')') | |
17334 | GOTO 9999 | |
17335 | ENDIF | |
17336 | ||
17337 | * transform final state particles back into Lab. | |
17338 | DO 4 I=1,IRH | |
17339 | NFSP = NFSP+1 | |
17340 | PX = CXRH(I)*PLRH(I) | |
17341 | PY = CYRH(I)*PLRH(I) | |
17342 | PZ = CZRH(I)*PLRH(I) | |
17343 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), | |
17344 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), | |
17345 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) | |
17346 | IDFSP(NFSP) = ITRH(I) | |
17347 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- | |
17348 | & PFSP(3,NFSP)**2 | |
17349 | IF (AMFSP2.LT.-TINY3) THEN | |
17350 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), | |
17351 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 | |
17352 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', | |
17353 | & I2,') with negative mass^2',/,1X,5E12.4) | |
17354 | GOTO 9999 | |
17355 | ELSE | |
17356 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) | |
17357 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN | |
17358 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), | |
17359 | & PFSP(5,NFSP) | |
17360 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', | |
17361 | & ' (id = ',I2,') with inconsistent mass',/,1X, | |
17362 | & 2E12.4) | |
17363 | KCORR = KCORR+1 | |
17364 | IF (KCORR.GT.2) GOTO 9999 | |
17365 | IMCORR(KCORR) = NFSP | |
17366 | ENDIF | |
17367 | ENDIF | |
17368 | * dump final state particles for energy-momentum cons. check | |
17369 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17370 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17371 | 4 CONTINUE | |
17372 | ||
17373 | * transform momenta on mass shell in case of inconsistencies in | |
17374 | * HADRIN | |
17375 | IF (KCORR.GT.0) THEN | |
17376 | IF (KCORR.EQ.2) THEN | |
17377 | I1 = IMCORR(1) | |
17378 | I2 = IMCORR(2) | |
17379 | ELSE | |
17380 | IF (IMCORR(1).EQ.1) THEN | |
17381 | I1 = 1 | |
17382 | I2 = 2 | |
17383 | ELSE | |
17384 | I1 = 1 | |
17385 | I2 = IMCORR(1) | |
17386 | ENDIF | |
17387 | ENDIF | |
17388 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), | |
17389 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) | |
17390 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), | |
17391 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) | |
17392 | DO 5 K=1,4 | |
17393 | P1IN(K) = PFSP(K,I1) | |
17394 | P2IN(K) = PFSP(K,I2) | |
17395 | 5 CONTINUE | |
17396 | XM1 = AAM(IDFSP(I1)) | |
17397 | XM2 = AAM(IDFSP(I2)) | |
17398 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17399 | IF (IREJ1.GT.0) THEN | |
17400 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17401 | C GOTO 9999 | |
17402 | ENDIF | |
17403 | DO 6 K=1,4 | |
17404 | PFSP(K,I1) = P1OUT(K) | |
17405 | PFSP(K,I2) = P2OUT(K) | |
17406 | 6 CONTINUE | |
17407 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 | |
17408 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) | |
17409 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 | |
17410 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) | |
17411 | * dump final state particles for energy-momentum cons. check | |
17412 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), | |
17413 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) | |
17414 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), | |
17415 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) | |
17416 | ENDIF | |
17417 | ||
17418 | * check energy-momentum conservation | |
17419 | IF (LEMCCK) THEN | |
17420 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) | |
17421 | IF (IREJ1.NE.0) GOTO 9999 | |
17422 | ENDIF | |
17423 | ||
17424 | RETURN | |
17425 | ||
17426 | 9998 CONTINUE | |
17427 | IREJ = 2 | |
17428 | RETURN | |
17429 | ||
17430 | 9999 CONTINUE | |
17431 | IREJ = 1 | |
17432 | RETURN | |
17433 | END | |
17434 | ||
17435 | *$ CREATE DT_HADCOL.FOR | |
17436 | *COPY DT_HADCOL | |
17437 | * | |
17438 | *===hadcol=============================================================* | |
17439 | * | |
17440 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) | |
17441 | ||
17442 | ************************************************************************ | |
17443 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17444 | * scattering. This subroutine samples hadron-nucleus interactions * | |
17445 | * below DPM-threshold. * | |
17446 | * IDPROJ BAMJET-index of projectile hadron * | |
17447 | * PPN projectile momentum in target rest frame * | |
17448 | * IDXTAR DTEVT1-index of target nucleon undergoing * | |
17449 | * interaction with projectile hadron * | |
17450 | * This subroutine replaces HADHAD. * | |
17451 | * This version dated 5.5.95 is written by S. Roesler * | |
17452 | ************************************************************************ | |
17453 | ||
17454 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17455 | SAVE | |
17456 | PARAMETER ( LINP = 10 , | |
17457 | & LOUT = 6 , | |
17458 | & LDAT = 9 ) | |
17459 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) | |
17460 | ||
17461 | LOGICAL LSTART | |
17462 | ||
17463 | * event history | |
17464 | PARAMETER (NMXHKK=200000) | |
17465 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17466 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17467 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17468 | * extended event history | |
17469 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17470 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17471 | & IHIST(2,NMXHKK) | |
17472 | * nuclear potential | |
17473 | LOGICAL LFERMI | |
17474 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17475 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17476 | & ETACOU(2),ICOUL,LFERMI | |
17477 | * interface HADRIN-DPM | |
17478 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
17479 | * parameter for intranuclear cascade | |
17480 | LOGICAL LPAULI | |
17481 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
17482 | * final state after inc step | |
17483 | PARAMETER (MAXFSP=10) | |
17484 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17485 | * particle properties (BAMJET index convention) | |
17486 | CHARACTER*8 ANAME | |
17487 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17488 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17489 | ||
17490 | DIMENSION PPROJ(5),PNUC(5) | |
17491 | ||
17492 | DATA LSTART /.TRUE./ | |
17493 | ||
17494 | IREJ = 0 | |
17495 | ||
17496 | NPOINT(1) = NHKK+1 | |
17497 | ||
17498 | TAUSAV = TAUFOR | |
17499 | **sr 6/9/01 commented | |
17500 | C TAUFOR = TAUFOR/2.0D0 | |
17501 | ** | |
17502 | IF (LSTART) THEN | |
17503 | WRITE(LOUT,1000) | |
17504 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') | |
17505 | WRITE(LOUT,1001) TAUFOR | |
17506 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', | |
17507 | & F5.1,' fm/c') | |
17508 | LSTART = .FALSE. | |
17509 | ENDIF | |
17510 | ||
17511 | IDNUC = IDBAM(IDXTAR) | |
17512 | IDNUC1 = IDT_MCHAD(IDNUC) | |
17513 | IDPRO1 = IDT_MCHAD(IDPROJ) | |
17514 | ||
17515 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN | |
17516 | IPROC = INTHAD | |
17517 | ELSE | |
17518 | ** | |
17519 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) | |
17520 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) | |
17521 | DUMZER = ZERO | |
17522 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) | |
17523 | SIGIN = SIGTOT-SIGEL | |
17524 | C SIGTOT = SIGIN+SIGEL | |
17525 | ** | |
17526 | IPROC = 1 | |
17527 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 | |
17528 | ENDIF | |
17529 | ||
17530 | PPROJ(1) = ZERO | |
17531 | PPROJ(2) = ZERO | |
17532 | PPROJ(3) = PPN | |
17533 | PPROJ(5) = AAM(IDPROJ) | |
17534 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) | |
17535 | DO 1 K=1,5 | |
17536 | PNUC(K) = PHKK(K,IDXTAR) | |
17537 | 1 CONTINUE | |
17538 | ||
17539 | ILOOP = 0 | |
17540 | 2 CONTINUE | |
17541 | ILOOP = ILOOP+1 | |
17542 | IF (ILOOP.GT.100) GOTO 9999 | |
17543 | ||
17544 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) | |
17545 | IF (IREJ1.EQ.1) GOTO 9999 | |
17546 | ||
17547 | IF (IREJ1.GT.1) THEN | |
17548 | * no interaction possible | |
17549 | * require Pauli blocking | |
17550 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 | |
17551 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 | |
17552 | IF ((IIBAR(IDPROJ).NE.1).AND. | |
17553 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 | |
17554 | * store incoming particle as final state particle | |
17555 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) | |
17556 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) | |
17557 | NPOINT(4) = NHKK | |
17558 | ELSE | |
17559 | * require Pauli blocking for final state nucleons | |
17560 | DO 4 I=1,NFSP | |
17561 | IF ((IDFSP(I).EQ.1).AND. | |
17562 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 | |
17563 | IF ((IDFSP(I).EQ.8).AND. | |
17564 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 | |
17565 | IF ((IIBAR(IDFSP(I)).NE.1).AND. | |
17566 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 | |
17567 | 4 CONTINUE | |
17568 | * store final state particles | |
17569 | DO 5 I=1,NFSP | |
17570 | IST = 1 | |
17571 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. | |
17572 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 | |
17573 | IDHAD = IDT_IPDGHA(IDFSP(I)) | |
17574 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) | |
17575 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), | |
17576 | & PCMS,ECMS,0,0,0) | |
17577 | IF (I.EQ.1) NPOINT(4) = NHKK | |
17578 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) | |
17579 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) | |
17580 | VHKK(3,NHKK) = VHKK(3,IDXTAR) | |
17581 | VHKK(4,NHKK) = VHKK(4,IDXTAR) | |
17582 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) | |
17583 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) | |
17584 | WHKK(3,NHKK) = WHKK(3,1) | |
17585 | WHKK(4,NHKK) = WHKK(4,1) | |
17586 | 5 CONTINUE | |
17587 | ENDIF | |
17588 | TAUFOR = TAUSAV | |
17589 | RETURN | |
17590 | ||
17591 | 9999 CONTINUE | |
17592 | IREJ = 1 | |
17593 | TAUFOR = TAUSAV | |
17594 | RETURN | |
17595 | END | |
17596 | ||
17597 | *$ CREATE DT_GETEMU.FOR | |
17598 | *COPY DT_GETEMU | |
17599 | * | |
17600 | *===getemu=============================================================* | |
17601 | * | |
17602 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) | |
17603 | ||
17604 | ************************************************************************ | |
17605 | * Sampling of emulsion component to be considered as target-nucleus. * | |
17606 | * This version dated 6.5.95 is written by S. Roesler. * | |
17607 | ************************************************************************ | |
17608 | ||
17609 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17610 | SAVE | |
17611 | PARAMETER ( LINP = 10 , | |
17612 | & LOUT = 6 , | |
17613 | & LDAT = 9 ) | |
17614 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
17615 | ||
17616 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
17617 | * emulsion treatment | |
17618 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
17619 | & NCOMPO,IEMUL | |
17620 | * Glauber formalism: flags and parameters for statistics | |
17621 | LOGICAL LPROD | |
17622 | CHARACTER*8 CGLB | |
17623 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
17624 | ||
17625 | IF (MODE.EQ.0) THEN | |
17626 | SUMFRA = ZERO | |
17627 | RR = DT_RNDM(SUMFRA) | |
17628 | IT = 0 | |
17629 | ITZ = 0 | |
17630 | DO 1 ICOMP=1,NCOMPO | |
17631 | SUMFRA = SUMFRA+EMUFRA(ICOMP) | |
17632 | IF (SUMFRA.GT.RR) THEN | |
17633 | IT = IEMUMA(ICOMP) | |
17634 | ITZ = IEMUCH(ICOMP) | |
17635 | KKMAT = ICOMP | |
17636 | GOTO 2 | |
17637 | ENDIF | |
17638 | 1 CONTINUE | |
17639 | 2 CONTINUE | |
17640 | IF (IT.LE.0) THEN | |
17641 | WRITE(LOUT,'(1X,A,E12.3)') | |
17642 | & 'Warning! norm. failure within emulsion fractions', | |
17643 | & SUMFRA | |
17644 | STOP | |
17645 | ENDIF | |
17646 | ELSEIF (MODE.EQ.1) THEN | |
17647 | NDIFF = 10000 | |
17648 | DO 3 I=1,NCOMPO | |
17649 | IDIFF = ABS(IT-IEMUMA(I)) | |
17650 | IF (IDIFF.LT.NDIFF) THEN | |
17651 | KKMAT = I | |
17652 | NDIFF = IDIFF | |
17653 | ENDIF | |
17654 | 3 CONTINUE | |
17655 | ELSE | |
17656 | STOP 'DT_GETEMU' | |
17657 | ENDIF | |
17658 | ||
17659 | * bypass for variable projectile/target/energy runs: the correct | |
17660 | * Glauber data will be always loaded on kkmat=1 | |
17661 | IF (IOGLB.EQ.100) THEN | |
17662 | KKMAT = 1 | |
17663 | ENDIF | |
17664 | ||
17665 | RETURN | |
17666 | END | |
17667 | ||
17668 | *$ CREATE DT_NCLPOT.FOR | |
17669 | *COPY DT_NCLPOT | |
17670 | * | |
17671 | *===nclpot=============================================================* | |
17672 | * | |
17673 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) | |
17674 | ||
17675 | ************************************************************************ | |
17676 | * Calculation of Coulomb and nuclear potential for a given configurat. * | |
17677 | * IPZ, IP charge/mass number of proj. * | |
17678 | * ITZ, IT charge/mass number of targ. * | |
17679 | * AFERP,AFERT factors modifying proj./target pot. * | |
17680 | * if =0, FERMOD is used * | |
17681 | * MODE = 0 calculation of binding energy * | |
17682 | * = 1 pre-calculated binding energy is used * | |
17683 | * This version dated 16.11.95 is written by S. Roesler. * | |
17684 | * * | |
17685 | * Last change 28.12.2006 by S. Roesler. * | |
17686 | ************************************************************************ | |
17687 | ||
17688 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17689 | SAVE | |
17690 | PARAMETER ( LINP = 10 , | |
17691 | & LOUT = 6 , | |
17692 | & LDAT = 9 ) | |
17693 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
17694 | & TINY10=1.0D-10) | |
17695 | ||
17696 | LOGICAL LSTART | |
17697 | ||
17698 | * particle properties (BAMJET index convention) | |
17699 | CHARACTER*8 ANAME | |
17700 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17701 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17702 | * nuclear potential | |
17703 | LOGICAL LFERMI | |
17704 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17705 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17706 | & ETACOU(2),ICOUL,LFERMI | |
17707 | ||
17708 | DIMENSION IDXPOT(14) | |
17709 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- | |
17710 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, | |
17711 | * asig0 asig+ atet0 atet+ | |
17712 | & 100, 101, 102, 103/ | |
17713 | ||
17714 | DATA AN /0.4D0/ | |
17715 | DATA LSTART /.TRUE./ | |
17716 | ||
17717 | IF (MODE.EQ.0) THEN | |
17718 | EBINDP(1) = ZERO | |
17719 | EBINDN(1) = ZERO | |
17720 | EBINDP(2) = ZERO | |
17721 | EBINDN(2) = ZERO | |
17722 | ENDIF | |
17723 | AIP = DBLE(IP) | |
17724 | AIPZ = DBLE(IPZ) | |
17725 | AIT = DBLE(IT) | |
17726 | AITZ = DBLE(ITZ) | |
17727 | ||
17728 | FERMIP = AFERP | |
17729 | IF (AFERP.LE.ZERO) FERMIP = FERMOD | |
17730 | FERMIT = AFERT | |
17731 | IF (AFERT.LE.ZERO) FERMIT = FERMOD | |
17732 | ||
17733 | * Fermi momenta and binding energy for projectile | |
17734 | IF ((IP.GT.1).AND.LFERMI) THEN | |
17735 | IF (MODE.EQ.0) THEN | |
17736 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) | |
17737 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) | |
17738 | BIP = AIP -ONE | |
17739 | BIPZ = AIPZ-ONE | |
17740 | EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ) | |
17741 | & -DT_ENERGY(AIP,AIPZ)) | |
17742 | IF (AIP.LE.AIPZ) THEN | |
17743 | EBINDN(1) = EBINDP(1) | |
17744 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' | |
17745 | ELSE | |
17746 | EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17747 | & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ)) | |
17748 | ENDIF | |
17749 | ENDIF | |
17750 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 | |
17751 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 | |
17752 | ELSE | |
17753 | PFERMP(1) = ZERO | |
17754 | PFERMN(1) = ZERO | |
17755 | ENDIF | |
17756 | * effective nuclear potential for projectile | |
17757 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) | |
17758 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) | |
17759 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) | |
17760 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) | |
17761 | ||
17762 | * Fermi momenta and binding energy for target | |
17763 | IF ((IT.GT.1).AND.LFERMI) THEN | |
17764 | IF (MODE.EQ.0) THEN | |
17765 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) | |
17766 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) | |
17767 | BIT = AIT -ONE | |
17768 | BITZ = AITZ-ONE | |
17769 | ||
17770 | EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ) | |
17771 | & -DT_ENERGY(AIT,AITZ)) | |
17772 | ||
17773 | IF (AIT.LE.AITZ) THEN | |
17774 | EBINDN(2) = EBINDP(2) | |
17775 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' | |
17776 | ELSE | |
17777 | ||
17778 | EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17779 | & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ)) | |
17780 | ||
17781 | ENDIF | |
17782 | ENDIF | |
17783 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 | |
17784 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 | |
17785 | ELSE | |
17786 | PFERMP(2) = ZERO | |
17787 | PFERMN(2) = ZERO | |
17788 | ENDIF | |
17789 | * effective nuclear potential for target | |
17790 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) | |
17791 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) | |
17792 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) | |
17793 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) | |
17794 | ||
17795 | DO 2 I=1,14 | |
17796 | EPOT(1,IDXPOT(I)) = EPOT(1,8) | |
17797 | EPOT(2,IDXPOT(I)) = EPOT(2,8) | |
17798 | 2 CONTINUE | |
17799 | ||
17800 | * Coulomb energy | |
17801 | ETACOU(1) = ZERO | |
17802 | ETACOU(2) = ZERO | |
17803 | IF (ICOUL.EQ.1) THEN | |
17804 | IF (IP.GT.1) | |
17805 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) | |
17806 | IF (IT.GT.1) | |
17807 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) | |
17808 | ENDIF | |
17809 | ||
17810 | IF (LSTART) THEN | |
17811 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, | |
17812 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), | |
17813 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), | |
17814 | & FERMOD,ETACOU | |
17815 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' | |
17816 | & ,' effects',/,12X,'---------------------------', | |
17817 | & '----------------',/,/,38X,'projectile', | |
17818 | & ' target',/,/,1X,'Mass number / charge', | |
17819 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', | |
17820 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' | |
17821 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', | |
17822 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, | |
17823 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, | |
17824 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) | |
17825 | LSTART = .FALSE. | |
17826 | ENDIF | |
17827 | ||
17828 | RETURN | |
17829 | END | |
17830 | ||
17831 | *$ CREATE DT_RESNCL.FOR | |
17832 | *COPY DT_RESNCL | |
17833 | * | |
17834 | *===resncl=============================================================* | |
17835 | * | |
17836 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) | |
17837 | ||
17838 | ************************************************************************ | |
17839 | * Treatment of residual nuclei and nuclear effects. * | |
17840 | * MODE = 1 initializations * | |
17841 | * = 2 treatment of final state * | |
17842 | * This version dated 16.11.95 is written by S. Roesler. * | |
17843 | * * | |
17844 | * Last change 05.01.2007 by S. Roesler. * | |
17845 | ************************************************************************ | |
17846 | ||
17847 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17848 | SAVE | |
17849 | PARAMETER ( LINP = 10 , | |
17850 | & LOUT = 6 , | |
17851 | & LDAT = 9 ) | |
17852 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, | |
17853 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, | |
17854 | & ONETHI=ONE/THREE) | |
17855 | PARAMETER (AMUAMU = 0.93149432D0, | |
17856 | & FM2MM = 1.0D-12, | |
17857 | & RNUCLE = 1.12D0) | |
17858 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
17859 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
17860 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
17861 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
17862 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
17863 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
17864 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
17865 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
17866 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) | |
17867 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) | |
17868 | ||
17869 | * event history | |
17870 | PARAMETER (NMXHKK=200000) | |
17871 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17872 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17873 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17874 | * extended event history | |
17875 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17876 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17877 | & IHIST(2,NMXHKK) | |
17878 | * particle properties (BAMJET index convention) | |
17879 | CHARACTER*8 ANAME | |
17880 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17881 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17882 | * flags for input different options | |
17883 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17884 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17885 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17886 | * nuclear potential | |
17887 | LOGICAL LFERMI | |
17888 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17889 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17890 | & ETACOU(2),ICOUL,LFERMI | |
17891 | * properties of interacting particles | |
17892 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
17893 | * properties of photon/lepton projectiles | |
17894 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
17895 | * Lorentz-parameters of the current interaction | |
17896 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
17897 | & UMO,PPCM,EPROJ,PPROJ | |
17898 | * treatment of residual nuclei: wounded nucleons | |
17899 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
17900 | * treatment of residual nuclei: 4-momenta | |
17901 | LOGICAL LRCLPR,LRCLTA | |
17902 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
17903 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
17904 | ||
17905 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) | |
17906 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), | |
17907 | & IDXCOR(15000),IDXOTH(NMXHKK) | |
17908 | ||
17909 | GOTO (1,2) MODE | |
17910 | ||
17911 | *------- initializations | |
17912 | 1 CONTINUE | |
17913 | ||
17914 | * initialize arrays for residual nuclei | |
17915 | DO 10 K=1,5 | |
17916 | IF (K.LE.4) THEN | |
17917 | PFSP(K) = ZERO | |
17918 | ENDIF | |
17919 | PINIPR(K) = ZERO | |
17920 | PINITA(K) = ZERO | |
17921 | PRCLPR(K) = ZERO | |
17922 | PRCLTA(K) = ZERO | |
17923 | TRCLPR(K) = ZERO | |
17924 | TRCLTA(K) = ZERO | |
17925 | 10 CONTINUE | |
17926 | SCPOT = ONE | |
17927 | NLOOP = 0 | |
17928 | ||
17929 | * correction of projectile 4-momentum for effective target pot. | |
17930 | * and Coulomb-energy (in case of hadron-nucleus interaction only) | |
9b65428d AM |
17931 | * IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
17932 | * EPNI = EPN | |
9aaba0d6 | 17933 | * Coulomb-energy: |
17934 | * positively charged hadron - check energy for Coloumb pot. | |
9b65428d AM |
17935 | * IF (IICH(IJPROJ).EQ.1) THEN |
17936 | * THRESH = ETACOU(2)+AAM(IJPROJ) | |
17937 | * IF (EPNI.LE.THRESH) THEN | |
17938 | * WRITE(LOUT,1000) | |
17939 | * 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', | |
17940 | * & ' below Coulomb threshold - event rejected',/) | |
17941 | * ISTHKK(1) = 1 | |
17942 | * RETURN | |
17943 | * ENDIF | |
9aaba0d6 | 17944 | * negatively charged hadron - increase energy by Coulomb energy |
9b65428d AM |
17945 | * ELSEIF (IICH(IJPROJ).EQ.-1) THEN |
17946 | * EPNI = EPNI+ETACOU(2) | |
17947 | * ENDIF | |
17948 | * IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN | |
9aaba0d6 | 17949 | * Effective target potential |
17950 | *sr 6.6. binding energy only (to avoid negative exc. energies) | |
17951 | C EPNI = EPNI+EPOT(2,IJPROJ) | |
9b65428d AM |
17952 | * EBIPOT = EBINDP(2) |
17953 | * IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) | |
17954 | * & EBIPOT = EBINDN(2) | |
17955 | * EPNI = EPNI+ABS(EBIPOT) | |
9aaba0d6 | 17956 | * re-initialization of DTLTRA |
9b65428d AM |
17957 | * DUM1 = ZERO |
17958 | * DUM2 = ZERO | |
17959 | * | |
17960 | * CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) | |
17961 | * ENDIF | |
17962 | * ENDIF | |
9aaba0d6 | 17963 | |
17964 | * projectile in n-n cms | |
17965 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN | |
17966 | PMASS1 = AAM(IJPROJ) | |
17967 | C* VDM assumption | |
17968 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) | |
17969 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) | |
17970 | PMASS2 = AAM(1) | |
17971 | PM1 = SIGN(PMASS1**2,PMASS1) | |
17972 | PM2 = SIGN(PMASS2**2,PMASS2) | |
17973 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) | |
17974 | PINIPR(5) = PMASS1 | |
17975 | IF (PMASS1.GT.ZERO) THEN | |
17976 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) | |
17977 | & *(PINIPR(4)+PINIPR(5))) | |
17978 | ELSE | |
17979 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) | |
17980 | ENDIF | |
17981 | AIT = DBLE(IT) | |
17982 | AITZ = DBLE(ITZ) | |
17983 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
17984 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
17985 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN | |
17986 | PMASS1 = AAM(1) | |
17987 | PMASS2 = AAM(IJTARG) | |
17988 | PM1 = SIGN(PMASS1**2,PMASS1) | |
17989 | PM2 = SIGN(PMASS2**2,PMASS2) | |
17990 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) | |
17991 | PINITA(5) = PMASS2 | |
17992 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) | |
17993 | & *(PINITA(4)+PINITA(5))) | |
17994 | AIP = DBLE(IP) | |
17995 | AIPZ = DBLE(IPZ) | |
17996 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
17997 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
17998 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17999 | AIP = DBLE(IP) | |
18000 | AIPZ = DBLE(IPZ) | |
18001 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
18002 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
18003 | AIT = DBLE(IT) | |
18004 | AITZ = DBLE(ITZ) | |
18005 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
18006 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
18007 | ENDIF | |
18008 | ||
18009 | RETURN | |
18010 | ||
18011 | *------- treatment of final state | |
18012 | 2 CONTINUE | |
18013 | ||
18014 | NLOOP = NLOOP+1 | |
18015 | IF (NLOOP.GT.1) SCPOT = 0.10D0 | |
18016 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT | |
18017 | ||
18018 | JPW = NPW | |
18019 | JPCW = NPCW | |
18020 | JTW = NTW | |
18021 | JTCW = NTCW | |
18022 | DO 40 K=1,4 | |
18023 | PFSP(K) = ZERO | |
18024 | 40 CONTINUE | |
18025 | ||
18026 | NOB = 0 | |
18027 | NOM = 0 | |
18028 | DO 900 I=NPOINT(4),NHKK | |
18029 | IDXOTH(I) = -1 | |
18030 | IF (ISTHKK(I).EQ.1) THEN | |
18031 | IF (IDBAM(I).EQ.7) GOTO 900 | |
18032 | IPOT = 0 | |
18033 | IOTHER = 0 | |
18034 | * particle moving into forward direction | |
18035 | IF (PHKK(3,I).GE.ZERO) THEN | |
18036 | * most likely to be effected by projectile potential | |
18037 | IPOT = 1 | |
18038 | * there is no projectile nucleus, try target | |
18039 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN | |
18040 | IPOT = 2 | |
18041 | IF (IP.GT.1) IOTHER = 1 | |
18042 | * there is no target nucleus --> skip | |
18043 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 | |
18044 | ENDIF | |
18045 | * particle moving into backward direction | |
18046 | ELSE | |
18047 | * most likely to be effected by target potential | |
18048 | IPOT = 2 | |
18049 | * there is no target nucleus, try projectile | |
18050 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN | |
18051 | IPOT = 1 | |
18052 | IF (IT.GT.1) IOTHER = 1 | |
18053 | * there is no projectile nucleus --> skip | |
18054 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 | |
18055 | ENDIF | |
18056 | ENDIF | |
18057 | IFLG = -IPOT | |
18058 | * nobam=3: particle is in overlap-region or neither inside proj. nor target | |
18059 | * =1: particle is not in overlap-region AND is inside target (2) | |
18060 | * =2: particle is not in overlap-region AND is inside projectile (1) | |
18061 | * flag particles which are inside the nucleus ipot but not in its | |
18062 | * overlap region | |
18063 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT | |
18064 | IF (IDBAM(I).NE.0) THEN | |
18065 | * baryons: keep all nucleons and all others where flag is set | |
18066 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18067 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) | |
18068 | & THEN | |
18069 | NOB = NOB+1 | |
18070 | PMOMB(NOB) = PHKK(3,I) | |
18071 | IDXB(NOB) = SIGN(10000000*IABS(IFLG) | |
18072 | & +1000000*IOTHER+I,IFLG) | |
18073 | ENDIF | |
18074 | * mesons: keep only those mesons where flag is set | |
18075 | ELSE | |
18076 | IF (IFLG.GT.0) THEN | |
18077 | NOM = NOM+1 | |
18078 | PMOMM(NOM) = PHKK(3,I) | |
18079 | IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I | |
18080 | ENDIF | |
18081 | ENDIF | |
18082 | ENDIF | |
18083 | ENDIF | |
18084 | 900 CONTINUE | |
18085 | * | |
18086 | * sort particles in the arrays according to increasing long. momentum | |
18087 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) | |
18088 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) | |
18089 | * | |
18090 | * shuffle indices into one and the same array according to the later | |
18091 | * sequence of correction | |
18092 | NCOR = 0 | |
18093 | IF (IT.GT.1) THEN | |
18094 | DO 910 I=1,NOB | |
18095 | IF (PMOMB(I).GT.ZERO) GOTO 911 | |
18096 | NCOR = NCOR+1 | |
18097 | IDXCOR(NCOR) = IDXB(I) | |
18098 | 910 CONTINUE | |
18099 | 911 CONTINUE | |
18100 | IF (IP.GT.1) THEN | |
18101 | DO 912 J=1,NOB | |
18102 | I = NOB+1-J | |
18103 | IF (PMOMB(I).LT.ZERO) GOTO 913 | |
18104 | NCOR = NCOR+1 | |
18105 | IDXCOR(NCOR) = IDXB(I) | |
18106 | 912 CONTINUE | |
18107 | 913 CONTINUE | |
18108 | ELSE | |
18109 | DO 914 I=1,NOB | |
18110 | IF (PMOMB(I).GT.ZERO) THEN | |
18111 | NCOR = NCOR+1 | |
18112 | IDXCOR(NCOR) = IDXB(I) | |
18113 | ENDIF | |
18114 | 914 CONTINUE | |
18115 | ENDIF | |
18116 | ELSE | |
18117 | DO 915 J=1,NOB | |
18118 | I = NOB+1-J | |
18119 | NCOR = NCOR+1 | |
18120 | IDXCOR(NCOR) = IDXB(I) | |
18121 | 915 CONTINUE | |
18122 | ENDIF | |
18123 | DO 925 I=1,NOM | |
18124 | IF (PMOMM(I).GT.ZERO) GOTO 926 | |
18125 | NCOR = NCOR+1 | |
18126 | IDXCOR(NCOR) = IDXM(I) | |
18127 | 925 CONTINUE | |
18128 | 926 CONTINUE | |
18129 | DO 927 J=1,NOM | |
18130 | I = NOM+1-J | |
18131 | IF (PMOMM(I).LT.ZERO) GOTO 928 | |
18132 | NCOR = NCOR+1 | |
18133 | IDXCOR(NCOR) = IDXM(I) | |
18134 | 927 CONTINUE | |
18135 | 928 CONTINUE | |
18136 | * | |
18137 | C IF (NEVHKK.EQ.484) THEN | |
18138 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW | |
18139 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) | |
18140 | C WRITE(LOUT,9001) NOB,NOM,NCOR | |
18141 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) | |
18142 | C WRITE(LOUT,'(/,A)') ' baryons ' | |
18143 | C DO 950 I=1,NOB | |
18144 | CC J = IABS(IDXB(I)) | |
18145 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18146 | C IPOT = IABS(IDXB(I))/10000000 | |
18147 | C IOTHER = IABS(IDXB(I))/1000000-IPOT*10 | |
18148 | C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000 | |
18149 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) | |
18150 | C 950 CONTINUE | |
18151 | C WRITE(LOUT,'(/,A)') ' mesons ' | |
18152 | C DO 951 I=1,NOM | |
18153 | CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000 | |
18154 | C IPOT = IABS(IDXM(I))/10000000 | |
18155 | C IOTHER = IABS(IDXM(I))/1000000-IPOT*10 | |
18156 | C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000 | |
18157 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) | |
18158 | C 951 CONTINUE | |
18159 | C 9002 FORMAT(1X,4I14,E14.5) | |
18160 | C WRITE(LOUT,'(/,A)') ' all ' | |
18161 | C DO 952 I=1,NCOR | |
18162 | CC J = IABS(IDXCOR(I)) | |
18163 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18164 | CC IPOT = IABS(IDXCOR(I))/10000000 | |
18165 | C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10 | |
18166 | C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000 | |
18167 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) | |
18168 | C 952 CONTINUE | |
18169 | C 9003 FORMAT(1X,4I14) | |
18170 | C ENDIF | |
18171 | * | |
18172 | DO 20 ICOR=1,NCOR | |
18173 | IPOT = IABS(IDXCOR(ICOR))/10000000 | |
18174 | IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10 | |
18175 | I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000 | |
18176 | IDXOTH(I) = 1 | |
18177 | ||
18178 | IDSEC = IDBAM(I) | |
18179 | ||
18180 | * reduction of particle momentum by corresponding nuclear potential | |
18181 | * (this applies only if Fermi-momenta are requested) | |
18182 | ||
18183 | IF (LFERMI) THEN | |
18184 | ||
18185 | * Lorentz-transformation into the rest system of the selected nucleus | |
18186 | IMODE = -IPOT-1 | |
18187 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18188 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) | |
18189 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) | |
18190 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) | |
18191 | JPMOD = 0 | |
18192 | ||
18193 | CHKLEV = TINY3 | |
18194 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 | |
18195 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 | |
18196 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN | |
18197 | IF (IOULEV(3).GT.0) | |
18198 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) | |
18199 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', | |
18200 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', | |
18201 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) | |
18202 | GOTO 23 | |
18203 | ENDIF | |
18204 | ||
18205 | DO 21 K=1,4 | |
18206 | PSEC0(K) = PSEC(K) | |
18207 | 21 CONTINUE | |
18208 | ||
18209 | * the correction for nuclear potential effects is applied to as many | |
18210 | * p/n as many nucleons were wounded; the momenta of other final state | |
18211 | * particles are corrected only if they materialize inside the corresp. | |
18212 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ | |
18213 | * = 3 part. outside proj. and targ., >=10 in overlapping region) | |
18214 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN | |
18215 | IF (IPOT.EQ.1) THEN | |
18216 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18217 | * this is most likely a wounded nucleon | |
18218 | **test | |
18219 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 | |
18220 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 | |
18221 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) | |
18222 | C RAD = RNUCLE*DBLE(IP)**ONETHI | |
18223 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) | |
18224 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18225 | ** | |
18226 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18227 | JPW = JPW-1 | |
18228 | JPMOD = 1 | |
18229 | ELSE | |
18230 | * correct only if part. was materialized inside nucleus | |
18231 | * and if it is ouside the overlapping region | |
18232 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN | |
18233 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18234 | JPMOD = 1 | |
18235 | ENDIF | |
18236 | ENDIF | |
18237 | ELSEIF (IPOT.EQ.2) THEN | |
18238 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18239 | * this is most likely a wounded nucleon | |
18240 | **test | |
18241 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 | |
18242 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 | |
18243 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) | |
18244 | C RAD = RNUCLE*DBLE(IT)**ONETHI | |
18245 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) | |
18246 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18247 | ** | |
18248 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18249 | JTW = JTW-1 | |
18250 | JPMOD = 1 | |
18251 | ELSE | |
18252 | * correct only if part. was materialized inside nucleus | |
18253 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN | |
18254 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18255 | JPMOD = 1 | |
18256 | ENDIF | |
18257 | ENDIF | |
18258 | ENDIF | |
18259 | ELSE | |
18260 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN | |
18261 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18262 | JPMOD = 1 | |
18263 | ENDIF | |
18264 | ENDIF | |
18265 | ||
18266 | IF (NLOOP.EQ.1) THEN | |
18267 | * Coulomb energy correction: | |
18268 | * the treatment of Coulomb potential correction is similar to the | |
18269 | * one for nuclear potential | |
18270 | IF (IDSEC.EQ.1) THEN | |
18271 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN | |
18272 | JPCW = JPCW-1 | |
18273 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN | |
18274 | JTCW = JTCW-1 | |
18275 | ELSE | |
18276 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18277 | ENDIF | |
18278 | ELSE | |
18279 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18280 | ENDIF | |
18281 | IF (IICH(IDSEC).EQ.1) THEN | |
18282 | * pos. particles: check if they are able to escape Coulomb potential | |
18283 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN | |
18284 | ISTHKK(I) = 14+IPOT | |
18285 | IF (ISTHKK(I).EQ.15) THEN | |
18286 | DO 26 K=1,4 | |
18287 | PHKK(K,I) = PSEC0(K) | |
18288 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18289 | 26 CONTINUE | |
18290 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18291 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18292 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18293 | DO 27 K=1,4 | |
18294 | PHKK(K,I) = PSEC0(K) | |
18295 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18296 | 27 CONTINUE | |
18297 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18298 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18299 | ENDIF | |
18300 | GOTO 20 | |
18301 | ENDIF | |
18302 | ELSEIF (IICH(IDSEC).EQ.-1) THEN | |
18303 | * neg. particles: decrease energy by Coulomb-potential | |
18304 | PSEC(4) = PSEC(4)-ETACOU(IPOT) | |
18305 | JPMOD = 1 | |
18306 | ENDIF | |
18307 | ENDIF | |
18308 | ||
18309 | 25 CONTINUE | |
18310 | ||
18311 | IF (PSEC(4).LT.AMSEC) THEN | |
18312 | IF (IOULEV(6).GT.0) | |
18313 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC | |
18314 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, | |
18315 | & ' is not allowed to escape nucleus',/, | |
18316 | & 8X,'id : ',I3,' reduced energy: ',E15.4, | |
18317 | & ' mass: ',E12.3) | |
18318 | ISTHKK(I) = 14+IPOT | |
18319 | IF (ISTHKK(I).EQ.15) THEN | |
18320 | DO 28 K=1,4 | |
18321 | PHKK(K,I) = PSEC0(K) | |
18322 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18323 | 28 CONTINUE | |
18324 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18325 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18326 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18327 | DO 29 K=1,4 | |
18328 | PHKK(K,I) = PSEC0(K) | |
18329 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18330 | 29 CONTINUE | |
18331 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18332 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18333 | ENDIF | |
18334 | GOTO 20 | |
18335 | ENDIF | |
18336 | ||
18337 | IF (JPMOD.EQ.1) THEN | |
18338 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) | |
18339 | * 4-momentum after correction for nuclear potential | |
18340 | DO 22 K=1,3 | |
18341 | PSEC(K) = PSEC(K)*PSECN/PSECO | |
18342 | 22 CONTINUE | |
18343 | ||
18344 | * store recoil momentum from particles escaping the nuclear potentials | |
18345 | DO 30 K=1,4 | |
18346 | IF (IPOT.EQ.1) THEN | |
18347 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) | |
18348 | ELSEIF (IPOT.EQ.2) THEN | |
18349 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) | |
18350 | ENDIF | |
18351 | 30 CONTINUE | |
18352 | ||
18353 | * transform momentum back into n-n cms | |
18354 | IMODE = IPOT+1 | |
18355 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), | |
18356 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18357 | & IDSEC,IMODE) | |
18358 | ENDIF | |
18359 | ||
18360 | ENDIF | |
18361 | ||
18362 | 23 CONTINUE | |
18363 | DO 31 K=1,4 | |
18364 | PFSP(K) = PFSP(K)+PHKK(K,I) | |
18365 | 31 CONTINUE | |
18366 | ||
18367 | 20 CONTINUE | |
18368 | ||
18369 | DO 33 I=NPOINT(4),NHKK | |
18370 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN | |
18371 | PFSP(1) = PFSP(1)+PHKK(1,I) | |
18372 | PFSP(2) = PFSP(2)+PHKK(2,I) | |
18373 | PFSP(3) = PFSP(3)+PHKK(3,I) | |
18374 | PFSP(4) = PFSP(4)+PHKK(4,I) | |
18375 | ENDIF | |
18376 | 33 CONTINUE | |
18377 | ||
18378 | DO 34 K=1,5 | |
18379 | PRCLPR(K) = TRCLPR(K) | |
18380 | PRCLTA(K) = TRCLTA(K) | |
18381 | 34 CONTINUE | |
18382 | ||
18383 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
18384 | * hadron-nucleus interactions: get residual momentum from energy- | |
18385 | * momentum conservation | |
18386 | DO 32 K=1,4 | |
18387 | PRCLPR(K) = ZERO | |
18388 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) | |
18389 | 32 CONTINUE | |
18390 | ELSE | |
18391 | * nucleus-hadron, nucleus-nucleus: get residual momentum from | |
18392 | * accumulated recoil momenta of particles leaving the spectators | |
18393 | * transform accumulated recoil momenta of residual nuclei into | |
18394 | * n-n cms | |
18395 | PZI = PRCLPR(3) | |
18396 | PEI = PRCLPR(4) | |
18397 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) | |
18398 | PZI = PRCLTA(3) | |
18399 | PEI = PRCLTA(4) | |
18400 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) | |
18401 | C IF (IP.GT.1) THEN | |
18402 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) | |
18403 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) | |
18404 | C ENDIF | |
18405 | IF (IT.GT.1) THEN | |
18406 | PRCLTA(3) = PRCLTA(3)+PINITA(3) | |
18407 | PRCLTA(4) = PRCLTA(4)+PINITA(4) | |
18408 | ENDIF | |
18409 | ENDIF | |
18410 | ||
18411 | * check momenta of residual nuclei | |
18412 | IF (LEMCCK) THEN | |
18413 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), | |
18414 | & 1,IDUM,IDUM) | |
18415 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), | |
18416 | & 2,IDUM,IDUM) | |
18417 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), | |
18418 | & 2,IDUM,IDUM) | |
18419 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), | |
18420 | & 2,IDUM,IDUM) | |
18421 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) | |
18422 | **sr 19.12. changed to avoid output when used with phojet | |
18423 | C CHKLEV = TINY3 | |
18424 | CHKLEV = TINY1 | |
18425 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) | |
18426 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) | |
18427 | C & CALL DT_EVTOUT(4) | |
18428 | IF (IREJ1.GT.0) RETURN | |
18429 | ENDIF | |
18430 | ||
18431 | RETURN | |
18432 | END | |
18433 | ||
18434 | *$ CREATE DT_SCN4BA.FOR | |
18435 | *COPY DT_SCN4BA | |
18436 | * | |
18437 | *===scn4ba=============================================================* | |
18438 | * | |
18439 | SUBROUTINE DT_SCN4BA | |
18440 | ||
18441 | ************************************************************************ | |
18442 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * | |
18443 | * This version dated 12.12.95 is written by S. Roesler. * | |
18444 | ************************************************************************ | |
18445 | ||
18446 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18447 | SAVE | |
18448 | PARAMETER ( LINP = 10 , | |
18449 | & LOUT = 6 , | |
18450 | & LDAT = 9 ) | |
18451 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
18452 | & TINY10=1.0D-10) | |
18453 | ||
18454 | * event history | |
18455 | PARAMETER (NMXHKK=200000) | |
18456 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18457 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18458 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18459 | * extended event history | |
18460 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18461 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18462 | & IHIST(2,NMXHKK) | |
18463 | * particle properties (BAMJET index convention) | |
18464 | CHARACTER*8 ANAME | |
18465 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18466 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18467 | * properties of interacting particles | |
18468 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
18469 | * nuclear potential | |
18470 | LOGICAL LFERMI | |
18471 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18472 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18473 | & ETACOU(2),ICOUL,LFERMI | |
18474 | * treatment of residual nuclei: wounded nucleons | |
18475 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
18476 | * treatment of residual nuclei: 4-momenta | |
18477 | LOGICAL LRCLPR,LRCLTA | |
18478 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18479 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18480 | ||
18481 | DIMENSION PLAB(2,5),PCMS(4) | |
18482 | ||
18483 | IREJ = 0 | |
18484 | ||
18485 | * get number of wounded nucleons | |
18486 | NPW = 0 | |
18487 | NPW0 = 0 | |
18488 | NPCW = 0 | |
18489 | NPSTCK = 0 | |
18490 | NTW = 0 | |
18491 | NTW0 = 0 | |
18492 | NTCW = 0 | |
18493 | NTSTCK = 0 | |
18494 | ||
18495 | ISGLPR = 0 | |
18496 | ISGLTA = 0 | |
18497 | LRCLPR = .FALSE. | |
18498 | LRCLTA = .FALSE. | |
18499 | ||
18500 | C DO 2 I=1,NHKK | |
18501 | DO 2 I=1,NPOINT(1) | |
18502 | * projectile nucleons wounded in primary interaction and in fzc | |
18503 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN | |
18504 | NPW = NPW+1 | |
18505 | IPW(NPW) = I | |
18506 | NPSTCK = NPSTCK+1 | |
18507 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 | |
18508 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 | |
18509 | C IF (IP.GT.1) THEN | |
18510 | DO 5 K=1,4 | |
18511 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) | |
18512 | 5 CONTINUE | |
18513 | C ENDIF | |
18514 | * target nucleons wounded in primary interaction and in fzc | |
18515 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN | |
18516 | NTW = NTW+1 | |
18517 | ITW(NTW) = I | |
18518 | NTSTCK = NTSTCK+1 | |
18519 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 | |
18520 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 | |
18521 | IF (IT.GT.1) THEN | |
18522 | DO 6 K=1,4 | |
18523 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) | |
18524 | 6 CONTINUE | |
18525 | ENDIF | |
18526 | ELSEIF (ISTHKK(I).EQ.13) THEN | |
18527 | ISGLPR = I | |
18528 | ELSEIF (ISTHKK(I).EQ.14) THEN | |
18529 | ISGLTA = I | |
18530 | ENDIF | |
18531 | 2 CONTINUE | |
18532 | ||
18533 | DO 11 I=NPOINT(4),NHKK | |
18534 | * baryons which are unable to escape the nuclear potential of proj. | |
18535 | IF (ISTHKK(I).EQ.15) THEN | |
18536 | ISGLPR = I | |
18537 | NPSTCK = NPSTCK-1 | |
18538 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18539 | NPW = NPW-1 | |
18540 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 | |
18541 | ENDIF | |
18542 | DO 7 K=1,4 | |
18543 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18544 | 7 CONTINUE | |
18545 | * baryons which are unable to escape the nuclear potential of targ. | |
18546 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18547 | ISGLTA = I | |
18548 | NTSTCK = NTSTCK-1 | |
18549 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18550 | NTW = NTW-1 | |
18551 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 | |
18552 | ENDIF | |
18553 | DO 8 K=1,4 | |
18554 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18555 | 8 CONTINUE | |
18556 | ENDIF | |
18557 | 11 CONTINUE | |
18558 | ||
18559 | * residual nuclei so far | |
18560 | IRESP = IP-NPSTCK | |
18561 | IREST = IT-NTSTCK | |
18562 | ||
18563 | * ckeck for "residual nuclei" consisting of one nucleon only | |
18564 | * treat it as final state particle | |
18565 | IF (IRESP.EQ.1) THEN | |
18566 | ID = IDBAM(ISGLPR) | |
18567 | IST = ISTHKK(ISGLPR) | |
18568 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), | |
18569 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), | |
18570 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) | |
18571 | IF (IST.EQ.13) THEN | |
18572 | ISTHKK(ISGLPR) = 11 | |
18573 | ELSE | |
18574 | ISTHKK(ISGLPR) = 2 | |
18575 | ENDIF | |
18576 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, | |
18577 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18578 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) | |
18579 | NOBAM(NHKK) = NOBAM(ISGLPR) | |
18580 | JDAHKK(1,ISGLPR) = NHKK | |
18581 | DO 21 K=1,4 | |
18582 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) | |
18583 | 21 CONTINUE | |
18584 | ENDIF | |
18585 | IF (IREST.EQ.1) THEN | |
18586 | ID = IDBAM(ISGLTA) | |
18587 | IST = ISTHKK(ISGLTA) | |
18588 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), | |
18589 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), | |
18590 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) | |
18591 | IF (IST.EQ.14) THEN | |
18592 | ISTHKK(ISGLTA) = 12 | |
18593 | ELSE | |
18594 | ISTHKK(ISGLTA) = 2 | |
18595 | ENDIF | |
18596 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, | |
18597 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18598 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) | |
18599 | NOBAM(NHKK) = NOBAM(ISGLTA) | |
18600 | JDAHKK(1,ISGLTA) = NHKK | |
18601 | DO 22 K=1,4 | |
18602 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) | |
18603 | 22 CONTINUE | |
18604 | ENDIF | |
18605 | ||
18606 | * get nuclear potential corresp. to the residual nucleus | |
18607 | IPRCL = IP -NPW | |
18608 | IPZRCL = IPZ-NPCW | |
18609 | ITRCL = IT -NTW | |
18610 | ITZRCL = ITZ-NTCW | |
18611 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
18612 | ||
18613 | * baryons unable to escape the nuclear potential are treated as | |
18614 | * excited nucleons (ISTHKK=15,16) | |
18615 | DO 3 I=NPOINT(4),NHKK | |
18616 | IF (ISTHKK(I).EQ.1) THEN | |
18617 | ID = IDBAM(I) | |
18618 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN | |
18619 | * final state n and p not being outside of both nuclei are considered | |
18620 | NPOTP = 1 | |
18621 | NPOTT = 1 | |
18622 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. | |
18623 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN | |
18624 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. | |
18625 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18626 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), | |
18627 | & PLAB(1,4),ID,-2) | |
18628 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) | |
18629 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* | |
18630 | & (PLAB(1,4)+PLABT) )) | |
18631 | EKIN = PLAB(1,4)-PLAB(1,5) | |
18632 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 | |
18633 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 | |
18634 | ENDIF | |
18635 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. | |
18636 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN | |
18637 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. | |
18638 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18639 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), | |
18640 | & PLAB(2,4),ID,-3) | |
18641 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) | |
18642 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* | |
18643 | & (PLAB(2,4)+PLABT) )) | |
18644 | EKIN = PLAB(2,4)-PLAB(2,5) | |
18645 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 | |
18646 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 | |
18647 | ENDIF | |
18648 | IF (PHKK(3,I).GE.ZERO) THEN | |
18649 | ISTHKK(I) = NPOTT | |
18650 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP | |
18651 | ELSE | |
18652 | ISTHKK(I) = NPOTP | |
18653 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT | |
18654 | ENDIF | |
18655 | IF (ISTHKK(I).NE.1) THEN | |
18656 | J = ISTHKK(I)-14 | |
18657 | DO 4 K=1,5 | |
18658 | PHKK(K,I) = PLAB(J,K) | |
18659 | 4 CONTINUE | |
18660 | IF (ISTHKK(I).EQ.15) THEN | |
18661 | NPW = NPW-1 | |
18662 | IF (ID.EQ.1) NPCW = NPCW-1 | |
18663 | DO 9 K=1,4 | |
18664 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18665 | 9 CONTINUE | |
18666 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18667 | NTW = NTW-1 | |
18668 | IF (ID.EQ.1) NTCW = NTCW-1 | |
18669 | DO 10 K=1,4 | |
18670 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18671 | 10 CONTINUE | |
18672 | ENDIF | |
18673 | ENDIF | |
18674 | ENDIF | |
18675 | ENDIF | |
18676 | 3 CONTINUE | |
18677 | ||
18678 | * again: get nuclear potential corresp. to the residual nucleus | |
18679 | IPRCL = IP -NPW | |
18680 | IPZRCL = IPZ-NPCW | |
18681 | ITRCL = IT -NTW | |
18682 | ITZRCL = ITZ-NTCW | |
18683 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) | |
18684 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) | |
18685 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 | |
18686 | C AFERP = 0.0D0 | |
18687 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) | |
18688 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) | |
18689 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 | |
18690 | C AFERT = 0.0D0 | |
18691 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 | |
18692 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 | |
18693 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 | |
18694 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 | |
18695 | AFERP = FERMOD+0.1D0 | |
18696 | AFERT = FERMOD+0.1D0 | |
18697 | ||
18698 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) | |
18699 | ||
18700 | RETURN | |
18701 | END | |
18702 | ||
18703 | *$ CREATE DT_FICONF.FOR | |
18704 | *COPY DT_FICONF | |
18705 | * | |
18706 | *===ficonf=============================================================* | |
18707 | * | |
18708 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) | |
18709 | ||
18710 | ************************************************************************ | |
18711 | * Treatment of FInal CONFiguration including evaporation, fission and * | |
18712 | * Fermi-break-up (for light nuclei only). * | |
18713 | * Adopted from the original routine FINALE and extended to residual * | |
18714 | * projectile nuclei. * | |
18715 | * This version dated 12.12.95 is written by S. Roesler. * | |
18716 | * * | |
18717 | * Last change 27.12.2006 by S. Roesler. * | |
18718 | ************************************************************************ | |
18719 | ||
18720 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18721 | SAVE | |
18722 | PARAMETER ( LINP = 10 , | |
18723 | & LOUT = 6 , | |
18724 | & LDAT = 9 ) | |
18725 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
18726 | PARAMETER (ANGLGB=5.0D-16) | |
18727 | PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3) | |
18728 | ||
18729 | * event history | |
18730 | PARAMETER (NMXHKK=200000) | |
18731 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18732 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18733 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18734 | * extended event history | |
18735 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18736 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18737 | & IHIST(2,NMXHKK) | |
18738 | * rejection counter | |
18739 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
18740 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
18741 | & IREXCI(3),IRDIFF(2),IRINC | |
18742 | * central particle production, impact parameter biasing | |
18743 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
18744 | * particle properties (BAMJET index convention) | |
18745 | CHARACTER*8 ANAME | |
18746 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18747 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18748 | * treatment of residual nuclei: 4-momenta | |
18749 | LOGICAL LRCLPR,LRCLTA | |
18750 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18751 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18752 | * treatment of residual nuclei: properties of residual nuclei | |
18753 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
18754 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
18755 | & NTOTFI(2),NPROFI(2) | |
18756 | * statistics: residual nuclei | |
18757 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
18758 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
18759 | & NINCST(2,4),NINCEV(2), | |
18760 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
18761 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
18762 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
18763 | & NEVAFI(2,2) | |
18764 | * flags for input different options | |
18765 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
18766 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
18767 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
18768 | * (original name: FINUC) | |
18769 | PARAMETER (MXP=999) | |
18770 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
18771 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
18772 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
18773 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
18774 | & KPART (MXP) | |
18775 | * (original name: RESNUC) | |
18776 | LOGICAL LRNFSS, LFRAGM | |
18777 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
18778 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
18779 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
18780 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
18781 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
18782 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
18783 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
18784 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
18785 | & LFRAGM | |
18786 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
18787 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
18788 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
18789 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
18790 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
18791 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
18792 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
18793 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
18794 | * (original name: PAREVT) | |
18795 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
18796 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
18797 | PARAMETER ( NALLWP = 39 ) | |
18798 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
18799 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
18800 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
18801 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
18802 | * event flag | |
18803 | COMMON /DTEVNO/ NEVENT,ICASCA | |
18804 | ||
18805 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), | |
18806 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), | |
18807 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) | |
18808 | ||
18809 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) | |
18810 | LOGICAL LLCPOT | |
18811 | DATA EXC,NEXC /520*ZERO,520*0/ | |
18812 | DATA EXPNUC /4.0D-3,4.0D-3/ | |
18813 | ||
18814 | IREJ = 0 | |
18815 | LRCLPR = .FALSE. | |
18816 | LRCLTA = .FALSE. | |
18817 | ||
18818 | * skip residual nucleus treatment if not requested or in case | |
18819 | * of central collisions | |
18820 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN | |
18821 | ||
18822 | DO 1 K=1,2 | |
18823 | IDPAR(K) = 0 | |
18824 | IDXPAR(K)= 0 | |
18825 | NTOT(K) = 0 | |
18826 | NTOTFI(K)= 0 | |
18827 | NPRO(K) = 0 | |
18828 | NPROFI(K)= 0 | |
18829 | NN(K) = 0 | |
18830 | NH(K) = 0 | |
18831 | NHPOS(K) = 0 | |
18832 | NQ(K) = 0 | |
18833 | EEXC(K) = ZERO | |
18834 | MO1(K) = 0 | |
18835 | MO2(K) = 0 | |
18836 | DO 2 I=1,4 | |
18837 | VRCL(K,I) = ZERO | |
18838 | WRCL(K,I) = ZERO | |
18839 | 2 CONTINUE | |
18840 | 1 CONTINUE | |
18841 | NFSP = 0 | |
18842 | INUC(1) = IP | |
18843 | INUC(2) = IT | |
18844 | ||
18845 | DO 3 I=1,NHKK | |
18846 | ||
18847 | * number of final state particles | |
18848 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
18849 | NFSP = NFSP+1 | |
18850 | IDFSP = IDBAM(I) | |
18851 | ENDIF | |
18852 | ||
18853 | * properties of remaining nucleon configurations | |
18854 | KF = 0 | |
18855 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 | |
18856 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 | |
18857 | IF (KF.GT.0) THEN | |
18858 | IF (MO1(KF).EQ.0) MO1(KF) = I | |
18859 | MO2(KF) = I | |
18860 | * position of residual nucleus = average position of nucleons | |
18861 | DO 4 K=1,4 | |
18862 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) | |
18863 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) | |
18864 | 4 CONTINUE | |
18865 | * total number of particles contributing to each residual nucleus | |
18866 | NTOT(KF) = NTOT(KF)+1 | |
18867 | IDTMP = IDBAM(I) | |
18868 | IDXTMP = I | |
18869 | * total charge of residual nuclei | |
18870 | NQ(KF) = NQ(KF)+IICH(IDTMP) | |
18871 | * number of protons | |
18872 | IF (IDHKK(I).EQ.2212) THEN | |
18873 | NPRO(KF) = NPRO(KF)+1 | |
18874 | * number of neutrons | |
18875 | ELSEIF (IDHKK(I).EQ.2112) THEN | |
18876 | NN(KF) = NN(KF)+1 | |
18877 | ELSE | |
18878 | * number of baryons other than n, p | |
18879 | IF (IIBAR(IDTMP).EQ.1) THEN | |
18880 | NH(KF) = NH(KF)+1 | |
18881 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 | |
18882 | ELSE | |
18883 | * any other mesons (status set to 1) | |
18884 | C WRITE(LOUT,1002) KF,IDTMP | |
18885 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, | |
18886 | C & ' containing meson ',I4,', status set to 1') | |
18887 | ISTHKK(I) = 1 | |
18888 | IDTMP = IDPAR(KF) | |
18889 | IDXTMP = IDXPAR(KF) | |
18890 | NTOT(KF) = NTOT(KF)-1 | |
18891 | ENDIF | |
18892 | ENDIF | |
18893 | IDPAR(KF) = IDTMP | |
18894 | IDXPAR(KF) = IDXTMP | |
18895 | ENDIF | |
18896 | 3 CONTINUE | |
18897 | ||
18898 | * reject elastic events (def: one final state particle = projectile) | |
18899 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN | |
18900 | IREXCI(3) = IREXCI(3)+1 | |
18901 | GOTO 9999 | |
18902 | C RETURN | |
18903 | ENDIF | |
18904 | ||
18905 | * check if one nucleus disappeared.. | |
18906 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN | |
18907 | C DO 5 K=1,4 | |
18908 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) | |
18909 | C PRCLPR(K) = ZERO | |
18910 | C 5 CONTINUE | |
18911 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN | |
18912 | C DO 6 K=1,4 | |
18913 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) | |
18914 | C PRCLTA(K) = ZERO | |
18915 | C 6 CONTINUE | |
18916 | C ENDIF | |
18917 | ||
18918 | ICOR = 0 | |
18919 | INORCL = 0 | |
18920 | DO 7 I=1,2 | |
18921 | DO 8 K=1,4 | |
18922 | * get the average of the nucleon positions | |
18923 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) | |
18924 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) | |
18925 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) | |
18926 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) | |
18927 | 8 CONTINUE | |
18928 | * mass number and charge of residual nuclei | |
18929 | AIF(I) = DBLE(NTOT(I)) | |
18930 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) | |
18931 | IF (NTOT(I).GT.1) THEN | |
18932 | * masses of residual nuclei in ground state | |
18933 | AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I)) | |
18934 | * masses of residual nuclei | |
18935 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) | |
18936 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) | |
18937 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) | |
18938 | * | |
18939 | * M_res^2 < 0 : configuration not allowed | |
18940 | * | |
18941 | * a) re-calculate E_exc with scaled nuclear potential | |
18942 | * (conditional jump to label 9998) | |
18943 | * b) or reject event if N_loop(max) is exceeded | |
18944 | * (conditional jump to label 9999) | |
18945 | * | |
18946 | IF (AMRCL(I).LE.ZERO) THEN | |
18947 | IF (IOULEV(3).GT.0) | |
18948 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), | |
18949 | & PRCL(I,4),NTOT | |
18950 | 1000 FORMAT(1X,'warning! negative excitation energy',/, | |
18951 | & I4,4E15.4,2I4) | |
18952 | AMRCL(I) = ZERO | |
18953 | EEXC(I) = ZERO | |
18954 | IF (NLOOP.LE.500) THEN | |
18955 | GOTO 9998 | |
18956 | ELSE | |
18957 | IREXCI(2) = IREXCI(2)+1 | |
18958 | GOTO 9999 | |
18959 | ENDIF | |
18960 | * | |
18961 | * 0 < M_res < M_res0 : mass below ground-state mass | |
18962 | * | |
18963 | * a) we had residual nuclei with mass N_tot and reasonable E_exc | |
18964 | * before- assign average E_exc of those configurations to this | |
18965 | * one ( Nexc(i,N_tot) > 0 ) | |
18966 | * b) or (and this applies always if run in transport codes) go up | |
18967 | * one mass number and | |
18968 | * i) if mass now larger than proj/targ mass or if run in | |
18969 | * transport codes assign average E_exc per wounded nucleon | |
18970 | * x number of wounded nucleons (Inuc-Ntot) | |
18971 | * ii) or assign average E_exc of those configurations to this | |
18972 | * one ( Nexc(i,m) > 0 ) | |
18973 | * | |
18974 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) | |
18975 | & THEN | |
18976 | M = MIN(NTOT(I),260) | |
18977 | IF (NEXC(I,M).GT.0) THEN | |
18978 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
18979 | ELSE | |
18980 | 70 CONTINUE | |
18981 | M = M+1 | |
18982 | **sr corrected 27.12.06 | |
18983 | * IF (M.GE.INUC(I)) THEN | |
18984 | * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) | |
18985 | IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN | |
18986 | IF ( INUC (I) .GT. NTOT (I) ) THEN | |
18987 | AMRCL(I) = AMRCL0(I) | |
18988 | & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) | |
18989 | ELSE | |
18990 | AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I) | |
18991 | END IF | |
18992 | ** | |
18993 | ELSE | |
18994 | IF (NEXC(I,M).GT.0) THEN | |
18995 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
18996 | ELSE | |
18997 | GOTO 70 | |
18998 | ENDIF | |
18999 | ENDIF | |
19000 | ENDIF | |
19001 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
19002 | ICOR = ICOR+I | |
19003 | * | |
19004 | * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc | |
19005 | * | |
19006 | * a) re-calculate E_exc with scaled nuclear potential | |
19007 | * (conditional jump to label 9998) | |
19008 | * b) or reject event if N_loop(max) is exceeded | |
19009 | * (conditional jump to label 9999) | |
19010 | * | |
19011 | * | |
19012 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN | |
19013 | IF (IOULEV(3).GT.0) | |
19014 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK | |
19015 | 1004 FORMAT(1X,'warning! too high excitation energy',/, | |
19016 | & I4,1P,2E15.4,3I5) | |
19017 | AMRCL(I) = ZERO | |
19018 | EEXC(I) = ZERO | |
19019 | IF (NLOOP.LE.500) THEN | |
19020 | GOTO 9998 | |
19021 | ELSE | |
19022 | IREXCI(2) = IREXCI(2)+1 | |
19023 | GOTO 9999 | |
19024 | ENDIF | |
19025 | * | |
19026 | * Otherwise (reasonable E_exc) : | |
19027 | * E_exc = M_res - M_res0 | |
19028 | * in addition: calculate and save E_exc per wounded nucleon as | |
19029 | * well as E_exc in <E_exc> counter | |
19030 | * | |
19031 | ELSE | |
19032 | * excitation energies of residual nuclei | |
19033 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
19034 | **sr 27.12.06 new excitation energy correction by A.F. | |
19035 | * | |
19036 | * all parts with Ilcopt<3 commented since not used | |
19037 | * | |
19038 | * still to be done/decided: | |
19039 | * Increase Icor and put back both residual nuclei on mass shell | |
19040 | * with the exciting correction further below. | |
19041 | * For the moment the modification in the excitation energy is simply | |
19042 | * corrected by scaling the energy of the residual nucleus. | |
19043 | * | |
19044 | LLCPOT = .TRUE. | |
19045 | ILCOPT = 3 | |
19046 | IF ( LLCPOT ) THEN | |
19047 | NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) | |
19048 | IF ( ILCOPT .LE. 2 ) THEN | |
19049 | C* Patch for Fermi momentum reduction correlated with impact parameter: | |
19050 | C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) | |
19051 | C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) | |
19052 | C AKPRHO = ONE - DLKPRH | |
19053 | C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen | |
19054 | C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, | |
19055 | C & 0.05D+00 ) | |
19056 | C* REDORI = 0.75D+00 | |
19057 | C* REDORI = ONE | |
19058 | C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19059 | ELSE | |
19060 | DLKPRH = ZERO | |
19061 | RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00) | |
19062 | * Take out roughly one/half of the skin: | |
19063 | RDCORE = RDCORE - 0.5D+00 | |
19064 | FRCFLL = RDCORE**3 | |
19065 | PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL | |
19066 | PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL ) | |
19067 | FRCFLL = ONE - PRSKIN | |
19068 | FRMRDC = FRCFLL + 0.5D+00 * PRSKIN | |
19069 | REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19070 | END IF | |
19071 | IF ( NNCHIT .GT. 0 ) THEN | |
19072 | C IF ( ILCOPT .EQ. 1 ) THEN | |
19073 | C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) | |
19074 | C DO 1220 NCH = 1, 10 | |
19075 | C ETAETA = ( ONE - SKINRH**INUC(I) | |
19076 | C & - DBLE(INUC(I))* ( ONE - FRCFLL ) | |
19077 | C & * ( ONE - SKINRH ) ) | |
19078 | C & / ( SKINRH**INUC(I) - DBLE (INUC(I)) | |
19079 | C & * ( ONE - FRCFLL) * SKINRH ) | |
19080 | C SKINRH = SKINRH * ( ONE + ETAETA ) | |
19081 | C 1220 CONTINUE | |
19082 | C PRSKIN = SKINRH**(NNCHIT-1) | |
19083 | C ELSE IF ( ILCOPT .EQ. 2 ) THEN | |
19084 | C PRSKIN = ONE - FRCFLL | |
19085 | C END IF | |
19086 | REDCTN = ZERO | |
19087 | DO 1230 NCH = 1, NNCHIT | |
19088 | IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN | |
19089 | PRFRMI = (( ONE - 2.D+00 * DLKPRH ) | |
19090 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19091 | ELSE | |
19092 | PRFRMI = ( ONE - 2.D+00 * DLKPRH | |
19093 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19094 | END IF | |
19095 | REDCTN = REDCTN + PRFRMI**2 | |
19096 | 1230 CONTINUE | |
19097 | REDCTN = REDCTN / DBLE (NNCHIT) | |
19098 | ELSE | |
19099 | REDCTN = 0.5D+00 | |
19100 | END IF | |
19101 | EEXC (I) = EEXC (I) * REDCTN / REDORI | |
19102 | AMRCL (I) = AMRCL0 (I) + EEXC (I) | |
19103 | PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 ) | |
19104 | END IF | |
19105 | ** | |
19106 | IF (ICASCA.EQ.0) THEN | |
19107 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) | |
19108 | M = MIN(NTOT(I),260) | |
19109 | EXC(I,M) = EXC(I,M)+EEXC(I) | |
19110 | NEXC(I,M) = NEXC(I,M)+1 | |
19111 | ENDIF | |
19112 | ENDIF | |
19113 | ELSEIF (NTOT(I).EQ.1) THEN | |
19114 | WRITE(LOUT,1003) I | |
19115 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') | |
19116 | GOTO 9999 | |
19117 | ELSE | |
19118 | AMRCL0(I) = ZERO | |
19119 | AMRCL(I) = ZERO | |
19120 | EEXC(I) = ZERO | |
19121 | INORCL = INORCL+I | |
19122 | ENDIF | |
19123 | 7 CONTINUE | |
19124 | ||
19125 | PRCLPR(5) = AMRCL(1) | |
19126 | PRCLTA(5) = AMRCL(2) | |
19127 | ||
19128 | IF (ICOR.GT.0) THEN | |
19129 | IF (INORCL.EQ.0) THEN | |
19130 | * one or both residual nuclei consist of one nucleon only, transform | |
19131 | * this nucleon on mass shell | |
19132 | DO 9 K=1,4 | |
19133 | P1IN(K) = PRCL(1,K) | |
19134 | P2IN(K) = PRCL(2,K) | |
19135 | 9 CONTINUE | |
19136 | XM1 = AMRCL(1) | |
19137 | XM2 = AMRCL(2) | |
19138 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
19139 | IF (IREJ1.GT.0) THEN | |
19140 | WRITE(LOUT,*) 'ficonf-mashel rejection' | |
19141 | GOTO 9999 | |
19142 | ENDIF | |
19143 | DO 10 K=1,4 | |
19144 | PRCL(1,K) = P1OUT(K) | |
19145 | PRCL(2,K) = P2OUT(K) | |
19146 | PRCLPR(K) = P1OUT(K) | |
19147 | PRCLTA(K) = P2OUT(K) | |
19148 | 10 CONTINUE | |
19149 | PRCLPR(5) = AMRCL(1) | |
19150 | PRCLTA(5) = AMRCL(2) | |
19151 | ELSE | |
19152 | IF (IOULEV(3).GT.0) | |
19153 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), | |
19154 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), | |
19155 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), | |
19156 | & AMRCL(2),AMRCL(2)-AMRCL0(2) | |
19157 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', | |
19158 | & ' correction',/,11X,'at event',I8, | |
19159 | & ', nucleon config. 1:',2I4,' 2:',2I4, | |
19160 | & 2(/,11X,3E12.3)) | |
19161 | IF (NLOOP.LE.500) THEN | |
19162 | GOTO 9998 | |
19163 | ELSE | |
19164 | IREXCI(1) = IREXCI(1)+1 | |
19165 | ENDIF | |
19166 | ENDIF | |
19167 | ENDIF | |
19168 | ||
19169 | * update counter | |
19170 | C IF (NRESEV(1).NE.NEVHKK) THEN | |
19171 | C NRESEV(1) = NEVHKK | |
19172 | C NRESEV(2) = NRESEV(2)+1 | |
19173 | C ENDIF | |
19174 | NRESEV(2) = NRESEV(2)+1 | |
19175 | DO 15 I=1,2 | |
19176 | EXCDPM(I) = EXCDPM(I)+EEXC(I) | |
19177 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) | |
19178 | NRESTO(I) = NRESTO(I)+NTOT(I) | |
19179 | NRESPR(I) = NRESPR(I)+NPRO(I) | |
19180 | NRESNU(I) = NRESNU(I)+NN(I) | |
19181 | NRESBA(I) = NRESBA(I)+NH(I) | |
19182 | NRESPB(I) = NRESPB(I)+NHPOS(I) | |
19183 | NRESCH(I) = NRESCH(I)+NQ(I) | |
19184 | 15 CONTINUE | |
19185 | ||
19186 | * evaporation | |
19187 | IF (LEVPRT) THEN | |
19188 | DO 13 I=1,2 | |
19189 | * initialize evaporation counter | |
19190 | EEXCFI(I) = ZERO | |
19191 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. | |
19192 | & (EEXC(I).GT.ZERO)) THEN | |
19193 | * put residual nuclei into DTEVT1 | |
19194 | IDRCL = 80000 | |
19195 | JMASS = INT( AIF(I)) | |
19196 | JCHAR = INT(AIZF(I)) | |
19197 | * the following patch is required to transmit the correct excitation | |
19198 | * energy to Eventd | |
19199 | IF (ITRSPT.EQ.1) THEN | |
19200 | IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND. | |
19201 | & (IOULEV(3).GT.0)) | |
19202 | & WRITE(LOUT,*) | |
19203 | & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', | |
19204 | & AMRCL(I),AMRCL0(I),EEXC(I) | |
19205 | PRCL0 = PRCL(I,4) | |
19206 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 | |
19207 | & +PRCL(I,3)**2) | |
19208 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN | |
19209 | WRITE(LOUT,*) | |
19210 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) | |
19211 | ENDIF | |
19212 | ENDIF | |
19213 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), | |
19214 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) | |
19215 | **sr 22.6.97 | |
19216 | NOBAM(NHKK) = I | |
19217 | ** | |
19218 | DO 14 J=1,4 | |
19219 | VHKK(J,NHKK) = VRCL(I,J) | |
19220 | WHKK(J,NHKK) = WRCL(I,J) | |
19221 | 14 CONTINUE | |
19222 | * interface to evaporation module - fill final residual nucleus into | |
19223 | * common FKRESN | |
19224 | * fill resnuc only if code is not used as event generator in Fluka | |
19225 | IF (ITRSPT.NE.1) THEN | |
19226 | PXRES = PRCL(I,1) | |
19227 | PYRES = PRCL(I,2) | |
19228 | PZRES = PRCL(I,3) | |
19229 | IBRES = NPRO(I)+NN(I)+NH(I) | |
19230 | ICRES = NPRO(I)+NHPOS(I) | |
19231 | ANOW = DBLE(IBRES) | |
19232 | ZNOW = DBLE(ICRES) | |
19233 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) | |
19234 | * ground state mass of the residual nucleus (should be equal to AM0T) | |
19235 | AMMRES = AMRCL0(I) | |
19236 | AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES) | |
19237 | * common FKFINU | |
19238 | TV = ZERO | |
19239 | * kinetic energy of residual nucleus | |
19240 | TVRECL = PRCL(I,4)-AMRCL(I) | |
19241 | * excitation energy of residual nucleus | |
19242 | TVCMS = EEXC(I) | |
19243 | PTOLD = PTRES | |
19244 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ | |
19245 | & 2.0D0*(AMMRES+TVCMS)))) | |
19246 | IF (PTOLD.LT.ANGLGB) THEN | |
19247 | CALL DT_RACO(PXRES,PYRES,PZRES) | |
19248 | PTOLD = ONE | |
19249 | ENDIF | |
19250 | PXRES = PXRES*PTRES/PTOLD | |
19251 | PYRES = PYRES*PTRES/PTOLD | |
19252 | PZRES = PZRES*PTRES/PTOLD | |
19253 | * zero counter of secondaries from evaporation | |
19254 | NP = 0 | |
19255 | * evaporation | |
19256 | WE = ONE | |
19257 | CALL DT_EVEVAP(WE) | |
19258 | * put evaporated particles and residual nuclei to DTEVT1 | |
19259 | MO = NHKK | |
19260 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) | |
19261 | ENDIF | |
19262 | EEXCFI(I) = EXCITF | |
19263 | EXCEVA(I) = EXCEVA(I)+EXCITF | |
19264 | ENDIF | |
19265 | 13 CONTINUE | |
19266 | ENDIF | |
19267 | ||
19268 | RETURN | |
19269 | ||
19270 | C9998 IREXCI(1) = IREXCI(1)+1 | |
19271 | 9998 IREJ = IREJ+1 | |
19272 | 9999 CONTINUE | |
19273 | LRCLPR = .TRUE. | |
19274 | LRCLTA = .TRUE. | |
19275 | IREJ = IREJ+1 | |
19276 | RETURN | |
19277 | END | |
19278 | ||
19279 | *$ CREATE DT_EVA2HE.FOR | |
19280 | *COPY DT_EVA2HE | |
19281 | * * | |
19282 | *====eva2he============================================================* | |
19283 | * * | |
19284 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) | |
19285 | ||
19286 | ************************************************************************ | |
19287 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * | |
19288 | * and DTEVT1. * | |
19289 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * | |
19290 | * EEXCF exitation energy of residual nucleus after evaporation * | |
19291 | * IRCL = 1 projectile residual nucleus * | |
19292 | * = 2 target residual nucleus * | |
19293 | * This version dated 19.04.95 is written by S. Roesler. * | |
19294 | * * | |
19295 | * Last change 27.12.2006 by S. Roesler. * | |
19296 | ************************************************************************ | |
19297 | ||
19298 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19299 | SAVE | |
19300 | PARAMETER ( LINP = 10 , | |
19301 | & LOUT = 6 , | |
19302 | & LDAT = 9 ) | |
19303 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) | |
19304 | ||
19305 | * event history | |
19306 | PARAMETER (NMXHKK=200000) | |
19307 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
19308 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
19309 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
19310 | * Note: DTEVT2 - special use for heavy fragments ! | |
19311 | * (IDRES(I) = mass number, IDXRES(I) = charge) | |
19312 | * extended event history | |
19313 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
19314 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
19315 | & IHIST(2,NMXHKK) | |
19316 | * particle properties (BAMJET index convention) | |
19317 | CHARACTER*8 ANAME | |
19318 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
19319 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
19320 | * flags for input different options | |
19321 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
19322 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
19323 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
19324 | * statistics: residual nuclei | |
19325 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
19326 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
19327 | & NINCST(2,4),NINCEV(2), | |
19328 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
19329 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
19330 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
19331 | & NEVAFI(2,2) | |
19332 | * treatment of residual nuclei: properties of residual nuclei | |
19333 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
19334 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
19335 | & NTOTFI(2),NPROFI(2) | |
19336 | * (original name: FINUC) | |
19337 | PARAMETER (MXP=999) | |
19338 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
19339 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
19340 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
19341 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
19342 | & KPART (MXP) | |
19343 | * (original name: FHEAVY,FHEAVC) | |
19344 | PARAMETER ( MXHEAV = 100 ) | |
19345 | CHARACTER*8 ANHEAV | |
19346 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
19347 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
19348 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
19349 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
19350 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
19351 | & IBHEAV ( 12 ) , NPHEAV | |
19352 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
19353 | * (original name: RESNUC) | |
19354 | LOGICAL LRNFSS, LFRAGM | |
19355 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
19356 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
19357 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
19358 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
19359 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
19360 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
19361 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
19362 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
19363 | & LFRAGM | |
19364 | ||
19365 | DIMENSION IPTOKP(39) | |
19366 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
19367 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, | |
19368 | & 100, 101, 97, 102, 98, 103, 109, 115 / | |
19369 | ||
19370 | IREJ = 0 | |
19371 | ||
19372 | * skip if evaporation package is not included | |
19373 | IF (.NOT.LEVAPO) RETURN | |
19374 | ||
19375 | * update counter | |
19376 | IF (NRESEV(3).NE.NEVHKK) THEN | |
19377 | NRESEV(3) = NEVHKK | |
19378 | NRESEV(4) = NRESEV(4)+1 | |
19379 | ENDIF | |
19380 | ||
19381 | IF (LEMCCK) | |
19382 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, | |
19383 | & IDUM,IDUM) | |
19384 | * mass number/charge of residual nucleus before evaporation | |
19385 | IBTOT = IDRES(MO) | |
19386 | IZTOT = IDXRES(MO) | |
19387 | ||
19388 | * protons/neutrons/gammas | |
19389 | DO 1 I=1,NP | |
19390 | PX = CXR(I)*PLR(I) | |
19391 | PY = CYR(I)*PLR(I) | |
19392 | PZ = CZR(I)*PLR(I) | |
19393 | ID = IPTOKP(KPART(I)) | |
19394 | IDPDG = IDT_IPDGHA(ID) | |
19395 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ | |
19396 | & (2.0D0*MAX(TKI(I),TINY10)) | |
19397 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN | |
19398 | WRITE(LOUT,1000) ID,AM,AAM(ID) | |
19399 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', | |
19400 | & 'particle',I3,2E10.3) | |
19401 | ENDIF | |
19402 | PE = TKI(I)+AM | |
19403 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) | |
19404 | NOBAM(NHKK) = IRCL | |
19405 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19406 | IBTOT = IBTOT-IIBAR(ID) | |
19407 | IZTOT = IZTOT-IICH(ID) | |
19408 | 1 CONTINUE | |
19409 | ||
19410 | * heavy fragments | |
19411 | DO 2 I=1,NPHEAV | |
19412 | PX = CXHEAV(I)*PHEAVY(I) | |
19413 | PY = CYHEAV(I)*PHEAVY(I) | |
19414 | PZ = CZHEAV(I)*PHEAVY(I) | |
19415 | IDHEAV = 80000 | |
19416 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ | |
19417 | & (2.0D0*MAX(TKHEAV(I),TINY10)) | |
19418 | PE = TKHEAV(I)+AM | |
19419 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, | |
19420 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) | |
19421 | NOBAM(NHKK) = IRCL | |
19422 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19423 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) | |
19424 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) | |
19425 | 2 CONTINUE | |
19426 | ||
19427 | IF (IBRES.GT.0) THEN | |
19428 | * residual nucleus after evaporation | |
19429 | IDNUC = 80000 | |
19430 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, | |
19431 | & IBRES,ICRES,0) | |
19432 | NOBAM(NHKK) = IRCL | |
19433 | ENDIF | |
19434 | EEXCF = TVCMS | |
19435 | NTOTFI(IRCL) = IBRES | |
19436 | NPROFI(IRCL) = ICRES | |
19437 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) | |
19438 | IBTOT = IBTOT-IBRES | |
19439 | IZTOT = IZTOT-ICRES | |
19440 | ||
19441 | * count events with fission | |
19442 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 | |
19443 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 | |
19444 | ||
19445 | * energy-momentum conservation check | |
19446 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) | |
19447 | C IF (IREJ.GT.0) THEN | |
19448 | C CALL DT_EVTOUT(4) | |
19449 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV | |
19450 | C ENDIF | |
19451 | * baryon-number/charge conservation check | |
19452 | IF (IBTOT+IZTOT.NE.0) THEN | |
19453 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT | |
19454 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', | |
19455 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) | |
19456 | ENDIF | |
19457 | ||
19458 | RETURN | |
19459 | END | |
19460 | ||
19461 | *$ CREATE DT_EBIND.FOR | |
19462 | *COPY DT_EBIND | |
19463 | * | |
19464 | *===ebind==============================================================* | |
19465 | * | |
19466 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) | |
19467 | ||
19468 | ************************************************************************ | |
19469 | * Binding energy for nuclei. * | |
19470 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * | |
19471 | * IA mass number * | |
19472 | * IZ atomic number * | |
19473 | * This version dated 5.5.95 is updated by S. Roesler. * | |
19474 | ************************************************************************ | |
19475 | ||
19476 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19477 | SAVE | |
19478 | PARAMETER ( LINP = 10 , | |
19479 | & LOUT = 6 , | |
19480 | & LDAT = 9 ) | |
19481 | PARAMETER (ZERO=0.0D0) | |
19482 | ||
19483 | DATA A1, A2, A3, A4, A5 | |
19484 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ | |
19485 | ||
19486 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN | |
19487 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ | |
19488 | DT_EBIND = ZERO | |
19489 | RETURN | |
19490 | ENDIF | |
19491 | AA = IA | |
19492 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) | |
19493 | & -A4*(IA-2*IZ)**2/AA | |
19494 | IF (MOD(IA,2).EQ.1) THEN | |
19495 | IA5 = 0 | |
19496 | ELSEIF (MOD(IZ,2).EQ.1) THEN | |
19497 | IA5 = 1 | |
19498 | ELSE | |
19499 | IA5 = -1 | |
19500 | ENDIF | |
19501 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) | |
19502 | ||
19503 | RETURN | |
19504 | END | |
19505 | ||
19506 | **sr 30.6. routine replaced completely | |
19507 | *$ CREATE DT_ENERGY.FOR | |
19508 | *COPY DT_ENERGY | |
19509 | * * | |
19510 | *=== energy ===========================================================* | |
19511 | * * | |
19512 | DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z ) | |
19513 | ||
19514 | C INCLUDE '(DBLPRC)' | |
19515 | * DBLPRC.ADD | |
19516 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19517 | SAVE | |
19518 | * (original name: GLOBAL) | |
19519 | PARAMETER ( KALGNM = 2 ) | |
19520 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
19521 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
19522 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
19523 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
19524 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
19525 | PARAMETER ( AINFNT = 1.0D+30 ) | |
19526 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
19527 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
19528 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
19529 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
19530 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
19531 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
19532 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
19533 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
19534 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
19535 | PARAMETER ( ZERZER = 0.D+00 ) | |
19536 | PARAMETER ( ONEONE = 1.D+00 ) | |
19537 | PARAMETER ( TWOTWO = 2.D+00 ) | |
19538 | PARAMETER ( THRTHR = 3.D+00 ) | |
19539 | PARAMETER ( FOUFOU = 4.D+00 ) | |
19540 | PARAMETER ( FIVFIV = 5.D+00 ) | |
19541 | PARAMETER ( SIXSIX = 6.D+00 ) | |
19542 | PARAMETER ( SEVSEV = 7.D+00 ) | |
19543 | PARAMETER ( EIGEIG = 8.D+00 ) | |
19544 | PARAMETER ( ANINEN = 9.D+00 ) | |
19545 | PARAMETER ( TENTEN = 10.D+00 ) | |
19546 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
19547 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
19548 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
19549 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
19550 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
19551 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
19552 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
19553 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
19554 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
19555 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
19556 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
19557 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
19558 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
19559 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
19560 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
19561 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
19562 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
19563 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
19564 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
19565 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
19566 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
19567 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
19568 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
19569 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
19570 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
19571 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
19572 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
19573 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
19574 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
19575 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
19576 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
19577 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
19578 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
19579 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
19580 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
19581 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
19582 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
19583 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
19584 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
19585 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
19586 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
19587 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
19588 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
19589 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
19590 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
19591 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
19592 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
19593 | & * 1.D-09 ) | |
19594 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
19595 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
19596 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
19597 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
19598 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
19599 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
19600 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
19601 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
19602 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
19603 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
19604 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
19605 | LOGICAL LGBIAS, LGBANA | |
19606 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
19607 | C INCLUDE '(DIMPAR)' | |
19608 | * DIMPAR.ADD | |
19609 | PARAMETER ( MXXRGN = 5000 ) | |
19610 | PARAMETER ( MXXMDF = 82 ) | |
19611 | PARAMETER ( MXXMDE = 54 ) | |
19612 | PARAMETER ( MFSTCK = 1000 ) | |
19613 | PARAMETER ( MESTCK = 100 ) | |
19614 | PARAMETER ( NALLWP = 39 ) | |
19615 | PARAMETER ( NELEMX = 80 ) | |
19616 | PARAMETER ( MPDPDX = 8 ) | |
19617 | PARAMETER ( ICOMAX = 180 ) | |
19618 | PARAMETER ( NSTBIS = 304 ) | |
19619 | PARAMETER ( IDMAXP = 220 ) | |
19620 | PARAMETER ( IDMXDC = 640 ) | |
19621 | PARAMETER ( MKBMX1 = 1 ) | |
19622 | PARAMETER ( MKBMX2 = 1 ) | |
19623 | C INCLUDE '(IOUNIT)' | |
19624 | * IOUNIT.ADD | |
19625 | PARAMETER ( LUNIN = 5 ) | |
19626 | PARAMETER ( LUNOUT = 6 ) | |
19627 | **sr 19.5. set error output-unit from 15 to 6 | |
19628 | PARAMETER ( LUNERR = 6 ) | |
19629 | PARAMETER ( LUNBER = 14 ) | |
19630 | PARAMETER ( LUNECH = 8 ) | |
19631 | PARAMETER ( LUNFLU = 13 ) | |
19632 | PARAMETER ( LUNGEO = 16 ) | |
19633 | PARAMETER ( LUNPMF = 12 ) | |
19634 | PARAMETER ( LUNRAN = 2 ) | |
19635 | PARAMETER ( LUNXSC = 9 ) | |
19636 | PARAMETER ( LUNDET = 17 ) | |
19637 | PARAMETER ( LUNRAY = 10 ) | |
19638 | PARAMETER ( LUNRDB = 1 ) | |
19639 | PARAMETER ( LUNPGO = 7 ) | |
19640 | PARAMETER ( LUNPGS = 4 ) | |
19641 | PARAMETER ( LUNSCR = 3 ) | |
19642 | * | |
19643 | *----------------------------------------------------------------------* | |
19644 | * * | |
19645 | * Revised version of the original routine from EVAP: * | |
19646 | * * | |
19647 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
19648 | * Infn - Milan * | |
19649 | * * | |
19650 | * Last change on 19-sep-95 by Alfredo Ferrari * | |
19651 | * * | |
19652 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19653 | * !!! It is supposed to be used with the updated atomic !!! * | |
19654 | * !!! mass data file !!! * | |
19655 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19656 | * * | |
19657 | *----------------------------------------------------------------------* | |
19658 | * | |
19659 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19660 | * reported in the mass tabulations are completely unstable and made | |
19661 | * up by Z proton masses + N neutron masses: | |
19662 | PARAMETER ( KAFREE = 4 ) | |
19663 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19664 | * reported in the mass tabulations are supposed to be particle unstable | |
19665 | PARAMETER ( KAPUNS = 12 ) | |
19666 | * Minimum energy required for particle unstable isotopes | |
19667 | PARAMETER ( DEPUNS = 0.5D+00 ) | |
19668 | * | |
19669 | * (original name: EVA0) | |
19670 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
19671 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
19672 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
19673 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
19674 | * APRIME (250), IA (6), IZ (6) | |
19675 | * (original name: ISOTOP) | |
19676 | PARAMETER ( NAMSMX = 270 ) | |
19677 | PARAMETER ( NZGVAX = 15 ) | |
19678 | PARAMETER ( NISMMX = 574 ) | |
19679 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
19680 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
19681 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
19682 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
19683 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
19684 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
19685 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
19686 | & INWISM (0:NAMSMX) | |
19687 | * | |
454792a9 | 19688 | CPH SAVE KA0, KZ0, IZ0 |
9aaba0d6 | 19689 | DATA KA0, KZ0, IZ0 / -1, -1, -1 / |
19690 | * | |
19691 | IFLAG = 1 | |
19692 | GO TO 10 | |
19693 | *======================================================================* | |
19694 | * * | |
19695 | * Entry ENergy - KNOWn * | |
19696 | * * | |
19697 | *======================================================================* | |
19698 | ENTRY DT_ENKNOW ( A, Z, IZZ0 ) | |
19699 | IZZ0 =-1 | |
19700 | IFLAG = 2 | |
19701 | 10 CONTINUE | |
19702 | * | |
19703 | KA0 = NINT ( A ) | |
19704 | KZ0 = NINT ( Z ) | |
19705 | N = KA0 - KZ0 | |
19706 | * +-------------------------------------------------------------------* | |
19707 | * | Null residual nucleus: | |
19708 | IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN | |
19709 | IF ( IFLAG .EQ. 1 ) THEN | |
19710 | DT_ENERGY = ZERZER | |
19711 | ELSE | |
19712 | DT_ENKNOW = ZERZER | |
19713 | IZZ0 = -1 | |
19714 | END IF | |
19715 | RETURN | |
19716 | * | | |
19717 | * +-------------------------------------------------------------------* | |
19718 | * | Only protons: | |
19719 | ELSE IF ( N .LE. 0 ) THEN | |
19720 | IF ( N .LT. 0 ) THEN | |
19721 | WRITE ( LUNOUT, * ) | |
19722 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19723 | & KA0, KZ0 | |
19724 | WRITE ( LUNOUT, * ) | |
19725 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19726 | & KA0, KZ0 | |
19727 | WRITE ( 77, * ) | |
19728 | & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!', | |
19729 | & KA0, KZ0 | |
19730 | STOP 'DT_ENERGY:KA0-KZ0' | |
19731 | END IF | |
19732 | IZ0 = -1 | |
19733 | IF ( IFLAG .EQ. 1 ) THEN | |
19734 | DT_ENERGY = Z * WAPS ( 1, 2 ) | |
19735 | ELSE | |
19736 | DT_ENKNOW = Z * WAPS ( 1, 2 ) | |
19737 | IZZ0 = -1 | |
19738 | END IF | |
19739 | RETURN | |
19740 | * | | |
19741 | * +-------------------------------------------------------------------* | |
19742 | * | Only neutrons: | |
19743 | ELSE IF ( KZ0 .LE. 0 ) THEN | |
19744 | IF ( KZ0 .LT. 0 ) THEN | |
19745 | WRITE ( LUNOUT, * ) | |
19746 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19747 | WRITE ( LUNOUT, * ) | |
19748 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19749 | WRITE ( 77, * ) | |
19750 | &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19751 | STOP 'DT_ENERGY:KZ0<0' | |
19752 | END IF | |
19753 | IZ0 = -1 | |
19754 | IF ( IFLAG .EQ. 1 ) THEN | |
19755 | DT_ENERGY = A * WAPS ( 1, 1 ) | |
19756 | ELSE | |
19757 | DT_ENKNOW = A * WAPS ( 1, 1 ) | |
19758 | IZZ0 = -1 | |
19759 | END IF | |
19760 | RETURN | |
19761 | END IF | |
19762 | * | | |
19763 | * +-------------------------------------------------------------------* | |
19764 | * +-------------------------------------------------------------------* | |
19765 | * | No actual nucleus | |
19766 | * | | |
19767 | * +-------------------------------------------------------------------* | |
19768 | * +-------------------------------------------------------------------* | |
19769 | * | A larger than maximum allowed: | |
19770 | IF ( KA0 .GT. NAMSMX ) THEN | |
19771 | IZ0 = -1 | |
19772 | IF ( IFLAG .EQ. 1 ) THEN | |
19773 | DT_ENERGY = DT_ENRG( A, Z ) | |
19774 | ELSE | |
19775 | DT_ENKNOW = DT_ENRG( A, Z ) | |
19776 | IZZ0 = -1 | |
19777 | END IF | |
19778 | RETURN | |
19779 | END IF | |
19780 | * | | |
19781 | * +-------------------------------------------------------------------* | |
19782 | IZZ = INWAPS ( KA0 ) | |
19783 | * +-------------------------------------------------------------------* | |
19784 | * | Too much neutron rich with respect to the stability line: | |
19785 | IF ( KZ0 .LT. IZZ ) THEN | |
19786 | * | +----------------------------------------------------------------* | |
19787 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19788 | IF ( KA0 .LE. KAFREE ) THEN | |
19789 | DT_ENERGY = AINFNT | |
19790 | * | | | |
19791 | * | +----------------------------------------------------------------* | |
19792 | * | | Up to Kapuns: be sure it is particle unstable | |
19793 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19794 | * | | Exp. excess mass for A,IZZ | |
19795 | ENEEXP = WAPS ( KA0, 1 ) | |
19796 | * | | Cameron excess mass for A, IZZ | |
19797 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19798 | * | | Cameron excess mass for A, Z | |
19799 | DT_ENERGY = DT_ENRG( A, Z ) | |
19800 | * | | Use just the difference according to Cameron!!! | |
19801 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19802 | JZZ = INWAPS ( KA0 - 1 ) | |
19803 | LZZ = INWAPS ( KA0 - 2 ) | |
19804 | * | | +-------------------------------------------------------------* | |
19805 | * | | | Residual mass for n-decay known: | |
19806 | IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN | |
19807 | IZ0 = KZ0 - JZZ + 1 | |
19808 | DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1) | |
19809 | & + DEPUNS ) | |
19810 | * | | | | |
19811 | * | | +-------------------------------------------------------------* | |
19812 | * | | | Residual mass for 2n-decay known: | |
19813 | ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN | |
19814 | IZ0 = KZ0 - LZZ + 1 | |
19815 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19816 | & ( WAPS (1,1) + DEPUNS ) ) | |
19817 | * | | | | |
19818 | * | | +-------------------------------------------------------------* | |
19819 | * | | | Set it unbound: | |
19820 | ELSE | |
19821 | DT_ENERGY = AINFNT | |
19822 | END IF | |
19823 | * | | | | |
19824 | * | | +-------------------------------------------------------------* | |
19825 | * | | | |
19826 | * | +----------------------------------------------------------------* | |
19827 | * | | Proceed as usual: | |
19828 | ELSE | |
19829 | * | | Exp. excess mass for A,IZZ | |
19830 | ENEEXP = WAPS ( KA0, 1 ) | |
19831 | * | | Cameron excess mass for A, IZZ | |
19832 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19833 | * | | Cameron excess mass for A, Z | |
19834 | DT_ENERGY = DT_ENRG( A, Z ) | |
19835 | * | | Use just the difference according to Cameron!!! | |
19836 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19837 | END IF | |
19838 | * | | | |
19839 | * | +----------------------------------------------------------------* | |
19840 | * | Be sure not to have a positive energy state: | |
19841 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19842 | IZ0 = -1 | |
19843 | IF ( IFLAG .EQ. 2 ) THEN | |
19844 | DT_ENKNOW = DT_ENERGY | |
19845 | IZZ0 = -1 | |
19846 | END IF | |
19847 | RETURN | |
19848 | * | | |
19849 | * +-------------------------------------------------------------------* | |
19850 | * | Too much proton rich with respect to the stability line: | |
19851 | ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN | |
19852 | * | +----------------------------------------------------------------* | |
19853 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19854 | IF ( KA0 .LE. KAFREE ) THEN | |
19855 | DT_ENERGY = AINFNT | |
19856 | * | | | |
19857 | * | +----------------------------------------------------------------* | |
19858 | * | | Up to Kapuns: be sure it is particle unstable | |
19859 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19860 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19861 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19862 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19863 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19864 | * | | Cameron excess mass for A, Z | |
19865 | DT_ENERGY = DT_ENRG( A, Z ) | |
19866 | * | | Use just the difference according to Cameron!!! | |
19867 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19868 | JZZ = INWAPS ( KA0 - 1 ) | |
19869 | LZZ = INWAPS ( KA0 - 2 ) | |
19870 | * | | +-------------------------------------------------------------* | |
19871 | * | | | Residual mass for p-decay known: | |
19872 | IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN | |
19873 | IZ0 = KZ0 - 1 - JZZ + 1 | |
19874 | DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2) | |
19875 | & + DEPUNS ) | |
19876 | * | | | | |
19877 | * | | +-------------------------------------------------------------* | |
19878 | * | | | Residual mass for 2p-decay known: | |
19879 | ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 ) | |
19880 | & THEN | |
19881 | IZ0 = KZ0 - 2 - LZZ + 1 | |
19882 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19883 | & ( WAPS (1,2) + DEPUNS ) ) | |
19884 | * | | | | |
19885 | * | | +-------------------------------------------------------------* | |
19886 | * | | | Set it unbound: | |
19887 | ELSE | |
19888 | DT_ENERGY = AINFNT | |
19889 | END IF | |
19890 | * | | | | |
19891 | * | | +-------------------------------------------------------------* | |
19892 | * | | | |
19893 | * | +----------------------------------------------------------------* | |
19894 | * | | Proceed as usual: | |
19895 | ELSE | |
19896 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19897 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19898 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19899 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19900 | * | | Cameron excess mass for A, Z | |
19901 | DT_ENERGY = DT_ENRG( A, Z ) | |
19902 | * | | Use just the difference according to Cameron!!! | |
19903 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19904 | END IF | |
19905 | * | | | |
19906 | * | +----------------------------------------------------------------* | |
19907 | * | Be sure not to have a positive energy state: | |
19908 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19909 | IZ0 = -1 | |
19910 | IF ( IFLAG .EQ. 2 ) THEN | |
19911 | DT_ENKNOW = DT_ENERGY | |
19912 | IZZ0 = -1 | |
19913 | END IF | |
19914 | RETURN | |
19915 | * | | |
19916 | * +-------------------------------------------------------------------* | |
19917 | * | Known isotope or anyway isotope "inside" the stability zone | |
19918 | ELSE | |
19919 | IZ0 = KZ0 - IZZ + 1 | |
19920 | DT_ENERGY = WAPS ( KA0, IZ0 ) | |
19921 | IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0 | |
19922 | * | +----------------------------------------------------------------* | |
19923 | * | | Mass not known | |
19924 | IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0 | |
19925 | & .NE. 6) ) THEN | |
19926 | IF ( IFLAG .EQ. 2 ) IZZ0 = -1 | |
19927 | * | | +-------------------------------------------------------------* | |
19928 | * | | | Set it unbound: | |
19929 | IF ( KA0 .LE. KAFREE ) THEN | |
19930 | DT_ENERGY = AINFNT | |
19931 | * | | | | |
19932 | * | | +-------------------------------------------------------------* | |
19933 | * | | | Try to get a reasonable excess mass: | |
19934 | ELSE | |
19935 | JZ0 = -100 | |
19936 | * | | | +----------------------------------------------------------* | |
19937 | * | | | | Check the closest one known: | |
19938 | DO 500 JZZ = 1, NZGVAX | |
19939 | IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND. | |
19940 | & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ | |
19941 | IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550 | |
19942 | 500 CONTINUE | |
19943 | * | | | | | |
19944 | * | | | +----------------------------------------------------------* | |
19945 | 550 CONTINUE | |
19946 | * | | | Exp. excess mass for A,IZZ+JZ0-1 | |
19947 | ENEEXP = WAPS ( KA0, JZ0 ) | |
19948 | * | | | Cameron excess mass for A, IZZ+JZ0-1 | |
19949 | ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) ) | |
19950 | * | | | Cameron excess mass for A, Z | |
19951 | DT_ENERGY = DT_ENRG( A, Z ) | |
19952 | * | | | Use just the difference according to Cameron!!! | |
19953 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19954 | IZ0 = -1 | |
19955 | END IF | |
19956 | * | | | | |
19957 | * | | +-------------------------------------------------------------* | |
19958 | * | | Be sure not to have a positive energy state: | |
19959 | DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) ) | |
19960 | END IF | |
19961 | * | | | |
19962 | * | +----------------------------------------------------------------* | |
19963 | IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY | |
19964 | RETURN | |
19965 | END IF | |
19966 | * | | |
19967 | * +-------------------------------------------------------------------* | |
19968 | *=== End of Function Energy ===========================================* | |
19969 | * RETURN | |
19970 | END | |
19971 | ** | |
19972 | ||
19973 | *$ CREATE DT_ENRG.FOR | |
19974 | *COPY DT_ENRG | |
19975 | * * | |
19976 | *=== enrg =============================================================* | |
19977 | * * | |
19978 | DOUBLE PRECISION FUNCTION DT_ENRG(A,Z) | |
19979 | ||
19980 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19981 | SAVE | |
19982 | ||
19983 | PARAMETER ( ZERZER = 0.D+00 ) | |
19984 | PARAMETER ( ONEONE = 1.D+00 ) | |
19985 | PARAMETER ( LUNIN = 5 ) | |
19986 | PARAMETER ( LUNOUT = 6 ) | |
19987 | * | |
19988 | *----------------------------------------------------------------------* | |
19989 | * * | |
19990 | * Revised version of the original routine from EVAP: * | |
19991 | * * | |
19992 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
19993 | * Infn - Milan * | |
19994 | * * | |
19995 | * Last change on 01-oct-94 by Alfredo Ferrari * | |
19996 | * * | |
19997 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19998 | * !!! It is supposed to be used with the updated atomic !!! * | |
19999 | * !!! mass data file !!! * | |
20000 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
20001 | * * | |
20002 | *----------------------------------------------------------------------* | |
20003 | * | |
20004 | PARAMETER ( O16OLD = 931.145 D+00 ) | |
20005 | PARAMETER ( O16NEW = 931.19826D+00 ) | |
20006 | PARAMETER ( O16RAT = O16NEW / O16OLD ) | |
20007 | PARAMETER ( C12NEW = 931.49432D+00 ) | |
20008 | PARAMETER ( ADJUST = -8.322737768178909D-02 ) | |
20009 | PARAMETER ( AINFNT = 1.0D+30 ) | |
20010 | * (original name: EVA0) | |
20011 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
20012 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
20013 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
20014 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
20015 | * APRIME (250), IA (6), IZ (6) | |
20016 | LOGICAL LFIRST | |
454792a9 | 20017 | CPH SAVE LFIRST, EXHYDR, EXNEUT |
9aaba0d6 | 20018 | DATA LFIRST / .TRUE. / |
20019 | * | |
20020 | IF ( LFIRST ) THEN | |
20021 | LFIRST = .FALSE. | |
20022 | **sr 30.6. | |
20023 | C EXHYDR = DT_ENERGY( ONEONE, ONEONE ) | |
20024 | C EXNEUT = DT_ENERGY( ONEONE, ZERZER ) | |
20025 | EXHYDR = A | |
20026 | EXNEUT = Z | |
20027 | DT_ENRG = -AINFNT | |
20028 | RETURN | |
20029 | ** | |
20030 | END IF | |
20031 | IZ0 = NINT (Z) | |
20032 | IF ( IZ0 .LE. 0 ) THEN | |
20033 | DT_ENRG = A * EXNEUT | |
20034 | RETURN | |
20035 | END IF | |
20036 | N = NINT (A-Z) | |
20037 | IF ( N .LE. 0 ) THEN | |
20038 | DT_ENRG = Z * EXHYDR | |
20039 | RETURN | |
20040 | END IF | |
20041 | AM2ZOA= (A-Z-Z)/A | |
20042 | AM2ZOA=AM2ZOA*AM2ZOA | |
20043 | A13 = RMASS(NINT(A)) | |
20044 | * A13 = A**.3333333333333333D+00 | |
20045 | AM13 = 1.D+00/A13 | |
20046 | EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A | |
20047 | ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)* | |
20048 | & (1.D+00 -0.62025D+00*AM13*AM13)* | |
20049 | & (A13*A13 -.62025D+00) | |
20050 | EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)* | |
20051 | & AM13-1.5849D+00)* | |
20052 | & AM13*AM13 +1.D+00) | |
20053 | EEX= -0.4323D+00*AM13*Z**1.3333333D+00* | |
20054 | & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13 | |
20055 | & + 1.D+00) | |
20056 | DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N) | |
20057 | DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST ) | |
20058 | DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT ) | |
20059 | RETURN | |
20060 | *=== End of function Enrg =============================================* | |
20061 | END | |
20062 | ||
20063 | *$ CREATE DT_INCINI.FOR | |
20064 | *COPY DT_INCINI | |
20065 | * * | |
20066 | *=== incini ===========================================================* | |
20067 | * * | |
20068 | SUBROUTINE DT_INCINI | |
20069 | ||
20070 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20071 | SAVE | |
20072 | ||
20073 | PARAMETER ( ZERZER = 0.D+00 ) | |
20074 | PARAMETER ( ONEONE = 1.D+00 ) | |
20075 | PARAMETER ( TWOTWO = 2.D+00 ) | |
20076 | PARAMETER ( THRTHR = 3.D+00 ) | |
20077 | PARAMETER ( FOUFOU = 4.D+00 ) | |
20078 | PARAMETER ( EIGEIG = 8.D+00 ) | |
20079 | PARAMETER ( ANINEN = 9.D+00 ) | |
20080 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
20081 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20082 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20083 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
20084 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
20085 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20086 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
20087 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
20088 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
20089 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20090 | ||
20091 | PARAMETER ( LUNOUT = 6 ) | |
20092 | * | |
20093 | *----------------------------------------------------------------------* | |
20094 | * * | |
20095 | * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala * | |
20096 | * Infn - Milan * | |
20097 | * * | |
20098 | * Last change on 02-may-95 by Alfredo Ferrari * | |
20099 | * * | |
20100 | * * | |
20101 | *----------------------------------------------------------------------* | |
20102 | * | |
20103 | * (original name: FHEAVY,FHEAVC) | |
20104 | PARAMETER ( MXHEAV = 100 ) | |
20105 | CHARACTER*8 ANHEAV | |
20106 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
20107 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
20108 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
20109 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
20110 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
20111 | & IBHEAV ( 12 ) , NPHEAV | |
20112 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
20113 | * (original name: INPFLG) | |
20114 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20115 | * (original name: FRBKCM) | |
20116 | PARAMETER ( MXFFBK = 6 ) | |
20117 | PARAMETER ( MXZFBK = 9 ) | |
20118 | PARAMETER ( MXNFBK = 10 ) | |
20119 | PARAMETER ( MXAFBK = 16 ) | |
20120 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20121 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20122 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20123 | PARAMETER ( MXPSST = 300 ) | |
20124 | PARAMETER ( MXPSFB = 41000 ) | |
20125 | LOGICAL LFRMBK, LNCMSS | |
20126 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20127 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20128 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20129 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20130 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20131 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20132 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20133 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20134 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20135 | * (original name: NUCDAT) | |
20136 | PARAMETER ( AMUAMU = AMUGEV ) | |
20137 | PARAMETER ( AMPROT = AMPRTN ) | |
20138 | PARAMETER ( AMNEUT = AMNTRN ) | |
20139 | PARAMETER ( AMELEC = AMELCT ) | |
20140 | PARAMETER ( R0NUCL = 1.12 D+00 ) | |
20141 | PARAMETER ( RCCOUL = 1.7 D+00 ) | |
20142 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
20143 | PARAMETER ( EXPEBN = 2.39 D+00 ) | |
20144 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
20145 | PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 ) | |
20146 | PARAMETER ( AMHYDR = AMPRTN + AMELCT ) | |
20147 | PARAMETER ( AMHTON = AMHYDR - AMNTRN ) | |
20148 | PARAMETER ( AMNTOU = AMNTRN - AMUC12 ) | |
20149 | PARAMETER ( AMUCSQ = AMUC12 * AMUC12 ) | |
20150 | PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 ) | |
20151 | PARAMETER ( GAMMIN = 1.0D-06 ) | |
20152 | PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) | |
20153 | PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) | |
20154 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
20155 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
20156 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
20157 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
20158 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
20159 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
20160 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
20161 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
20162 | * (original name: PAREVT) | |
20163 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20164 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20165 | PARAMETER ( NALLWP = 39 ) | |
20166 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20167 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20168 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20169 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20170 | * (original name: NUCOLD) | |
20171 | COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2), | |
20172 | & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ, | |
20173 | & FSPRED, FEX0RD | |
20174 | * | |
20175 | BBOLD = - 1.D+10 | |
20176 | ZZOLD = - 1.D+10 | |
20177 | SQROLD = - 1.D+10 | |
20178 | APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL | |
20179 | AMNUCL (1) = AMPROT | |
20180 | AMNUCL (2) = AMNEUT | |
20181 | AMNUSQ (1) = AMPROT * AMPROT | |
20182 | AMNUSQ (2) = AMNEUT * AMNEUT | |
20183 | AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) ) | |
20184 | ASQHLP = AMNHLP**2 | |
20185 | * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) ) | |
20186 | AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP | |
20187 | AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 / | |
20188 | & ( 5.6D+00 * ASQHLP ) ) | |
20189 | AV0WEL = AEFRMX + EBNDAV | |
20190 | EBNDNG (1) = EBNDAV | |
20191 | EBNDNG (2) = EBNDAV | |
20192 | AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 ) | |
20193 | CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 ) | |
20194 | AMMC12 = 12.D+00 * AMUGEV + AEXC12 | |
20195 | AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN | |
20196 | AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 ) | |
20197 | CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 ) | |
20198 | AMMO16 = 16.D+00 * AMUGEV + AEXO16 | |
20199 | AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN | |
20200 | AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 ) | |
20201 | CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 ) | |
20202 | AMMS28 = 28.D+00 * AMUGEV + AEXS28 | |
20203 | AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN | |
20204 | AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 ) | |
20205 | CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 ) | |
20206 | AMMC40 = 40.D+00 * AMUGEV + AEXC40 | |
20207 | AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN | |
20208 | AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 ) | |
20209 | CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 ) | |
20210 | AMMF56 = 56.D+00 * AMUGEV + AEXF56 | |
20211 | AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN | |
20212 | AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 ) | |
20213 | CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 ) | |
20214 | AMM107 = 107.D+00 * AMUGEV + AEX107 | |
20215 | AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN | |
20216 | AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 ) | |
20217 | CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 ) | |
20218 | AMM132 = 132.D+00 * AMUGEV + AEX132 | |
20219 | AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN | |
20220 | AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 ) | |
20221 | CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 ) | |
20222 | AMM181 = 181.D+00 * AMUGEV + AEX181 | |
20223 | AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN | |
20224 | AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 ) | |
20225 | CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 ) | |
20226 | AMM208 = 208.D+00 * AMUGEV + AEX208 | |
20227 | AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN | |
20228 | AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 ) | |
20229 | CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 ) | |
20230 | AMM238 = 238.D+00 * AMUGEV + AEX238 | |
20231 | AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN | |
20232 | ||
20233 | AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER ) | |
20234 | AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE ) | |
20235 | AMHEAV (3) = TWOTWO * AMUGEV | |
20236 | & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE ) | |
20237 | AMHEAV (4) = THRTHR * AMUGEV | |
20238 | & + EMVGEV * DT_ENERGY( THRTHR, ONEONE ) | |
20239 | AMHEAV (5) = THRTHR * AMUGEV | |
20240 | & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO ) | |
20241 | AMHEAV (6) = FOUFOU * AMUGEV | |
20242 | & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO ) | |
20243 | ELBNDE (0) = ZERZER | |
20244 | ELBNDE (1) = 13.6D-09 | |
20245 | DO 2000 IZ = 2, 100 | |
20246 | ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN | |
20247 | 2000 CONTINUE | |
20248 | AMNHEA (1) = AMHEAV (1) + ELBNDE (0) | |
20249 | AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1) | |
20250 | AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1) | |
20251 | AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1) | |
20252 | AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2) | |
20253 | AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2) | |
20254 | IF ( LEVPRT ) THEN | |
20255 | WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus', | |
20256 | & ' activated **** ' | |
20257 | IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma', | |
20258 | & ' production activated **** ' | |
20259 | **sr 18.5.95 | |
20260 | * commented, since obsolete | |
20261 | C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"', | |
20262 | C & ' transport activated **** ' | |
20263 | IF ( IFISS .GT. 0 ) | |
20264 | & WRITE ( LUNOUT, * )' **** High Energy fission ', | |
20265 | & ' requested & activated **** ' | |
20266 | IF ( LFRMBK ) | |
20267 | & WRITE ( LUNOUT, * )' **** Fermi Break Up ', | |
20268 | & ' requested & activated **** ' | |
20269 | IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.) | |
20270 | ELSE | |
20271 | LDEEXG = .FALSE. | |
20272 | LHEAVY = .FALSE. | |
20273 | LFRMBK = .FALSE. | |
20274 | IFISS = 0 | |
20275 | END IF | |
20276 | RETURN | |
20277 | *=== End of subroutine incini =========================================* | |
20278 | END | |
20279 | ||
20280 | *$ CREATE DT_STALIN.FOR | |
20281 | *COPY DT_STALIN | |
20282 | * * | |
20283 | *=== stalin ===========================================================* | |
20284 | * * | |
20285 | SUBROUTINE DT_STALIN | |
20286 | ||
20287 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20288 | SAVE | |
20289 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
20290 | PARAMETER ( ZERZER = 0.D+00 ) | |
20291 | PARAMETER ( ONEONE = 1.D+00 ) | |
20292 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20293 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20294 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20295 | PARAMETER ( NSTBIS = 304 ) | |
20296 | PARAMETER ( LUNIN = 5 ) | |
20297 | PARAMETER ( LUNOUT = 6 ) | |
20298 | * | |
20299 | *----------------------------------------------------------------------* | |
20300 | * * | |
20301 | * STAbility LINe calculation: * | |
20302 | * * | |
20303 | * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala * | |
20304 | * Infn - Milan * | |
20305 | * * | |
20306 | * Last change on 04-dec-92 by Alfredo Ferrari * | |
20307 | * * | |
20308 | * * | |
20309 | *----------------------------------------------------------------------* | |
20310 | * | |
20311 | * (original name: ISOTOP) | |
20312 | PARAMETER ( NAMSMX = 270 ) | |
20313 | PARAMETER ( NZGVAX = 15 ) | |
20314 | PARAMETER ( NISMMX = 574 ) | |
20315 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20316 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20317 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20318 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20319 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20320 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20321 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20322 | & INWISM (0:NAMSMX) | |
20323 | * | |
20324 | DIMENSION ZNORM (260) | |
20325 | * +-------------------------------------------------------------------* | |
20326 | * | | |
20327 | DO 1000 IZ=1,100 | |
20328 | DO 500 J=1,2 | |
20329 | ASTLIN (J,IZ) = ZERZER | |
20330 | 500 CONTINUE | |
20331 | 1000 CONTINUE | |
20332 | * | | |
20333 | * +-------------------------------------------------------------------* | |
20334 | * +-------------------------------------------------------------------* | |
20335 | * | | |
20336 | DO 2000 IA=1,260 | |
20337 | ZNORM (IA) = ZERZER | |
20338 | DO 1500 J=1,2 | |
20339 | ZSTLIN (J,IA) = ZERZER | |
20340 | 1500 CONTINUE | |
20341 | 2000 CONTINUE | |
20342 | * | | |
20343 | * +-------------------------------------------------------------------* | |
20344 | * +-------------------------------------------------------------------* | |
20345 | * | Loop on the Atomic Number | |
20346 | DO 3000 IZ=1,100 | |
20347 | AMSSST (IZ) = ZERZER | |
20348 | ANORM = ONEONE | |
20349 | ZTAR = IZ | |
20350 | * | +----------------------------------------------------------------* | |
20351 | * | | Loop on the stable isotopes | |
20352 | DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ) | |
20353 | IA = ISOMNM (IS) | |
20354 | ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA | |
20355 | ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2 | |
20356 | ZNORM (IA) = ZNORM (IA) + ABUISO (IS) | |
20357 | ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ | |
20358 | ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2 | |
20359 | AHELP = IA | |
20360 | IF ( AHELP .LE. 1.00001D+00 ) THEN | |
20361 | ANORM = ONEONE / ( ONEONE - ABUISO (IS) ) | |
20362 | GO TO 2500 | |
20363 | END IF | |
20364 | AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV | |
20365 | & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ) | |
20366 | 2500 CONTINUE | |
20367 | * | | | |
20368 | * | +----------------------------------------------------------------* | |
20369 | AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV | |
20370 | * | Normalize and print A_stab versus Z data: | |
20371 | ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2), | |
20372 | & 0.5D+00 ) | |
20373 | * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)), | |
20374 | * & ' Sigma_st',SNGL(ASTLIN(2,IZ)) | |
20375 | 3000 CONTINUE | |
20376 | * | | |
20377 | * +-------------------------------------------------------------------* | |
20378 | * +-------------------------------------------------------------------* | |
20379 | * | Normalize and print Z_stab versus A data: | |
20380 | DO 4000 IA=1,260 | |
20381 | ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20382 | ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20383 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 ) | |
20384 | IF ( ZNORM (IA) .GT. ANGLGB ) | |
20385 | **sr 2.11. avoid underflows at Pentium | |
20386 | & ZSTLIN (2,IA) = | |
20387 | & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ), | |
20388 | C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2), | |
20389 | & 0.3D+00 ) | |
20390 | 4000 CONTINUE | |
20391 | * | | |
20392 | * +-------------------------------------------------------------------* | |
20393 | * +-------------------------------------------------------------------* | |
20394 | * | Normalize and print Z_stab versus A data: | |
20395 | DO 5000 IA=1,260 | |
20396 | IF ( ZNORM (IA) .LE. ANGLGB ) THEN | |
20397 | DO 4200 JA = IA-1,1,-1 | |
20398 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20399 | IA1 = JA | |
20400 | GO TO 4300 | |
20401 | END IF | |
20402 | 4200 CONTINUE | |
20403 | 4300 CONTINUE | |
20404 | DO 4400 JA = IA+1,260 | |
20405 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20406 | IA2 = JA | |
20407 | GO TO 4500 | |
20408 | END IF | |
20409 | 4400 CONTINUE | |
20410 | IA2 = IA1 | |
20411 | IA1 = IA1 - 1 | |
20412 | 4500 CONTINUE | |
20413 | ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20414 | & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) ) | |
20415 | & + ZSTLIN (1,IA1) | |
20416 | ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20417 | & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) ) | |
20418 | & + ZSTLIN (2,IA1) | |
20419 | END IF | |
20420 | IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) ) | |
20421 | ATOZ = IZ / ASTLIN (1,IZ) | |
20422 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) ) | |
20423 | * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)), | |
20424 | * & ' Sigma_st',SNGL(ZSTLIN(2,IA)) | |
20425 | 5000 CONTINUE | |
20426 | * | | |
20427 | * +-------------------------------------------------------------------* | |
20428 | RETURN | |
20429 | END | |
20430 | ||
20431 | *$ CREATE DT_BERTTP.FOR | |
20432 | *COPY DT_BERTTP | |
20433 | * | |
20434 | *=== berttp ===========================================================* | |
20435 | * * | |
20436 | SUBROUTINE DT_BERTTP | |
20437 | ||
20438 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20439 | SAVE | |
20440 | ||
20441 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
20442 | PARAMETER ( ZERZER = 0.D+00 ) | |
20443 | PARAMETER ( ONEONE = 1.D+00 ) | |
20444 | PARAMETER ( THRTHR = 3.D+00 ) | |
20445 | PARAMETER ( SIXSIX = 6.D+00 ) | |
20446 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20447 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20448 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
20449 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
20450 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20451 | ||
20452 | PARAMETER ( NSTBIS = 304 ) | |
20453 | ||
20454 | PARAMETER ( LUNIN = 5 ) | |
20455 | PARAMETER ( LUNOUT = 6 ) | |
20456 | **sr 19.5. set error output-unit from 15 to 6 | |
20457 | PARAMETER ( LUNERR = 6 ) | |
20458 | C--------------------------------------------------------------------- | |
20459 | C SUBNAME = DT_BERTTP --- READ BERTINI DATA | |
20460 | C--------------------------------------------------------------------- | |
20461 | C ---------------------------------- I-N-C DATA | |
20462 | C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849) | |
20463 | C REAL*8 R8,R8B,CRSC,CS | |
20464 | C REAL*4 R4 | |
20465 | C --------------------------------- EVAPORATION DATA | |
20466 | * (original name: COOKCM) | |
20467 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
20468 | LOGICAL LDEFOZ, LDEFON | |
20469 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
20470 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
20471 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
20472 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
20473 | * (original name: EVA0) | |
20474 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
20475 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
20476 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
20477 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
20478 | * APRIME (250), IA (6), IZ (6) | |
20479 | * (original name: FRBKCM) | |
20480 | PARAMETER ( MXFFBK = 6 ) | |
20481 | PARAMETER ( MXZFBK = 9 ) | |
20482 | PARAMETER ( MXNFBK = 10 ) | |
20483 | PARAMETER ( MXAFBK = 16 ) | |
20484 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20485 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20486 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20487 | PARAMETER ( MXPSST = 300 ) | |
20488 | PARAMETER ( MXPSFB = 41000 ) | |
20489 | LOGICAL LFRMBK, LNCMSS | |
20490 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20491 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20492 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20493 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20494 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20495 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20496 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20497 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20498 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20499 | * (original name: HETTP) | |
20500 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
20501 | * (original name: INPFLG) | |
20502 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20503 | * (original name: ISOTOP) | |
20504 | PARAMETER ( NAMSMX = 270 ) | |
20505 | PARAMETER ( NZGVAX = 15 ) | |
20506 | PARAMETER ( NISMMX = 574 ) | |
20507 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20508 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20509 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20510 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20511 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20512 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20513 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20514 | & INWISM (0:NAMSMX) | |
20515 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
20516 | PARAMETER ( PI = PIPIPI ) | |
20517 | PARAMETER ( PISQ = PIPISQ ) | |
20518 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
20519 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
20520 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
20521 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
20522 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
20523 | & / R0PROT ) | |
20524 | PARAMETER ( RLLE04 = RZNUCL ) | |
20525 | PARAMETER ( RLLE16 = RZNUCL ) | |
20526 | PARAMETER ( RLGT16 = RZNUCL ) | |
20527 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
20528 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
20529 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
20530 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
20531 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
20532 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
20533 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
20534 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
20535 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
20536 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
20537 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
20538 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
20539 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
20540 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
20541 | PARAMETER ( POTBA0 = 1.D+00 ) | |
20542 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
20543 | PARAMETER ( RADPIM = 0.035D+00 ) | |
20544 | PARAMETER ( RDPMHL = 14.D+00 ) | |
20545 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
20546 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
20547 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
20548 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
20549 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
20550 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
20551 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
20552 | PARAMETER ( MXSCIN = 50 ) | |
20553 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
20554 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
20555 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
20556 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
20557 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
20558 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
20559 | & PFRTAB (2:260) | |
20560 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
20561 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
20562 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
20563 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
20564 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
20565 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
20566 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
20567 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
20568 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
20569 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
20570 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
20571 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
20572 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
20573 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
20574 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
20575 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
20576 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
20577 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
20578 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
20579 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
20580 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
20581 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
20582 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
20583 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
20584 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
20585 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
20586 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
20587 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
20588 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
20589 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
20590 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
20591 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
20592 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
20593 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
20594 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
20595 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
20596 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
20597 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
20598 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
20599 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
20600 | & LNCDCY, LNUSCT | |
20601 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
20602 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
20603 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
20604 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
20605 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
20606 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
20607 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
20608 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
20609 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
20610 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
20611 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
20612 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
20613 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
20614 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
20615 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
20616 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
20617 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
20618 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
20619 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
20620 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
20621 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
20622 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
20623 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
20624 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
20625 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
20626 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
20627 | * (original name: NUCLEV) | |
20628 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
20629 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
20630 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
20631 | & CUMRAD (0:160,2), RUSNUC (2), | |
20632 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
20633 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
20634 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
20635 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
20636 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
20637 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
20638 | & LFLVSL, LRLVSL, LEQSBL | |
20639 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
20640 | & MGSSPR (19) , MGSSNE (25) | |
20641 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
20642 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
20643 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
20644 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
20645 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
20646 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
20647 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
20648 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
20649 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
20650 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
20651 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
20652 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
20653 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
20654 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
20655 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
20656 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
20657 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
20658 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
20659 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
20660 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
20661 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
20662 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
20663 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
20664 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
20665 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
20666 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
20667 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
20668 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
20669 | * (original name: PAREVT) | |
20670 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20671 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20672 | PARAMETER ( NALLWP = 39 ) | |
20673 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20674 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20675 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20676 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20677 | * (original name: XSEPAR) | |
20678 | COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100), | |
20679 | & DDNXSE (100), EENXSE (100), ZZNXSE (100), | |
20680 | & EMNXSE (100), XMNXSE (100), | |
20681 | & AAPXSE (100), BBPXSE (100), CCPXSE (100), | |
20682 | & DDPXSE (100), EEPXSE (100), FFPXSE (100), | |
20683 | & ZZPXSE (100), EMPXSE (100), XMPXSE (100) | |
20684 | ||
20685 | C--------------------------------------------------------------------- | |
20686 | **sr 17.5.95 | |
20687 | * modified for use in DPMJET | |
20688 | C WRITE( LUNOUT,'(A,I2)') | |
20689 | C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP | |
20690 | C REWIND NBERTP | |
20691 | IF (LEVPRT) WRITE(LUNOUT,1000) | |
20692 | 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module', | |
20693 | & /,12X,'------------------------------------',/) | |
20694 | NBERNW = 23 | |
f87dab60 | 20695 | CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN') |
9aaba0d6 | 20696 | |
20697 | **sr 17.5. | |
20698 | *!!!! changed to be able to read the ASCII !!!! | |
20699 | ** | |
20700 | C A. Ferrari: first of all read isotopic data | |
20701 | READ (NBERNW,*) ISONDX | |
20702 | READ (NBERNW,*) ISOMNM | |
20703 | READ (NBERNW,*) ABUISO | |
20704 | C READ (NBERTP) ISONDX | |
20705 | C READ (NBERTP) ISOMNM | |
20706 | C READ (NBERTP) ABUISO | |
20707 | DO 1 I=1,4 | |
20708 | C READ (NBERTP) (CRSC(J,I),J=1,600) | |
20709 | C A. Ferrari: commented also the dummy read to save disk space | |
20710 | C READ (NBERTP) | |
20711 | 1 CONTINUE | |
20712 | C READ (NBERTP) CS | |
20713 | C A. Ferrari: commented also the dummy read to save disk space | |
20714 | C READ (NBERTP) | |
20715 | C--------------------------------------------------------------------- | |
20716 | READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001) | |
20717 | READ (NBERNW,*) IA,IZ | |
20718 | DO 2 I=1,6 | |
20719 | FLA(I)=IA(I) | |
20720 | FLZ(I)=IZ(I) | |
20721 | 2 CONTINUE | |
20722 | READ (NBERNW,*) RHO,OMEGA | |
20723 | READ (NBERNW,*) EXMASS | |
20724 | READ (NBERNW,*) CAM2 | |
20725 | READ (NBERNW,*) CAM3 | |
20726 | READ (NBERNW,*) CAM4 | |
20727 | READ (NBERNW,*) CAM5 | |
20728 | READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3) | |
20729 | DO 3 I=1,7 | |
20730 | T(4,I) = ZERZER | |
20731 | 3 CONTINUE | |
20732 | READ (NBERNW,*) RMASS | |
20733 | READ (NBERNW,*) ALPH | |
20734 | READ (NBERNW,*) BET | |
20735 | READ (NBERNW,*) INWAPS | |
20736 | READ (NBERNW,*) WAPS | |
20737 | READ (NBERNW,*) T12NUC | |
20738 | READ (NBERNW,*) JSPNUC | |
20739 | READ (NBERNW,*) JPTNUC | |
20740 | READ (NBERNW,*) INWISM | |
20741 | READ (NBERNW,*) IZWISM | |
20742 | READ (NBERNW,*) WAPISM | |
20743 | READ (NBERNW,*) T12ISM | |
20744 | READ (NBERNW,*) JSPISM | |
20745 | READ (NBERNW,*) JPTISM | |
20746 | READ (NBERNW,*) APRIME | |
20747 | IF (LEVPRT) | |
20748 | &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20749 | READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20750 | IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20751 | & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20752 | WRITE (LUNOUT,*) | |
20753 | & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20754 | STOP | |
20755 | END IF | |
20756 | READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20757 | & EKATAB, PFATAB, PFRTAB | |
20758 | READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20759 | & EMNXSE, XMNXSE | |
20760 | READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20761 | & ZZPXSE, EMPXSE, XMPXSE | |
20762 | * Data about Fermi-breakup: | |
20763 | READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20764 | IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20765 | & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20766 | WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20767 | & ' in the Nuclear Data file ***' | |
20768 | STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20769 | END IF | |
20770 | READ (NBERNW,*) IFRBKN | |
20771 | READ (NBERNW,*) IFRBKZ | |
20772 | READ (NBERNW,*) IFBKSP | |
20773 | READ (NBERNW,*) IFBKST | |
20774 | READ (NBERNW,*) EEXFBK | |
20775 | ||
20776 | CLOSE (UNIT=NBERNW) | |
20777 | ||
20778 | C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001) | |
20779 | C READ (NBERTP) IA,IZ | |
20780 | C DO 2 I=1,6 | |
20781 | C FLA(I)=IA(I) | |
20782 | C FLZ(I)=IZ(I) | |
20783 | C 2 CONTINUE | |
20784 | C READ (NBERTP) RHO,OMEGA | |
20785 | C READ (NBERTP) EXMASS | |
20786 | C READ (NBERTP) CAM2 | |
20787 | C READ (NBERTP) CAM3 | |
20788 | C READ (NBERTP) CAM4 | |
20789 | C READ (NBERTP) CAM5 | |
20790 | C READ (NBERTP) ((T(I,J),J=1,7),I=1,3) | |
20791 | C DO 3 I=1,7 | |
20792 | C T(4,I) = ZERZER | |
20793 | C 3 CONTINUE | |
20794 | C READ (NBERTP) RMASS | |
20795 | C READ (NBERTP) ALPH | |
20796 | C READ (NBERTP) BET | |
20797 | C READ (NBERTP) INWAPS | |
20798 | C READ (NBERTP) WAPS | |
20799 | C READ (NBERTP) T12NUC | |
20800 | C READ (NBERTP) JSPNUC | |
20801 | C READ (NBERTP) JPTNUC | |
20802 | C READ (NBERTP) INWISM | |
20803 | C READ (NBERTP) IZWISM | |
20804 | C READ (NBERTP) WAPISM | |
20805 | C READ (NBERTP) T12ISM | |
20806 | C READ (NBERTP) JSPISM | |
20807 | C READ (NBERTP) JPTISM | |
20808 | C READ (NBERTP) APRIME | |
20809 | C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20810 | C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20811 | C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20812 | C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20813 | C WRITE (LUNOUT,*) | |
20814 | C & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20815 | C STOP | |
20816 | C END IF | |
20817 | C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20818 | C & EKATAB, PFATAB, PFRTAB | |
20819 | C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20820 | C & EMNXSE, XMNXSE | |
20821 | C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20822 | C & ZZPXSE, EMPXSE, XMPXSE | |
20823 | * Data about Fermi-breakup: | |
20824 | C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20825 | C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20826 | C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20827 | C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20828 | C & ' in the Nuclear Data file ***' | |
20829 | C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20830 | C END IF | |
20831 | C READ (NBERTP) IFRBKN | |
20832 | C READ (NBERTP) IFRBKZ | |
20833 | C READ (NBERTP) IFBKSP | |
20834 | C READ (NBERTP) IFBKST | |
20835 | C READ (NBERTP) EEXFBK | |
20836 | C CLOSE (UNIT=NBERTP) | |
20837 | DO 100 JZ = 1, 130 | |
20838 | SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) ) | |
20839 | 100 CONTINUE | |
20840 | DO 200 JA = 1, 200 | |
20841 | SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) ) | |
20842 | 200 CONTINUE | |
20843 | CALL DT_STALIN | |
20844 | IF ( ILVMOD .LE. 0 ) THEN | |
20845 | ILVMOD = IB0 | |
20846 | ELSE | |
20847 | IB0 = ILVMOD | |
20848 | END IF | |
20849 | IF ( LLVMOD ) THEN | |
20850 | DO 300 JZ = 1, IZCOOK | |
20851 | CAM4 (JZ) = PZCOOK (JZ) | |
20852 | 300 CONTINUE | |
20853 | DO 400 JN = 1, INCOOK | |
20854 | CAM5 (JN) = PNCOOK (JZ) | |
20855 | 400 CONTINUE | |
20856 | END IF | |
20857 | **sr | |
20858 | IF (LEVPRT) THEN | |
20859 | WRITE (LUNOUT,*) | |
20860 | IF ( ILVMOD .EQ. 1 ) THEN | |
20861 | WRITE (LUNOUT,*) | |
20862 | & ' **** Standard EVAP T=0 level density used ****' | |
20863 | ELSE IF ( ILVMOD .EQ. 2 ) THEN | |
20864 | WRITE (LUNOUT,*) | |
20865 | & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****' | |
20866 | ELSE IF ( ILVMOD .EQ. 3 ) THEN | |
20867 | WRITE (LUNOUT,*) | |
20868 | & ' **** Julich A-dependent level density used ****' | |
20869 | ELSE IF ( ILVMOD .EQ. 4 ) THEN | |
20870 | WRITE (LUNOUT,*) | |
20871 | & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used', | |
20872 | & ' ****' | |
20873 | ELSE | |
20874 | WRITE (LUNOUT,*) | |
20875 | & ' **** Unknown T=0 level density option requested ****' | |
20876 | STOP 'BERTTP-ILVMOD' | |
20877 | END IF | |
20878 | IF ( JLVMOD .LE. 0 ) THEN | |
20879 | GAMIGN = ZERZER | |
20880 | WRITE (LUNOUT,*) | |
20881 | & ' **** No Excitation en. dependence for level densities ****' | |
20882 | ELSE IF ( JLVMOD .EQ. 1 ) THEN | |
20883 | WRITE (LUNOUT,*) | |
20884 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20885 | WRITE (LUNOUT,*) | |
20886 | & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo', | |
20887 | & ' ****' | |
20888 | GAMIGN = 0.054D+00 | |
20889 | BETIGN = -6.3 D-05 | |
20890 | ALPIGN = 0.154D+00 | |
20891 | POWIGN = ZERZER | |
20892 | ELSE IF ( JLVMOD .EQ. 2 ) THEN | |
20893 | WRITE (LUNOUT,*) | |
20894 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20895 | WRITE (LUNOUT,*) | |
20896 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20897 | STOP 'BERTTP-JLVMOD' | |
20898 | ELSE IF ( JLVMOD .EQ. 3 ) THEN | |
20899 | WRITE (LUNOUT,*) | |
20900 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20901 | WRITE (LUNOUT,*) | |
20902 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20903 | STOP 'BERTTP-JLVMOD' | |
20904 | ELSE IF ( JLVMOD .EQ. 4 ) THEN | |
20905 | WRITE (LUNOUT,*) | |
20906 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20907 | WRITE (LUNOUT,*) | |
20908 | & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo', | |
20909 | & ' ****' | |
20910 | GAMIGN = 0.054D+00 | |
20911 | BETIGN = 0.162D+00 | |
20912 | ALPIGN = 0.114D+00 | |
20913 | POWIGN = -ONETHI | |
20914 | ELSE IF ( JLVMOD .EQ. 5 ) THEN | |
20915 | WRITE (LUNOUT,*) | |
20916 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20917 | WRITE (LUNOUT,*) | |
20918 | & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****' | |
20919 | GAMIGN = 0.051D+00 | |
20920 | BETIGN = 0.098D+00 | |
20921 | ALPIGN = 0.114D+00 | |
20922 | POWIGN = -ONETHI | |
20923 | ELSE IF ( JLVMOD .EQ. 6 ) THEN | |
20924 | WRITE (LUNOUT,*) | |
20925 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20926 | WRITE (LUNOUT,*) | |
20927 | & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****' | |
20928 | GAMIGN = -0.46D+00 | |
20929 | BETIGN = 0.107D+00 | |
20930 | ALPIGN = 0.111D+00 | |
20931 | POWIGN = -ONETHI | |
20932 | ELSE IF ( JLVMOD .EQ. 7 ) THEN | |
20933 | WRITE (LUNOUT,*) | |
20934 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20935 | WRITE (LUNOUT,*) | |
20936 | & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****' | |
20937 | GAMIGN = 0.059D+00 | |
20938 | BETIGN = 0.257D+00 | |
20939 | ALPIGN = 0.072D+00 | |
20940 | POWIGN = -ONETHI | |
20941 | ELSE IF ( JLVMOD .EQ. 8 ) THEN | |
20942 | WRITE (LUNOUT,*) | |
20943 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20944 | WRITE (LUNOUT,*) | |
20945 | & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****' | |
20946 | GAMIGN = -0.37D+00 | |
20947 | BETIGN = 0.229D+00 | |
20948 | ALPIGN = 0.077D+00 | |
20949 | POWIGN = -ONETHI | |
20950 | ELSE | |
20951 | WRITE (LUNOUT,*) | |
20952 | & ' **** Unknown T=oo level density option requested ****' | |
20953 | STOP 'BERTTP-JLVMOD' | |
20954 | END IF | |
20955 | IF ( LLVMOD ) THEN | |
20956 | WRITE (LUNOUT,*) | |
20957 | & ' **** Cook''s modified pairing energy used ****' | |
20958 | ELSE | |
20959 | WRITE (LUNOUT,*) | |
20960 | & ' **** Original Gilbert/Cameron pairing energy used ****' | |
20961 | END IF | |
20962 | ENDIF | |
20963 | ** | |
20964 | ||
20965 | ILVMOD = IB0 | |
20966 | DO 500 JZ = 1, 130 | |
20967 | PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ) | |
20968 | 500 CONTINUE | |
20969 | DO 600 JA = 1, 200 | |
20970 | PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA) | |
20971 | 600 CONTINUE | |
20972 | RETURN | |
20973 | END | |
20974 | ||
20975 | *$ CREATE DT_EVEVAP.FOR | |
20976 | *COPY DT_EVEVAP | |
20977 | * | |
20978 | *====evevap============================================================* | |
20979 | * | |
20980 | SUBROUTINE DT_EVEVAP(WE) | |
20981 | ||
20982 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20983 | SAVE | |
20984 | PARAMETER ( LINP = 10 , | |
20985 | & LOUT = 6 , | |
20986 | & LDAT = 9 ) | |
20987 | ||
20988 | * flags for input different options | |
20989 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
20990 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
20991 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
20992 | ||
20993 | LEVAPO = .FALSE. | |
20994 | ||
20995 | RETURN | |
20996 | END | |
20997 | ||
20998 | *$ CREATE DT_FRBKIN.FOR | |
20999 | *COPY DT_FRBKIN | |
21000 | * | |
21001 | *====frbkin============================================================* | |
21002 | * | |
21003 | SUBROUTINE DT_FRBKIN(LDUM1,LDUM2) | |
21004 | ||
21005 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21006 | SAVE | |
21007 | PARAMETER ( LINP = 10 , | |
21008 | & LOUT = 6 , | |
21009 | & LDAT = 9 ) | |
21010 | ||
21011 | LOGICAL LDUM1,LDUM2 | |
21012 | ||
21013 | RETURN | |
21014 | END | |
21015 | ||
21016 | *$ CREATE DT_EXPLOD.FOR | |
21017 | *COPY DT_EXPLOD | |
21018 | * | |
21019 | *=== explod ===========================================================* | |
21020 | * | |
21021 | SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
21022 | & PYEXPL, PZEXPL ) | |
21023 | ||
21024 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21025 | SAVE | |
21026 | ||
21027 | DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL), | |
21028 | & ETEXPL (NPEXPL), AMEXPL (NPEXPL) | |
21029 | ||
21030 | RETURN | |
21031 | END | |
21032 | ||
21033 | ************************************************************************ | |
21034 | * * | |
21035 | * DPMJET 3.0: cross section routines * | |
21036 | * * | |
21037 | ************************************************************************ | |
21038 | * | |
21039 | * | |
21040 | * SUBROUTINE DT_SHNDIF | |
21041 | * diffractive cross sections (all energies) | |
21042 | * SUBROUTINE DT_PHOXS | |
21043 | * total and inel. cross sections from PHOJET interpol. tables | |
21044 | * SUBROUTINE DT_XSHN | |
21045 | * total and el. cross sections for all energies | |
21046 | * SUBROUTINE DT_SIHNAB | |
21047 | * pion 2-nucleon absorption cross sections | |
21048 | * SUBROUTINE DT_SIGEMU | |
21049 | * cross section for target "compounds" | |
21050 | * SUBROUTINE DT_SIGGA | |
21051 | * photon nucleus cross sections | |
21052 | * SUBROUTINE DT_SIGGAT | |
21053 | * photon nucleus cross sections from tables | |
21054 | * SUBROUTINE DT_SANO | |
21055 | * anomalous hard photon-nucleon cross sections from tables | |
21056 | * SUBROUTINE DT_SIGGP | |
21057 | * photon nucleon cross sections | |
21058 | * SUBROUTINE DT_SIGVEL | |
21059 | * quasi-elastic vector meson prod. cross sections | |
21060 | * DOUBLE PRECISION FUNCTION DT_SIGVP | |
21061 | * sigma_VN(tilde) | |
21062 | * DOUBLE PRECISION FUNCTION DT_RRM2 | |
21063 | * DOUBLE PRECISION FUNCTION DT_RM2 | |
21064 | * DOUBLE PRECISION FUNCTION DT_SAM2 | |
21065 | * SUBROUTINE DT_CKMT | |
21066 | * SUBROUTINE DT_CKMTX | |
21067 | * SUBROUTINE DT_PDF0 | |
21068 | * SUBROUTINE DT_CKMTQ0 | |
21069 | * SUBROUTINE DT_CKMTDE | |
21070 | * SUBROUTINE DT_CKMTPR | |
21071 | * FUNCTION DT_CKMTFF | |
21072 | * | |
21073 | * SUBROUTINE DT_FLUINI | |
21074 | * total nucleon cross section fluctuation treatment | |
21075 | * | |
21076 | * SUBROUTINE DT_SIGTBL | |
21077 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL | |
21078 | * SUBROUTINE DT_XSTABL | |
21079 | * service routines | |
21080 | * | |
21081 | * | |
21082 | *$ CREATE DT_SHNDIF.FOR | |
21083 | *COPY DT_SHNDIF | |
21084 | * | |
21085 | *===shndif===============================================================* | |
21086 | * | |
21087 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) | |
21088 | ||
21089 | ********************************************************************** | |
21090 | * Single diffractive hadron-nucleon cross sections * | |
21091 | * S.Roesler 14/1/93 * | |
21092 | * * | |
21093 | * The cross sections are calculated from extrapolated single * | |
21094 | * diffractive antiproton-proton cross sections (DTUJET92) using * | |
21095 | * scaling relations between total and single diffractive cross * | |
21096 | * sections. * | |
21097 | ********************************************************************** | |
21098 | ||
21099 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21100 | SAVE | |
21101 | PARAMETER (ZERO=0.0D0) | |
21102 | ||
21103 | * particle properties (BAMJET index convention) | |
21104 | CHARACTER*8 ANAME | |
21105 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21106 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21107 | * | |
21108 | CSD1 = 4.201483727D0 | |
21109 | CSD4 = -0.4763103556D-02 | |
21110 | CSD5 = 0.4324148297D0 | |
21111 | * | |
21112 | CHMSD1 = 0.8519297242D0 | |
21113 | CHMSD4 = -0.1443076599D-01 | |
21114 | CHMSD5 = 0.4014954567D0 | |
21115 | * | |
21116 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) | |
21117 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) | |
21118 | * | |
21119 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21120 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) | |
21121 | FRAC = SHMSD/SDIAPP | |
21122 | * | |
21123 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, | |
21124 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, | |
21125 | & 10, 10, 20, 20, 20) KPROJ | |
21126 | * | |
21127 | 10 CONTINUE | |
21128 | *---------------------------- p - p , n - p , sigma0+- - p , | |
21129 | * Lambda - p | |
21130 | CSD1 = 6.004476070D0 | |
21131 | CSD4 = -0.1257784606D-03 | |
21132 | CSD5 = 0.2447335720D0 | |
21133 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21134 | SIGDIH = FRAC*SIGDIF | |
21135 | RETURN | |
21136 | * | |
21137 | 20 CONTINUE | |
21138 | * | |
21139 | KPSCAL = 2 | |
21140 | KTSCAL = 1 | |
21141 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) | |
21142 | DUMZER = ZERO | |
21143 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) | |
21144 | F = SDIAPP/SIGTO | |
21145 | KT = 1 | |
21146 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F | |
21147 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) | |
21148 | SIGDIF = SIGTO*F | |
21149 | SIGDIH = FRAC*SIGDIF | |
21150 | RETURN | |
21151 | * | |
21152 | 999 CONTINUE | |
21153 | *-------------------------- leptons.. | |
21154 | SIGDIF = 1.D-10 | |
21155 | SIGDIH = 1.D-10 | |
21156 | RETURN | |
21157 | END | |
21158 | ||
21159 | *$ CREATE DT_PHOXS.FOR | |
21160 | *COPY DT_PHOXS | |
21161 | * | |
21162 | *===phoxs================================================================* | |
21163 | * | |
21164 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) | |
21165 | ||
21166 | ************************************************************************ | |
21167 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * | |
21168 | * interpolation tables. * | |
21169 | * This version dated 05.11.97 is written by S. Roesler * | |
21170 | ************************************************************************ | |
21171 | ||
21172 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21173 | SAVE | |
21174 | ||
21175 | PARAMETER ( LINP = 10 , | |
21176 | & LOUT = 6 , | |
21177 | & LDAT = 9 ) | |
21178 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21179 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
21180 | & PI = TWOPI/TWO, | |
21181 | & GEV2MB = 0.38938D0) | |
21182 | ||
21183 | LOGICAL LFIRST | |
21184 | DATA LFIRST /.TRUE./ | |
21185 | ||
21186 | * nucleon-nucleon event-generator | |
21187 | CHARACTER*8 CMODEL | |
21188 | LOGICAL LPHOIN | |
21189 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21190 | * particle properties (BAMJET index convention) | |
21191 | CHARACTER*8 ANAME | |
21192 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21193 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21194 | ||
21195 | **PHOJET105a | |
21196 | C PARAMETER (IEETAB=10) | |
21197 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21198 | **PHOJET110 | |
21199 | C energy-interpolation table | |
21200 | INTEGER IEETA2 | |
21201 | PARAMETER ( IEETA2 = 20 ) | |
21202 | INTEGER ISIMAX | |
21203 | DOUBLE PRECISION SIGTAB,SIGECM | |
21204 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21205 | ** | |
21206 | ||
21207 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN | |
21208 | WRITE(LOUT,*) MCGENE | |
21209 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') | |
21210 | STOP | |
21211 | ENDIF | |
21212 | ||
21213 | IF (ECM.LE.ZERO) THEN | |
21214 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) | |
21215 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) | |
21216 | ENDIF | |
21217 | ||
21218 | IF (MODE.EQ.1) THEN | |
21219 | * DL | |
21220 | DELDL = 0.0808D0 | |
21221 | EPSDL = -0.4525D0 | |
21222 | S = ECM*ECM | |
21223 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL | |
21224 | ALPHAP= 0.25D0 | |
21225 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) | |
21226 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) | |
21227 | SINE = STOT-SIGEL | |
21228 | SDIF1 = ZERO | |
21229 | ELSE | |
21230 | * Phojet | |
21231 | IP = 1 | |
21232 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
21233 | I1 = 1 | |
21234 | I2 = 1 | |
21235 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
21236 | DO 1 I=2,ISIMAX | |
21237 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 | |
21238 | 1 CONTINUE | |
21239 | 2 CONTINUE | |
21240 | I1 = I-1 | |
21241 | I2 = I | |
21242 | ELSE | |
21243 | IF (LFIRST) THEN | |
21244 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
21245 | & 'PHOXS: warning! energy above initialization limit (', | |
21246 | & ECM,SIGECM(IP,ISIMAX) | |
21247 | LFIRST = .FALSE. | |
21248 | ENDIF | |
21249 | I1 = ISIMAX | |
21250 | I2 = ISIMAX | |
21251 | ENDIF | |
21252 | FAC2 = ZERO | |
21253 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
21254 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
21255 | FAC1 = ONE-FAC2 | |
21256 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
21257 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
21258 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ | |
21259 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) | |
21260 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) | |
21261 | ENDIF | |
21262 | ||
21263 | RETURN | |
21264 | END | |
21265 | ||
21266 | *$ CREATE DT_XSHN.FOR | |
21267 | *COPY DT_XSHN | |
21268 | * | |
21269 | *===xshn===============================================================* | |
21270 | * | |
21271 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) | |
21272 | ||
21273 | ************************************************************************ | |
21274 | * Total and elastic hadron-nucleon cross section. * | |
21275 | * Below 500GeV cross sections are based on the '98 data compilation * | |
21276 | * of the PDG. At higher energies PHOJET results are used (patched to * | |
21277 | * the low energy data at 500GeV). * | |
21278 | * IP projectile index (BAMJET numbering scheme) * | |
21279 | * (should be in the range 1..25) * | |
21280 | * IT target index (BAMJET numbering scheme) * | |
21281 | * (1 = proton, 8 = neutron) * | |
21282 | * PL laboratory momentum * | |
21283 | * ECM cm. energy (ignored if PL>0) * | |
21284 | * STOT total cross section * | |
21285 | * SELA elastic cross section * | |
21286 | * Last change: 24.4.99 by S. Roesler * | |
21287 | ************************************************************************ | |
21288 | ||
21289 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21290 | SAVE | |
21291 | ||
21292 | PARAMETER ( LINP = 10 , | |
21293 | & LOUT = 6 , | |
21294 | & LDAT = 9 ) | |
21295 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
21296 | ||
21297 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, | |
21298 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) | |
21299 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) | |
21300 | ||
21301 | LOGICAL LFIRST | |
21302 | * particle properties (BAMJET index convention) | |
21303 | CHARACTER*8 ANAME | |
21304 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21305 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21306 | * nucleon-nucleon event-generator | |
21307 | CHARACTER*8 CMODEL | |
21308 | LOGICAL LPHOIN | |
21309 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21310 | **PHOJET105a | |
21311 | C PARAMETER (IEETAB=10) | |
21312 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21313 | **PHOJET110 | |
21314 | C energy-interpolation table | |
21315 | INTEGER IEETA2 | |
21316 | PARAMETER ( IEETA2 = 20 ) | |
21317 | INTEGER ISIMAX | |
21318 | DOUBLE PRECISION SIGTAB,SIGECM | |
21319 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21320 | ||
21321 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) | |
21322 | DIMENSION IDXDAT(25,2) | |
21323 | * | |
21324 | DATA APL / | |
21325 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, | |
21326 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, | |
21327 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, | |
21328 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, | |
21329 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, | |
21330 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, | |
21331 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ | |
21332 | * | |
21333 | * total cross sections: | |
21334 | * p p | |
21335 | DATA (ASIGTO(1,K),K=1,NPOINT) / | |
21336 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21337 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21338 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, | |
21339 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, | |
21340 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, | |
21341 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, | |
21342 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ | |
21343 | * pbar p | |
21344 | DATA (ASIGTO(2,K),K=1,NPOINT) / | |
21345 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, | |
21346 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, | |
21347 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, | |
21348 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, | |
21349 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, | |
21350 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, | |
21351 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ | |
21352 | * n p | |
21353 | DATA (ASIGTO(3,K),K=1,NPOINT) / | |
21354 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21355 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21356 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21357 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, | |
21358 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21359 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21360 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21361 | * pi+ p | |
21362 | DATA (ASIGTO(4,K),K=1,NPOINT) / | |
21363 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21364 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21365 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, | |
21366 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, | |
21367 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, | |
21368 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, | |
21369 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ | |
21370 | * pi- p | |
21371 | DATA (ASIGTO(5,K),K=1,NPOINT) / | |
21372 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, | |
21373 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, | |
21374 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, | |
21375 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, | |
21376 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, | |
21377 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, | |
21378 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ | |
21379 | * K+ p | |
21380 | DATA (ASIGTO(6,K),K=1,NPOINT) / | |
21381 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21382 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21383 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, | |
21384 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, | |
21385 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, | |
21386 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, | |
21387 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ | |
21388 | * K- p | |
21389 | DATA (ASIGTO(7,K),K=1,NPOINT) / | |
21390 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, | |
21391 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, | |
21392 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, | |
21393 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, | |
21394 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, | |
21395 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, | |
21396 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ | |
21397 | * K+ n | |
21398 | DATA (ASIGTO(8,K),K=1,NPOINT) / | |
21399 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21400 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21401 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, | |
21402 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, | |
21403 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, | |
21404 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, | |
21405 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ | |
21406 | * K- n | |
21407 | DATA (ASIGTO(9,K),K=1,NPOINT) / | |
21408 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, | |
21409 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, | |
21410 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, | |
21411 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, | |
21412 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, | |
21413 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, | |
21414 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ | |
21415 | * Lambda p | |
21416 | DATA (ASIGTO(10,K),K=1,NPOINT) / | |
21417 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21418 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, | |
21419 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, | |
21420 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, | |
21421 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21422 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21423 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21424 | * | |
21425 | * elastic cross sections: | |
21426 | * p p | |
21427 | DATA (ASIGEL(1,K),K=1,NPOINT) / | |
21428 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21429 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21430 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, | |
21431 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, | |
21432 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, | |
21433 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, | |
21434 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ | |
21435 | * pbar p | |
21436 | DATA (ASIGEL(2,K),K=1,NPOINT) / | |
21437 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, | |
21438 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, | |
21439 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, | |
21440 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, | |
21441 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, | |
21442 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, | |
21443 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ | |
21444 | * n p | |
21445 | DATA (ASIGEL(3,K),K=1,NPOINT) / | |
21446 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21447 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21448 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21449 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, | |
21450 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21451 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21452 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21453 | * pi+ p | |
21454 | DATA (ASIGEL(4,K),K=1,NPOINT) / | |
21455 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21456 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21457 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, | |
21458 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, | |
21459 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, | |
21460 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, | |
21461 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ | |
21462 | * pi- p | |
21463 | DATA (ASIGEL(5,K),K=1,NPOINT) / | |
21464 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, | |
21465 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, | |
21466 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, | |
21467 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, | |
21468 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, | |
21469 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, | |
21470 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ | |
21471 | * K+ p | |
21472 | DATA (ASIGEL(6,K),K=1,NPOINT) / | |
21473 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, | |
21474 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, | |
21475 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, | |
21476 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, | |
21477 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, | |
21478 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, | |
21479 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ | |
21480 | * K- p | |
21481 | DATA (ASIGEL(7,K),K=1,NPOINT) / | |
21482 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, | |
21483 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, | |
21484 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, | |
21485 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, | |
21486 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, | |
21487 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, | |
21488 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ | |
21489 | * K+ n | |
21490 | DATA (ASIGEL(8,K),K=1,NPOINT) / | |
21491 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21492 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21493 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, | |
21494 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, | |
21495 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, | |
21496 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, | |
21497 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ | |
21498 | * K- n | |
21499 | DATA (ASIGEL(9,K),K=1,NPOINT) / | |
21500 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, | |
21501 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, | |
21502 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, | |
21503 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, | |
21504 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, | |
21505 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, | |
21506 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ | |
21507 | * Lambda p | |
21508 | DATA (ASIGEL(10,K),K=1,NPOINT) / | |
21509 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21510 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, | |
21511 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, | |
21512 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, | |
21513 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21514 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21515 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21516 | ||
21517 | DATA (IDXDAT(K,1),K=1,25) / | |
21518 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, | |
21519 | & 1, 3,45, 8, 9/ | |
21520 | DATA (IDXDAT(K,2),K=1,25) / | |
21521 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, | |
21522 | & 3, 1,45, 6, 7/ | |
21523 | ||
21524 | DATA LFIRST /.TRUE./ | |
21525 | ||
21526 | IF (LFIRST) THEN | |
21527 | APLABL = LOG10(PLABLO) | |
21528 | APLABH = LOG10(PLABHI) | |
21529 | APTHRE = LOG10(PTHRE) | |
21530 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) | |
21531 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) | |
21532 | DUM0 = ZERO | |
21533 | PHOPLA = PLABHI | |
21534 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) | |
21535 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) | |
21536 | IF (MCGENE.EQ.2) THEN | |
21537 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN | |
21538 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21539 | ELSE | |
21540 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21541 | ENDIF | |
21542 | ELSE | |
21543 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21544 | ENDIF | |
21545 | PHOSEL = PHOSTO-PHOSIN | |
21546 | APHOST = LOG10(PHOSTO) | |
21547 | APHOSE = LOG10(PHOSEL) | |
21548 | LFIRST = .FALSE. | |
21549 | ENDIF | |
21550 | STOT = ZERO | |
21551 | SELA = ZERO | |
21552 | PLAB = PL | |
21553 | ECMS = ECM | |
21554 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN | |
21555 | WRITE(LOUT,1000) IP,IT | |
21556 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', | |
21557 | & 'proj/target',2I4) | |
21558 | STOP | |
21559 | ENDIF | |
21560 | ||
21561 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN | |
21562 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) | |
21563 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) | |
21564 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN | |
21565 | WRITE(LOUT,1001) PLAB,ECMS | |
21566 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) | |
21567 | STOP | |
21568 | ENDIF | |
21569 | ||
21570 | * index of spectrum | |
21571 | IDXP = IP | |
21572 | IF (IP.GT.25) THEN | |
21573 | IF (AAM(IP).GT.ZERO) THEN | |
21574 | IF (ABS(IIBAR(IP)).GT.0) THEN | |
21575 | IDXP = 1 | |
21576 | ELSE | |
21577 | IDXP = 13 | |
21578 | ENDIF | |
21579 | ELSE | |
21580 | IDXP = 7 | |
21581 | ENDIF | |
21582 | ENDIF | |
21583 | IDXT = 1 | |
21584 | IF (IT.EQ.8) IDXT = 2 | |
21585 | IDXS = IDXDAT(IDXP,IDXT) | |
21586 | IF (IDXS.EQ.0) RETURN | |
21587 | ||
21588 | * compute momentum bin indices | |
21589 | IF (PLAB.LT.PLABLO) THEN | |
21590 | IDX0 = 1 | |
21591 | IDX1 = 1 | |
21592 | ELSEIF (PLAB.GE.PLABHI) THEN | |
21593 | IDX0 = NPOINT | |
21594 | IDX1 = NPOINT | |
21595 | ELSE | |
21596 | APLAB = LOG10(PLAB) | |
21597 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN | |
21598 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 | |
21599 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN | |
21600 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 | |
21601 | ENDIF | |
21602 | IDX1 = IDX0+1 | |
21603 | ENDIF | |
21604 | ||
21605 | * interpolate cross section | |
21606 | IF (IDXS.GT.10) THEN | |
21607 | IDXS1 = IDXS/10 | |
21608 | IDXS2 = IDXS-10*IDXS1 | |
21609 | IF (IDX0.EQ.IDX1) THEN | |
21610 | IF (IDX0.EQ.1) THEN | |
21611 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) | |
21612 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) | |
21613 | ELSE | |
21614 | DUM0 = ZERO | |
21615 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21616 | PHOSEL = PHOSTO-PHOSIN | |
21617 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) | |
21618 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21619 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) | |
21620 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21621 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21622 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21623 | ENDIF | |
21624 | ELSE | |
21625 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21626 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ | |
21627 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) | |
21628 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ | |
21629 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) | |
21630 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21631 | ASELA1 = ASIGEL(IDXS1,IDX0)+ | |
21632 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) | |
21633 | ASELA2 = ASIGEL(IDXS2,IDX0)+ | |
21634 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) | |
21635 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21636 | ENDIF | |
21637 | ELSE | |
21638 | IF (IDX0.EQ.IDX1) THEN | |
21639 | IF (IDX0.EQ.1) THEN | |
21640 | ASTOT = ASIGTO(IDXS,IDX0) | |
21641 | ASELA = ASIGEL(IDXS,IDX0) | |
21642 | ELSE | |
21643 | DUM0 = ZERO | |
21644 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21645 | PHOSEL = PHOSTO-PHOSIN | |
21646 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) | |
21647 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21648 | ENDIF | |
21649 | ELSE | |
21650 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21651 | ASTOT = ASIGTO(IDXS,IDX0)+ | |
21652 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) | |
21653 | ASELA = ASIGEL(IDXS,IDX0)+ | |
21654 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) | |
21655 | ENDIF | |
21656 | ENDIF | |
21657 | STOT = 10.0D0**ASTOT | |
21658 | SELA = 10.0D0**ASELA | |
21659 | ||
21660 | RETURN | |
21661 | END | |
21662 | ||
21663 | *$ CREATE DT_SIHNAB.FOR | |
21664 | *COPY DT_SIHNAB | |
21665 | * | |
21666 | *===sihnab===============================================================* | |
21667 | * | |
21668 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) | |
21669 | ||
21670 | ********************************************************************** | |
21671 | * Pion 2-nucleon absorption cross sections. * | |
21672 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * | |
21673 | * taken from Ritchie PRC 28 (1983) 926 ) * | |
21674 | * This version dated 18.05.96 is written by S. Roesler * | |
21675 | ********************************************************************** | |
21676 | ||
21677 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21678 | SAVE | |
21679 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) | |
21680 | PARAMETER (AMPR = 938.0D0, | |
21681 | & AMPI = 140.0D0, | |
21682 | & AMDE = TWO*AMPR, | |
21683 | & A = -1.2D0, | |
21684 | & B = 3.5D0, | |
21685 | & C = 7.4D0, | |
21686 | & D = 5600.0D0, | |
21687 | & ER = 2136.0D0) | |
21688 | ||
21689 | SIGABS = ZERO | |
21690 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) | |
21691 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN | |
21692 | PTOT = PLAB*1.0D3 | |
21693 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI | |
21694 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN | |
21695 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) | |
21696 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) | |
21697 | * approximate 3N-abs., I=1-abs. etc. | |
21698 | SIGABS = SIGABS/0.40D0 | |
21699 | * pi0-absorption (rough approximation!!) | |
21700 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS | |
21701 | ||
21702 | RETURN | |
21703 | END | |
21704 | ||
21705 | *$ CREATE DT_SIGEMU.FOR | |
21706 | *COPY DT_SIGEMU | |
21707 | * | |
21708 | *===sigemu=============================================================* | |
21709 | * | |
21710 | SUBROUTINE DT_SIGEMU | |
21711 | ||
21712 | ************************************************************************ | |
21713 | * Combined cross section for target compounds. * | |
21714 | * This version dated 6.4.98 is written by S. Roesler * | |
21715 | ************************************************************************ | |
21716 | ||
21717 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21718 | SAVE | |
21719 | PARAMETER ( LINP = 10 , | |
21720 | & LOUT = 6 , | |
21721 | & LDAT = 9 ) | |
21722 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21723 | & OHALF=0.5D0,ONE=1.0D0) | |
21724 | ||
21725 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21726 | * Glauber formalism: cross sections | |
21727 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21728 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21729 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21730 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21731 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21732 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21733 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21734 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21735 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21736 | & BSLOPE,NEBINI,NQBINI | |
21737 | * emulsion treatment | |
21738 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
21739 | & NCOMPO,IEMUL | |
21740 | * nucleon-nucleon event-generator | |
21741 | CHARACTER*8 CMODEL | |
21742 | LOGICAL LPHOIN | |
21743 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21744 | ||
21745 | IF (MCGENE.NE.4) THEN | |
21746 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' | |
21747 | WRITE(LOUT,'(15X,A)') '-----------------------' | |
21748 | ENDIF | |
21749 | DO 1 IE=1,NEBINI | |
21750 | DO 2 IQ=1,NQBINI | |
21751 | SIGTOT = ZERO | |
21752 | SIGELA = ZERO | |
21753 | SIGQEP = ZERO | |
21754 | SIGQET = ZERO | |
21755 | SIGQE2 = ZERO | |
21756 | SIGPRO = ZERO | |
21757 | SIGDEL = ZERO | |
21758 | SIGDQE = ZERO | |
21759 | ERRTOT = ZERO | |
21760 | ERRELA = ZERO | |
21761 | ERRQEP = ZERO | |
21762 | ERRQET = ZERO | |
21763 | ERRQE2 = ZERO | |
21764 | ERRPRO = ZERO | |
21765 | ERRDEL = ZERO | |
21766 | ERRDQE = ZERO | |
21767 | IF (NCOMPO.GT.0) THEN | |
21768 | DO 3 IC=1,NCOMPO | |
21769 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) | |
21770 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) | |
21771 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) | |
21772 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) | |
21773 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) | |
21774 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) | |
21775 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) | |
21776 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) | |
21777 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 | |
21778 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 | |
21779 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 | |
21780 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 | |
21781 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 | |
21782 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 | |
21783 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 | |
21784 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 | |
21785 | 3 CONTINUE | |
21786 | ERRTOT = SQRT(ERRTOT) | |
21787 | ERRELA = SQRT(ERRELA) | |
21788 | ERRQEP = SQRT(ERRQEP) | |
21789 | ERRQET = SQRT(ERRQET) | |
21790 | ERRQE2 = SQRT(ERRQE2) | |
21791 | ERRPRO = SQRT(ERRPRO) | |
21792 | ERRDEL = SQRT(ERRDEL) | |
21793 | ERRDQE = SQRT(ERRDQE) | |
21794 | ELSE | |
21795 | SIGTOT = XSTOT(IE,IQ,1) | |
21796 | SIGELA = XSELA(IE,IQ,1) | |
21797 | SIGQEP = XSQEP(IE,IQ,1) | |
21798 | SIGQET = XSQET(IE,IQ,1) | |
21799 | SIGQE2 = XSQE2(IE,IQ,1) | |
21800 | SIGPRO = XSPRO(IE,IQ,1) | |
21801 | SIGDEL = XSDEL(IE,IQ,1) | |
21802 | SIGDQE = XSDQE(IE,IQ,1) | |
21803 | ERRTOT = XETOT(IE,IQ,1) | |
21804 | ERRELA = XEELA(IE,IQ,1) | |
21805 | ERRQEP = XEQEP(IE,IQ,1) | |
21806 | ERRQET = XEQET(IE,IQ,1) | |
21807 | ERRQE2 = XEQE2(IE,IQ,1) | |
21808 | ERRPRO = XEPRO(IE,IQ,1) | |
21809 | ERRDEL = XEDEL(IE,IQ,1) | |
21810 | ERRDQE = XEDQE(IE,IQ,1) | |
21811 | ENDIF | |
21812 | IF (MCGENE.NE.4) THEN | |
21813 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) | |
21814 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) | |
21815 | WRITE(LOUT,1001) SIGTOT,ERRTOT | |
21816 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') | |
21817 | WRITE(LOUT,1002) SIGELA,ERRELA | |
21818 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') | |
21819 | WRITE(LOUT,1003) SIGQEP,ERRQEP | |
21820 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', | |
21821 | & F11.5,' mb') | |
21822 | WRITE(LOUT,1004) SIGQET,ERRQET | |
21823 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', | |
21824 | & F11.5,' mb') | |
21825 | WRITE(LOUT,1005) SIGQE2,ERRQE2 | |
21826 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, | |
21827 | & ' +-',F11.5,' mb') | |
21828 | WRITE(LOUT,1006) SIGPRO,ERRPRO | |
21829 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') | |
21830 | WRITE(LOUT,1007) SIGDEL,ERRDEL | |
21831 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') | |
21832 | WRITE(LOUT,1008) SIGDQE,ERRDQE | |
21833 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') | |
21834 | ENDIF | |
21835 | ||
21836 | 2 CONTINUE | |
21837 | 1 CONTINUE | |
21838 | ||
21839 | RETURN | |
21840 | END | |
21841 | ||
21842 | *$ CREATE DT_SIGGA.FOR | |
21843 | *COPY DT_SIGGA | |
21844 | * | |
21845 | *===sigga==============================================================* | |
21846 | * | |
21847 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) | |
21848 | ||
21849 | ************************************************************************ | |
21850 | * Total/inelastic photon-nucleus cross sections. * | |
21851 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * | |
21852 | * production runs !!!! * | |
21853 | * This version dated 27.03.96 is written by S. Roesler * | |
21854 | ************************************************************************ | |
21855 | ||
21856 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21857 | SAVE | |
21858 | PARAMETER ( LINP = 10 , | |
21859 | & LOUT = 6 , | |
21860 | & LDAT = 9 ) | |
21861 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21862 | & OHALF=0.5D0,ONE=1.0D0) | |
21863 | PARAMETER (AMPROT = 0.938D0) | |
21864 | ||
21865 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21866 | * Glauber formalism: cross sections | |
21867 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21868 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21869 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21870 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21871 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21872 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21873 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21874 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21875 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21876 | & BSLOPE,NEBINI,NQBINI | |
21877 | ||
21878 | NT = NTI | |
21879 | X = XI | |
21880 | Q2 = Q2I | |
21881 | ECM = ECMI | |
21882 | XNU = XNUI | |
21883 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21884 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) | |
21885 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) | |
21886 | STOT = XSTOT(1,1,1) | |
21887 | ETOT = XETOT(1,1,1) | |
21888 | SIN = XSPRO(1,1,1) | |
21889 | EIN = XEPRO(1,1,1) | |
21890 | ||
21891 | RETURN | |
21892 | END | |
21893 | ||
21894 | *$ CREATE DT_SIGGAT.FOR | |
21895 | *COPY DT_SIGGAT | |
21896 | * | |
21897 | *===siggat=============================================================* | |
21898 | * | |
21899 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) | |
21900 | ||
21901 | ************************************************************************ | |
21902 | * Total/inelastic photon-nucleus cross sections. * | |
21903 | * Uses pre-tabulated cross section. * | |
21904 | * This version dated 29.07.96 is written by S. Roesler * | |
21905 | ************************************************************************ | |
21906 | ||
21907 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21908 | SAVE | |
21909 | PARAMETER ( LINP = 10 , | |
21910 | & LOUT = 6 , | |
21911 | & LDAT = 9 ) | |
21912 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21913 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21914 | ||
21915 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21916 | * Glauber formalism: cross sections | |
21917 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21918 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21919 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21920 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21921 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21922 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21923 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21924 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21925 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21926 | & BSLOPE,NEBINI,NQBINI | |
21927 | ||
21928 | NTARG = ABS(NT) | |
21929 | I1 = 1 | |
21930 | I2 = 1 | |
21931 | RATE = ONE | |
21932 | IF (NEBINI.GT.1) THEN | |
21933 | IF (ECMI.GE.ECMNN(NEBINI)) THEN | |
21934 | I1 = NEBINI | |
21935 | I2 = NEBINI | |
21936 | RATE = ONE | |
21937 | ELSEIF (ECMI.GT.ECMNN(1)) THEN | |
21938 | DO 1 I=2,NEBINI | |
21939 | IF (ECMI.LT.ECMNN(I)) THEN | |
21940 | I1 = I-1 | |
21941 | I2 = I | |
21942 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
21943 | GOTO 2 | |
21944 | ENDIF | |
21945 | 1 CONTINUE | |
21946 | 2 CONTINUE | |
21947 | ENDIF | |
21948 | ENDIF | |
21949 | J1 = 1 | |
21950 | J2 = 1 | |
21951 | RATQ = ONE | |
21952 | IF (NQBINI.GT.1) THEN | |
21953 | IF (Q2I.GE.Q2G(NQBINI)) THEN | |
21954 | J1 = NQBINI | |
21955 | J2 = NQBINI | |
21956 | RATQ = ONE | |
21957 | ELSEIF (Q2I.GT.Q2G(1)) THEN | |
21958 | DO 3 I=2,NQBINI | |
21959 | IF (Q2I.LT.Q2G(I)) THEN | |
21960 | J1 = I-1 | |
21961 | J2 = I | |
21962 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ | |
21963 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
21964 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
21965 | GOTO 4 | |
21966 | ENDIF | |
21967 | 3 CONTINUE | |
21968 | 4 CONTINUE | |
21969 | ENDIF | |
21970 | ENDIF | |
21971 | ||
21972 | STOT = XSTOT(I1,J1,NTARG)+ | |
21973 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21974 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21975 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ | |
21976 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) | |
21977 | ||
21978 | RETURN | |
21979 | END | |
21980 | ||
21981 | *$ CREATE DT_SANO.FOR | |
21982 | *COPY DT_SANO | |
21983 | * | |
21984 | *===sigano=============================================================* | |
21985 | * | |
21986 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) | |
21987 | ||
21988 | ************************************************************************ | |
21989 | * This version dated 31.07.96 is written by S. Roesler * | |
21990 | ************************************************************************ | |
21991 | ||
21992 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21993 | SAVE | |
21994 | PARAMETER ( LINP = 10 , | |
21995 | & LOUT = 6 , | |
21996 | & LDAT = 9 ) | |
21997 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21998 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21999 | PARAMETER (NE = 8) | |
22000 | ||
22001 | * VDM parameter for photon-nucleus interactions | |
22002 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22003 | * properties of interacting particles | |
22004 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
22005 | ||
22006 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) | |
22007 | DATA ECMANO / | |
22008 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, | |
22009 | & 0.100D+04,0.200D+04,0.500D+04 | |
22010 | & / | |
22011 | * fixed cut (3 GeV/c) | |
22012 | DATA FRAANO / | |
22013 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, | |
22014 | & 0.062D+00,0.054D+00,0.042D+00 | |
22015 | & / | |
22016 | DATA SIGHRD / | |
22017 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, | |
22018 | & 3.3086D-01,7.6255D-01,2.1319D+00 | |
22019 | & / | |
22020 | * running cut (based on obsolete Phojet-caluclations, bugs..) | |
22021 | C DATA FRAANO / | |
22022 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, | |
22023 | C & 0.167E+00,0.150E+00,0.131E+00 | |
22024 | C & / | |
22025 | C DATA SIGHRD / | |
22026 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, | |
22027 | C & 2.5736E-01,4.5593E-01,8.2550E-01 | |
22028 | C & / | |
22029 | ||
22030 | DT_SANO = ZERO | |
22031 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN | |
22032 | J1 = 0 | |
22033 | J2 = 0 | |
22034 | RATE = ONE | |
22035 | IF (ECM.GE.ECMANO(NE)) THEN | |
22036 | J1 = NE | |
22037 | J2 = NE | |
22038 | ELSEIF (ECM.GT.ECMANO(1)) THEN | |
22039 | DO 1 IE=2,NE | |
22040 | IF (ECM.LT.ECMANO(IE)) THEN | |
22041 | J1 = IE-1 | |
22042 | J2 = IE | |
22043 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) | |
22044 | GOTO 2 | |
22045 | ENDIF | |
22046 | 1 CONTINUE | |
22047 | 2 CONTINUE | |
22048 | ENDIF | |
22049 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN | |
22050 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) | |
22051 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) | |
22052 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) | |
22053 | ENDIF | |
22054 | ||
22055 | RETURN | |
22056 | END | |
22057 | ||
22058 | *$ CREATE DT_SIGGP.FOR | |
22059 | *COPY DT_SIGGP | |
22060 | * | |
22061 | *===siggp==============================================================* | |
22062 | * | |
22063 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) | |
22064 | ||
22065 | ************************************************************************ | |
22066 | * Total/inelastic photon-nucleon cross sections. * | |
22067 | * This version dated 30.04.96 is written by S. Roesler * | |
22068 | ************************************************************************ | |
22069 | ||
22070 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22071 | SAVE | |
22072 | PARAMETER ( LINP = 10 , | |
22073 | & LOUT = 6 , | |
22074 | & LDAT = 9 ) | |
22075 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22076 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22077 | & PI = TWOPI/TWO, | |
22078 | & GEV2MB = 0.38938D0, | |
22079 | & ALPHEM = ONE/137.0D0) | |
22080 | ||
22081 | * particle properties (BAMJET index convention) | |
22082 | CHARACTER*8 ANAME | |
22083 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22084 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22085 | * VDM parameter for photon-nucleus interactions | |
22086 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22087 | ||
22088 | **PHOJET105a | |
22089 | C CHARACTER*8 MDLNA | |
22090 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
22091 | C PARAMETER (IEETAB=10) | |
22092 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
22093 | **PHOJET110 | |
22094 | C model switches and parameters | |
22095 | CHARACTER*8 MDLNA | |
22096 | INTEGER ISWMDL,IPAMDL | |
22097 | DOUBLE PRECISION PARMDL | |
22098 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
22099 | C energy-interpolation table | |
22100 | INTEGER IEETA2 | |
22101 | PARAMETER ( IEETA2 = 20 ) | |
22102 | INTEGER ISIMAX | |
22103 | DOUBLE PRECISION SIGTAB,SIGECM | |
22104 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
22105 | ** | |
22106 | ||
22107 | C PARAMETER (NPOINT=80) | |
22108 | PARAMETER (NPOINT=16) | |
22109 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22110 | ||
22111 | STOT = ZERO | |
22112 | SINE = ZERO | |
22113 | SDIR = ZERO | |
22114 | ||
22115 | W2 = ECMI**2 | |
22116 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22117 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22118 | Q2 = Q2I | |
22119 | X = XI | |
22120 | * photoprod. | |
22121 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22122 | Q2 = 0.0001D0 | |
22123 | X = Q2/(W2+Q2-AAM(1)**2) | |
22124 | * DIS | |
22125 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22126 | X = Q2/(W2+Q2-AAM(1)**2) | |
22127 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22128 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22129 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22130 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22131 | ELSE | |
22132 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X | |
22133 | STOP | |
22134 | ENDIF | |
22135 | ECM = SQRT(W2) | |
22136 | ||
22137 | IF (MODEGA.EQ.1) THEN | |
22138 | SCALE = SQRT(Q2) | |
22139 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22140 | & IDPDF) | |
22141 | C W = SQRT(W2) | |
22142 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22143 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22144 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22145 | SINE = ZERO | |
22146 | SDIR = ZERO | |
22147 | ELSEIF (MODEGA.EQ.2) THEN | |
22148 | IF (INTRGE(1).EQ.1) THEN | |
22149 | AMLO2 = (3.0D0*AAM(13))**2 | |
22150 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22151 | AMLO2 = AAM(33)**2 | |
22152 | ELSE | |
22153 | AMLO2 = AAM(96)**2 | |
22154 | ENDIF | |
22155 | IF (INTRGE(2).EQ.1) THEN | |
22156 | AMHI2 = W2/TWO | |
22157 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22158 | AMHI2 = W2/4.0D0 | |
22159 | ELSE | |
22160 | AMHI2 = W2 | |
22161 | ENDIF | |
22162 | AMHI20 = (ECM-AAM(1))**2 | |
22163 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22164 | XAMLO = LOG( AMLO2+Q2 ) | |
22165 | XAMHI = LOG( AMHI2+Q2 ) | |
22166 | **PHOJET105a | |
22167 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22168 | **PHOJET112 | |
22169 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22170 | ** | |
22171 | SUM = ZERO | |
22172 | DO 1 J=1,NPOINT | |
22173 | AM2 = EXP(ABSZX(J))-Q2 | |
22174 | IF (AM2.LT.16.0D0) THEN | |
22175 | R = TWO | |
22176 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN | |
22177 | R = 10.0D0/3.0D0 | |
22178 | ELSE | |
22179 | R = 11.0D0/3.0D0 | |
22180 | ENDIF | |
22181 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22182 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22183 | & * (ONE+EPSPOL*Q2/AM2) | |
22184 | SUM = SUM+WEIGHT(J)*FAC | |
22185 | 1 CONTINUE | |
22186 | SINE = SUM | |
22187 | SDIR = DT_SIGVP(X,Q2) | |
22188 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR | |
22189 | SDIR = SDIR/(0.588D0+RL2+Q2) | |
22190 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) | |
22191 | ELSEIF (MODEGA.EQ.3) THEN | |
22192 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) | |
22193 | ELSEIF (MODEGA.EQ.4) THEN | |
22194 | * load cross sections from PHOJET interpolation table | |
22195 | IP = 1 | |
22196 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
22197 | I1 = 1 | |
22198 | I2 = 1 | |
22199 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
22200 | DO 2 I=2,ISIMAX | |
22201 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 | |
22202 | 2 CONTINUE | |
22203 | 3 CONTINUE | |
22204 | I1 = I-1 | |
22205 | I2 = I | |
22206 | ELSE | |
22207 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
22208 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
22209 | I1 = ISIMAX | |
22210 | I2 = ISIMAX | |
22211 | ENDIF | |
22212 | FAC2 = ZERO | |
22213 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
22214 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
22215 | FAC1 = ONE-FAC2 | |
22216 | * cross section dependence on photon virtuality | |
22217 | FSUP1 = ZERO | |
22218 | DO 4 I=1,3 | |
22219 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) | |
22220 | & /(1.D0+Q2/PARMDL(30+I))**2 | |
22221 | 4 CONTINUE | |
22222 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) | |
22223 | FAC1 = FAC1*FSUP1 | |
22224 | FAC2 = FAC2*FSUP1 | |
22225 | FSUP2 = 1.0D0 | |
22226 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
22227 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
22228 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
22229 | **re: | |
22230 | STOT = STOT-SDIR | |
22231 | ** | |
22232 | SDIR = SDIR/(FSUP1*FSUP2) | |
22233 | **re: | |
22234 | STOT = STOT+SDIR | |
22235 | ** | |
22236 | ENDIF | |
22237 | ||
22238 | RETURN | |
22239 | END | |
22240 | ||
22241 | *$ CREATE DT_SIGVEL.FOR | |
22242 | *COPY DT_SIGVEL | |
22243 | * | |
22244 | *===sigvel=============================================================* | |
22245 | * | |
22246 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) | |
22247 | ||
22248 | ************************************************************************ | |
22249 | * Cross section for elastic vector meson production * | |
22250 | * This version dated 10.05.96 is written by S. Roesler * | |
22251 | ************************************************************************ | |
22252 | ||
22253 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22254 | SAVE | |
22255 | PARAMETER ( LINP = 10 , | |
22256 | & LOUT = 6 , | |
22257 | & LDAT = 9 ) | |
22258 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22259 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22260 | & PI = TWOPI/TWO, | |
22261 | & GEV2MB = 0.38938D0, | |
22262 | & ALPHEM = ONE/137.0D0) | |
22263 | ||
22264 | * particle properties (BAMJET index convention) | |
22265 | CHARACTER*8 ANAME | |
22266 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22267 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22268 | * VDM parameter for photon-nucleus interactions | |
22269 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22270 | ||
22271 | W2 = ECMI**2 | |
22272 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22273 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22274 | Q2 = Q2I | |
22275 | X = XI | |
22276 | * photoprod. | |
22277 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22278 | Q2 = 0.0001D0 | |
22279 | X = Q2/(W2+Q2-AAM(1)**2) | |
22280 | * DIS | |
22281 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22282 | X = Q2/(W2+Q2-AAM(1)**2) | |
22283 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22284 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22285 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22286 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22287 | ELSE | |
22288 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X | |
22289 | STOP | |
22290 | ENDIF | |
22291 | ECM = SQRT(W2) | |
22292 | ||
22293 | AMV = AAM(IDXV) | |
22294 | AMV2 = AMV**2 | |
22295 | ||
22296 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
22297 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB | |
22298 | ROSH = 0.1D0 | |
22299 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) | |
22300 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) | |
22301 | ||
22302 | IF (IDXV.EQ.33) THEN | |
22303 | COUPL = 0.00365D0 | |
22304 | ELSE | |
22305 | STOP | |
22306 | ENDIF | |
22307 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) | |
22308 | SIG2 = SELVP | |
22309 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 | |
22310 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP | |
22311 | ||
22312 | RETURN | |
22313 | END | |
22314 | ||
22315 | *$ CREATE DT_SIGVP.FOR | |
22316 | *COPY DT_SIGVP | |
22317 | * | |
22318 | *===sigvp==============================================================* | |
22319 | * | |
22320 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) | |
22321 | ||
22322 | ************************************************************************ | |
22323 | * sigma_Vp * | |
22324 | ************************************************************************ | |
22325 | ||
22326 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22327 | SAVE | |
22328 | ||
22329 | PARAMETER ( LINP = 10 , | |
22330 | & LOUT = 6 , | |
22331 | & LDAT = 9 ) | |
22332 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22333 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22334 | & PI = TWOPI/TWO, | |
22335 | & GEV2MB = 0.38938D0, | |
22336 | & AMPROT = 0.938D0, | |
22337 | & ALPHEM = ONE/137.0D0) | |
22338 | * VDM parameter for photon-nucleus interactions | |
22339 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22340 | ||
22341 | X = XI | |
22342 | Q2 = Q2I | |
22343 | IF (XI.LE.ZERO) X = 0.0001D0 | |
22344 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 | |
22345 | ||
22346 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) | |
22347 | ||
22348 | SCALE = SQRT(Q2) | |
22349 | IF (MODEGA.EQ.1) THEN | |
22350 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22351 | & IDPDF) | |
22352 | C W = ECM | |
22353 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22354 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22355 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22356 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) | |
22357 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB | |
22358 | ELSEIF (MODEGA.EQ.4) THEN | |
22359 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) | |
22360 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT | |
22361 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT | |
22362 | ELSE | |
22363 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' | |
22364 | ENDIF | |
22365 | ||
22366 | RETURN | |
22367 | ||
22368 | END | |
22369 | ||
22370 | *$ CREATE DT_RRM2.FOR | |
22371 | *COPY DT_RRM2 | |
22372 | * | |
22373 | *===RRM2===============================================================* | |
22374 | * | |
22375 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) | |
22376 | ||
22377 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22378 | SAVE | |
22379 | PARAMETER ( LINP = 10 , | |
22380 | & LOUT = 6 , | |
22381 | & LDAT = 9 ) | |
22382 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22383 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22384 | & PI = TWOPI/TWO, | |
22385 | & GEV2MB = 0.38938D0) | |
22386 | ||
22387 | * particle properties (BAMJET index convention) | |
22388 | CHARACTER*8 ANAME | |
22389 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22390 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22391 | * VDM parameter for photon-nucleus interactions | |
22392 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22393 | ||
22394 | S = Q2*(ONE-X)/X+AAM(1)**2 | |
22395 | ECM = SQRT(S) | |
22396 | ||
22397 | IF (INTRGE(1).EQ.1) THEN | |
22398 | AMLO2 = (3.0D0*AAM(13))**2 | |
22399 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22400 | AMLO2 = AAM(33)**2 | |
22401 | ELSE | |
22402 | AMLO2 = AAM(96)**2 | |
22403 | ENDIF | |
22404 | IF (INTRGE(2).EQ.1) THEN | |
22405 | AMHI2 = S/TWO | |
22406 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22407 | AMHI2 = S/4.0D0 | |
22408 | ELSE | |
22409 | AMHI2 = S | |
22410 | ENDIF | |
22411 | AMHI20 = (ECM-AAM(1))**2 | |
22412 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22413 | ||
22414 | AM1C2 = 16.0D0 | |
22415 | AM2C2 = 121.0D0 | |
22416 | IF (AMHI2.LE.AM1C2) THEN | |
22417 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) | |
22418 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22419 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22420 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) | |
22421 | ELSE | |
22422 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22423 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ | |
22424 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) | |
22425 | ENDIF | |
22426 | ||
22427 | RETURN | |
22428 | END | |
22429 | ||
22430 | *$ CREATE DT_RM2.FOR | |
22431 | *COPY DT_RM2 | |
22432 | * | |
22433 | *===RM2================================================================* | |
22434 | * | |
22435 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) | |
22436 | ||
22437 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22438 | SAVE | |
22439 | PARAMETER ( LINP = 10 , | |
22440 | & LOUT = 6 , | |
22441 | & LDAT = 9 ) | |
22442 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22443 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22444 | & PI = TWOPI/TWO, | |
22445 | & GEV2MB = 0.38938D0) | |
22446 | * VDM parameter for photon-nucleus interactions | |
22447 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22448 | ||
22449 | IF (RL2.LE.ZERO) THEN | |
22450 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - | |
22451 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22452 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22453 | ELSE | |
22454 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) | |
22455 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) | |
22456 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI | |
22457 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) | |
22458 | & +EPSPOL*( | |
22459 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI | |
22460 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) | |
22461 | ENDIF | |
22462 | ||
22463 | RETURN | |
22464 | END | |
22465 | ||
22466 | *$ CREATE DT_SAM2.FOR | |
22467 | *COPY DT_SAM2 | |
22468 | * | |
22469 | *===SAM2===============================================================* | |
22470 | * | |
22471 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) | |
22472 | ||
22473 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22474 | SAVE | |
22475 | PARAMETER ( LINP = 10 , | |
22476 | & LOUT = 6 , | |
22477 | & LDAT = 9 ) | |
22478 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
22479 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) | |
22480 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22481 | & PI = TWOPI/TWO, | |
22482 | & GEV2MB = 0.38938D0) | |
22483 | ||
22484 | * particle properties (BAMJET index convention) | |
22485 | CHARACTER*8 ANAME | |
22486 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22487 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22488 | * VDM parameter for photon-nucleus interactions | |
22489 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22490 | ||
22491 | S = ECM**2 | |
22492 | IF (INTRGE(1).EQ.1) THEN | |
22493 | AMLO2 = (3.0D0*AAM(13))**2 | |
22494 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22495 | AMLO2 = AAM(33)**2 | |
22496 | ELSE | |
22497 | AMLO2 = AAM(96)**2 | |
22498 | ENDIF | |
22499 | IF (INTRGE(2).EQ.1) THEN | |
22500 | AMHI2 = S/TWO | |
22501 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22502 | AMHI2 = S/4.0D0 | |
22503 | ELSE | |
22504 | AMHI2 = S | |
22505 | ENDIF | |
22506 | AMHI20 = (ECM-AAM(1))**2 | |
22507 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22508 | ||
22509 | AM1C2 = 16.0D0 | |
22510 | AM2C2 = 121.0D0 | |
22511 | YLO = LOG(AMLO2+Q2) | |
22512 | YC1 = LOG(AM1C2+Q2) | |
22513 | YC2 = LOG(AM2C2+Q2) | |
22514 | YHI = LOG(AMHI2+Q2) | |
22515 | IF (AMHI2.LE.AM1C2) THEN | |
22516 | FACHI = TWO | |
22517 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22518 | FACHI = TENTRD | |
22519 | ELSE | |
22520 | FACHI = ELVTRD | |
22521 | ENDIF | |
22522 | ||
22523 | 1 CONTINUE | |
22524 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) | |
22525 | IF (YSAM2.LE.YC1) THEN | |
22526 | FAC = TWO | |
22527 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN | |
22528 | FAC = TENTRD | |
22529 | ELSE | |
22530 | FAC = ELVTRD | |
22531 | ENDIF | |
22532 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) | |
22533 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) | |
22534 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 | |
22535 | ||
22536 | DT_SAM2 = EXP(YSAM2)-Q2 | |
22537 | ||
22538 | RETURN | |
22539 | END | |
22540 | ||
22541 | *$ CREATE DT_CKMT.FOR | |
22542 | *COPY DT_CKMT | |
22543 | * | |
22544 | *===ckmt===============================================================* | |
22545 | * | |
22546 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, | |
22547 | & F2,IPAR) | |
22548 | ||
22549 | ************************************************************************ | |
22550 | * This version dated 31.01.96 is written by S. Roesler * | |
22551 | ************************************************************************ | |
22552 | ||
22553 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22554 | SAVE | |
22555 | PARAMETER ( LINP = 10 , | |
22556 | & LOUT = 6 , | |
22557 | & LDAT = 9 ) | |
22558 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) | |
22559 | ||
22560 | PARAMETER (Q02 = 2.0D0, | |
22561 | & DQ2 = 10.05D0, | |
22562 | & Q12 = Q02+DQ2) | |
22563 | ||
22564 | DIMENSION PD(-6:6),SEA(3),VAL(2) | |
22565 | ||
22566 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) | |
22567 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) | |
22568 | ADQ2 = LOG10(Q12)-LOG10(Q02) | |
22569 | F2P = (F2Q1-F2Q0)/ADQ2 | |
22570 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) | |
22571 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) | |
22572 | F2PP = (F2PQ1-F2PQ0)/ADQ2 | |
22573 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 | |
22574 | ||
22575 | Q2 = MAX(SCALE**2.0D0,TINY10) | |
22576 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 | |
22577 | IF (Q2.LT.Q02) THEN | |
22578 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22579 | UPV = VAL(1) | |
22580 | DNV = VAL(2) | |
22581 | USEA = SEA(1) | |
22582 | DSEA = SEA(2) | |
22583 | STR = SEA(3) | |
22584 | CHM = 0.0D0 | |
22585 | BOT = 0.0D0 | |
22586 | TOP = 0.0D0 | |
22587 | GL = GLU | |
22588 | ELSE | |
22589 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) | |
22590 | F2 = F2*SMOOTH | |
22591 | UPV = PD(2)-PD(3) | |
22592 | DNV = PD(1)-PD(3) | |
22593 | USEA = PD(3) | |
22594 | DSEA = PD(3) | |
22595 | STR = PD(3) | |
22596 | CHM = PD(4) | |
22597 | BOT = PD(5) | |
22598 | TOP = PD(6) | |
22599 | GL = PD(0) | |
22600 | C UPV = UPV*SMOOTH | |
22601 | C DNV = DNV*SMOOTH | |
22602 | C USEA = USEA*SMOOTH | |
22603 | C DSEA = DSEA*SMOOTH | |
22604 | C STR = STR*SMOOTH | |
22605 | C CHM = CHM*SMOOTH | |
22606 | C GL = GL*SMOOTH | |
22607 | ENDIF | |
22608 | ||
22609 | RETURN | |
22610 | END | |
22611 | C | |
22612 | ||
22613 | *$ CREATE DT_CKMTX.FOR | |
22614 | *COPY DT_CKMTX | |
22615 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) | |
22616 | C********************************************************************** | |
22617 | C | |
22618 | C PDF based on Regge theory, evolved with .... by .... | |
22619 | C | |
22620 | C input: IPAR 2212 proton (not installed) | |
22621 | C 45 Pomeron | |
22622 | C 100 Deuteron | |
22623 | C | |
22624 | C output: PD(-6:6) x*f(x) parton distribution functions | |
22625 | C (PDFLIB convention: d = PD(1), u = PD(2) ) | |
22626 | C | |
22627 | C********************************************************************** | |
22628 | ||
22629 | SAVE | |
22630 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 | |
22631 | PARAMETER ( LINP = 10 , | |
22632 | & LOUT = 6 , | |
22633 | & LDAT = 9 ) | |
22634 | DIMENSION QQ(7) | |
22635 | C | |
22636 | Q2=SNGL(SCALE2) | |
22637 | Q1S=Q2 | |
22638 | XX=SNGL(X) | |
22639 | C QCD lambda for evolution | |
22640 | OWLAM = 0.23D0 | |
22641 | OWLAM2=OWLAM**2 | |
22642 | C Q0**2 for evolution | |
22643 | Q02 = 2.D0 | |
22644 | C | |
22645 | C | |
22646 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... | |
22647 | C q(6)=x*charm, q(7)=x*gluon | |
22648 | C | |
22649 | SB=0. | |
22650 | IF(Q2-Q02) 1,1,2 | |
22651 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) | |
22652 | 1 CONTINUE | |
22653 | IF(IPAR.EQ.2212) THEN | |
22654 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) | |
22655 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) | |
22656 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) | |
22657 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) | |
22658 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) | |
22659 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) | |
22660 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) | |
22661 | C ELSEIF (IPAR.EQ.45) THEN | |
22662 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) | |
22663 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) | |
22664 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) | |
22665 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) | |
22666 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) | |
22667 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) | |
22668 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) | |
22669 | ELSEIF (IPAR.EQ.100) THEN | |
22670 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) | |
22671 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) | |
22672 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) | |
22673 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) | |
22674 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) | |
22675 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) | |
22676 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) | |
22677 | ELSE | |
22678 | WRITE(LOUT,'(1X,A,I4,A)') | |
22679 | & 'CKMTX: IPAR =',IPAR,' not implemented!' | |
22680 | STOP | |
22681 | ENDIF | |
22682 | C | |
22683 | PD(-6) = 0.D0 | |
22684 | PD(-5) = 0.D0 | |
22685 | PD(-4) = DBLE(QQ(6)) | |
22686 | PD(-3) = DBLE(QQ(3)) | |
22687 | PD(-2) = DBLE(QQ(4)) | |
22688 | PD(-1) = DBLE(QQ(5)) | |
22689 | PD(0) = DBLE(QQ(7)) | |
22690 | PD(1) = DBLE(QQ(2)) | |
22691 | PD(2) = DBLE(QQ(1)) | |
22692 | PD(3) = DBLE(QQ(3)) | |
22693 | PD(4) = DBLE(QQ(6)) | |
22694 | PD(5) = 0.D0 | |
22695 | PD(6) = 0.D0 | |
22696 | IF(IPAR.EQ.45) THEN | |
22697 | CDN = (PD(1)-PD(-1))/2.D0 | |
22698 | CUP = (PD(2)-PD(-2))/2.D0 | |
22699 | PD(-1) = PD(-1) + CDN | |
22700 | PD(-2) = PD(-2) + CUP | |
22701 | PD(1) = PD(-1) | |
22702 | PD(2) = PD(-2) | |
22703 | ENDIF | |
22704 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ | |
22705 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ | |
22706 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) | |
22707 | END | |
22708 | C | |
22709 | ||
22710 | *$ CREATE DT_PDF0.FOR | |
22711 | *COPY DT_PDF0 | |
22712 | * | |
22713 | *===pdf0===============================================================* | |
22714 | * | |
22715 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22716 | ||
22717 | ************************************************************************ | |
22718 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22719 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22720 | * IPAR = 2212 proton * | |
22721 | * = 100 deuteron * | |
22722 | * This version dated 31.01.96 is written by S. Roesler * | |
22723 | ************************************************************************ | |
22724 | ||
22725 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22726 | SAVE | |
22727 | PARAMETER ( LINP = 10 , | |
22728 | & LOUT = 6 , | |
22729 | & LDAT = 9 ) | |
22730 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22731 | ||
22732 | PARAMETER ( | |
22733 | & AA = 0.1502D0, | |
22734 | & BBDEU = 1.2D0, | |
22735 | & BUD = 0.754D0, | |
22736 | & BDD = 0.4495D0, | |
22737 | & BUP = 1.2064D0, | |
22738 | & BDP = 0.1798D0, | |
22739 | & DELTA0 = 0.07684D0, | |
22740 | & D = 1.117D0, | |
22741 | & C = 3.5489D0, | |
22742 | & A = 0.2631D0, | |
22743 | & B = 0.6452D0, | |
22744 | & ALPHAR = 0.415D0, | |
22745 | & E = 0.1D0 | |
22746 | & ) | |
22747 | ||
22748 | PARAMETER (NPOINT=16) | |
22749 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22750 | DIMENSION SEA(3),VAL(2) | |
22751 | ||
22752 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22753 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22754 | * proton, deuteron | |
22755 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22756 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22757 | SEA(1) = 0.75D0*SEA0 | |
22758 | SEA(2) = SEA(1) | |
22759 | SEA(3) = SEA(1) | |
22760 | VAL(1) = 9.0D0/4.0D0*VALU0 | |
22761 | VAL(2) = 9.0D0*VALD0 | |
22762 | GLU0 = SEA(1)/(1.0D0-X) | |
22763 | F2 = SEA0+VALU0+VALD0 | |
22764 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ | |
22765 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ | |
22766 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) | |
22767 | IF (ABS(F2-F2PDF).GT.TINY9) THEN | |
22768 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF | |
22769 | STOP | |
22770 | ENDIF | |
22771 | **PHOJET105a | |
22772 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22773 | **PHOJET112 | |
22774 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22775 | ** | |
22776 | C SUMQ = ZERO | |
22777 | C SUMG = ZERO | |
22778 | C DO 1 J=1,NPOINT | |
22779 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) | |
22780 | C VALU0 = 9.0D0/4.0D0*VALU0 | |
22781 | C VALD0 = 9.0D0*VALD0 | |
22782 | C SEA0 = 0.75D0*SEA0 | |
22783 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) | |
22784 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) | |
22785 | C 1 CONTINUE | |
22786 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG | |
22787 | ELSE | |
22788 | WRITE(LOUT,'(1X,A,I4,A)') | |
22789 | & 'PDF0: IPAR =',IPAR,' not implemented!' | |
22790 | STOP | |
22791 | ENDIF | |
22792 | ||
22793 | RETURN | |
22794 | END | |
22795 | ||
22796 | *$ CREATE DT_CKMTQ0.FOR | |
22797 | *COPY DT_CKMTQ0 | |
22798 | * | |
22799 | *===ckmtq0=============================================================* | |
22800 | * | |
22801 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22802 | ||
22803 | ************************************************************************ | |
22804 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22805 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22806 | * IPAR = 2212 proton * | |
22807 | * = 100 deuteron * | |
22808 | * This version dated 31.01.96 is written by S. Roesler * | |
22809 | ************************************************************************ | |
22810 | ||
22811 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22812 | SAVE | |
22813 | PARAMETER ( LINP = 10 , | |
22814 | & LOUT = 6 , | |
22815 | & LDAT = 9 ) | |
22816 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22817 | ||
22818 | PARAMETER ( | |
22819 | & AA = 0.1502D0, | |
22820 | & BBDEU = 1.2D0, | |
22821 | & BUD = 0.754D0, | |
22822 | & BDD = 0.4495D0, | |
22823 | & BUP = 1.2064D0, | |
22824 | & BDP = 0.1798D0, | |
22825 | & DELTA0 = 0.07684D0, | |
22826 | & D = 1.117D0, | |
22827 | & C = 3.5489D0, | |
22828 | & A = 0.2631D0, | |
22829 | & B = 0.6452D0, | |
22830 | & ALPHAR = 0.415D0, | |
22831 | & E = 0.1D0 | |
22832 | & ) | |
22833 | ||
22834 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22835 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22836 | * proton, deuteron | |
22837 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22838 | IF (IPAR.EQ.2212) THEN | |
22839 | BU = BUP | |
22840 | BD = BDP | |
22841 | ELSE | |
22842 | BU = BUD | |
22843 | BD = BDD | |
22844 | ENDIF | |
22845 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* | |
22846 | & (Q2/(Q2+A))**(1.0D0+DELTA) | |
22847 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* | |
22848 | & (Q2/(Q2+B))**(ALPHAR) | |
22849 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* | |
22850 | & (Q2/(Q2+B))**(ALPHAR) | |
22851 | ELSE | |
22852 | WRITE(LOUT,'(1X,A,I4,A)') | |
22853 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' | |
22854 | STOP | |
22855 | ENDIF | |
22856 | RETURN | |
22857 | END | |
22858 | C | |
22859 | C | |
22860 | ||
22861 | *$ CREATE DT_CKMTDE.FOR | |
22862 | *COPY DT_CKMTDE | |
22863 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) | |
22864 | C | |
22865 | C********************************************************************** | |
22866 | C Deuteron - PDFs | |
22867 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
22868 | C ANS = PDF(I) | |
22869 | C This version by S. Roesler, 30.01.96 | |
22870 | C********************************************************************** | |
22871 | ||
22872 | SAVE | |
22873 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
22874 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
22875 | DATA DELTA/.13/ | |
22876 | C | |
22877 | DATA (DL(K),K= 1, 85) / | |
22878 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
22879 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, | |
22880 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, | |
22881 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, | |
22882 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, | |
22883 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, | |
22884 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, | |
22885 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, | |
22886 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, | |
22887 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, | |
22888 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, | |
22889 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, | |
22890 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, | |
22891 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, | |
22892 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, | |
22893 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, | |
22894 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ | |
22895 | DATA (DL(K),K= 86, 170) / | |
22896 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, | |
22897 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, | |
22898 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, | |
22899 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, | |
22900 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, | |
22901 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, | |
22902 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, | |
22903 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22904 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22905 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22906 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22907 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22908 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22909 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22910 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22911 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
22912 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ | |
22913 | DATA (DL(K),K= 171, 255) / | |
22914 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, | |
22915 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, | |
22916 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, | |
22917 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, | |
22918 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, | |
22919 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, | |
22920 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, | |
22921 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, | |
22922 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, | |
22923 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, | |
22924 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, | |
22925 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, | |
22926 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, | |
22927 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, | |
22928 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, | |
22929 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, | |
22930 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ | |
22931 | DATA (DL(K),K= 256, 340) / | |
22932 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, | |
22933 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, | |
22934 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, | |
22935 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, | |
22936 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, | |
22937 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22938 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22939 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22940 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22941 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22942 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22943 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22944 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22945 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
22946 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, | |
22947 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, | |
22948 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ | |
22949 | DATA (DL(K),K= 341, 425) / | |
22950 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, | |
22951 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, | |
22952 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, | |
22953 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, | |
22954 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, | |
22955 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, | |
22956 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, | |
22957 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, | |
22958 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, | |
22959 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, | |
22960 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, | |
22961 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, | |
22962 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, | |
22963 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, | |
22964 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, | |
22965 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, | |
22966 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ | |
22967 | DATA (DL(K),K= 426, 510) / | |
22968 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, | |
22969 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, | |
22970 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, | |
22971 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22972 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22973 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22974 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22975 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22976 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22977 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22978 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22979 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
22980 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, | |
22981 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, | |
22982 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, | |
22983 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, | |
22984 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ | |
22985 | DATA (DL(K),K= 511, 595) / | |
22986 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, | |
22987 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, | |
22988 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, | |
22989 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, | |
22990 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, | |
22991 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, | |
22992 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, | |
22993 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, | |
22994 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, | |
22995 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, | |
22996 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, | |
22997 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, | |
22998 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, | |
22999 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, | |
23000 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, | |
23001 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, | |
23002 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ | |
23003 | DATA (DL(K),K= 596, 680) / | |
23004 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, | |
23005 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23006 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23007 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23008 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23009 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23010 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23011 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23012 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23013 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23014 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, | |
23015 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, | |
23016 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, | |
23017 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, | |
23018 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, | |
23019 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, | |
23020 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ | |
23021 | DATA (DL(K),K= 681, 765) / | |
23022 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, | |
23023 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, | |
23024 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, | |
23025 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, | |
23026 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, | |
23027 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, | |
23028 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, | |
23029 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, | |
23030 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, | |
23031 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, | |
23032 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, | |
23033 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, | |
23034 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, | |
23035 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, | |
23036 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, | |
23037 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, | |
23038 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23039 | DATA (DL(K),K= 766, 850) / | |
23040 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23041 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23042 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23043 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23044 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23048 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, | |
23049 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, | |
23050 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, | |
23051 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, | |
23052 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, | |
23053 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, | |
23054 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, | |
23055 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, | |
23056 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ | |
23057 | DATA (DL(K),K= 851, 935) / | |
23058 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, | |
23059 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, | |
23060 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, | |
23061 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, | |
23062 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, | |
23063 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, | |
23064 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, | |
23065 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, | |
23066 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, | |
23067 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, | |
23068 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, | |
23069 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, | |
23070 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, | |
23071 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, | |
23072 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23073 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23074 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23075 | DATA (DL(K),K= 936, 1020) / | |
23076 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23077 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23078 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23082 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, | |
23083 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, | |
23084 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, | |
23085 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, | |
23086 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, | |
23087 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, | |
23088 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, | |
23089 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, | |
23090 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, | |
23091 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, | |
23092 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ | |
23093 | DATA (DL(K),K= 1021, 1105) / | |
23094 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, | |
23095 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, | |
23096 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, | |
23097 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, | |
23098 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, | |
23099 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, | |
23100 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, | |
23101 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, | |
23102 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, | |
23103 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, | |
23104 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, | |
23105 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, | |
23106 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23107 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23108 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23109 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23110 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23111 | DATA (DL(K),K= 1106, 1190) / | |
23112 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
23116 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, | |
23117 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, | |
23118 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, | |
23119 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, | |
23120 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, | |
23121 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, | |
23122 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, | |
23123 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, | |
23124 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, | |
23125 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, | |
23126 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, | |
23127 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, | |
23128 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ | |
23129 | DATA (DL(K),K= 1191, 1275) / | |
23130 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, | |
23131 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, | |
23132 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, | |
23133 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, | |
23134 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, | |
23135 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, | |
23136 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, | |
23137 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, | |
23138 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, | |
23139 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, | |
23140 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23141 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23142 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23143 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23144 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23145 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23146 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23147 | DATA (DL(K),K= 1276, 1360) / | |
23148 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23149 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
23150 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, | |
23151 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, | |
23152 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, | |
23153 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, | |
23154 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, | |
23155 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, | |
23156 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, | |
23157 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, | |
23158 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, | |
23159 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, | |
23160 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, | |
23161 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, | |
23162 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, | |
23163 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, | |
23164 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ | |
23165 | DATA (DL(K),K= 1361, 1445) / | |
23166 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, | |
23167 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, | |
23168 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, | |
23169 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, | |
23170 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, | |
23171 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, | |
23172 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, | |
23173 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, | |
23174 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23175 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23176 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23177 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23178 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23179 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23180 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23181 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23182 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
23183 | DATA (DL(K),K= 1446, 1530) / | |
23184 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, | |
23185 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, | |
23186 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, | |
23187 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, | |
23188 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, | |
23189 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, | |
23190 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, | |
23191 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, | |
23192 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, | |
23193 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, | |
23194 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, | |
23195 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, | |
23196 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, | |
23197 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, | |
23198 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, | |
23199 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, | |
23200 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ | |
23201 | DATA (DL(K),K= 1531, 1615) / | |
23202 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, | |
23203 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, | |
23204 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, | |
23205 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, | |
23206 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, | |
23207 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, | |
23208 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23209 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23210 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23211 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23212 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23213 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23214 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23215 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23216 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
23217 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, | |
23218 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ | |
23219 | DATA (DL(K),K= 1616, 1700) / | |
23220 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, | |
23221 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, | |
23222 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, | |
23223 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, | |
23224 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, | |
23225 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, | |
23226 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, | |
23227 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, | |
23228 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, | |
23229 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, | |
23230 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, | |
23231 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, | |
23232 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, | |
23233 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, | |
23234 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, | |
23235 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, | |
23236 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ | |
23237 | DATA (DL(K),K= 1701, 1785) / | |
23238 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, | |
23239 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, | |
23240 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, | |
23241 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, | |
23242 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23243 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23244 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23245 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23246 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23247 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23248 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23249 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23250 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
23251 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, | |
23252 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, | |
23253 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, | |
23254 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ | |
23255 | DATA (DL(K),K= 1786, 1870) / | |
23256 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, | |
23257 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, | |
23258 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, | |
23259 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, | |
23260 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, | |
23261 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, | |
23262 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, | |
23263 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, | |
23264 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, | |
23265 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, | |
23266 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, | |
23267 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, | |
23268 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, | |
23269 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, | |
23270 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, | |
23271 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, | |
23272 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ | |
23273 | DATA (DL(K),K= 1871, 1955) / | |
23274 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, | |
23275 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, | |
23276 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23277 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23278 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23279 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23280 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23281 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23282 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23283 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23284 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
23285 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, | |
23286 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, | |
23287 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, | |
23288 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, | |
23289 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, | |
23290 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ | |
23291 | DATA (DL(K),K= 1956, 2040) / | |
23292 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, | |
23293 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, | |
23294 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, | |
23295 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, | |
23296 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, | |
23297 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, | |
23298 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, | |
23299 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, | |
23300 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, | |
23301 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, | |
23302 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, | |
23303 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, | |
23304 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, | |
23305 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, | |
23306 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, | |
23307 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, | |
23308 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ | |
23309 | DATA (DL(K),K= 2041, 2125) / | |
23310 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23311 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23312 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23313 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23314 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23315 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
23319 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, | |
23320 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, | |
23321 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, | |
23322 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, | |
23323 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, | |
23324 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, | |
23325 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, | |
23326 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ | |
23327 | DATA (DL(K),K= 2126, 2210) / | |
23328 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, | |
23329 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, | |
23330 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, | |
23331 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, | |
23332 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, | |
23333 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, | |
23334 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, | |
23335 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, | |
23336 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, | |
23337 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, | |
23338 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, | |
23339 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, | |
23340 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, | |
23341 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, | |
23342 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, | |
23343 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23344 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23345 | DATA (DL(K),K= 2211, 2295) / | |
23346 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23347 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23348 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23349 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
23353 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, | |
23354 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, | |
23355 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, | |
23356 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, | |
23357 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, | |
23358 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, | |
23359 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, | |
23360 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, | |
23361 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, | |
23362 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ | |
23363 | DATA (DL(K),K= 2296, 2380) / | |
23364 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, | |
23365 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, | |
23366 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, | |
23367 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, | |
23368 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, | |
23369 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, | |
23370 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, | |
23371 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, | |
23372 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, | |
23373 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, | |
23374 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, | |
23375 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, | |
23376 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, | |
23377 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23378 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23379 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23380 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23381 | DATA (DL(K),K= 2381, 2465) / | |
23382 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23383 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
23387 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, | |
23388 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, | |
23389 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, | |
23390 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, | |
23391 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, | |
23392 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, | |
23393 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, | |
23394 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, | |
23395 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, | |
23396 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, | |
23397 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, | |
23398 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ | |
23399 | DATA (DL(K),K= 2466, 2550) / | |
23400 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, | |
23401 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, | |
23402 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, | |
23403 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, | |
23404 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, | |
23405 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, | |
23406 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, | |
23407 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, | |
23408 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, | |
23409 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, | |
23410 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, | |
23411 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23412 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23413 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23414 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23415 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23416 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23417 | DATA (DL(K),K= 2551, 2635) / | |
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.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, | |
23421 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, | |
23422 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, | |
23423 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, | |
23424 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, | |
23425 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, | |
23426 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, | |
23427 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, | |
23428 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, | |
23429 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, | |
23430 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, | |
23431 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, | |
23432 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, | |
23433 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, | |
23434 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ | |
23435 | DATA (DL(K),K= 2636, 2720) / | |
23436 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, | |
23437 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, | |
23438 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, | |
23439 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, | |
23440 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, | |
23441 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, | |
23442 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, | |
23443 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, | |
23444 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, | |
23445 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23446 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23447 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23448 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23449 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23450 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23451 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23452 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23453 | DATA (DL(K),K= 2721, 2805) / | |
23454 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, | |
23455 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, | |
23456 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, | |
23457 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, | |
23458 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, | |
23459 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, | |
23460 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, | |
23461 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, | |
23462 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, | |
23463 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, | |
23464 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, | |
23465 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, | |
23466 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, | |
23467 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, | |
23468 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, | |
23469 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, | |
23470 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ | |
23471 | DATA (DL(K),K= 2806, 2890) / | |
23472 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, | |
23473 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, | |
23474 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, | |
23475 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, | |
23476 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, | |
23477 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, | |
23478 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, | |
23479 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23480 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23481 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23482 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23483 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23484 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23485 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23486 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23487 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, | |
23488 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ | |
23489 | DATA (DL(K),K= 2891, 2975) / | |
23490 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, | |
23491 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, | |
23492 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, | |
23493 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, | |
23494 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, | |
23495 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, | |
23496 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, | |
23497 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, | |
23498 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, | |
23499 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, | |
23500 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, | |
23501 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, | |
23502 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, | |
23503 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, | |
23504 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, | |
23505 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, | |
23506 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ | |
23507 | DATA (DL(K),K= 2976, 3060) / | |
23508 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, | |
23509 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, | |
23510 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, | |
23511 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, | |
23512 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, | |
23513 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23514 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23515 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23516 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23517 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23518 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23519 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23520 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23521 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
23522 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, | |
23523 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, | |
23524 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ | |
23525 | DATA (DL(K),K= 3061, 3145) / | |
23526 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, | |
23527 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, | |
23528 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, | |
23529 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, | |
23530 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, | |
23531 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, | |
23532 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, | |
23533 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, | |
23534 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, | |
23535 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, | |
23536 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, | |
23537 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, | |
23538 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, | |
23539 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, | |
23540 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, | |
23541 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, | |
23542 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ | |
23543 | DATA (DL(K),K= 3146, 3230) / | |
23544 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, | |
23545 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, | |
23546 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, | |
23547 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23548 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23549 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23550 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23551 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23552 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23553 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23554 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23555 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
23556 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, | |
23557 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, | |
23558 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, | |
23559 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, | |
23560 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ | |
23561 | DATA (DL(K),K= 3231, 3315) / | |
23562 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, | |
23563 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, | |
23564 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, | |
23565 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, | |
23566 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, | |
23567 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, | |
23568 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, | |
23569 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, | |
23570 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, | |
23571 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, | |
23572 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, | |
23573 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, | |
23574 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, | |
23575 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, | |
23576 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, | |
23577 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, | |
23578 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ | |
23579 | DATA (DL(K),K= 3316, 3400) / | |
23580 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, | |
23581 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23582 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23583 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23584 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23585 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23586 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23587 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23588 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23589 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, | |
23590 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, | |
23591 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, | |
23592 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, | |
23593 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, | |
23594 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, | |
23595 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, | |
23596 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ | |
23597 | DATA (DL(K),K= 3401, 3485) / | |
23598 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, | |
23599 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, | |
23600 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, | |
23601 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, | |
23602 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, | |
23603 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, | |
23604 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, | |
23605 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, | |
23606 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, | |
23607 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, | |
23608 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, | |
23609 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, | |
23610 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, | |
23611 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, | |
23612 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, | |
23613 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, | |
23614 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23615 | DATA (DL(K),K= 3486, 3570) / | |
23616 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23617 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23618 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23619 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23620 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23621 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23622 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23623 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, | |
23624 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, | |
23625 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, | |
23626 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, | |
23627 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, | |
23628 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, | |
23629 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, | |
23630 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, | |
23631 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, | |
23632 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ | |
23633 | DATA (DL(K),K= 3571, 3655) / | |
23634 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, | |
23635 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, | |
23636 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, | |
23637 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, | |
23638 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, | |
23639 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, | |
23640 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, | |
23641 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, | |
23642 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, | |
23643 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, | |
23644 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, | |
23645 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, | |
23646 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, | |
23647 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, | |
23648 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23649 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23650 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23651 | DATA (DL(K),K= 3656, 3740) / | |
23652 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23653 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23654 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23655 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23656 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23657 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
23658 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, | |
23659 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, | |
23660 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, | |
23661 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, | |
23662 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, | |
23663 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, | |
23664 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, | |
23665 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, | |
23666 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, | |
23667 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, | |
23668 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ | |
23669 | DATA (DL(K),K= 3741, 3825) / | |
23670 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, | |
23671 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, | |
23672 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, | |
23673 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, | |
23674 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, | |
23675 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, | |
23676 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, | |
23677 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, | |
23678 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, | |
23679 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, | |
23680 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, | |
23681 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, | |
23682 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23683 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23684 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23685 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23686 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23687 | DATA (DL(K),K= 3826, 3910) / | |
23688 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
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.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
23692 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, | |
23693 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, | |
23694 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, | |
23695 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, | |
23696 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, | |
23697 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, | |
23698 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, | |
23699 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, | |
23700 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, | |
23701 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, | |
23702 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, | |
23703 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, | |
23704 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ | |
23705 | DATA (DL(K),K= 3911, 3995) / | |
23706 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, | |
23707 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, | |
23708 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, | |
23709 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, | |
23710 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, | |
23711 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, | |
23712 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, | |
23713 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, | |
23714 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, | |
23715 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, | |
23716 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23717 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23718 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23719 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23720 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23721 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23722 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23723 | DATA (DL(K),K= 3996, 4000) / | |
23724 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23725 | C | |
23726 | ANS = 0. | |
23727 | IF (X.GT.0.9985) RETURN | |
23728 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
23729 | C | |
23730 | IS = S/DELTA+1 | |
23731 | IS1 = IS+1 | |
23732 | DO 1 L=1,25 | |
23733 | KL = L+NDRV*25 | |
23734 | F1(L) = GF(I,IS,KL) | |
23735 | F2(L) = GF(I,IS1,KL) | |
23736 | 1 CONTINUE | |
23737 | A1 = DT_CKMTFF(X,F1) | |
23738 | A2 = DT_CKMTFF(X,F2) | |
23739 | C A1=ALOG(A1) | |
23740 | C A2=ALOG(A2) | |
23741 | S1 = (IS-1)*DELTA | |
23742 | S2 = S1+DELTA | |
23743 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
23744 | C ANS=EXP(ANS) | |
23745 | RETURN | |
23746 | END | |
23747 | C | |
23748 | C | |
23749 | ||
23750 | *$ CREATE DT_CKMTPR.FOR | |
23751 | *COPY DT_CKMTPR | |
23752 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) | |
23753 | C | |
23754 | C********************************************************************** | |
23755 | C Proton - PDFs | |
23756 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
23757 | C ANS = PDF(I) | |
23758 | C This version by S. Roesler, 31.01.96 | |
23759 | C********************************************************************** | |
23760 | ||
23761 | SAVE | |
23762 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
23763 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
23764 | DATA DELTA/.10/ | |
23765 | C | |
23766 | DATA (DL(K),K= 1, 85) / | |
23767 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
23768 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, | |
23769 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, | |
23770 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, | |
23771 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, | |
23772 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, | |
23773 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, | |
23774 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, | |
23775 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, | |
23776 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, | |
23777 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, | |
23778 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, | |
23779 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, | |
23780 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, | |
23781 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, | |
23782 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, | |
23783 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ | |
23784 | DATA (DL(K),K= 86, 170) / | |
23785 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, | |
23786 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, | |
23787 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, | |
23788 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, | |
23789 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, | |
23790 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, | |
23791 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, | |
23792 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, | |
23793 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, | |
23794 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, | |
23795 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, | |
23796 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, | |
23797 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, | |
23798 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23799 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23800 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
23801 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ | |
23802 | DATA (DL(K),K= 171, 255) / | |
23803 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, | |
23804 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, | |
23805 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, | |
23806 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, | |
23807 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, | |
23808 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, | |
23809 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, | |
23810 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, | |
23811 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, | |
23812 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, | |
23813 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, | |
23814 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, | |
23815 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, | |
23816 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, | |
23817 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, | |
23818 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, | |
23819 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ | |
23820 | DATA (DL(K),K= 256, 340) / | |
23821 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, | |
23822 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, | |
23823 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, | |
23824 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, | |
23825 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, | |
23826 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, | |
23827 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, | |
23828 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, | |
23829 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, | |
23830 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, | |
23831 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, | |
23832 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23833 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23834 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
23835 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, | |
23836 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, | |
23837 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ | |
23838 | DATA (DL(K),K= 341, 425) / | |
23839 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, | |
23840 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, | |
23841 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, | |
23842 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, | |
23843 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, | |
23844 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, | |
23845 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, | |
23846 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, | |
23847 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, | |
23848 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, | |
23849 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, | |
23850 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, | |
23851 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, | |
23852 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, | |
23853 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, | |
23854 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, | |
23855 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ | |
23856 | DATA (DL(K),K= 426, 510) / | |
23857 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, | |
23858 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, | |
23859 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, | |
23860 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, | |
23861 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, | |
23862 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, | |
23863 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, | |
23864 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, | |
23865 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, | |
23866 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23867 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23868 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
23869 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, | |
23870 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, | |
23871 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, | |
23872 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, | |
23873 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ | |
23874 | DATA (DL(K),K= 511, 595) / | |
23875 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, | |
23876 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, | |
23877 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, | |
23878 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, | |
23879 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, | |
23880 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, | |
23881 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, | |
23882 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, | |
23883 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, | |
23884 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, | |
23885 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, | |
23886 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, | |
23887 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, | |
23888 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, | |
23889 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, | |
23890 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, | |
23891 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ | |
23892 | DATA (DL(K),K= 596, 680) / | |
23893 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, | |
23894 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, | |
23895 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, | |
23896 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, | |
23897 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, | |
23898 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, | |
23899 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, | |
23900 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23901 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23902 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23903 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, | |
23904 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, | |
23905 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, | |
23906 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, | |
23907 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, | |
23908 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, | |
23909 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ | |
23910 | DATA (DL(K),K= 681, 765) / | |
23911 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, | |
23912 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, | |
23913 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, | |
23914 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, | |
23915 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, | |
23916 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, | |
23917 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, | |
23918 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, | |
23919 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, | |
23920 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, | |
23921 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, | |
23922 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, | |
23923 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, | |
23924 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, | |
23925 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, | |
23926 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, | |
23927 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ | |
23928 | DATA (DL(K),K= 766, 850) / | |
23929 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, | |
23930 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, | |
23931 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, | |
23932 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, | |
23933 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, | |
23934 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23935 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23936 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23937 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, | |
23938 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, | |
23939 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, | |
23940 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, | |
23941 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, | |
23942 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, | |
23943 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, | |
23944 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, | |
23945 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ | |
23946 | DATA (DL(K),K= 851, 935) / | |
23947 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, | |
23948 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, | |
23949 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, | |
23950 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, | |
23951 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, | |
23952 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, | |
23953 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, | |
23954 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, | |
23955 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, | |
23956 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, | |
23957 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, | |
23958 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, | |
23959 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, | |
23960 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, | |
23961 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, | |
23962 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, | |
23963 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ | |
23964 | DATA (DL(K),K= 936, 1020) / | |
23965 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, | |
23966 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, | |
23967 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, | |
23968 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23969 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23970 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23971 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, | |
23972 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, | |
23973 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, | |
23974 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, | |
23975 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, | |
23976 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, | |
23977 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, | |
23978 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, | |
23979 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, | |
23980 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, | |
23981 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ | |
23982 | DATA (DL(K),K= 1021, 1105) / | |
23983 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, | |
23984 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, | |
23985 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, | |
23986 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, | |
23987 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, | |
23988 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, | |
23989 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, | |
23990 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, | |
23991 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, | |
23992 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, | |
23993 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, | |
23994 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, | |
23995 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, | |
23996 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, | |
23997 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, | |
23998 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, | |
23999 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ | |
24000 | DATA (DL(K),K= 1106, 1190) / | |
24001 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, | |
24002 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
24003 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24004 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
24005 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, | |
24006 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, | |
24007 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, | |
24008 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, | |
24009 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, | |
24010 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, | |
24011 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, | |
24012 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, | |
24013 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, | |
24014 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, | |
24015 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, | |
24016 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, | |
24017 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ | |
24018 | DATA (DL(K),K= 1191, 1275) / | |
24019 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, | |
24020 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, | |
24021 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, | |
24022 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, | |
24023 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, | |
24024 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, | |
24025 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, | |
24026 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, | |
24027 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, | |
24028 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, | |
24029 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, | |
24030 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, | |
24031 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, | |
24032 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, | |
24033 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, | |
24034 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, | |
24035 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24036 | DATA (DL(K),K= 1276, 1360) / | |
24037 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24038 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
24039 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, | |
24040 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, | |
24041 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, | |
24042 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, | |
24043 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, | |
24044 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, | |
24045 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, | |
24046 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, | |
24047 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, | |
24048 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, | |
24049 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, | |
24050 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, | |
24051 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, | |
24052 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, | |
24053 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ | |
24054 | DATA (DL(K),K= 1361, 1445) / | |
24055 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, | |
24056 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, | |
24057 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, | |
24058 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, | |
24059 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, | |
24060 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, | |
24061 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, | |
24062 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, | |
24063 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, | |
24064 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, | |
24065 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, | |
24066 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, | |
24067 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, | |
24068 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, | |
24069 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
24070 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24071 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
24072 | DATA (DL(K),K= 1446, 1530) / | |
24073 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, | |
24074 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, | |
24075 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, | |
24076 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, | |
24077 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, | |
24078 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, | |
24079 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, | |
24080 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, | |
24081 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, | |
24082 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, | |
24083 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, | |
24084 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, | |
24085 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, | |
24086 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, | |
24087 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, | |
24088 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, | |
24089 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ | |
24090 | DATA (DL(K),K= 1531, 1615) / | |
24091 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, | |
24092 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, | |
24093 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, | |
24094 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, | |
24095 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, | |
24096 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, | |
24097 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, | |
24098 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, | |
24099 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, | |
24100 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, | |
24101 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, | |
24102 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, | |
24103 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24104 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24105 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
24106 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, | |
24107 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ | |
24108 | DATA (DL(K),K= 1616, 1700) / | |
24109 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, | |
24110 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, | |
24111 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, | |
24112 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, | |
24113 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, | |
24114 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, | |
24115 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, | |
24116 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, | |
24117 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, | |
24118 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, | |
24119 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, | |
24120 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, | |
24121 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, | |
24122 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, | |
24123 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, | |
24124 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, | |
24125 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ | |
24126 | DATA (DL(K),K= 1701, 1785) / | |
24127 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, | |
24128 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, | |
24129 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, | |
24130 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, | |
24131 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, | |
24132 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, | |
24133 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, | |
24134 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, | |
24135 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, | |
24136 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, | |
24137 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24138 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24139 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
24140 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, | |
24141 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, | |
24142 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, | |
24143 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ | |
24144 | DATA (DL(K),K= 1786, 1870) / | |
24145 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, | |
24146 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, | |
24147 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, | |
24148 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, | |
24149 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, | |
24150 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, | |
24151 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, | |
24152 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, | |
24153 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, | |
24154 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, | |
24155 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, | |
24156 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, | |
24157 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, | |
24158 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, | |
24159 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, | |
24160 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, | |
24161 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ | |
24162 | DATA (DL(K),K= 1871, 1955) / | |
24163 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, | |
24164 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, | |
24165 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, | |
24166 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, | |
24167 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, | |
24168 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, | |
24169 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, | |
24170 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, | |
24171 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24172 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24173 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
24174 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, | |
24175 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, | |
24176 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, | |
24177 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, | |
24178 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, | |
24179 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ | |
24180 | DATA (DL(K),K= 1956, 2040) / | |
24181 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, | |
24182 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, | |
24183 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, | |
24184 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, | |
24185 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, | |
24186 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, | |
24187 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, | |
24188 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, | |
24189 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, | |
24190 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, | |
24191 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, | |
24192 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, | |
24193 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, | |
24194 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, | |
24195 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, | |
24196 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, | |
24197 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ | |
24198 | DATA (DL(K),K= 2041, 2125) / | |
24199 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, | |
24200 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, | |
24201 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, | |
24202 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, | |
24203 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, | |
24204 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, | |
24205 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24206 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24207 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
24208 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, | |
24209 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, | |
24210 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, | |
24211 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, | |
24212 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, | |
24213 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, | |
24214 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, | |
24215 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ | |
24216 | DATA (DL(K),K= 2126, 2210) / | |
24217 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, | |
24218 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, | |
24219 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, | |
24220 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, | |
24221 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, | |
24222 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, | |
24223 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, | |
24224 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, | |
24225 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, | |
24226 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, | |
24227 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, | |
24228 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, | |
24229 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, | |
24230 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, | |
24231 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, | |
24232 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, | |
24233 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ | |
24234 | DATA (DL(K),K= 2211, 2295) / | |
24235 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, | |
24236 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, | |
24237 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, | |
24238 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, | |
24239 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24240 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24241 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
24242 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, | |
24243 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, | |
24244 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, | |
24245 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, | |
24246 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, | |
24247 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, | |
24248 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, | |
24249 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, | |
24250 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, | |
24251 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ | |
24252 | DATA (DL(K),K= 2296, 2380) / | |
24253 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, | |
24254 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, | |
24255 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, | |
24256 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, | |
24257 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, | |
24258 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, | |
24259 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, | |
24260 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, | |
24261 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, | |
24262 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, | |
24263 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, | |
24264 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, | |
24265 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, | |
24266 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, | |
24267 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, | |
24268 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, | |
24269 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ | |
24270 | DATA (DL(K),K= 2381, 2465) / | |
24271 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, | |
24272 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, | |
24273 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24274 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24275 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
24276 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, | |
24277 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, | |
24278 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, | |
24279 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, | |
24280 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, | |
24281 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, | |
24282 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, | |
24283 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, | |
24284 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, | |
24285 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, | |
24286 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, | |
24287 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ | |
24288 | DATA (DL(K),K= 2466, 2550) / | |
24289 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, | |
24290 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, | |
24291 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, | |
24292 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, | |
24293 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, | |
24294 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, | |
24295 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, | |
24296 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, | |
24297 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, | |
24298 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, | |
24299 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, | |
24300 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, | |
24301 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, | |
24302 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, | |
24303 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, | |
24304 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, | |
24305 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ | |
24306 | DATA (DL(K),K= 2551, 2635) / | |
24307 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24308 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24309 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, | |
24310 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, | |
24311 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, | |
24312 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, | |
24313 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, | |
24314 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, | |
24315 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, | |
24316 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, | |
24317 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, | |
24318 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, | |
24319 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, | |
24320 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, | |
24321 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, | |
24322 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, | |
24323 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ | |
24324 | DATA (DL(K),K= 2636, 2720) / | |
24325 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, | |
24326 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, | |
24327 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, | |
24328 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, | |
24329 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, | |
24330 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, | |
24331 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, | |
24332 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, | |
24333 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, | |
24334 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, | |
24335 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, | |
24336 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, | |
24337 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, | |
24338 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, | |
24339 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, | |
24340 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24341 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24342 | DATA (DL(K),K= 2721, 2805) / | |
24343 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, | |
24344 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, | |
24345 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, | |
24346 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, | |
24347 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, | |
24348 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, | |
24349 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, | |
24350 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, | |
24351 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, | |
24352 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, | |
24353 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, | |
24354 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, | |
24355 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, | |
24356 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, | |
24357 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, | |
24358 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, | |
24359 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ | |
24360 | DATA (DL(K),K= 2806, 2890) / | |
24361 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, | |
24362 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, | |
24363 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, | |
24364 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, | |
24365 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, | |
24366 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, | |
24367 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, | |
24368 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, | |
24369 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, | |
24370 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, | |
24371 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, | |
24372 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, | |
24373 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, | |
24374 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24375 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24376 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, | |
24377 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ | |
24378 | DATA (DL(K),K= 2891, 2975) / | |
24379 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, | |
24380 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, | |
24381 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, | |
24382 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, | |
24383 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, | |
24384 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, | |
24385 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, | |
24386 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, | |
24387 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, | |
24388 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, | |
24389 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, | |
24390 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, | |
24391 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, | |
24392 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, | |
24393 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, | |
24394 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, | |
24395 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ | |
24396 | DATA (DL(K),K= 2976, 3060) / | |
24397 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, | |
24398 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, | |
24399 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, | |
24400 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, | |
24401 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, | |
24402 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, | |
24403 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, | |
24404 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, | |
24405 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, | |
24406 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, | |
24407 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, | |
24408 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24409 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24410 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
24411 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, | |
24412 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, | |
24413 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ | |
24414 | DATA (DL(K),K= 3061, 3145) / | |
24415 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, | |
24416 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, | |
24417 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, | |
24418 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, | |
24419 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, | |
24420 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, | |
24421 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, | |
24422 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, | |
24423 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, | |
24424 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, | |
24425 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, | |
24426 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, | |
24427 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, | |
24428 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, | |
24429 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, | |
24430 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, | |
24431 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ | |
24432 | DATA (DL(K),K= 3146, 3230) / | |
24433 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, | |
24434 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, | |
24435 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, | |
24436 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, | |
24437 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, | |
24438 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, | |
24439 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, | |
24440 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, | |
24441 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, | |
24442 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24443 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24444 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
24445 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, | |
24446 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, | |
24447 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, | |
24448 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, | |
24449 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ | |
24450 | DATA (DL(K),K= 3231, 3315) / | |
24451 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, | |
24452 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, | |
24453 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, | |
24454 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, | |
24455 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, | |
24456 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, | |
24457 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, | |
24458 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, | |
24459 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, | |
24460 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, | |
24461 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, | |
24462 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, | |
24463 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, | |
24464 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, | |
24465 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, | |
24466 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, | |
24467 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ | |
24468 | DATA (DL(K),K= 3316, 3400) / | |
24469 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, | |
24470 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, | |
24471 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, | |
24472 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, | |
24473 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, | |
24474 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, | |
24475 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, | |
24476 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24477 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24478 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, | |
24479 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, | |
24480 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, | |
24481 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, | |
24482 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, | |
24483 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, | |
24484 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, | |
24485 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ | |
24486 | DATA (DL(K),K= 3401, 3485) / | |
24487 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, | |
24488 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, | |
24489 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, | |
24490 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, | |
24491 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, | |
24492 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, | |
24493 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, | |
24494 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, | |
24495 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, | |
24496 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, | |
24497 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, | |
24498 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, | |
24499 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, | |
24500 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, | |
24501 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, | |
24502 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, | |
24503 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ | |
24504 | DATA (DL(K),K= 3486, 3570) / | |
24505 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, | |
24506 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, | |
24507 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, | |
24508 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, | |
24509 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, | |
24510 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24511 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24512 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, | |
24513 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, | |
24514 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, | |
24515 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, | |
24516 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, | |
24517 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, | |
24518 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, | |
24519 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, | |
24520 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, | |
24521 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ | |
24522 | DATA (DL(K),K= 3571, 3655) / | |
24523 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, | |
24524 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, | |
24525 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, | |
24526 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, | |
24527 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, | |
24528 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, | |
24529 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, | |
24530 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, | |
24531 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, | |
24532 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, | |
24533 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, | |
24534 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, | |
24535 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, | |
24536 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, | |
24537 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, | |
24538 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, | |
24539 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ | |
24540 | DATA (DL(K),K= 3656, 3740) / | |
24541 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, | |
24542 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, | |
24543 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, | |
24544 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, | |
24545 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24546 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
24547 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, | |
24548 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, | |
24549 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, | |
24550 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, | |
24551 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, | |
24552 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, | |
24553 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, | |
24554 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, | |
24555 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, | |
24556 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, | |
24557 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ | |
24558 | DATA (DL(K),K= 3741, 3825) / | |
24559 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, | |
24560 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, | |
24561 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, | |
24562 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, | |
24563 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, | |
24564 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, | |
24565 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, | |
24566 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, | |
24567 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, | |
24568 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, | |
24569 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, | |
24570 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, | |
24571 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, | |
24572 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, | |
24573 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, | |
24574 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, | |
24575 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ | |
24576 | DATA (DL(K),K= 3826, 3910) / | |
24577 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, | |
24578 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, | |
24579 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24580 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
24581 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, | |
24582 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, | |
24583 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, | |
24584 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, | |
24585 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, | |
24586 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, | |
24587 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, | |
24588 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, | |
24589 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, | |
24590 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, | |
24591 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, | |
24592 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, | |
24593 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ | |
24594 | DATA (DL(K),K= 3911, 3995) / | |
24595 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, | |
24596 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, | |
24597 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, | |
24598 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, | |
24599 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, | |
24600 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, | |
24601 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, | |
24602 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, | |
24603 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, | |
24604 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, | |
24605 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, | |
24606 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, | |
24607 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, | |
24608 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, | |
24609 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, | |
24610 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, | |
24611 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24612 | DATA (DL(K),K= 3996, 4000) / | |
24613 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24614 | C | |
24615 | ANS = 0. | |
24616 | IF (X.GT.0.9985) RETURN | |
24617 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
24618 | C | |
24619 | IS = S/DELTA+1 | |
24620 | IS1 = IS+1 | |
24621 | DO 1 L=1,25 | |
24622 | KL = L+NDRV*25 | |
24623 | F1(L) = GF(I,IS,KL) | |
24624 | F2(L) = GF(I,IS1,KL) | |
24625 | 1 CONTINUE | |
24626 | A1 = DT_CKMTFF(X,F1) | |
24627 | A2 = DT_CKMTFF(X,F2) | |
24628 | C A1=ALOG(A1) | |
24629 | C A2=ALOG(A2) | |
24630 | S1 = (IS-1)*DELTA | |
24631 | S2 = S1+DELTA | |
24632 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
24633 | C ANS=EXP(ANS) | |
24634 | RETURN | |
24635 | END | |
24636 | C | |
24637 | ||
24638 | *$ CREATE DT_CKMTFF.FOR | |
24639 | *COPY DT_CKMTFF | |
24640 | FUNCTION DT_CKMTFF(X,FVL) | |
24641 | C********************************************************************** | |
24642 | C | |
24643 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE | |
24644 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. | |
24645 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED | |
24646 | C IN MAIN ROUTINE. | |
24647 | C | |
24648 | C********************************************************************** | |
24649 | ||
24650 | SAVE | |
24651 | DIMENSION FVL(25),XGRID(25) | |
24652 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, | |
24653 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ | |
24654 | C | |
24655 | DT_CKMTFF=0. | |
24656 | DO 1 I=1,NX | |
24657 | IF(X.LT.XGRID(I)) GO TO 2 | |
24658 | 1 CONTINUE | |
24659 | 2 I=I-1 | |
24660 | IF(I.EQ.0) THEN | |
24661 | I=I+1 | |
24662 | ELSE IF(I.GT.23) THEN | |
24663 | I=23 | |
24664 | ENDIF | |
24665 | J=I+1 | |
24666 | K=J+1 | |
24667 | AXI=LOG(XGRID(I)) | |
24668 | BXI=LOG(1.-XGRID(I)) | |
24669 | AXJ=LOG(XGRID(J)) | |
24670 | BXJ=LOG(1.-XGRID(J)) | |
24671 | AXK=LOG(XGRID(K)) | |
24672 | BXK=LOG(1.-XGRID(K)) | |
24673 | FI=LOG(ABS(FVL(I)) +1.E-15) | |
24674 | FJ=LOG(ABS(FVL(J)) +1.E-16) | |
24675 | FK=LOG(ABS(FVL(K)) +1.E-17) | |
24676 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) | |
24677 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* | |
24678 | $ BXI))/DET | |
24679 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET | |
24680 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET | |
24681 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) | |
24682 | 1RETURN | |
24683 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN | |
24684 | C WRITE(6,2001) X,FVL | |
24685 | C 2001 FORMAT(8E12.4) | |
24686 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET | |
24687 | C ENDIF | |
24688 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA | |
24689 | RETURN | |
24690 | END | |
24691 | ||
24692 | *$ CREATE DT_FLUINI.FOR | |
24693 | *COPY DT_FLUINI | |
24694 | * | |
24695 | *===fluini=============================================================* | |
24696 | * | |
24697 | SUBROUTINE DT_FLUINI | |
24698 | ||
24699 | ************************************************************************ | |
24700 | * Initialisation of the nucleon-nucleon cross section fluctuation * | |
24701 | * treatment. The original version by J. Ranft. * | |
24702 | * This version dated 21.04.95 is revised by S. Roesler. * | |
24703 | ************************************************************************ | |
24704 | ||
24705 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24706 | SAVE | |
24707 | PARAMETER ( LINP = 10 , | |
24708 | & LOUT = 6 , | |
24709 | & LDAT = 9 ) | |
24710 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
24711 | ||
24712 | PARAMETER ( A = 0.1D0, | |
24713 | & B = 0.893D0, | |
24714 | & OM = 1.1D0, | |
24715 | & N = 6, | |
24716 | & DX = 0.003D0) | |
24717 | ||
24718 | * n-n cross section fluctuations | |
24719 | PARAMETER (NBINS = 1000) | |
24720 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
24721 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) | |
24722 | ||
24723 | WRITE(LOUT,1000) | |
24724 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', | |
24725 | & 'treated') | |
24726 | ||
24727 | FLUSU = ZERO | |
24728 | FLUSUU = ZERO | |
24729 | ||
24730 | DO 1 I=1,NBINS | |
24731 | X = DBLE(I)*DX | |
24732 | FLUIX(I) = X | |
24733 | FLUS = ((X-B)/(OM*B))**N | |
24734 | IF (FLUS.LE.20.0D0) THEN | |
24735 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) | |
24736 | ELSE | |
24737 | FLUSI(I) = ZERO | |
24738 | ENDIF | |
24739 | FLUSU = FLUSU+FLUSI(I) | |
24740 | 1 CONTINUE | |
24741 | DO 2 I=1,NBINS | |
24742 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU | |
24743 | FLUSI(I) = FLUSUU | |
24744 | 2 CONTINUE | |
24745 | ||
24746 | C WRITE(LOUT,1001) | |
24747 | C1001 FORMAT(1X,'FLUCTUATIONS') | |
24748 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) | |
24749 | ||
24750 | DO 3 I=1,NBINS | |
24751 | AF = DBLE(I)*0.001D0 | |
24752 | DO 4 J=1,NBINS | |
24753 | IF (AF.LE.FLUSI(J)) THEN | |
24754 | FLUIXX(I) = FLUIX(J) | |
24755 | GOTO 5 | |
24756 | ENDIF | |
24757 | 4 CONTINUE | |
24758 | 5 CONTINUE | |
24759 | 3 CONTINUE | |
24760 | FLUIXX(1) = FLUIX(1) | |
24761 | FLUIXX(NBINS) = FLUIX(NBINS) | |
24762 | ||
24763 | RETURN | |
24764 | END | |
24765 | ||
24766 | *$ CREATE DT_SIGTBL.FOR | |
24767 | *COPY DT_SIGTBL | |
24768 | * | |
24769 | *===sigtab=============================================================* | |
24770 | * | |
24771 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) | |
24772 | ||
24773 | ************************************************************************ | |
24774 | * This version dated 18.11.95 is written by S. Roesler * | |
24775 | ************************************************************************ | |
24776 | ||
24777 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24778 | SAVE | |
24779 | PARAMETER ( LINP = 10 , | |
24780 | & LOUT = 6 , | |
24781 | & LDAT = 9 ) | |
24782 | ||
24783 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24784 | & OHALF=0.5D0,ONE=1.0D0) | |
24785 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) | |
24786 | ||
24787 | LOGICAL LINIT | |
24788 | ||
24789 | * particle properties (BAMJET index convention) | |
24790 | CHARACTER*8 ANAME | |
24791 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24792 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24793 | ||
24794 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) | |
24795 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, | |
24796 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, | |
24797 | & 0, 0, 5/ | |
24798 | DATA LINIT /.FALSE./ | |
24799 | ||
24800 | * precalculation and tabulation of elastic cross sections | |
24801 | IF (ABS(MODE).EQ.1) THEN | |
24802 | IF (MODE.EQ.1) | |
24803 | & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN') | |
24804 | PLABLX = LOG10(PLO) | |
24805 | PLABHX = LOG10(PHI) | |
24806 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) | |
24807 | DO 1 I=1,NBINS+1 | |
24808 | PLAB = PLABLX+DBLE(I-1)*DPLAB | |
24809 | PLAB = 10**PLAB | |
24810 | DO 2 IPROJ=1,23 | |
24811 | IDX = IDSIG(IPROJ) | |
24812 | IF (IDX.GT.0) THEN | |
24813 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) | |
24814 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) | |
24815 | DUMZER = ZERO | |
24816 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) | |
24817 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) | |
24818 | ENDIF | |
24819 | 2 CONTINUE | |
24820 | IF (MODE.EQ.1) THEN | |
24821 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), | |
24822 | & (SIGEN(IDX,I),IDX=1,5) | |
24823 | 1000 FORMAT(F5.1,10F7.2) | |
24824 | ENDIF | |
24825 | 1 CONTINUE | |
24826 | IF (MODE.EQ.1) CLOSE(LDAT) | |
24827 | LINIT = .TRUE. | |
24828 | ELSE | |
24829 | SIGE = -ONE | |
24830 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) | |
24831 | & .AND.(PTOT.LE.PHI) ) THEN | |
24832 | IDX = IDSIG(JP) | |
24833 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN | |
24834 | PLABX = LOG10(PTOT) | |
24835 | IF (PLABX.LE.PLABLX) THEN | |
24836 | I1 = 1 | |
24837 | I2 = 1 | |
24838 | ELSEIF (PLABX.GE.PLABHX) THEN | |
24839 | I1 = NBINS+1 | |
24840 | I2 = NBINS+1 | |
24841 | ELSE | |
24842 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 | |
24843 | I2 = I1+1 | |
24844 | ENDIF | |
24845 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB | |
24846 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB | |
24847 | PBIN = PLAB2X-PLAB1X | |
24848 | IF (PBIN.GT.TINY10) THEN | |
24849 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) | |
24850 | ELSE | |
24851 | RATX = ZERO | |
24852 | ENDIF | |
24853 | IF (JT.EQ.1) THEN | |
24854 | SIG1 = SIGEP(IDX,I1) | |
24855 | SIG2 = SIGEP(IDX,I2) | |
24856 | ELSE | |
24857 | SIG1 = SIGEN(IDX,I1) | |
24858 | SIG2 = SIGEN(IDX,I2) | |
24859 | ENDIF | |
24860 | SIGE = SIG1+RATX*(SIG2-SIG1) | |
24861 | ENDIF | |
24862 | ENDIF | |
24863 | ENDIF | |
24864 | ||
24865 | RETURN | |
24866 | END | |
24867 | ||
24868 | *$ CREATE DT_XSTABL.FOR | |
24869 | *COPY DT_XSTABL | |
24870 | * | |
24871 | *===xstabl=============================================================* | |
24872 | * | |
24873 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
24874 | ||
24875 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24876 | SAVE | |
24877 | PARAMETER ( LINP = 10 , | |
24878 | & LOUT = 6 , | |
24879 | & LDAT = 9 ) | |
24880 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24881 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) | |
24882 | LOGICAL LLAB,LELOG,LQLOG | |
24883 | ||
24884 | * particle properties (BAMJET index convention) | |
24885 | CHARACTER*8 ANAME | |
24886 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24887 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24888 | * properties of interacting particles | |
24889 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
24890 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
24891 | * Glauber formalism: cross sections | |
24892 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
24893 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
24894 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
24895 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
24896 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
24897 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
24898 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
24899 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
24900 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
24901 | & BSLOPE,NEBINI,NQBINI | |
24902 | * emulsion treatment | |
24903 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
24904 | & NCOMPO,IEMUL | |
24905 | ||
24906 | DIMENSION WHAT(6) | |
24907 | ||
24908 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) | |
24909 | ELO = ABS(WHAT(1)) | |
24910 | EHI = ABS(WHAT(2)) | |
24911 | IF (ELO.GT.EHI) ELO = EHI | |
24912 | LELOG = WHAT(3).LT.ZERO | |
24913 | NEBINS = MAX(INT(ABS(WHAT(3))),1) | |
24914 | DEBINS = (EHI-ELO)/DBLE(NEBINS) | |
24915 | IF (LELOG) THEN | |
24916 | AELO = LOG10(ELO) | |
24917 | AEHI = LOG10(EHI) | |
24918 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) | |
24919 | ENDIF | |
24920 | Q2LO = WHAT(4) | |
24921 | Q2HI = WHAT(5) | |
24922 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI | |
24923 | LQLOG = WHAT(6).LT.ZERO | |
24924 | NQBINS = MAX(INT(ABS(WHAT(6))),1) | |
24925 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) | |
24926 | IF (LQLOG) THEN | |
24927 | AQ2LO = LOG10(Q2LO) | |
24928 | AQ2HI = LOG10(Q2HI) | |
24929 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) | |
24930 | ENDIF | |
24931 | ||
24932 | IF ( ELO.EQ. EHI) NEBINS = 0 | |
24933 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 | |
24934 | ||
24935 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT | |
24936 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, | |
24937 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, | |
24938 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, | |
24939 | & ' A_p = ',I3,' A_t = ',I3,/) | |
24940 | ||
24941 | C IF (IJPROJ.NE.7) THEN | |
24942 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' | |
24943 | * normalize fractions of emulsion components | |
24944 | IF (NCOMPO.GT.0) THEN | |
24945 | SUMFRA = ZERO | |
24946 | DO 10 I=1,NCOMPO | |
24947 | SUMFRA = SUMFRA+EMUFRA(I) | |
24948 | 10 CONTINUE | |
24949 | IF (SUMFRA.GT.ZERO) THEN | |
24950 | DO 11 I=1,NCOMPO | |
24951 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
24952 | 11 CONTINUE | |
24953 | ENDIF | |
24954 | ENDIF | |
24955 | C ELSE | |
24956 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' | |
24957 | C ENDIF | |
24958 | DO 1 I=1,NEBINS+1 | |
24959 | IF (LELOG) THEN | |
24960 | E = 10**(AELO+DBLE(I-1)*ADEBIN) | |
24961 | ELSE | |
24962 | E = ELO+DBLE(I-1)*DEBINS | |
24963 | ENDIF | |
24964 | DO 2 J=1,NQBINS+1 | |
24965 | IF (LQLOG) THEN | |
24966 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) | |
24967 | ELSE | |
24968 | Q2 = Q2LO+DBLE(J-1)*DQBINS | |
24969 | ENDIF | |
24970 | c IF (IJPROJ.NE.7) THEN | |
24971 | IF (LLAB) THEN | |
24972 | PLAB = ZERO | |
24973 | ECM = ZERO | |
24974 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) | |
24975 | ELSE | |
24976 | ECM = E | |
24977 | ENDIF | |
24978 | XI = ZERO | |
24979 | Q2I = ZERO | |
24980 | IF (IJPROJ.EQ.7) Q2I = Q2 | |
24981 | IF (NCOMPO.GT.0) THEN | |
24982 | DO 20 IC=1,NCOMPO | |
24983 | IIT = IEMUMA(IC) | |
24984 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) | |
24985 | 20 CONTINUE | |
24986 | ELSE | |
24987 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) | |
24988 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) | |
24989 | ENDIF | |
24990 | IF (NCOMPO.GT.0) THEN | |
24991 | XTOT = ZERO | |
24992 | ETOT = ZERO | |
24993 | XELA = ZERO | |
24994 | EELA = ZERO | |
24995 | XQEP = ZERO | |
24996 | EQEP = ZERO | |
24997 | XQET = ZERO | |
24998 | EQET = ZERO | |
24999 | XQE2 = ZERO | |
25000 | EQE2 = ZERO | |
25001 | XPRO = ZERO | |
25002 | EPRO = ZERO | |
25003 | XPRO1= ZERO | |
25004 | XDEL = ZERO | |
25005 | EDEL = ZERO | |
25006 | XDQE = ZERO | |
25007 | EDQE = ZERO | |
25008 | DO 21 IC=1,NCOMPO | |
25009 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) | |
25010 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 | |
25011 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) | |
25012 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 | |
25013 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) | |
25014 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 | |
25015 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) | |
25016 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 | |
25017 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) | |
25018 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 | |
25019 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) | |
25020 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 | |
25021 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) | |
25022 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 | |
25023 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) | |
25024 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 | |
25025 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) | |
25026 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) | |
25027 | & -XSQE2(1,1,IC) | |
25028 | XPRO1= XPRO1+EMUFRA(IC)*YPRO | |
25029 | 21 CONTINUE | |
25030 | ETOT = SQRT(ETOT) | |
25031 | EELA = SQRT(EELA) | |
25032 | EQEP = SQRT(EQEP) | |
25033 | EQET = SQRT(EQET) | |
25034 | EQE2 = SQRT(EQE2) | |
25035 | EPRO = SQRT(EPRO) | |
25036 | EDEL = SQRT(EDEL) | |
25037 | EDQE = SQRT(EDQE) | |
25038 | WRITE(LOUT,'(8E9.3)') | |
25039 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 | |
25040 | C WRITE(LOUT,'(4E9.3)') | |
25041 | C & E,XDEL,XDQE,XDEL+XDQE | |
25042 | ELSE | |
25043 | WRITE(LOUT,'(11E10.3)') | |
25044 | & E, | |
25045 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), | |
25046 | & XSQE2(1,1,1),XSPRO(1,1,1), | |
25047 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) | |
25048 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), | |
25049 | & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25050 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), | |
25051 | C & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25052 | ENDIF | |
25053 | c ELSE | |
25054 | c IF (LLAB) THEN | |
25055 | c IF (IT.GT.1) THEN | |
25056 | c IF (IXSQEL.EQ.0) THEN | |
25057 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, | |
25058 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, | |
25059 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, | |
25060 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25061 | c IF (IRATIO.EQ.1) THEN | |
25062 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) | |
25063 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) | |
25064 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) | |
25065 | c*!! save cross sections | |
25066 | c STOTA = STOT | |
25067 | c ETOTA = ETOT | |
25068 | c STOTP = STGP | |
25069 | c*!! | |
25070 | c STOT = STOT/(DBLE(IT)*STGP) | |
25071 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25072 | c STOT0 = STGP | |
25073 | c ETOT = ZERO | |
25074 | c EIN = ZERO | |
25075 | c ENDIF | |
25076 | c ELSE | |
25077 | c WRITE(LOUT,*) | |
25078 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25079 | c STOP | |
25080 | c ENDIF | |
25081 | c ELSE | |
25082 | c ETOT = ZERO | |
25083 | c EIN = ZERO | |
25084 | c STOT0= ZERO | |
25085 | c IF (IXSQEL.EQ.0) THEN | |
25086 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) | |
25087 | c ELSE | |
25088 | c SIN = ZERO | |
25089 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) | |
25090 | c ENDIF | |
25091 | c ENDIF | |
25092 | c ELSE | |
25093 | c IF (IT.GT.1) THEN | |
25094 | c IF (IXSQEL.EQ.0) THEN | |
25095 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, | |
25096 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25097 | c IF (IRATIO.EQ.1) THEN | |
25098 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) | |
25099 | c*!! save cross sections | |
25100 | c STOTA = STOT | |
25101 | c ETOTA = ETOT | |
25102 | c STOTP = STGP | |
25103 | c*!! | |
25104 | c STOT = STOT/(DBLE(IT)*STGP) | |
25105 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25106 | c STOT0 = STGP | |
25107 | c ETOT = ZERO | |
25108 | c EIN = ZERO | |
25109 | c ENDIF | |
25110 | c ELSE | |
25111 | c WRITE(LOUT,*) | |
25112 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25113 | c STOP | |
25114 | c ENDIF | |
25115 | c ELSE | |
25116 | c ETOT = ZERO | |
25117 | c EIN = ZERO | |
25118 | c STOT0= ZERO | |
25119 | c IF (IXSQEL.EQ.0) THEN | |
25120 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) | |
25121 | c ELSE | |
25122 | c SIN = ZERO | |
25123 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) | |
25124 | c ENDIF | |
25125 | c ENDIF | |
25126 | c ENDIF | |
25127 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO | |
25128 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR | |
25129 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 | |
25130 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN | |
25131 | c ENDIF | |
25132 | 2 CONTINUE | |
25133 | 1 CONTINUE | |
25134 | ||
25135 | RETURN | |
25136 | END | |
25137 | ||
25138 | *$ CREATE DT_TESTXS.FOR | |
25139 | *COPY DT_TESTXS | |
25140 | * | |
25141 | *===testxs=============================================================* | |
25142 | * | |
25143 | SUBROUTINE DT_TESTXS | |
25144 | ||
25145 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25146 | SAVE | |
25147 | ||
25148 | DIMENSION XSTOT(26,2),XSELA(26,2) | |
25149 | ||
25150 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') | |
25151 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') | |
25152 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') | |
25153 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') | |
25154 | DUMECM = 0.0D0 | |
25155 | PLABL = 0.01D0 | |
25156 | PLABH = 10000.0D0 | |
25157 | NBINS = 120 | |
25158 | APLABL = LOG10(PLABL) | |
25159 | APLABH = LOG10(PLABH) | |
25160 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) | |
25161 | DO 1 I=1,NBINS+1 | |
25162 | ADP = APLABL+DBLE(I-1)*ADPLAB | |
25163 | P = 10.0D0**ADP | |
25164 | DO 2 J=1,26 | |
25165 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) | |
25166 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) | |
25167 | 2 CONTINUE | |
25168 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) | |
25169 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) | |
25170 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) | |
25171 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) | |
25172 | 1 CONTINUE | |
25173 | 1000 FORMAT(F8.3,26F9.3) | |
25174 | ||
25175 | RETURN | |
25176 | END | |
25177 | ||
25178 | ************************************************************************ | |
25179 | * * | |
25180 | * DTUNUC 2.0: library routines * | |
25181 | * processed by S. Roesler, 6.5.95 * | |
25182 | * * | |
25183 | ************************************************************************ | |
25184 | * | |
25185 | * 1) Handling of parton momenta | |
25186 | * SUBROUTINE MASHEL | |
25187 | * SUBROUTINE DFERMI | |
25188 | * | |
25189 | * 2) Handling of parton flavors and particle indices | |
25190 | * INTEGER FUNCTION IPDG2B | |
25191 | * INTEGER FUNCTION IB2PDG | |
25192 | * INTEGER FUNCTION IQUARK | |
25193 | * INTEGER FUNCTION IBJQUA | |
25194 | * INTEGER FUNCTION ICIHAD | |
25195 | * INTEGER FUNCTION IPDGHA | |
25196 | * INTEGER FUNCTION MCHAD | |
25197 | * SUBROUTINE FLAHAD | |
25198 | * | |
25199 | * 3) Energy-momentum and quantum number conservation check routines | |
25200 | * SUBROUTINE EMC1 | |
25201 | * SUBROUTINE EMC2 | |
25202 | * SUBROUTINE EVTEMC | |
25203 | * SUBROUTINE EVTFLC | |
25204 | * SUBROUTINE EVTCHG | |
25205 | * | |
25206 | * 4) Transformations | |
25207 | * SUBROUTINE LTINI | |
25208 | * SUBROUTINE LTRANS | |
25209 | * SUBROUTINE LTNUC | |
25210 | * SUBROUTINE DALTRA | |
25211 | * SUBROUTINE DTRAFO | |
25212 | * SUBROUTINE STTRAN | |
25213 | * SUBROUTINE MYTRAN | |
25214 | * SUBROUTINE LT2LAO | |
25215 | * SUBROUTINE LT2LAB | |
25216 | * | |
25217 | * 5) Sampling from distributions | |
25218 | * INTEGER FUNCTION NPOISS | |
25219 | * DOUBLE PRECISION FUNCTION SAMPXB | |
25220 | * DOUBLE PRECISION FUNCTION SAMPEX | |
25221 | * DOUBLE PRECISION FUNCTION SAMSQX | |
25222 | * DOUBLE PRECISION FUNCTION BETREJ | |
25223 | * DOUBLE PRECISION FUNCTION DGAMRN | |
25224 | * DOUBLE PRECISION FUNCTION DBETAR | |
25225 | * SUBROUTINE RANNOR | |
25226 | * SUBROUTINE DPOLI | |
25227 | * SUBROUTINE DSFECF | |
25228 | * SUBROUTINE RACO | |
25229 | * | |
25230 | * 6) Special functions, algorithms and service routines | |
25231 | * DOUBLE PRECISION FUNCTION YLAMB | |
25232 | * SUBROUTINE SORT | |
25233 | * SUBROUTINE SORT1 | |
25234 | * SUBROUTINE DT_XTIME | |
25235 | * | |
25236 | * 7) Random number generator package | |
25237 | * DOUBLE PRECISION FUNCTION DT_RNDM | |
25238 | * SUBROUTINE DT_RNDMST | |
25239 | * SUBROUTINE DT_RNDMIN | |
25240 | * SUBROUTINE DT_RNDMOU | |
25241 | * SUBROUTINE DT_RNDMTE | |
25242 | * | |
25243 | ************************************************************************ | |
25244 | * * | |
25245 | * 1) Handling of parton momenta * | |
25246 | * * | |
25247 | ************************************************************************ | |
25248 | *$ CREATE DT_MASHEL.FOR | |
25249 | *COPY DT_MASHEL | |
25250 | * | |
25251 | *===mashel=============================================================* | |
25252 | * | |
25253 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) | |
25254 | ||
25255 | ************************************************************************ | |
25256 | * * | |
25257 | * rescaling of momenta of two partons to put both * | |
25258 | * on mass shell * | |
25259 | * * | |
25260 | * input: PA1,PA2 input momentum vectors * | |
25261 | * XM1,2 desired masses of particles afterwards * | |
25262 | * P1,P2 changed momentum vectors * | |
25263 | * * | |
25264 | * The original version is written by R. Engel. * | |
25265 | * This version dated 12.12.94 is modified by S. Roesler. * | |
25266 | ************************************************************************ | |
25267 | ||
25268 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25269 | SAVE | |
25270 | PARAMETER ( LINP = 10 , | |
25271 | & LOUT = 6 , | |
25272 | & LDAT = 9 ) | |
25273 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
25274 | ||
25275 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
25276 | ||
25277 | IREJ = 0 | |
25278 | ||
25279 | * Lorentz transformation into system CMS | |
25280 | PX = PA1(1)+PA2(1) | |
25281 | PY = PA1(2)+PA2(2) | |
25282 | PZ = PA1(3)+PA2(3) | |
25283 | EE = PA1(4)+PA2(4) | |
25284 | XPTOT = SQRT(PX**2+PY**2+PZ**2) | |
25285 | XMS = (EE-XPTOT)*(EE+XPTOT) | |
25286 | IF(XMS.LT.(XM1+XM2)**2) THEN | |
25287 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 | |
25288 | GOTO 9999 | |
25289 | ENDIF | |
25290 | XMS = SQRT(XMS) | |
25291 | BGX = PX/XMS | |
25292 | BGY = PY/XMS | |
25293 | BGZ = PZ/XMS | |
25294 | GAM = EE/XMS | |
25295 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), | |
25296 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25297 | * rotation angles | |
25298 | COD = P1(3)/PTOT1 | |
25299 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
25300 | PPT = SQRT(P1(1)**2+P1(2)**2) | |
25301 | SID = PPT/PTOT1 | |
25302 | COF = ONE | |
25303 | SIF = ZERO | |
25304 | IF(PTOT1*SID.GT.TINY10) THEN | |
25305 | COF = P1(1)/(SID*PTOT1) | |
25306 | SIF = P1(2)/(SID*PTOT1) | |
25307 | ANORF = SQRT(COF*COF+SIF*SIF) | |
25308 | COF = COF/ANORF | |
25309 | SIF = SIF/ANORF | |
25310 | ENDIF | |
25311 | * new CM momentum and energies (for masses XM1,XM2) | |
25312 | XM12 = SIGN(XM1**2,XM1) | |
25313 | XM22 = SIGN(XM2**2,XM2) | |
25314 | SS = XMS**2 | |
25315 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) | |
25316 | EE1 = SQRT(XM12+PCMP**2) | |
25317 | EE2 = XMS-EE1 | |
25318 | * back rotation | |
25319 | MODE = 1 | |
25320 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) | |
25321 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, | |
25322 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25323 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, | |
25324 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) | |
25325 | * check consistency | |
25326 | DEL = XMS*0.0001D0 | |
25327 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN | |
25328 | IDEV = 1 | |
25329 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN | |
25330 | IDEV = 2 | |
25331 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN | |
25332 | IDEV = 3 | |
25333 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN | |
25334 | IDEV = 4 | |
25335 | ELSE | |
25336 | IDEV = 0 | |
25337 | ENDIF | |
25338 | IF (IDEV.NE.0) THEN | |
25339 | WRITE(LOUT,'(/1X,A,I3)') | |
25340 | & 'MASHEL: inconsistent transformation',IDEV | |
25341 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' | |
25342 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 | |
25343 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 | |
25344 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' | |
25345 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) | |
25346 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) | |
25347 | ENDIF | |
25348 | RETURN | |
25349 | ||
25350 | 9999 CONTINUE | |
25351 | IREJ = 1 | |
25352 | RETURN | |
25353 | END | |
25354 | ||
25355 | *$ CREATE DT_DFERMI.FOR | |
25356 | *COPY DT_DFERMI | |
25357 | * | |
25358 | *===dfermi=============================================================* | |
25359 | * | |
25360 | SUBROUTINE DT_DFERMI(GPART) | |
25361 | ||
25362 | ************************************************************************ | |
25363 | * Find largest of three random numbers. * | |
25364 | ************************************************************************ | |
25365 | ||
25366 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25367 | SAVE | |
25368 | ||
25369 | DIMENSION G(3) | |
25370 | ||
25371 | DO 10 I=1,3 | |
25372 | G(I)=DT_RNDM(GPART) | |
25373 | 10 CONTINUE | |
25374 | IF (G(3).LT.G(2)) GOTO 40 | |
25375 | IF (G(3).LT.G(1)) GOTO 30 | |
25376 | GPART = G(3) | |
25377 | 20 RETURN | |
25378 | 30 GPART = G(1) | |
25379 | GOTO 20 | |
25380 | 40 IF (G(2).LT.G(1)) GOTO 30 | |
25381 | GPART = G(2) | |
25382 | GOTO 20 | |
25383 | ||
25384 | END | |
25385 | ||
25386 | ************************************************************************ | |
25387 | * * | |
25388 | * 2) Handling of parton flavors and particle indices * | |
25389 | * * | |
25390 | ************************************************************************ | |
25391 | *$ CREATE IDT_IPDG2B.FOR | |
25392 | *COPY IDT_IPDG2B | |
25393 | * | |
25394 | *===ipdg2b=============================================================* | |
25395 | * | |
25396 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) | |
25397 | ||
25398 | ************************************************************************ | |
25399 | * * | |
25400 | * conversion of quark numbering scheme * | |
25401 | * * | |
25402 | * input: PDG parton numbering * | |
25403 | * for diquarks: NN number of the constituent quark * | |
25404 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * | |
25405 | * * | |
25406 | * output: BAMJET particle codes * | |
25407 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25408 | * 2 d 8 a-d -2 a-d * | |
25409 | * 3 s 9 a-s -3 a-s * | |
25410 | * 4 c 10 a-c -4 a-c * | |
25411 | * * | |
25412 | * This is a modified version of ICONV2 written by R. Engel. * | |
25413 | * This version dated 13.12.94 is written by S. Roesler. * | |
25414 | ************************************************************************ | |
25415 | ||
25416 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25417 | SAVE | |
25418 | PARAMETER ( LINP = 10 , | |
25419 | & LOUT = 6 , | |
25420 | & LDAT = 9 ) | |
25421 | ||
25422 | IDA = ABS(ID) | |
25423 | * diquarks | |
25424 | IF (IDA.GT.6) THEN | |
25425 | KF = 3 | |
25426 | IF (IDA.GE.1000) KF = 4 | |
25427 | IDA = IDA/(10**(KF-NN)) | |
25428 | IDA = MOD(IDA,10) | |
25429 | ENDIF | |
25430 | * exchange up and dn quarks | |
25431 | IF (IDA.EQ.1) THEN | |
25432 | IDA = 2 | |
25433 | ELSEIF (IDA.EQ.2) THEN | |
25434 | IDA = 1 | |
25435 | ENDIF | |
25436 | * antiquarks | |
25437 | IF (ID.LT.0) THEN | |
25438 | IF (MODE.EQ.1) THEN | |
25439 | IDA = IDA+6 | |
25440 | ELSE | |
25441 | IDA = -IDA | |
25442 | ENDIF | |
25443 | ENDIF | |
25444 | IDT_IPDG2B = IDA | |
25445 | ||
25446 | RETURN | |
25447 | END | |
25448 | ||
25449 | *$ CREATE IDT_IB2PDG.FOR | |
25450 | *COPY IDT_IB2PDG | |
25451 | * | |
25452 | *===ib2pdg=============================================================* | |
25453 | * | |
25454 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) | |
25455 | ||
25456 | ************************************************************************ | |
25457 | * * | |
25458 | * conversion of quark numbering scheme * | |
25459 | * * | |
25460 | * input: BAMJET particle codes * | |
25461 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25462 | * 2 d 8 a-d -2 a-d * | |
25463 | * 3 s 9 a-s -3 a-s * | |
25464 | * 4 c 10 a-c -4 a-c * | |
25465 | * * | |
25466 | * output: PDG parton numbering * | |
25467 | * * | |
25468 | * This version dated 13.12.94 is written by S. Roesler. * | |
25469 | ************************************************************************ | |
25470 | ||
25471 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25472 | SAVE | |
25473 | PARAMETER ( LINP = 10 , | |
25474 | & LOUT = 6 , | |
25475 | & LDAT = 9 ) | |
25476 | ||
25477 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) | |
25478 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ | |
25479 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, | |
25480 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, | |
25481 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ | |
25482 | ||
25483 | IDA = ID1 | |
25484 | IDB = ID2 | |
25485 | IF (MODE.EQ.1) THEN | |
25486 | IF (ID1.GT.6) IDA = -(ID1-6) | |
25487 | IF (ID2.GT.6) IDB = -(ID2-6) | |
25488 | ENDIF | |
25489 | IF (ID2.EQ.0) THEN | |
25490 | IDT_IB2PDG = IHKKQ(IDA) | |
25491 | ELSE | |
25492 | IDT_IB2PDG = IHKKQQ(IDA,IDB) | |
25493 | ENDIF | |
25494 | ||
25495 | RETURN | |
25496 | END | |
25497 | ||
25498 | *$ CREATE IDT_IQUARK.FOR | |
25499 | *COPY IDT_IQUARK | |
25500 | * | |
25501 | *===ipdgqu=============================================================* | |
25502 | * | |
25503 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) | |
25504 | ||
25505 | ************************************************************************ | |
25506 | * * | |
25507 | * quark contents according to PDG conventions * | |
25508 | * (random selection in case of quark mixing) * | |
25509 | * * | |
25510 | * input: IDBAMJ BAMJET particle code * | |
25511 | * K 1..3 quark number * | |
25512 | * * | |
25513 | * output: 1 d (anti --> neg.) * | |
25514 | * 2 u * | |
25515 | * 3 s * | |
25516 | * 4 c * | |
25517 | * * | |
25518 | * This version written by R. Engel. * | |
25519 | ************************************************************************ | |
25520 | ||
25521 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25522 | SAVE | |
25523 | ||
25524 | IQ = IDT_IBJQUA(K,IDBAMJ) | |
25525 | * quark-antiquark | |
25526 | IF (IQ.GT.6) THEN | |
25527 | IQ = 6-IQ | |
25528 | ENDIF | |
25529 | * exchange of up and down | |
25530 | IF (ABS(IQ).EQ.1) THEN | |
25531 | IQ = SIGN(2,IQ) | |
25532 | ELSEIF (ABS(IQ).EQ.2) THEN | |
25533 | IQ = SIGN(1,IQ) | |
25534 | ENDIF | |
25535 | IDT_IQUARK = IQ | |
25536 | ||
25537 | RETURN | |
25538 | END | |
25539 | ||
25540 | *$ CREATE IDT_IBJQUA.FOR | |
25541 | *COPY IDT_IBJQUA | |
25542 | * | |
25543 | *===ibamq==============================================================* | |
25544 | * | |
25545 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) | |
25546 | ||
25547 | ************************************************************************ | |
25548 | * * | |
25549 | * quark contents according to BAMJET conventions * | |
25550 | * (random selection in case of quark mixing) * | |
25551 | * * | |
25552 | * input: IDBAMJ BAMJET particle code * | |
25553 | * K 1..3 quark number * | |
25554 | * * | |
25555 | * output: 1 u 7 u bar * | |
25556 | * 2 d 8 d bar * | |
25557 | * 3 s 9 s bar * | |
25558 | * 4 c 10 c bar * | |
25559 | * * | |
25560 | * This version written by R. Engel. * | |
25561 | ************************************************************************ | |
25562 | ||
25563 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25564 | SAVE | |
25565 | ||
25566 | DIMENSION ITAB(3,210) | |
25567 | DATA ((ITAB(I,K),I=1,3),K=1,30) / | |
25568 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, | |
25569 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25570 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, | |
25571 | *sr 10.1.94 | |
25572 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25573 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, | |
25574 | * | |
25575 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, | |
25576 | *sr 10.1.94 | |
25577 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, | |
25578 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, | |
25579 | *sr 10.1.94 | |
25580 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, | |
25581 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, | |
25582 | * | |
25583 | & 1, 2, 3, 201,202, 0, 2, 9, 0, | |
25584 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, | |
25585 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25586 | DATA ((ITAB(I,K),I=1,3),K=31,60) / | |
25587 | & 3, 9, 0, 1, 8, 0, 203,204, 0, | |
25588 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, | |
25589 | & 2, 9, 0, 3, 7, 0, 3, 8, 0, | |
25590 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25591 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25592 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25593 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25594 | & 0, 0, 0, 1, 1, 1, 1, 1, 2, | |
25595 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, | |
25596 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25597 | DATA ((ITAB(I,K),I=1,3),K=61,90) / | |
25598 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25599 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25600 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, | |
25601 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, | |
25602 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25603 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25604 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25605 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25606 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25607 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25608 | DATA ((ITAB(I,K),I=1,3),K=91,120) / | |
25609 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25610 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, | |
25611 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, | |
25612 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, | |
25613 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, | |
25614 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, | |
25615 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, | |
25616 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, | |
25617 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, | |
25618 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / | |
25619 | DATA ((ITAB(I,K),I=1,3),K=121,150) / | |
25620 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, | |
25621 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, | |
25622 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, | |
25623 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25624 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25625 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, | |
25626 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, | |
25627 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, | |
25628 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25629 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / | |
25630 | DATA ((ITAB(I,K),I=1,3),K=151,180) / | |
25631 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, | |
25632 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, | |
25633 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, | |
25634 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, | |
25635 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, | |
25636 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25637 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, | |
25638 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, | |
25639 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, | |
25640 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / | |
25641 | DATA ((ITAB(I,K),I=1,3),K=181,210) / | |
25642 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25643 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25644 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25645 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25646 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25647 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25648 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, | |
25649 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, | |
25650 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25651 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25652 | DATA IDOLD /0/ | |
25653 | ||
25654 | ONE = 1.0D0 | |
25655 | IF (ITAB(1,IDBAMJ).LE.200) THEN | |
25656 | ID = ITAB(K,IDBAMJ) | |
25657 | ELSE | |
25658 | IF(IDOLD.NE.IDBAMJ) THEN | |
25659 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* | |
25660 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) | |
25661 | ELSE | |
25662 | IDOLD = 0 | |
25663 | ENDIF | |
25664 | ID = ITAB(K,IT) | |
25665 | ENDIF | |
25666 | IDOLD = IDBAMJ | |
25667 | IDT_IBJQUA = ID | |
25668 | ||
25669 | RETURN | |
25670 | END | |
25671 | ||
25672 | *$ CREATE IDT_ICIHAD.FOR | |
25673 | *COPY IDT_ICIHAD | |
25674 | * | |
25675 | *===icihad=============================================================* | |
25676 | * | |
25677 | INTEGER FUNCTION IDT_ICIHAD(MCIND) | |
25678 | ||
25679 | ************************************************************************ | |
25680 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * | |
25681 | * This is a completely new version dated 25.10.95. * | |
25682 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25683 | ************************************************************************ | |
25684 | ||
25685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25686 | SAVE | |
25687 | ||
25688 | * hadron index conversion (BAMJET <--> PDG) | |
25689 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25690 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25691 | & IAMCIN(210) | |
25692 | ||
25693 | IDT_ICIHAD = 0 | |
25694 | KPDG = ABS(MCIND) | |
25695 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN | |
25696 | IF (MCIND.LT.0) THEN | |
25697 | JSIGN = 1 | |
25698 | ELSE | |
25699 | JSIGN = 2 | |
25700 | ENDIF | |
25701 | IF (KPDG.GE.10000) THEN | |
25702 | DO 1 I=1,19 | |
25703 | IDT_ICIHAD = IBAM5(JSIGN,I) | |
25704 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 | |
25705 | IDT_ICIHAD = 0 | |
25706 | 1 CONTINUE | |
25707 | ELSEIF (KPDG.GE.1000) THEN | |
25708 | DO 2 I=1,29 | |
25709 | IDT_ICIHAD = IBAM4(JSIGN,I) | |
25710 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 | |
25711 | IDT_ICIHAD = 0 | |
25712 | 2 CONTINUE | |
25713 | ELSEIF (KPDG.GE.100) THEN | |
25714 | DO 3 I=1,22 | |
25715 | IDT_ICIHAD = IBAM3(JSIGN,I) | |
25716 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 | |
25717 | IDT_ICIHAD = 0 | |
25718 | 3 CONTINUE | |
25719 | ELSEIF (KPDG.GE.10) THEN | |
25720 | DO 4 I=1,7 | |
25721 | IDT_ICIHAD = IBAM2(JSIGN,I) | |
25722 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 | |
25723 | IDT_ICIHAD = 0 | |
25724 | 4 CONTINUE | |
25725 | ENDIF | |
25726 | 5 CONTINUE | |
25727 | ||
25728 | RETURN | |
25729 | END | |
25730 | ||
25731 | *$ CREATE IDT_IPDGHA.FOR | |
25732 | *COPY IDT_IPDGHA | |
25733 | * | |
25734 | *===ipdgha=============================================================* | |
25735 | * | |
25736 | INTEGER FUNCTION IDT_IPDGHA(MCIND) | |
25737 | ||
25738 | ************************************************************************ | |
25739 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * | |
25740 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * | |
25741 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25742 | ************************************************************************ | |
25743 | ||
25744 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25745 | SAVE | |
25746 | ||
25747 | * hadron index conversion (BAMJET <--> PDG) | |
25748 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25749 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25750 | & IAMCIN(210) | |
25751 | ||
25752 | IDT_IPDGHA = IAMCIN(MCIND) | |
25753 | ||
25754 | RETURN | |
25755 | END | |
25756 | ||
25757 | *$ CREATE DT_FLAHAD.FOR | |
25758 | *COPY DT_FLAHAD | |
25759 | * | |
25760 | *===flahad=============================================================* | |
25761 | * | |
25762 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) | |
25763 | ||
25764 | ************************************************************************ | |
25765 | * sampling of FLAvor composition for HADrons/photons * | |
25766 | * ID BAMJET-id of hadron * | |
25767 | * IF1,2,3 flavor content * | |
25768 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * | |
25769 | * Note: - u,d numbering as in BAMJET * | |
25770 | * - ID .le. 30 !! * | |
25771 | * This version dated 12.03.96 is written by S. Roesler * | |
25772 | ************************************************************************ | |
25773 | ||
25774 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25775 | SAVE | |
25776 | ||
25777 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
25778 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
25779 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
25780 | & IQTCHR(-6:6),MQUARK(3,39) | |
25781 | ||
25782 | DIMENSION JSEL(3,6) | |
25783 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ | |
25784 | ||
25785 | ONE = 1.0D0 | |
25786 | IF (ID.EQ.7) THEN | |
25787 | * photon (charge dependent flavour sampling) | |
25788 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) | |
25789 | IF (K.LE.4) THEN | |
25790 | IF1 = 2 | |
25791 | IF2 = -2 | |
25792 | ELSE IF(K.EQ.5) THEN | |
25793 | IF1 = 1 | |
25794 | IF2 = -1 | |
25795 | ELSE | |
25796 | IF1 = 3 | |
25797 | IF2 = -3 | |
25798 | ENDIF | |
25799 | IF(DT_RNDM(ONE).LT.0.5D0) THEN | |
25800 | K = IF1 | |
25801 | IF1 = IF2 | |
25802 | IF2 = K | |
25803 | ENDIF | |
25804 | IF3 = 0 | |
25805 | ELSE | |
25806 | * hadron | |
25807 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) | |
25808 | IF1 = MQUARK(JSEL(1,IX),ID) | |
25809 | IF2 = MQUARK(JSEL(2,IX),ID) | |
25810 | IF3 = MQUARK(JSEL(3,IX),ID) | |
25811 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN | |
25812 | IF1 = IF3 | |
25813 | IF3 = 0 | |
25814 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN | |
25815 | IF2 = IF3 | |
25816 | IF3 = 0 | |
25817 | ENDIF | |
25818 | ENDIF | |
25819 | ||
25820 | RETURN | |
25821 | END | |
25822 | ||
25823 | *$ CREATE IDT_MCHAD.FOR | |
25824 | *COPY IDT_MCHAD | |
25825 | * | |
25826 | *===mchad==============================================================* | |
25827 | * | |
25828 | INTEGER FUNCTION IDT_MCHAD(ITDTU) | |
25829 | ||
25830 | ************************************************************************ | |
25831 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * | |
25832 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * | |
25833 | * * | |
25834 | * Last change 28.12.2006 by S. Roesler. * | |
25835 | ************************************************************************ | |
25836 | ||
25837 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25838 | SAVE | |
25839 | ||
25840 | DIMENSION ITRANS(210) | |
25841 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, | |
25842 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, | |
25843 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, | |
25844 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, | |
25845 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, | |
25846 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, | |
25847 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ | |
25848 | ||
25849 | IF ( ITDTU .GT. 0 ) THEN | |
25850 | IDT_MCHAD = ITRANS(ITDTU) | |
25851 | ELSE | |
25852 | IDT_MCHAD = -1 | |
25853 | END IF | |
25854 | ||
25855 | RETURN | |
25856 | END | |
25857 | ||
25858 | ************************************************************************ | |
25859 | * * | |
25860 | * 3) Energy-momentum and quantum number conservation check routines * | |
25861 | * * | |
25862 | ************************************************************************ | |
25863 | *$ CREATE DT_EMC1.FOR | |
25864 | *COPY DT_EMC1 | |
25865 | * | |
25866 | *===emc1===============================================================* | |
25867 | * | |
25868 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) | |
25869 | ||
25870 | ************************************************************************ | |
25871 | * This version dated 15.12.94 is written by S. Roesler * | |
25872 | ************************************************************************ | |
25873 | ||
25874 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25875 | SAVE | |
25876 | PARAMETER ( LINP = 10 , | |
25877 | & LOUT = 6 , | |
25878 | & LDAT = 9 ) | |
25879 | PARAMETER (TINY10=1.0D-10) | |
25880 | ||
25881 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
25882 | ||
25883 | IREJ = 0 | |
25884 | ||
25885 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) | |
25886 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE | |
25887 | ||
25888 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN | |
25889 | IF (MODE.EQ.1) THEN | |
25890 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) | |
25891 | ELSEIF (MODE.EQ.2) THEN | |
25892 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) | |
25893 | ENDIF | |
25894 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) | |
25895 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) | |
25896 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) | |
25897 | ELSEIF (MODE.LT.0) THEN | |
25898 | IF (MODE.EQ.-1) THEN | |
25899 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) | |
25900 | ELSEIF (MODE.EQ.-2) THEN | |
25901 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) | |
25902 | ENDIF | |
25903 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) | |
25904 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) | |
25905 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) | |
25906 | ENDIF | |
25907 | ||
25908 | IF (ABS(MODE).EQ.3) THEN | |
25909 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) | |
25910 | IF (IREJ1.NE.0) GOTO 9999 | |
25911 | ENDIF | |
25912 | RETURN | |
25913 | ||
25914 | 9999 CONTINUE | |
25915 | IREJ = 1 | |
25916 | RETURN | |
25917 | END | |
25918 | ||
25919 | *$ CREATE DT_EMC2.FOR | |
25920 | *COPY DT_EMC2 | |
25921 | * | |
25922 | *===emc2===============================================================* | |
25923 | * | |
25924 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, | |
25925 | & MODE,IPOS,IREJ) | |
25926 | ||
25927 | ************************************************************************ | |
25928 | * MODE = 1 energy-momentum cons. check * | |
25929 | * = 2 flavor-cons. check * | |
25930 | * = 3 energy-momentum & flavor cons. check * | |
25931 | * = 4 energy-momentum & charge cons. check * | |
25932 | * = 5 energy-momentum & flavor & charge cons. check * | |
25933 | * This version dated 16.01.95 is written by S. Roesler * | |
25934 | ************************************************************************ | |
25935 | ||
25936 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25937 | SAVE | |
25938 | PARAMETER ( LINP = 10 , | |
25939 | & LOUT = 6 , | |
25940 | & LDAT = 9 ) | |
25941 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
25942 | ||
25943 | * event history | |
25944 | PARAMETER (NMXHKK=200000) | |
25945 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25946 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25947 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25948 | * extended event history | |
25949 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
25950 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
25951 | & IHIST(2,NMXHKK) | |
25952 | ||
25953 | IREJ = 0 | |
25954 | IREJ1 = 0 | |
25955 | IREJ2 = 0 | |
25956 | IREJ3 = 0 | |
25957 | ||
25958 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25959 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) | |
25960 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25961 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) | |
25962 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) | |
25963 | DO 1 I=1,NHKK | |
25964 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. | |
25965 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. | |
25966 | & (ISTHKK(I).EQ.IP5)) THEN | |
25967 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25968 | & .OR.(MODE.EQ.5)) | |
25969 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
25970 | & 2,IDUM,IDUM) | |
25971 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25972 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) | |
25973 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25974 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) | |
25975 | ENDIF | |
25976 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. | |
25977 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. | |
25978 | & (ISTHKK(I).EQ.IN5)) THEN | |
25979 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25980 | & .OR.(MODE.EQ.5)) | |
25981 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), | |
25982 | & 2,IDUM,IDUM) | |
25983 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25984 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) | |
25985 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25986 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) | |
25987 | ENDIF | |
25988 | 1 CONTINUE | |
25989 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25990 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) | |
25991 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25992 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) | |
25993 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) | |
25994 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 | |
25995 | ||
25996 | RETURN | |
25997 | ||
25998 | 9999 CONTINUE | |
25999 | IREJ = 1 | |
26000 | RETURN | |
26001 | END | |
26002 | ||
26003 | *$ CREATE DT_EVTEMC.FOR | |
26004 | *COPY DT_EVTEMC | |
26005 | * | |
26006 | *===evtemc=============================================================* | |
26007 | * | |
26008 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) | |
26009 | ||
26010 | ************************************************************************ | |
26011 | * This version dated 13.12.94 is written by S. Roesler * | |
26012 | ************************************************************************ | |
26013 | ||
26014 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26015 | SAVE | |
26016 | PARAMETER ( LINP = 10 , | |
26017 | & LOUT = 6 , | |
26018 | & LDAT = 9 ) | |
26019 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, | |
26020 | & ZERO=0.0D0) | |
26021 | ||
26022 | * event history | |
26023 | PARAMETER (NMXHKK=200000) | |
26024 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26025 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26026 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26027 | * flags for input different options | |
26028 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
26029 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
26030 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
26031 | ||
26032 | IREJ = 0 | |
26033 | ||
26034 | MODE = IMODE | |
26035 | CHKLEV = TINY10 | |
26036 | IF (MODE.EQ.4) THEN | |
26037 | CHKLEV = TINY2 | |
26038 | MODE = 3 | |
26039 | ELSEIF (MODE.EQ.5) THEN | |
26040 | CHKLEV = TINY1 | |
26041 | MODE = 3 | |
26042 | ELSEIF (MODE.EQ.-1) THEN | |
26043 | CHKLEV = EIO | |
26044 | MODE = 3 | |
26045 | ENDIF | |
26046 | ||
26047 | IF (ABS(MODE).EQ.3) THEN | |
26048 | PXDEV = PX | |
26049 | PYDEV = PY | |
26050 | PZDEV = PZ | |
26051 | EDEV = E | |
26052 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 | |
26053 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. | |
26054 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN | |
26055 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') | |
26056 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, | |
26057 | & ' event ',NEVHKK, | |
26058 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV | |
26059 | PX = 0.0D0 | |
26060 | PY = 0.0D0 | |
26061 | PZ = 0.0D0 | |
26062 | E = 0.0D0 | |
26063 | GOTO 9999 | |
26064 | ENDIF | |
26065 | PX = 0.0D0 | |
26066 | PY = 0.0D0 | |
26067 | PZ = 0.0D0 | |
26068 | E = 0.0D0 | |
26069 | RETURN | |
26070 | ENDIF | |
26071 | ||
26072 | IF (MODE.EQ.1) THEN | |
26073 | PX = 0.0D0 | |
26074 | PY = 0.0D0 | |
26075 | PZ = 0.0D0 | |
26076 | E = 0.0D0 | |
26077 | ENDIF | |
26078 | ||
26079 | PX = PX+PXIO | |
26080 | PY = PY+PYIO | |
26081 | PZ = PZ+PZIO | |
26082 | E = E+EIO | |
26083 | ||
26084 | RETURN | |
26085 | ||
26086 | 9999 CONTINUE | |
26087 | IREJ = 1 | |
26088 | RETURN | |
26089 | END | |
26090 | ||
26091 | *$ CREATE DT_EVTFLC.FOR | |
26092 | *COPY DT_EVTFLC | |
26093 | * | |
26094 | *===evtflc=============================================================* | |
26095 | * | |
26096 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) | |
26097 | ||
26098 | ************************************************************************ | |
26099 | * Flavor conservation check. * | |
26100 | * ID identity of particle * | |
26101 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * | |
26102 | * = 2 ID for particle/resonance in BAMJET numbering scheme * | |
26103 | * = 3 ID for particle/resonance in PDG numbering scheme * | |
26104 | * MODE = 1 initialization and add ID * | |
26105 | * =-1 initialization and subtract ID * | |
26106 | * = 2 add ID * | |
26107 | * =-2 subtract ID * | |
26108 | * = 3 check flavor cons. * | |
26109 | * IPOS flag to give position of call of EVTFLC to output * | |
26110 | * unit in case of violation * | |
26111 | * This version dated 10.01.95 is written by S. Roesler * | |
26112 | ************************************************************************ | |
26113 | ||
26114 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26115 | SAVE | |
26116 | PARAMETER ( LINP = 10 , | |
26117 | & LOUT = 6 , | |
26118 | & LDAT = 9 ) | |
26119 | PARAMETER (TINY10=1.0D-10) | |
26120 | ||
26121 | IREJ = 0 | |
26122 | ||
26123 | IF (MODE.EQ.3) THEN | |
26124 | IF (IFL.NE.0) THEN | |
26125 | WRITE(LOUT,'(1X,A,I3,A,I3)') | |
26126 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, | |
26127 | & ' ! IFL = ',IFL | |
26128 | IFL = 0 | |
26129 | GOTO 9999 | |
26130 | ENDIF | |
26131 | IFL = 0 | |
26132 | RETURN | |
26133 | ENDIF | |
26134 | ||
26135 | IF (MODE.EQ.1) IFL = 0 | |
26136 | IF (ID.EQ.0) RETURN | |
26137 | ||
26138 | IF (ID1.EQ.1) THEN | |
26139 | IDD = ABS(ID) | |
26140 | NQ = 1 | |
26141 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 | |
26142 | IF (IDD.GE.1000) NQ = 3 | |
26143 | DO 1 I=1,NQ | |
26144 | IFBAM = IDT_IPDG2B(ID,I,2) | |
26145 | IF (ABS(IFBAM).EQ.1) THEN | |
26146 | IFBAM = SIGN(2,IFBAM) | |
26147 | ELSEIF (ABS(IFBAM).EQ.2) THEN | |
26148 | IFBAM = SIGN(1,IFBAM) | |
26149 | ENDIF | |
26150 | IF (MODE.GT.0) THEN | |
26151 | IFL = IFL+IFBAM | |
26152 | ELSE | |
26153 | IFL = IFL-IFBAM | |
26154 | ENDIF | |
26155 | 1 CONTINUE | |
26156 | RETURN | |
26157 | ENDIF | |
26158 | ||
26159 | IDD = ID | |
26160 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) | |
26161 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN | |
26162 | DO 2 I=1,3 | |
26163 | IF (MODE.GT.0) THEN | |
26164 | IFL = IFL+IDT_IQUARK(I,IDD) | |
26165 | ELSE | |
26166 | IFL = IFL-IDT_IQUARK(I,IDD) | |
26167 | ENDIF | |
26168 | 2 CONTINUE | |
26169 | ENDIF | |
26170 | RETURN | |
26171 | ||
26172 | 9999 CONTINUE | |
26173 | IREJ = 1 | |
26174 | RETURN | |
26175 | END | |
26176 | ||
26177 | *$ CREATE DT_EVTCHG.FOR | |
26178 | *COPY DT_EVTCHG | |
26179 | * | |
26180 | *===evtchg=============================================================* | |
26181 | * | |
26182 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) | |
26183 | ||
26184 | ************************************************************************ | |
26185 | * Charge conservation check. * | |
26186 | * ID identity of particle (PDG-numbering scheme) * | |
26187 | * MODE = 1 initialization * | |
26188 | * =-2 subtract ID-charge * | |
26189 | * = 2 add ID-charge * | |
26190 | * = 3 check charge cons. * | |
26191 | * IPOS flag to give position of call of EVTCHG to output * | |
26192 | * unit in case of violation * | |
26193 | * This version dated 10.01.95 is written by S. Roesler * | |
26194 | * Last change: s.r. 21.01.01 * | |
26195 | ************************************************************************ | |
26196 | ||
26197 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26198 | SAVE | |
26199 | PARAMETER ( LINP = 10 , | |
26200 | & LOUT = 6 , | |
26201 | & LDAT = 9 ) | |
26202 | ||
26203 | * event history | |
26204 | PARAMETER (NMXHKK=200000) | |
26205 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26206 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26207 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26208 | * particle properties (BAMJET index convention) | |
26209 | CHARACTER*8 ANAME | |
26210 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26211 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26212 | ||
26213 | IREJ = 0 | |
26214 | ||
26215 | IF (MODE.EQ.1) THEN | |
26216 | ICH = 0 | |
26217 | IBAR = 0 | |
26218 | RETURN | |
26219 | ENDIF | |
26220 | ||
26221 | IF (MODE.EQ.3) THEN | |
26222 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN | |
26223 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') | |
26224 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, | |
26225 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK | |
26226 | ICH = 0 | |
26227 | IBAR = 0 | |
26228 | GOTO 9999 | |
26229 | ENDIF | |
26230 | ICH = 0 | |
26231 | IBAR = 0 | |
26232 | RETURN | |
26233 | ENDIF | |
26234 | ||
26235 | IF (ID.EQ.0) RETURN | |
26236 | ||
26237 | IDD = IDT_ICIHAD(ID) | |
26238 | * modification 21.1.01: use intrinsic phojet-functions to determine charge | |
26239 | * and baryon number | |
26240 | C IF (IDD.GT.0) THEN | |
26241 | C IF (MODE.EQ.2) THEN | |
26242 | C ICH = ICH+IICH(IDD) | |
26243 | C IBAR = IBAR+IIBAR(IDD) | |
26244 | C ELSEIF (MODE.EQ.-2) THEN | |
26245 | C ICH = ICH-IICH(IDD) | |
26246 | C IBAR = IBAR-IIBAR(IDD) | |
26247 | C ENDIF | |
26248 | C ELSE | |
26249 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID | |
26250 | C CALL DT_EVTOUT(4) | |
26251 | C STOP | |
26252 | C ENDIF | |
26253 | IF (MODE.EQ.2) THEN | |
26254 | ICH = ICH+IPHO_CHR3(ID,1)/3 | |
26255 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 | |
26256 | ELSEIF (MODE.EQ.-2) THEN | |
26257 | ICH = ICH-IPHO_CHR3(ID,1)/3 | |
26258 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 | |
26259 | ENDIF | |
26260 | ||
26261 | RETURN | |
26262 | ||
26263 | 9999 CONTINUE | |
26264 | IREJ = 1 | |
26265 | RETURN | |
26266 | END | |
26267 | ||
26268 | ************************************************************************ | |
26269 | * * | |
26270 | * 4) Transformations * | |
26271 | * * | |
26272 | ************************************************************************ | |
26273 | *$ CREATE DT_LTINI.FOR | |
26274 | *COPY DT_LTINI | |
26275 | * | |
26276 | *===ltini==============================================================* | |
26277 | * | |
26278 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) | |
26279 | ||
26280 | ************************************************************************ | |
26281 | * Initializations of Lorentz-transformations, calculation of Lorentz- * | |
26282 | * parameters. * | |
26283 | * This version dated 13.11.95 is written by S. Roesler. * | |
26284 | ************************************************************************ | |
26285 | ||
26286 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26287 | SAVE | |
26288 | PARAMETER ( LINP = 10 , | |
26289 | & LOUT = 6 , | |
26290 | & LDAT = 9 ) | |
26291 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, | |
26292 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
26293 | ||
26294 | * Lorentz-parameters of the current interaction | |
26295 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26296 | & UMO,PPCM,EPROJ,PPROJ | |
26297 | * properties of photon/lepton projectiles | |
26298 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
26299 | * particle properties (BAMJET index convention) | |
26300 | CHARACTER*8 ANAME | |
26301 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26302 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26303 | * nucleon-nucleon event-generator | |
26304 | CHARACTER*8 CMODEL | |
26305 | LOGICAL LPHOIN | |
26306 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
26307 | ||
26308 | Q2 = VIRT | |
26309 | IDP = IDPR | |
26310 | IF (MCGENE.NE.3) THEN | |
26311 | * lepton-projectiles and PHOJET: initialize real photon instead | |
26312 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26313 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. | |
26314 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN | |
26315 | IDP = 7 | |
26316 | Q2 = ZERO | |
26317 | ENDIF | |
26318 | ENDIF | |
26319 | IDT = IDTA | |
26320 | EPN = EPN0 | |
26321 | PPN = PPN0 | |
26322 | ECM = ECM0 | |
26323 | AMP = AAM(IDP)-SQRT(ABS(Q2)) | |
26324 | AMT = AAM(IDT) | |
26325 | AMP2 = SIGN(AMP**2,AMP) | |
26326 | AMT2 = AMT**2 | |
26327 | IF (ECM0.GT.ZERO) THEN | |
26328 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
26329 | IF (AMP2.GT.ZERO) THEN | |
26330 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26331 | ELSE | |
26332 | PPN = SQRT(EPN**2-AMP2) | |
26333 | ENDIF | |
26334 | ELSE | |
26335 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26336 | IF (IDP.EQ.7) EPN = ABS(EPN) | |
26337 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP | |
26338 | IF (AMP2.GT.ZERO) THEN | |
26339 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26340 | ELSE | |
26341 | PPN = SQRT(EPN**2-AMP2) | |
26342 | ENDIF | |
26343 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26344 | IF (AMP2.GT.ZERO) THEN | |
26345 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) | |
26346 | ELSE | |
26347 | EPN = SQRT(PPN**2+AMP2) | |
26348 | ENDIF | |
26349 | ENDIF | |
26350 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) | |
26351 | ENDIF | |
26352 | UMO = ECM | |
26353 | EPROJ = EPN | |
26354 | PPROJ = PPN | |
26355 | IF (AMP2.GT.ZERO) THEN | |
26356 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) | |
26357 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) | |
26358 | ELSE | |
26359 | ETARG = TINY10 | |
26360 | PTARG = TINY10 | |
26361 | ENDIF | |
26362 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) | |
26363 | IF (IDP.EQ.7) THEN | |
26364 | PGAMM(1) = ZERO | |
26365 | PGAMM(2) = ZERO | |
26366 | AMGAM = AMP | |
26367 | AMGAM2 = AMP2 | |
26368 | IF (ECM0.GT.ZERO) THEN | |
26369 | S = ECM0**2 | |
26370 | ELSE | |
26371 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26372 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) | |
26373 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26374 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) | |
26375 | ENDIF | |
26376 | ENDIF | |
26377 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 | |
26378 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) | |
26379 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) | |
26380 | IF (MODE.EQ.1) THEN | |
26381 | PNUCL(1) = ZERO | |
26382 | PNUCL(2) = ZERO | |
26383 | PNUCL(3) = -PGAMM(3) | |
26384 | PNUCL(4) = SQRT(S)-PGAMM(4) | |
26385 | ENDIF | |
26386 | ENDIF | |
26387 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26388 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN | |
26389 | PLEPT0(1) = ZERO | |
26390 | PLEPT0(2) = ZERO | |
26391 | * neglect lepton masses | |
26392 | C AMLPT2 = AAM(IDPR)**2 | |
26393 | AMLPT2 = ZERO | |
26394 | * | |
26395 | IF (ECM0.GT.ZERO) THEN | |
26396 | S = ECM0**2 | |
26397 | ELSE | |
26398 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26399 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) | |
26400 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26401 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) | |
26402 | ENDIF | |
26403 | ENDIF | |
26404 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 | |
26405 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) | |
26406 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) | |
26407 | PNUCL(1) = ZERO | |
26408 | PNUCL(2) = ZERO | |
26409 | PNUCL(3) = -PLEPT0(3) | |
26410 | PNUCL(4) = SQRT(S)-PLEPT0(4) | |
26411 | ENDIF | |
26412 | * Lorentz-parameter for transformation Lab. - projectile rest system | |
26413 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN | |
26414 | GALAB = TINY10 | |
26415 | BGLAB = TINY10 | |
26416 | BLAB = TINY10 | |
26417 | ELSE | |
26418 | GALAB = EPROJ/AMP | |
26419 | BGLAB = PPROJ/AMP | |
26420 | BLAB = BGLAB/GALAB | |
26421 | ENDIF | |
26422 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. | |
26423 | IF (IDP.EQ.7) THEN | |
26424 | GACMS(1) = TINY10 | |
26425 | BGCMS(1) = TINY10 | |
26426 | ELSE | |
26427 | GACMS(1) = (ETARG+AMP)/UMO | |
26428 | BGCMS(1) = PTARG/UMO | |
26429 | ENDIF | |
26430 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. | |
26431 | GACMS(2) = (EPROJ+AMT)/UMO | |
26432 | BGCMS(2) = PPROJ/UMO | |
26433 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ | |
26434 | ||
26435 | EPN0 = EPN | |
26436 | PPN0 = PPN | |
26437 | ECM0 = ECM | |
26438 | ||
26439 | RETURN | |
26440 | END | |
26441 | ||
26442 | *$ CREATE DT_LTRANS.FOR | |
26443 | *COPY DT_LTRANS | |
26444 | * | |
26445 | *===ltrans=============================================================* | |
26446 | * | |
26447 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) | |
26448 | ||
26449 | ************************************************************************ | |
26450 | * Lorentz-transformations. * | |
26451 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26452 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26453 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26454 | * This version dated 01.11.95 is written by S. Roesler. * | |
26455 | ************************************************************************ | |
26456 | ||
26457 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26458 | SAVE | |
26459 | PARAMETER ( LINP = 10 , | |
26460 | & LOUT = 6 , | |
26461 | & LDAT = 9 ) | |
26462 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) | |
26463 | ||
26464 | PARAMETER (SQTINF=1.0D+15) | |
26465 | ||
26466 | * particle properties (BAMJET index convention) | |
26467 | CHARACTER*8 ANAME | |
26468 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26469 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26470 | ||
26471 | PXO = PXI | |
26472 | PYO = PYI | |
26473 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) | |
26474 | ||
26475 | * check particle mass for consistency (numerical rounding errors) | |
26476 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) | |
26477 | AMO2 = (PEO-PO)*(PEO+PO) | |
26478 | AMORQ2 = AAM(ID)**2 | |
26479 | AMDIF2 = ABS(AMO2-AMORQ2) | |
26480 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN | |
26481 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) | |
26482 | PEO = PEO+DELTA | |
26483 | PO1 = PO -DELTA | |
26484 | PXO = PXO*PO1/PO | |
26485 | PYO = PYO*PO1/PO | |
26486 | PZO = PZO*PO1/PO | |
26487 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID | |
26488 | ENDIF | |
26489 | ||
26490 | RETURN | |
26491 | END | |
26492 | ||
26493 | *$ CREATE DT_LTNUC.FOR | |
26494 | *COPY DT_LTNUC | |
26495 | * | |
26496 | *===ltnuc==============================================================* | |
26497 | * | |
26498 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) | |
26499 | ||
26500 | ************************************************************************ | |
26501 | * Lorentz-transformations. * | |
26502 | * PIN longitudnal momentum (input) * | |
26503 | * EIN energy (input) * | |
26504 | * POUT transformed long. momentum (output) * | |
26505 | * EOUT transformed energy (output) * | |
26506 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26507 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26508 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26509 | * This version dated 01.11.95 is written by S. Roesler. * | |
26510 | ************************************************************************ | |
26511 | ||
26512 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26513 | SAVE | |
26514 | PARAMETER ( LINP = 10 , | |
26515 | & LOUT = 6 , | |
26516 | & LDAT = 9 ) | |
26517 | PARAMETER (ZERO=0.0D0) | |
26518 | ||
26519 | * Lorentz-parameters of the current interaction | |
26520 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26521 | & UMO,PPCM,EPROJ,PPROJ | |
26522 | ||
26523 | BDUM1 = ZERO | |
26524 | BDUM2 = ZERO | |
26525 | PDUM1 = ZERO | |
26526 | PDUM2 = ZERO | |
26527 | IF (ABS(MODE).EQ.1) THEN | |
26528 | BG = -SIGN(BGLAB,DBLE(MODE)) | |
26529 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, | |
26530 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26531 | ELSEIF (ABS(MODE).EQ.2) THEN | |
26532 | BG = SIGN(BGCMS(1),DBLE(MODE)) | |
26533 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26534 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26535 | ELSEIF (ABS(MODE).EQ.3) THEN | |
26536 | BG = -SIGN(BGCMS(2),DBLE(MODE)) | |
26537 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26538 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26539 | ELSE | |
26540 | WRITE(LOUT,1000) MODE | |
26541 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') | |
26542 | EOUT = EIN | |
26543 | POUT = PIN | |
26544 | ENDIF | |
26545 | ||
26546 | RETURN | |
26547 | END | |
26548 | ||
26549 | *$ CREATE DT_DALTRA.FOR | |
26550 | *COPY DT_DALTRA | |
26551 | * | |
26552 | *===daltra=============================================================* | |
26553 | * | |
26554 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) | |
26555 | ||
26556 | ************************************************************************ | |
26557 | * Arbitrary Lorentz-transformation. * | |
26558 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * | |
26559 | ************************************************************************ | |
26560 | ||
26561 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26562 | SAVE | |
26563 | PARAMETER (ONE=1.0D0) | |
26564 | ||
26565 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ | |
26566 | PE = EP/(GA+ONE)+EC | |
26567 | PX = PCX+BGX*PE | |
26568 | PY = PCY+BGY*PE | |
26569 | PZ = PCZ+BGZ*PE | |
26570 | P = SQRT(PX*PX+PY*PY+PZ*PZ) | |
26571 | E = GA*EC+EP | |
26572 | ||
26573 | RETURN | |
26574 | END | |
26575 | ||
26576 | *$ CREATE DT_DTRAFO.FOR | |
26577 | *COPY DT_DTRAFO | |
26578 | * | |
26579 | *====dtrafo============================================================* | |
26580 | * | |
26581 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, | |
26582 | & PL,CXL,CYL,CZL,EL) | |
26583 | ||
26584 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM | |
26585 | ||
26586 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26587 | SAVE | |
26588 | ||
26589 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) | |
26590 | SID = SQRT(1.D0-COD*COD) | |
26591 | PLX = P*SID*COF | |
26592 | PLY = P*SID*SIF | |
26593 | PCMZ = P*COD | |
26594 | PLZ = GAM*PCMZ+BGAM*ECM | |
26595 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) | |
26596 | EL = GAM*ECM+BGAM*PCMZ | |
26597 | C ROTATION INTO THE ORIGINAL DIRECTION | |
26598 | COZ = PLZ/PL | |
26599 | SIZ = SQRT(1.D0-COZ**2) | |
26600 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) | |
26601 | ||
26602 | RETURN | |
26603 | END | |
26604 | ||
26605 | *$ CREATE DT_STTRAN.FOR | |
26606 | *COPY DT_STTRAN | |
26607 | * | |
26608 | *====sttran============================================================* | |
26609 | * | |
26610 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) | |
26611 | ||
26612 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26613 | SAVE | |
26614 | DATA ANGLSQ/1.D-30/ | |
26615 | ************************************************************************ | |
26616 | * VERSION BY J. RANFT * | |
26617 | * LEIPZIG * | |
26618 | * * | |
26619 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * | |
26620 | * * | |
26621 | * INPUT VARIABLES: * | |
26622 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * | |
26623 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * | |
26624 | * ANGLE OF "SCATTERING" * | |
26625 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * | |
26626 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * | |
26627 | * OF "SCATTERING" * | |
26628 | * * | |
26629 | * OUTPUT VARIABLES: * | |
26630 | * X,Y,Z = NEW DIRECTION COSINES * | |
26631 | * * | |
26632 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * | |
26633 | ************************************************************************ | |
26634 | * | |
26635 | * | |
26636 | * Changed by A. Ferrari | |
26637 | * | |
26638 | * IF (ABS(XO)-0.0001D0) 1,1,2 | |
26639 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 | |
26640 | * 3 CONTINUE | |
26641 | A = XO**2 + YO**2 | |
26642 | IF ( A .LT. ANGLSQ ) THEN | |
26643 | X=SDE*CFE | |
26644 | Y=SDE*SFE | |
26645 | Z=CDE*ZO | |
26646 | ELSE | |
26647 | XI=SDE*CFE | |
26648 | YI=SDE*SFE | |
26649 | ZI=CDE | |
26650 | A=SQRT(A) | |
26651 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI | |
26652 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI | |
26653 | Z=A*YI+ZO*ZI | |
26654 | ENDIF | |
26655 | ||
26656 | RETURN | |
26657 | END | |
26658 | ||
26659 | *$ CREATE DT_MYTRAN.FOR | |
26660 | *COPY DT_MYTRAN | |
26661 | * | |
26662 | *===mytran=============================================================* | |
26663 | * | |
26664 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) | |
26665 | ||
26666 | ************************************************************************ | |
26667 | * This subroutine rotates the coordinate frame * | |
26668 | * a) theta around y * | |
26669 | * b) phi around z if IMODE = 1 * | |
26670 | * * | |
26671 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * | |
26672 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * | |
26673 | * z' 0 0 1 -sin(th) 0 cos(th) z * | |
26674 | * * | |
26675 | * and vice versa if IMODE = 0. * | |
26676 | * This version dated 5.4.94 is based on the original version DTRAN * | |
26677 | * by J. Ranft and is written by S. Roesler. * | |
26678 | ************************************************************************ | |
26679 | ||
26680 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26681 | SAVE | |
26682 | PARAMETER ( LINP = 10 , | |
26683 | & LOUT = 6 , | |
26684 | & LDAT = 9 ) | |
26685 | ||
26686 | IF (IMODE.EQ.1) THEN | |
26687 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO | |
26688 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO | |
26689 | Z=-SDE *XO +CDE *ZO | |
26690 | ELSE | |
26691 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO | |
26692 | Y= -SFE*XO+CFE*YO | |
26693 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO | |
26694 | ENDIF | |
26695 | RETURN | |
26696 | END | |
26697 | ||
26698 | *$ CREATE DT_LT2LAO.FOR | |
26699 | *COPY DT_LT2LAO | |
26700 | * | |
26701 | *===lt2lab=============================================================* | |
26702 | * | |
26703 | SUBROUTINE DT_LT2LAO | |
26704 | ||
26705 | ************************************************************************ | |
26706 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26707 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26708 | * and transforms them back to the lab. * | |
26709 | * This version dated 16.11.95 is written by S. Roesler * | |
26710 | ************************************************************************ | |
26711 | ||
26712 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26713 | SAVE | |
26714 | PARAMETER ( LINP = 10 , | |
26715 | & LOUT = 6 , | |
26716 | & LDAT = 9 ) | |
26717 | ||
26718 | * event history | |
26719 | PARAMETER (NMXHKK=200000) | |
26720 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26721 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26722 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26723 | * extended event history | |
26724 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26725 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26726 | & IHIST(2,NMXHKK) | |
26727 | ||
26728 | NEND = NHKK | |
26729 | NPOINT(5) = NHKK+1 | |
26730 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN | |
26731 | DO 1 I=NPOINT(4),NEND | |
26732 | C DO 1 I=1,NEND | |
26733 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26734 | & (ISTHKK(I).EQ.1001)) THEN | |
26735 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26736 | NOB = NOBAM(I) | |
26737 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), | |
26738 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) | |
26739 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN | |
26740 | ISTHKK(I) = 3*ISTHKK(I) | |
26741 | NOBAM(NHKK) = NOB | |
26742 | ELSE | |
26743 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB | |
26744 | ISTHKK(I) = SIGN(3,ISTHKK(I)) | |
26745 | ENDIF | |
26746 | JDAHKK(1,I) = NHKK | |
26747 | ENDIF | |
26748 | 1 CONTINUE | |
26749 | ||
26750 | RETURN | |
26751 | END | |
26752 | ||
26753 | *$ CREATE DT_LT2LAB.FOR | |
26754 | *COPY DT_LT2LAB | |
26755 | * | |
26756 | *===lt2lab=============================================================* | |
26757 | * | |
26758 | SUBROUTINE DT_LT2LAB | |
26759 | ||
26760 | ************************************************************************ | |
26761 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26762 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26763 | * and transforms them to the lab. * | |
26764 | * This version dated 07.01.96 is written by S. Roesler * | |
26765 | ************************************************************************ | |
26766 | ||
26767 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26768 | SAVE | |
26769 | PARAMETER ( LINP = 10 , | |
26770 | & LOUT = 6 , | |
26771 | & LDAT = 9 ) | |
26772 | ||
26773 | * event history | |
26774 | PARAMETER (NMXHKK=200000) | |
26775 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26776 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26777 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26778 | * extended event history | |
26779 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26780 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26781 | & IHIST(2,NMXHKK) | |
26782 | ||
26783 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
26784 | DO 1 I=NPOINT(4),NHKK | |
26785 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26786 | & (ISTHKK(I).EQ.1001)) THEN | |
430525dd | 26787 | |
9aaba0d6 | 26788 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
26789 | PHKK(3,I) = PZ | |
26790 | PHKK(4,I) = PE | |
26791 | ENDIF | |
26792 | 1 CONTINUE | |
26793 | ||
26794 | RETURN | |
26795 | END | |
26796 | ||
26797 | ************************************************************************ | |
26798 | * * | |
26799 | * 5) Sampling from distributions * | |
26800 | * * | |
26801 | ************************************************************************ | |
26802 | *$ CREATE IDT_NPOISS.FOR | |
26803 | *COPY IDT_NPOISS | |
26804 | * | |
26805 | *===npoiss=============================================================* | |
26806 | * | |
26807 | INTEGER FUNCTION IDT_NPOISS(AVN) | |
26808 | ||
26809 | ************************************************************************ | |
26810 | * Sample according to Poisson distribution with Poisson parameter AVN. * | |
26811 | * The original version written by J. Ranft. * | |
26812 | * This version dated 11.1.95 is written by S. Roesler. * | |
26813 | ************************************************************************ | |
26814 | ||
26815 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26816 | SAVE | |
26817 | PARAMETER ( LINP = 10 , | |
26818 | & LOUT = 6 , | |
26819 | & LDAT = 9 ) | |
26820 | ||
26821 | EXPAVN = EXP(-AVN) | |
26822 | K = 1 | |
26823 | A = 1.0D0 | |
26824 | ||
26825 | 10 CONTINUE | |
26826 | A = DT_RNDM(A)*A | |
26827 | IF (A.GE.EXPAVN) THEN | |
26828 | K = K+1 | |
26829 | GOTO 10 | |
26830 | ENDIF | |
26831 | IDT_NPOISS = K-1 | |
26832 | ||
26833 | RETURN | |
26834 | END | |
26835 | ||
26836 | *$ CREATE DT_SAMPXB.FOR | |
26837 | *COPY DT_SAMPXB | |
26838 | * | |
26839 | *===sampxb=============================================================* | |
26840 | * | |
26841 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) | |
26842 | ||
26843 | ************************************************************************ | |
26844 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * | |
26845 | * Processed by S. Roesler, 6.5.95 * | |
26846 | ************************************************************************ | |
26847 | ||
26848 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26849 | SAVE | |
26850 | PARAMETER (TWO=2.0D0) | |
26851 | ||
26852 | A1 = LOG(X1+SQRT(X1**2+B**2)) | |
26853 | A2 = LOG(X2+SQRT(X2**2+B**2)) | |
26854 | AN = A2-A1 | |
26855 | A = AN*DT_RNDM(A1)+A1 | |
26856 | BB = EXP(A) | |
26857 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) | |
26858 | ||
26859 | RETURN | |
26860 | END | |
26861 | ||
26862 | *$ CREATE DT_SAMPEX.FOR | |
26863 | *COPY DT_SAMPEX | |
26864 | * | |
26865 | *===sampex=============================================================* | |
26866 | * | |
26867 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) | |
26868 | ||
26869 | ************************************************************************ | |
26870 | * Sampling from f(x)=1./x between x1 and x2. * | |
26871 | * Processed by S. Roesler, 6.5.95 * | |
26872 | ************************************************************************ | |
26873 | ||
26874 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26875 | SAVE | |
26876 | PARAMETER (ONE=1.0D0) | |
26877 | ||
26878 | R = DT_RNDM(X1) | |
26879 | AL1 = LOG(X1) | |
26880 | AL2 = LOG(X2) | |
26881 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) | |
26882 | ||
26883 | RETURN | |
26884 | END | |
26885 | ||
26886 | *$ CREATE DT_SAMSQX.FOR | |
26887 | *COPY DT_SAMSQX | |
26888 | * | |
26889 | *===samsqx=============================================================* | |
26890 | * | |
26891 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) | |
26892 | ||
26893 | ************************************************************************ | |
26894 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * | |
26895 | * Processed by S. Roesler, 6.5.95 * | |
26896 | ************************************************************************ | |
26897 | ||
26898 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26899 | SAVE | |
26900 | PARAMETER (ONE=1.0D0) | |
26901 | ||
26902 | R = DT_RNDM(X1) | |
26903 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 | |
26904 | ||
26905 | RETURN | |
26906 | END | |
26907 | ||
26908 | *$ CREATE DT_SAMPLW.FOR | |
26909 | *COPY DT_SAMPLW | |
26910 | * | |
26911 | *===samplw=============================================================* | |
26912 | * | |
26913 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) | |
26914 | ||
26915 | ************************************************************************ | |
26916 | * Sampling from f(x)=1/x^b between x_min and x_max. * | |
26917 | * S. Roesler, 18.4.98 * | |
26918 | ************************************************************************ | |
26919 | ||
26920 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26921 | SAVE | |
26922 | PARAMETER (ONE=1.0D0) | |
26923 | ||
26924 | R = DT_RNDM(B) | |
26925 | IF (B.EQ.ONE) THEN | |
26926 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) | |
26927 | ELSE | |
26928 | ONEMB = ONE-B | |
26929 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) | |
26930 | ENDIF | |
26931 | ||
26932 | RETURN | |
26933 | END | |
26934 | ||
26935 | *$ CREATE DT_BETREJ.FOR | |
26936 | *COPY DT_BETREJ | |
26937 | * | |
26938 | *===betrej=============================================================* | |
26939 | * | |
26940 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) | |
26941 | ||
26942 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26943 | SAVE | |
26944 | ||
26945 | PARAMETER ( LINP = 10 , | |
26946 | & LOUT = 6 , | |
26947 | & LDAT = 9 ) | |
26948 | PARAMETER (ONE=1.0D0) | |
26949 | ||
26950 | IF (XMIN.GE.XMAX)THEN | |
26951 | WRITE (LOUT,500) XMIN,XMAX | |
26952 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) | |
26953 | STOP | |
26954 | ENDIF | |
26955 | ||
26956 | 10 CONTINUE | |
26957 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) | |
26958 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) | |
26959 | YY = BETMAX*DT_RNDM(XX) | |
26960 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) | |
26961 | IF (YY.GT.BETXX) GOTO 10 | |
26962 | DT_BETREJ = XX | |
26963 | ||
26964 | RETURN | |
26965 | END | |
26966 | ||
26967 | *$ CREATE DT_DGAMRN.FOR | |
26968 | *COPY DT_DGAMRN | |
26969 | * | |
26970 | *===dgamrn=============================================================* | |
26971 | * | |
26972 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) | |
26973 | ||
26974 | ************************************************************************ | |
26975 | * Sampling from Gamma-distribution. * | |
26976 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * | |
26977 | * Processed by S. Roesler, 6.5.95 * | |
26978 | ************************************************************************ | |
26979 | ||
26980 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26981 | SAVE | |
26982 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) | |
26983 | ||
26984 | NCOU = 0 | |
26985 | N = INT(ETA) | |
26986 | F = ETA-DBLE(N) | |
26987 | IF (F.EQ.ZERO) GOTO 20 | |
26988 | 10 R = DT_RNDM(F) | |
26989 | NCOU = NCOU+1 | |
26990 | IF (NCOU.GE.11) GOTO 20 | |
26991 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 | |
26992 | YYY = LOG(DT_RNDM(R)+TINY9)/F | |
26993 | IF (ABS(YYY).GT.50.0D0) GOTO 20 | |
26994 | Y = EXP(YYY) | |
26995 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 | |
26996 | GOTO 40 | |
26997 | 20 Y = 0.0D0 | |
26998 | GOTO 50 | |
26999 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) | |
27000 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 | |
27001 | 40 IF (N.EQ.0) GOTO 70 | |
27002 | 50 Z = 1.0D0 | |
27003 | DO 60 I = 1,N | |
27004 | 60 Z = Z*DT_RNDM(Z) | |
27005 | Y = Y-LOG(Z+TINY9) | |
27006 | 70 DT_DGAMRN = Y/ALAM | |
27007 | ||
27008 | RETURN | |
27009 | END | |
27010 | ||
27011 | *$ CREATE DT_DBETAR.FOR | |
27012 | *COPY DT_DBETAR | |
27013 | * | |
27014 | *===dbetar=============================================================* | |
27015 | * | |
27016 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) | |
27017 | ||
27018 | ************************************************************************ | |
27019 | * Sampling from Beta -distribution between 0.0 and 1.0 * | |
27020 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* | |
27021 | * Processed by S. Roesler, 6.5.95 * | |
27022 | ************************************************************************ | |
27023 | ||
27024 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27025 | SAVE | |
27026 | ||
27027 | Y = DT_DGAMRN(1.0D0,GAM) | |
27028 | Z = DT_DGAMRN(1.0D0,ETA) | |
27029 | DT_DBETAR = Y/(Y+Z) | |
27030 | ||
27031 | RETURN | |
27032 | END | |
27033 | ||
27034 | *$ CREATE DT_RANNOR.FOR | |
27035 | *COPY DT_RANNOR | |
27036 | * | |
27037 | *===rannor=============================================================* | |
27038 | * | |
27039 | SUBROUTINE DT_RANNOR(X,Y) | |
27040 | ||
27041 | ************************************************************************ | |
27042 | * Sampling from Gaussian distribution. * | |
27043 | * Processed by S. Roesler, 6.5.95 * | |
27044 | ************************************************************************ | |
27045 | ||
27046 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27047 | SAVE | |
27048 | PARAMETER (TINY10=1.0D-10) | |
27049 | ||
27050 | CALL DT_DSFECF(SFE,CFE) | |
27051 | V = MAX(TINY10,DT_RNDM(X)) | |
27052 | A = SQRT(-2.D0*LOG(V)) | |
27053 | X = A*SFE | |
27054 | Y = A*CFE | |
27055 | ||
27056 | RETURN | |
27057 | END | |
27058 | ||
27059 | *$ CREATE DT_DPOLI.FOR | |
27060 | *COPY DT_DPOLI | |
27061 | * | |
27062 | *===dpoli==============================================================* | |
27063 | * | |
27064 | SUBROUTINE DT_DPOLI(CS,SI) | |
27065 | ||
27066 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27067 | SAVE | |
27068 | ||
27069 | U = DT_RNDM(CS) | |
27070 | CS = DT_RNDM(U) | |
27071 | IF (U.LT.0.5D0) CS=-CS | |
27072 | SI = SQRT(1.0D0-CS*CS+1.0D-10) | |
27073 | ||
27074 | RETURN | |
27075 | END | |
27076 | ||
27077 | *$ CREATE DT_DSFECF.FOR | |
27078 | *COPY DT_DSFECF | |
27079 | * | |
27080 | *===dsfecf=============================================================* | |
27081 | * | |
27082 | SUBROUTINE DT_DSFECF(SFE,CFE) | |
27083 | ||
27084 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27085 | SAVE | |
27086 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27087 | ||
27088 | 1 CONTINUE | |
27089 | X = DT_RNDM(SFE) | |
27090 | Y = DT_RNDM(X) | |
27091 | XX = X*X | |
27092 | YY = Y*Y | |
27093 | XY = XX+YY | |
27094 | IF (XY.GT.ONE) GOTO 1 | |
27095 | CFE = (XX-YY)/XY | |
27096 | SFE = TWO*X*Y/XY | |
27097 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE | |
27098 | RETURN | |
27099 | END | |
27100 | ||
27101 | *$ CREATE DT_RACO.FOR | |
27102 | *COPY DT_RACO | |
27103 | * | |
27104 | *===raco===============================================================* | |
27105 | * | |
27106 | SUBROUTINE DT_RACO(WX,WY,WZ) | |
27107 | ||
27108 | ************************************************************************ | |
27109 | * Direction cosines of random uniform (isotropic) direction in three * | |
27110 | * dimensional space * | |
27111 | * Processed by S. Roesler, 20.11.95 * | |
27112 | ************************************************************************ | |
27113 | ||
27114 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27115 | SAVE | |
27116 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27117 | ||
27118 | 10 CONTINUE | |
27119 | X = TWO*DT_RNDM(WX)-ONE | |
27120 | Y = DT_RNDM(X) | |
27121 | X2 = X*X | |
27122 | Y2 = Y*Y | |
27123 | IF (X2+Y2.GT.ONE) GOTO 10 | |
27124 | ||
27125 | CFE = (X2-Y2)/(X2+Y2) | |
27126 | SFE = TWO*X*Y/(X2+Y2) | |
27127 | * z = 1/2 [ 1 + cos (theta) ] | |
27128 | Z = DT_RNDM(X) | |
27129 | * 1/2 sin (theta) | |
27130 | WZ = SQRT(Z*(ONE-Z)) | |
27131 | WX = TWO*WZ*CFE | |
27132 | WY = TWO*WZ*SFE | |
27133 | WZ = TWO*Z-ONE | |
27134 | ||
27135 | RETURN | |
27136 | END | |
27137 | ||
27138 | ************************************************************************ | |
27139 | * * | |
27140 | * 6) Special functions, algorithms and service routines * | |
27141 | * * | |
27142 | ************************************************************************ | |
27143 | *$ CREATE DT_YLAMB.FOR | |
27144 | *COPY DT_YLAMB | |
27145 | * | |
27146 | *===ylamb==============================================================* | |
27147 | * | |
27148 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) | |
27149 | ||
27150 | ************************************************************************ | |
27151 | * * | |
27152 | * auxiliary function for three particle decay mode * | |
27153 | * (standard LAMBDA**(1/2) function) * | |
27154 | * * | |
27155 | * Adopted from an original version written by R. Engel. * | |
27156 | * This version dated 12.12.94 is written by S. Roesler. * | |
27157 | ************************************************************************ | |
27158 | ||
27159 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27160 | SAVE | |
27161 | ||
27162 | YZ = Y-Z | |
27163 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ | |
27164 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) | |
27165 | DT_YLAMB = SQRT(XLAM) | |
27166 | ||
27167 | RETURN | |
27168 | END | |
27169 | ||
27170 | *$ CREATE DT_SORT.FOR | |
27171 | *COPY DT_SORT | |
27172 | * | |
27173 | *===sort1==============================================================* | |
27174 | * | |
27175 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) | |
27176 | ||
27177 | ************************************************************************ | |
27178 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27179 | * of A(3,i). * | |
27180 | * MODE = 1 increasing in A(3,i=1..N) * | |
27181 | * = 2 decreasing in A(3,i=1..N) * | |
27182 | * This version dated 21.04.95 is revised by S. Roesler * | |
27183 | ************************************************************************ | |
27184 | ||
27185 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27186 | SAVE | |
27187 | ||
27188 | DIMENSION A(3,N) | |
27189 | ||
27190 | M = I1 | |
27191 | 10 CONTINUE | |
27192 | M = I1-1 | |
27193 | IF (M.LE.0) RETURN | |
27194 | L = 0 | |
27195 | DO 20 I=I0,M | |
27196 | J = I+1 | |
27197 | IF (MODE.EQ.1) THEN | |
27198 | IF (A(3,I).LE.A(3,J)) GOTO 20 | |
27199 | ELSE | |
27200 | IF (A(3,I).GE.A(3,J)) GOTO 20 | |
27201 | ENDIF | |
27202 | B = A(3,I) | |
27203 | C = A(1,I) | |
27204 | D = A(2,I) | |
27205 | A(3,I) = A(3,J) | |
27206 | A(2,I) = A(2,J) | |
27207 | A(1,I) = A(1,J) | |
27208 | A(3,J) = B | |
27209 | A(1,J) = C | |
27210 | A(2,J) = D | |
27211 | L = 1 | |
27212 | 20 CONTINUE | |
27213 | IF (L.EQ.1) GOTO 10 | |
27214 | ||
27215 | RETURN | |
27216 | END | |
27217 | ||
27218 | *$ CREATE DT_SORT1.FOR | |
27219 | *COPY DT_SORT1 | |
27220 | * | |
27221 | *===sort1==============================================================* | |
27222 | * | |
27223 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) | |
27224 | ||
27225 | ************************************************************************ | |
27226 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27227 | * of A(i). * | |
27228 | * MODE = 1 increasing in A(i=1..N) * | |
27229 | * = 2 decreasing in A(i=1..N) * | |
27230 | * This version dated 21.04.95 is revised by S. Roesler * | |
27231 | ************************************************************************ | |
27232 | ||
27233 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27234 | SAVE | |
27235 | ||
27236 | DIMENSION A(N),IDX(N) | |
27237 | ||
27238 | M = I1 | |
27239 | 10 CONTINUE | |
27240 | M = I1-1 | |
27241 | IF (M.LE.0) RETURN | |
27242 | L = 0 | |
27243 | DO 20 I=I0,M | |
27244 | J = I+1 | |
27245 | IF (MODE.EQ.1) THEN | |
27246 | IF (A(I).LE.A(J)) GOTO 20 | |
27247 | ELSE | |
27248 | IF (A(I).GE.A(J)) GOTO 20 | |
27249 | ENDIF | |
27250 | B = A(I) | |
27251 | A(I) = A(J) | |
27252 | A(J) = B | |
27253 | IX = IDX(I) | |
27254 | IDX(I) = IDX(J) | |
27255 | IDX(J) = IX | |
27256 | L = 1 | |
27257 | 20 CONTINUE | |
27258 | IF (L.EQ.1) GOTO 10 | |
27259 | ||
27260 | RETURN | |
27261 | END | |
27262 | ||
27263 | *$ CREATE DT_XTIME.FOR | |
27264 | *COPY DT_XTIME | |
27265 | * | |
27266 | *===xtime==============================================================* | |
27267 | * | |
27268 | SUBROUTINE DT_XTIME | |
27269 | ||
27270 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27271 | SAVE | |
27272 | PARAMETER ( LINP = 10 , | |
27273 | & LOUT = 6 , | |
27274 | & LDAT = 9 ) | |
27275 | ||
27276 | CHARACTER DAT*9,TIM*11 | |
27277 | ||
27278 | DAT = ' ' | |
27279 | TIM = ' ' | |
27280 | C CALL GETDAT(IYEAR,IMONTH,IDAY) | |
27281 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) | |
27282 | ||
27283 | C CALL DATE(DAT) | |
27284 | C CALL TIME(TIM) | |
27285 | C WRITE(LOUT,1000) DAT,TIM | |
27286 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) | |
27287 | ||
27288 | RETURN | |
27289 | END | |
27290 | ||
27291 | ************************************************************************ | |
27292 | * * | |
27293 | * 7) Random number generator package * | |
27294 | * * | |
27295 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * | |
27296 | * SERVICE ROUTINES. * | |
27297 | * THE ALGORITHM IS FROM * | |
27298 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * | |
27299 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * | |
27300 | * IMPLEMENTATION BY K. HAHN DEC. 88, * | |
27301 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * | |
27302 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * | |
27303 | * THE PERIOD IS ABOUT 2**144, * | |
27304 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * | |
27305 | * THE PACKAGE CONTAINS * | |
27306 | * FUNCTION DT_RNDM(I) : GENERATOR * | |
27307 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * | |
27308 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * | |
27309 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * | |
27310 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * | |
27311 | *--- * | |
27312 | * FUNCTION DT_RNDM(I) * | |
27313 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * | |
27314 | * I - DUMMY VARIABLE, NOT USED * | |
27315 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * | |
27316 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * | |
27317 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * | |
27318 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * | |
27319 | * 12,34,56 ARE THE STANDARD VALUES * | |
27320 | * NB1 MUST BE IN 1..168 * | |
27321 | * 78 IS THE STANDARD VALUE * | |
27322 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * | |
27323 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * | |
27324 | * AS AFTER THE LAST DT_RNDMOU CALL ) * | |
27325 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * | |
27326 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * | |
27327 | * TAKES SEED FROM GENERATOR * | |
27328 | * U(97),C,CD,CM,I,J - SEED VALUES * | |
27329 | * SUBROUTINE DT_RNDMTE(IO) * | |
27330 | * TEST OF THE GENERATOR * | |
27331 | * IO - DEFINES OUTPUT * | |
27332 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * | |
27333 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * | |
27334 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * | |
27335 | * SAME STATUS * | |
27336 | * AS BEFORE CALL OF DT_RNDMTE * | |
27337 | ************************************************************************ | |
27338 | *$ CREATE DT_RNDM.FOR | |
27339 | *COPY DT_RNDM | |
27340 | * | |
839efe5b | 27341 | c$$$*===rndm===============================================================* |
27342 | c$$$* | |
27343 | c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) | |
27344 | c$$$ | |
27345 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27346 | c$$$ SAVE | |
27347 | c$$$ | |
27348 | c$$$* random number generator | |
27349 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27350 | c$$$ | |
27351 | c$$$* counter of calls to random number generator | |
27352 | c$$$* uncomment if needed | |
27353 | c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1 | |
27354 | c$$$C LOGICAL LFIRST | |
27355 | c$$$C DATA LFIRST /.TRUE./ | |
27356 | c$$$ | |
27357 | c$$$* counter of calls to random number generator | |
27358 | c$$$* uncomment if needed | |
27359 | c$$$C IF (LFIRST) THEN | |
27360 | c$$$C IRNCT0 = 0 | |
27361 | c$$$C IRNCT1 = 0 | |
27362 | c$$$C LFIRST = .FALSE. | |
27363 | c$$$C ENDIF | |
27364 | c$$$ 100 CONTINUE | |
27365 | c$$$ DT_RNDM = U(I)-U(J) | |
27366 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27367 | c$$$ U(I) = DT_RNDM | |
27368 | c$$$ I = I-1 | |
27369 | c$$$ IF ( I.EQ.0 ) I = 97 | |
27370 | c$$$ J = J-1 | |
27371 | c$$$ IF ( J.EQ.0 ) J = 97 | |
27372 | c$$$ C = C-CD | |
27373 | c$$$ IF ( C.LT.0.0D0 ) C = C+CM | |
27374 | c$$$ DT_RNDM = DT_RNDM-C | |
27375 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27376 | c$$$ | |
27377 | c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100 | |
27378 | c$$$ | |
27379 | c$$$* counter of calls to random number generator | |
27380 | c$$$* uncomment if needed | |
27381 | c$$$C IRNCT0 = IRNCT0+1 | |
27382 | c$$$ | |
27383 | c$$$ RETURN | |
27384 | c$$$ END | |
27385 | c$$$ | |
27386 | c$$$*$ CREATE DT_RNDMST.FOR | |
27387 | c$$$*COPY DT_RNDMST | |
27388 | c$$$* | |
27389 | c$$$*===rndmst=============================================================* | |
27390 | c$$$* | |
27391 | c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) | |
27392 | c$$$ | |
27393 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27394 | c$$$ SAVE | |
27395 | c$$$ | |
27396 | c$$$* random number generator | |
27397 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27398 | c$$$ | |
27399 | c$$$ MA1 = NA1 | |
27400 | c$$$ MA2 = NA2 | |
27401 | c$$$ MA3 = NA3 | |
27402 | c$$$ MB1 = NB1 | |
27403 | c$$$ I = 97 | |
27404 | c$$$ J = 33 | |
27405 | c$$$ DO 20 II2 = 1,97 | |
27406 | c$$$ S = 0 | |
27407 | c$$$ T = 0.5D0 | |
27408 | c$$$ DO 10 II1 = 1,24 | |
27409 | c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179) | |
27410 | c$$$ MA1 = MA2 | |
27411 | c$$$ MA2 = MA3 | |
27412 | c$$$ MA3 = MAT | |
27413 | c$$$ MB1 = MOD(53*MB1+1,169) | |
27414 | c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T | |
27415 | c$$$ 10 T = 0.5D0*T | |
27416 | c$$$ 20 U(II2) = S | |
27417 | c$$$ C = 362436.0D0/16777216.0D0 | |
27418 | c$$$ CD = 7654321.0D0/16777216.0D0 | |
27419 | c$$$ CM = 16777213.0D0/16777216.0D0 | |
27420 | c$$$ RETURN | |
27421 | c$$$ END | |
27422 | c$$$ | |
27423 | c$$$*$ CREATE DT_RNDMIN.FOR | |
27424 | c$$$*COPY DT_RNDMIN | |
27425 | c$$$* | |
27426 | c$$$*===rndmin=============================================================* | |
27427 | c$$$* | |
27428 | c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) | |
27429 | c$$$ | |
27430 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27431 | c$$$ SAVE | |
27432 | c$$$ | |
27433 | c$$$* random number generator | |
27434 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27435 | c$$$ | |
27436 | c$$$ DIMENSION UIN(97) | |
27437 | c$$$ | |
27438 | c$$$ DO 10 KKK = 1,97 | |
27439 | c$$$ 10 U(KKK) = UIN(KKK) | |
27440 | c$$$ C = CIN | |
27441 | c$$$ CD = CDIN | |
27442 | c$$$ CM = CMIN | |
27443 | c$$$ I = IIN | |
27444 | c$$$ J = JIN | |
27445 | c$$$ | |
27446 | c$$$ RETURN | |
27447 | c$$$ END | |
27448 | c$$$ | |
27449 | c$$$*$ CREATE DT_RNDMOU.FOR | |
27450 | c$$$*COPY DT_RNDMOU | |
27451 | c$$$* | |
27452 | c$$$*===rndmou=============================================================* | |
27453 | c$$$* | |
27454 | c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) | |
27455 | c$$$ | |
27456 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27457 | c$$$ SAVE | |
27458 | c$$$ | |
27459 | c$$$* random number generator | |
27460 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27461 | c$$$ | |
27462 | c$$$ DIMENSION UOUT(97) | |
27463 | c$$$ | |
27464 | c$$$ DO 10 KKK = 1,97 | |
27465 | c$$$ 10 UOUT(KKK) = U(KKK) | |
27466 | c$$$ COUT = C | |
27467 | c$$$ CDOUT = CD | |
27468 | c$$$ CMOUT = CM | |
27469 | c$$$ IOUT = I | |
27470 | c$$$ JOUT = J | |
27471 | c$$$ | |
27472 | c$$$ RETURN | |
27473 | c$$$ END | |
27474 | c$$$ | |
27475 | c$$$*$ CREATE DT_RNDMTE.FOR | |
27476 | c$$$*COPY DT_RNDMTE | |
27477 | c$$$* | |
27478 | c$$$*===rndmte=============================================================* | |
27479 | c$$$* | |
27480 | c$$$ SUBROUTINE DT_RNDMTE(IO) | |
27481 | c$$$ | |
27482 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27483 | c$$$ SAVE | |
27484 | c$$$ | |
27485 | c$$$ DIMENSION UU(97),U(6),X(6),D(6) | |
27486 | c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, | |
27487 | c$$$ +8354498.D0, 10633180.D0/ | |
27488 | c$$$ | |
27489 | c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) | |
27490 | c$$$ CALL DT_RNDMST(12,34,56,78) | |
27491 | c$$$ DO 10 II1 = 1,20000 | |
27492 | c$$$ 10 XX = DT_RNDM(XX) | |
27493 | c$$$ SD = 0.0D0 | |
27494 | c$$$ DO 20 II2 = 1,6 | |
27495 | c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) | |
27496 | c$$$ D(II2) = X(II2)-U(II2) | |
27497 | c$$$ 20 SD = SD+D(II2) | |
27498 | c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) | |
27499 | c$$$**sr 24.01.95 | |
27500 | c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) | |
27501 | c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN | |
27502 | c$$$C WRITE(6,1000) | |
27503 | c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', | |
27504 | c$$$ & ' passed') | |
27505 | c$$$ ENDIF | |
27506 | c$$$** | |
27507 | c$$$ RETURN | |
27508 | c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, | |
27509 | c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. | |
27510 | c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;', | |
27511 | c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') | |
27512 | c$$$ END | |
9aaba0d6 | 27513 | * |
27514 | *$ CREATE PHO_RNDM.FOR | |
27515 | *COPY PHO_RNDM | |
27516 | * | |
27517 | *===pho_rndm===========================================================* | |
27518 | * | |
27519 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) | |
27520 | ||
27521 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27522 | SAVE | |
27523 | ||
27524 | PHO_RNDM = DT_RNDM(DUMMY) | |
27525 | ||
27526 | RETURN | |
27527 | END | |
27528 | ||
27529 | *$ CREATE PYR.FOR | |
27530 | *COPY PYR | |
27531 | * | |
27532 | *===pyr================================================================* | |
27533 | * | |
27534 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) | |
27535 | ||
27536 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27537 | SAVE | |
27538 | ||
27539 | DUMMY = DBLE(IDUMMY) | |
27540 | PYR = DT_RNDM(DUMMY) | |
27541 | ||
27542 | RETURN | |
27543 | END | |
27544 | ||
27545 | *$ CREATE DT_TITLE.FOR | |
27546 | *COPY DT_TITLE | |
27547 | * | |
27548 | *===title==============================================================* | |
27549 | * | |
27550 | SUBROUTINE DT_TITLE | |
27551 | ||
27552 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27553 | SAVE | |
27554 | PARAMETER ( LINP = 10 , | |
27555 | & LOUT = 6 , | |
27556 | & LDAT = 9 ) | |
27557 | ||
27558 | CHARACTER*6 CVERSI | |
27559 | CHARACTER*11 CCHANG | |
27560 | DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/ | |
27561 | ||
27562 | CALL DT_XTIME | |
27563 | WRITE(LOUT,1000) CVERSI,CCHANG | |
27564 | 1000 FORMAT(1X,'+-------------------------------------------------', | |
27565 | & '----------------------+',/, | |
27566 | & 1X,'|',71X,'|',/, | |
27567 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, | |
27568 | & 1X,'|',71X,'|',/, | |
27569 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, | |
27570 | & 1X,'|',71X,'|',/, | |
27571 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, | |
27572 | & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/, | |
27573 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, | |
27574 | & 1X,'|',71X,'|',/, | |
27575 | & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', | |
27576 | & 17X,'|',/, | |
27577 | & 1X,'|',71X,'|',/, | |
27578 | & 1X,'+-------------------------------------------------', | |
27579 | & '----------------------+',/, | |
27580 | & 1X,'| Please send suggestions, bug reports, etc. to: ', | |
27581 | & 'Stefan.Roesler@cern.ch |',/, | |
27582 | & 1X,'+-------------------------------------------------', | |
27583 | & '----------------------+',/) | |
27584 | ||
27585 | RETURN | |
27586 | END | |
27587 | ||
27588 | *$ CREATE DT_EVTINI.FOR | |
27589 | *COPY DT_EVTINI | |
27590 | * | |
27591 | *===evtini=============================================================* | |
27592 | * | |
27593 | SUBROUTINE DT_EVTINI | |
27594 | ||
27595 | ************************************************************************ | |
27596 | * Initialization of DTEVT1. * | |
27597 | * This version dated 15.01.94 is written by S. Roesler * | |
27598 | ************************************************************************ | |
27599 | ||
27600 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27601 | SAVE | |
27602 | PARAMETER ( LINP = 10 , | |
27603 | & LOUT = 6 , | |
27604 | & LDAT = 9 ) | |
27605 | ||
27606 | * event history | |
27607 | PARAMETER (NMXHKK=200000) | |
27608 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27609 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27610 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27611 | * extended event history | |
27612 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27613 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27614 | & IHIST(2,NMXHKK) | |
27615 | * event flag | |
27616 | COMMON /DTEVNO/ NEVENT,ICASCA | |
27617 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
27618 | * emulsion treatment | |
27619 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
27620 | & NCOMPO,IEMUL | |
27621 | ||
27622 | * initialization of DTEVT1/DTEVT2 | |
27623 | NEND = NHKK | |
27624 | IF (NEVENT.EQ.1) NEND = NMXHKK | |
27625 | NHKK = 0 | |
27626 | NEVHKK = NEVENT | |
27627 | DO 1 I=1,NEND | |
27628 | ISTHKK(I) = 0 | |
27629 | IDHKK(I) = 0 | |
27630 | JMOHKK(1,I) = 0 | |
27631 | JMOHKK(2,I) = 0 | |
27632 | JDAHKK(1,I) = 0 | |
27633 | JDAHKK(2,I) = 0 | |
27634 | IDRES(I) = 0 | |
27635 | IDXRES(I) = 0 | |
27636 | NOBAM(I) = 0 | |
27637 | IDCH(I) = 0 | |
27638 | IHIST(1,I) = 0 | |
27639 | IHIST(2,I) = 0 | |
27640 | DO 2 J=1,4 | |
27641 | PHKK(J,I) = 0.0D0 | |
27642 | VHKK(J,I) = 0.0D0 | |
27643 | WHKK(J,I) = 0.0D0 | |
27644 | 2 CONTINUE | |
27645 | PHKK(5,I) = 0.0D0 | |
27646 | 1 CONTINUE | |
27647 | DO 3 I=1,10 | |
27648 | NPOINT(I) = 0 | |
27649 | 3 CONTINUE | |
27650 | CALL DT_CHASTA(-1) | |
27651 | ||
27652 | C* initialization of DTLTRA | |
27653 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) | |
27654 | ||
27655 | RETURN | |
27656 | END | |
27657 | ||
27658 | *$ CREATE DT_STATIS.FOR | |
27659 | *COPY DT_STATIS | |
27660 | * | |
27661 | *===statis=============================================================* | |
27662 | * | |
27663 | SUBROUTINE DT_STATIS(MODE) | |
27664 | ||
27665 | ************************************************************************ | |
27666 | * Initialization and output of run-statistics. * | |
27667 | * MODE = 1 initialization * | |
27668 | * = 2 output * | |
27669 | * This version dated 23.01.94 is written by S. Roesler * | |
27670 | ************************************************************************ | |
27671 | ||
27672 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27673 | SAVE | |
27674 | PARAMETER ( LINP = 10 , | |
27675 | & LOUT = 6 , | |
27676 | & LDAT = 9 ) | |
27677 | PARAMETER (TINY3=1.0D-3) | |
27678 | ||
27679 | * statistics | |
27680 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
27681 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
27682 | & ICEVTG(8,0:30) | |
27683 | * rejection counter | |
27684 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27685 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27686 | & IREXCI(3),IRDIFF(2),IRINC | |
27687 | * central particle production, impact parameter biasing | |
27688 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
27689 | * various options for treatment of partons (DTUNUC 1.x) | |
27690 | * (chain recombination, Cronin,..) | |
27691 | LOGICAL LCO2CR,LINTPT | |
27692 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
27693 | & LCO2CR,LINTPT | |
27694 | * nucleon-nucleon event-generator | |
27695 | CHARACTER*8 CMODEL | |
27696 | LOGICAL LPHOIN | |
27697 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
27698 | * flags for particle decays | |
27699 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
27700 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
27701 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
27702 | * diquark-breaking mechanism | |
27703 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
27704 | ||
27705 | DIMENSION PP(4),PT(4) | |
27706 | ||
27707 | GOTO (1,2) MODE | |
27708 | ||
27709 | * initialization | |
27710 | 1 CONTINUE | |
27711 | ||
27712 | * initialize statistics counter | |
27713 | ICREQU = 0 | |
27714 | ICSAMP = 0 | |
27715 | ICCPRO = 0 | |
27716 | ICDPR = 0 | |
27717 | ICDTA = 0 | |
27718 | ICRJSS = 0 | |
27719 | ICVV2S = 0 | |
27720 | DO 10 I=1,9 | |
27721 | ICRES(I) = 0 | |
27722 | ICCHAI(1,I) = 0 | |
27723 | ICCHAI(2,I) = 0 | |
27724 | 10 CONTINUE | |
27725 | * initialize rejection counter | |
27726 | IRPT = 0 | |
27727 | IRHHA = 0 | |
27728 | LOMRES = 0 | |
27729 | LOBRES = 0 | |
27730 | IRFRAG = 0 | |
27731 | IREVT = 0 | |
27732 | IRRES(1) = 0 | |
27733 | IRRES(2) = 0 | |
27734 | IRCHKI(1) = 0 | |
27735 | IRCHKI(2) = 0 | |
27736 | IRCRON(1) = 0 | |
27737 | IRCRON(2) = 0 | |
27738 | IRCRON(3) = 0 | |
27739 | IRDIFF(1) = 0 | |
27740 | IRDIFF(2) = 0 | |
27741 | IRINC = 0 | |
27742 | DO 11 I=1,5 | |
27743 | ICDIFF(I) = 0 | |
27744 | 11 CONTINUE | |
27745 | DO 12 I=1,8 | |
27746 | DO 13 J=0,30 | |
27747 | ICEVTG(I,J) = 0 | |
27748 | 13 CONTINUE | |
27749 | 12 CONTINUE | |
27750 | ||
27751 | RETURN | |
27752 | ||
27753 | * output | |
27754 | 2 CONTINUE | |
27755 | ||
27756 | * statistics counter | |
27757 | WRITE(LOUT,1000) | |
27758 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, | |
27759 | & 28X,'---------------------') | |
be6523b4 | 27760 | IF (ICREQU.GT.0) THEN |
9aaba0d6 | 27761 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) |
27762 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, | |
27763 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', | |
27764 | & 'event',11X,F9.1) | |
be6523b4 | 27765 | ENDIF |
9aaba0d6 | 27766 | IF (ICDIFF(1).NE.0) THEN |
27767 | WRITE(LOUT,1009) ICDIFF | |
27768 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, | |
27769 | & 'low mass high mass',/,24X,'single diffraction', | |
27770 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) | |
27771 | ENDIF | |
be6523b4 | 27772 | IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN |
9aaba0d6 | 27773 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), |
27774 | & DBLE(ICSAMP)/DBLE(ICCPRO) | |
27775 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', | |
27776 | & ' of sampled Glauber-events per event',9X,F9.1,/, | |
27777 | & 2X,'fraction of production cross section',21X,F10.6) | |
27778 | ENDIF | |
be6523b4 | 27779 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27780 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), |
27781 | & DBLE(ICDTA)/DBLE(ICSAMP) | |
27782 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', | |
27783 | & ' nucleons after x-sampling',2(4X,F6.2)) | |
be6523b4 | 27784 | ENDIF |
9aaba0d6 | 27785 | |
27786 | IF (MCGENE.EQ.1) THEN | |
be6523b4 | 27787 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27788 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) |
27789 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', | |
27790 | & ' event',3X,F9.1) | |
27791 | IF (ISICHA.EQ.1) THEN | |
27792 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) | |
27793 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', | |
27794 | & 'of single chains per event',13X,F9.1) | |
27795 | ENDIF | |
be6523b4 | 27796 | ENDIF |
27797 | IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN | |
9aaba0d6 | 27798 | WRITE(LOUT,1006) |
27799 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, | |
27800 | & 23X,'mean number of chains mean number of chains',/, | |
27801 | & 23X,'sampled hadronized having mass of a reso.') | |
27802 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), | |
27803 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), | |
27804 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), | |
27805 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) | |
27806 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27807 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27808 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27809 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27810 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27811 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27812 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27813 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27814 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) | |
27815 | WRITE(LOUT,1008) | |
27816 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), | |
27817 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), | |
27818 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), | |
27819 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), | |
27820 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), | |
27821 | & DBLE(IRHHA)/DBLE(ICREQU), | |
27822 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), | |
27823 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) | |
27824 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, | |
27825 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', | |
27826 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, | |
27827 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, | |
27828 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, | |
27829 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', | |
27830 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, | |
27831 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', | |
27832 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, | |
27833 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, | |
27834 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', | |
27835 | & F7.2,/,1X,'Total no. of rej.', | |
27836 | & ' in chain-systems treatment (GETCSY)',/,43X, | |
27837 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', | |
27838 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, | |
27839 | & 1X,'Total no. of rej. in DPM-treatment of one event', | |
27840 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, | |
27841 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' | |
27842 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, | |
27843 | & 'IREXCI(3) = ',I5,/) | |
be6523b4 | 27844 | ENDIF |
9aaba0d6 | 27845 | ELSEIF (MCGENE.EQ.2) THEN |
27846 | WRITE(LOUT,1010) ELOJET | |
27847 | 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', | |
27848 | & F4.1,' GeV') | |
27849 | WRITE(LOUT,1011) | |
27850 | 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, | |
27851 | & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', | |
27852 | & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') | |
27853 | WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), | |
27854 | & (INT(ICCHAI(2,I)/2.0D0),I=1,8), | |
27855 | & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), | |
27856 | & ((ICEVTG(I,J),I=1,8),J=3,7), | |
27857 | & ((ICEVTG(I,J),I=1,8),J=19,21), | |
27858 | & (ICEVTG(I,8),I=1,8), | |
27859 | & ((ICEVTG(I,J),I=1,8),J=22,24), | |
27860 | & (ICEVTG(I,9),I=1,8), | |
27861 | & ((ICEVTG(I,J),I=1,8),J=25,28), | |
27862 | & ((ICEVTG(I,J),I=1,8),J=10,18) | |
27863 | 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', | |
27864 | & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, | |
27865 | & ' no-dif.',8I8,/, | |
27866 | & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, | |
27867 | & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, | |
27868 | & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, | |
27869 | & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, | |
27870 | & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, | |
27871 | & ' hi-lo ',8I8,/, | |
27872 | & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, | |
27873 | & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, | |
27874 | & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) | |
27875 | WRITE(LOUT,1013) | |
27876 | 1013 FORMAT(/,1X,'2. chain system statistics -', | |
27877 | & ' mean numbers per evt:',/,30X,'---------------------', | |
27878 | & /,/,16X,'s-s',7X,'d-s',7X,'s-d') | |
be6523b4 | 27879 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27880 | WRITE(LOUT,1014) |
27881 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), | |
27882 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), | |
27883 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) | |
27884 | 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, | |
27885 | & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, | |
27886 | & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, | |
27887 | & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, | |
27888 | & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, | |
27889 | & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, | |
27890 | & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, | |
27891 | & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, | |
27892 | & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, | |
27893 | & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) | |
be6523b4 | 27894 | ENDIF |
9aaba0d6 | 27895 | WRITE(LOUT,1015) |
27896 | 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') | |
be6523b4 | 27897 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27898 | WRITE(LOUT,1016) |
27899 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), | |
27900 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), | |
27901 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) | |
27902 | 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, | |
27903 | & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, | |
27904 | & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, | |
27905 | & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, | |
27906 | & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, | |
27907 | & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, | |
27908 | & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, | |
27909 | & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, | |
27910 | & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, | |
27911 | & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) | |
be6523b4 | 27912 | ENDIF |
9aaba0d6 | 27913 | |
27914 | ENDIF | |
27915 | CALL DT_CHASTA(1) | |
27916 | ||
27917 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
27918 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
27919 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', | |
27920 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), | |
27921 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) | |
27922 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', | |
27923 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), | |
27924 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) | |
27925 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', | |
27926 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), | |
27927 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) | |
27928 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', | |
27929 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), | |
27930 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) | |
27931 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', | |
27932 | & DBRKA(3,1),DBRKA(3,2), | |
27933 | & DBRKA(3,3),DBRKA(3,4) | |
27934 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', | |
27935 | & DBRKR(3,1),DBRKR(3,2), | |
27936 | & DBRKR(3,3),DBRKR(3,4) | |
27937 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', | |
27938 | & DBRKA(3,5),DBRKA(3,6), | |
27939 | & DBRKA(3,7),DBRKA(3,8) | |
27940 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', | |
27941 | & DBRKR(3,5),DBRKR(3,6), | |
27942 | & DBRKR(3,7),DBRKR(3,8) | |
27943 | ENDIF | |
27944 | ||
27945 | FAC = 1.0D0 | |
27946 | IF (MCGENE.EQ.2) THEN | |
27947 | C CALL PHO_PHIST(-2,SIGMAX) | |
27948 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) | |
27949 | ENDIF | |
27950 | ||
27951 | CALL DT_XTIME | |
27952 | ||
27953 | RETURN | |
27954 | END | |
27955 | ||
27956 | *$ CREATE DT_EVTOUT.FOR | |
27957 | *COPY DT_EVTOUT | |
27958 | * | |
27959 | *===evtout=============================================================* | |
27960 | * | |
27961 | SUBROUTINE DT_EVTOUT(MODE) | |
27962 | ||
27963 | ************************************************************************ | |
27964 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27965 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27966 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27967 | * This version dated 11.12.94 is written by S. Roesler * | |
27968 | ************************************************************************ | |
27969 | ||
27970 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27971 | SAVE | |
27972 | PARAMETER ( LINP = 10 , | |
27973 | & LOUT = 6 , | |
27974 | & LDAT = 9 ) | |
27975 | * event history | |
27976 | PARAMETER (NMXHKK=200000) | |
27977 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27978 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27979 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27980 | ||
27981 | DIMENSION IRANGE(NMXHKK) | |
27982 | ||
27983 | IF (MODE.EQ.2) RETURN | |
27984 | ||
27985 | CALL DT_EVTPLO(IRANGE,MODE) | |
27986 | ||
27987 | RETURN | |
27988 | END | |
27989 | ||
27990 | *$ CREATE DT_EVTPLO.FOR | |
27991 | *COPY DT_EVTPLO | |
27992 | * | |
27993 | *===evtplo=============================================================* | |
27994 | * | |
27995 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) | |
27996 | ||
27997 | ************************************************************************ | |
27998 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27999 | * 2 plot entries of DTEVT1 given by IRANGE * | |
28000 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
28001 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
28002 | * 5 plot rejection counter * | |
28003 | * This version dated 11.12.94 is written by S. Roesler * | |
28004 | ************************************************************************ | |
28005 | ||
28006 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28007 | SAVE | |
28008 | PARAMETER ( LINP = 10 , | |
28009 | & LOUT = 6 , | |
28010 | & LDAT = 9 ) | |
28011 | ||
28012 | CHARACTER*16 CHAU | |
28013 | ||
28014 | * event history | |
28015 | PARAMETER (NMXHKK=200000) | |
28016 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28017 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28018 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28019 | * extended event history | |
28020 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28021 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28022 | & IHIST(2,NMXHKK) | |
28023 | * rejection counter | |
28024 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
28025 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
28026 | & IREXCI(3),IRDIFF(2),IRINC | |
28027 | ||
28028 | DIMENSION IRANGE(NMXHKK) | |
28029 | ||
28030 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN | |
28031 | WRITE(LOUT,1000) | |
28032 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, | |
28033 | & 15X,' --------------------------',/,/, | |
28034 | & ' ST ID M1 M2 D1 D2 PX PY', | |
28035 | & ' PZ E M',/) | |
28036 | DO 1 I=1,NHKK | |
28037 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28038 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28039 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28040 | & PHKK(5,I) | |
28041 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28042 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28043 | C & PHKK(3,I),PHKK(4,I) | |
28044 | C WRITE(LOUT,'(4E15.4)') | |
28045 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) | |
28046 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) | |
28047 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) | |
28048 | 1 CONTINUE | |
28049 | WRITE(LOUT,*) | |
28050 | C DO 4 I=1,NHKK | |
28051 | C WRITE(LOUT,1006) I,ISTHKK(I), | |
28052 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), | |
28053 | C & WHKK(2,I),WHKK(3,I) | |
28054 | C1006 FORMAT(1X,I4,I6,6E10.3) | |
28055 | C 4 CONTINUE | |
28056 | ENDIF | |
28057 | ||
28058 | IF (MODE.EQ.2) THEN | |
28059 | WRITE(LOUT,1000) | |
28060 | NC = 0 | |
28061 | 2 CONTINUE | |
28062 | NC = NC+1 | |
28063 | IF (IRANGE(NC).EQ.-100) GOTO 9999 | |
28064 | I = IRANGE(NC) | |
28065 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28066 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28067 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28068 | & PHKK(5,I) | |
28069 | GOTO 2 | |
28070 | ENDIF | |
28071 | ||
28072 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN | |
28073 | WRITE(LOUT,1002) | |
28074 | 1002 FORMAT(/,1X,'EVTPLO:',14X, | |
28075 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, | |
28076 | & 15X,' -----------------------------------',/,/, | |
28077 | & ' ST ID M1 M2 D1 D2 IDR IDXR', | |
28078 | & ' NOBAM IDCH M',/) | |
28079 | DO 3 I=1,NHKK | |
28080 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN | |
28081 | KF = IDHKK(I) | |
28082 | IDCHK = KF/10000 | |
28083 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28084 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 | |
28085 | CALL PYNAME(KF,CHAU) | |
28086 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28087 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28088 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), | |
28089 | & PHKK(5,I),CHAU | |
28090 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) | |
28091 | C ENDIF | |
28092 | 3 CONTINUE | |
28093 | ENDIF | |
28094 | ||
28095 | IF (MODE.EQ.5) THEN | |
28096 | WRITE(LOUT,1004) | |
28097 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, | |
28098 | & 15X,' --------------------------',/) | |
28099 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, | |
28100 | & IRSEA,IRCRON | |
28101 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, | |
28102 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, | |
28103 | & 1X,'IREMC = ',10I5,/, | |
28104 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) | |
28105 | ENDIF | |
28106 | ||
28107 | 9999 RETURN | |
28108 | END | |
28109 | ||
28110 | *$ CREATE DT_EVTPUT.FOR | |
28111 | *COPY DT_EVTPUT | |
28112 | * | |
28113 | *===evtput=============================================================* | |
28114 | * | |
28115 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) | |
28116 | ||
28117 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28118 | SAVE | |
28119 | PARAMETER ( LINP = 10 , | |
28120 | & LOUT = 6 , | |
28121 | & LDAT = 9 ) | |
28122 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, | |
28123 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) | |
28124 | ||
28125 | * event history | |
28126 | PARAMETER (NMXHKK=200000) | |
28127 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28128 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28129 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28130 | * extended event history | |
28131 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28132 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28133 | & IHIST(2,NMXHKK) | |
28134 | * Lorentz-parameters of the current interaction | |
28135 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28136 | & UMO,PPCM,EPROJ,PPROJ | |
28137 | * particle properties (BAMJET index convention) | |
28138 | CHARACTER*8 ANAME | |
28139 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28140 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28141 | ||
28142 | C IF (MODE.GT.100) THEN | |
28143 | C WRITE(LOUT,'(1X,A,I5,A,I5)') | |
28144 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 | |
28145 | C NHKK = NHKK-MODE+100 | |
28146 | C RETURN | |
28147 | C ENDIF | |
28148 | MO1 = M1 | |
28149 | MO2 = M2 | |
28150 | NHKK = NHKK+1 | |
28151 | ||
28152 | IF (NHKK.GT.NMXHKK) THEN | |
28153 | WRITE(LOUT,1000) NHKK | |
28154 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, | |
28155 | & '! program execution stopped..') | |
28156 | STOP | |
28157 | ENDIF | |
28158 | IF (M1.LT.0) MO1 = NHKK+M1 | |
28159 | IF (M2.LT.0) MO2 = NHKK+M2 | |
28160 | ISTHKK(NHKK) = IST | |
28161 | IDHKK(NHKK) = ID | |
28162 | JMOHKK(1,NHKK) = MO1 | |
28163 | JMOHKK(2,NHKK) = MO2 | |
28164 | JDAHKK(1,NHKK) = 0 | |
28165 | JDAHKK(2,NHKK) = 0 | |
28166 | IDRES(NHKK) = IDR | |
28167 | IDXRES(NHKK) = IDXR | |
28168 | IDCH(NHKK) = IDC | |
28169 | ** here we need to do something.. | |
28170 | IF (ID.EQ.88888) THEN | |
28171 | IDMO1 = ABS(IDHKK(MO1)) | |
28172 | IDMO2 = ABS(IDHKK(MO2)) | |
28173 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 | |
28174 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 | |
28175 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 | |
28176 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 | |
28177 | ELSE | |
28178 | NOBAM(NHKK) = 0 | |
28179 | ENDIF | |
28180 | IDBAM(NHKK) = IDT_ICIHAD(ID) | |
28181 | IF (MO1.GT.0) THEN | |
28182 | IF (JDAHKK(1,MO1).NE.0) THEN | |
28183 | JDAHKK(2,MO1) = NHKK | |
28184 | ELSE | |
28185 | JDAHKK(1,MO1) = NHKK | |
28186 | ENDIF | |
28187 | ENDIF | |
28188 | IF (MO2.GT.0) THEN | |
28189 | IF (JDAHKK(1,MO2).NE.0) THEN | |
28190 | JDAHKK(2,MO2) = NHKK | |
28191 | ELSE | |
28192 | JDAHKK(1,MO2) = NHKK | |
28193 | ENDIF | |
28194 | ENDIF | |
28195 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN | |
28196 | C PTOT = SQRT(PX**2+PY**2+PZ**2) | |
28197 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) | |
28198 | C AMRQ = AAM(IDBAM(NHKK)) | |
28199 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
28200 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. | |
28201 | C & (PTOT.GT.ZERO)) THEN | |
28202 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) | |
28203 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) | |
28204 | C E = E+DELTA | |
28205 | C PTOT1 = PTOT-DELTA | |
28206 | C PX = PX*PTOT1/PTOT | |
28207 | C PY = PY*PTOT1/PTOT | |
28208 | C PZ = PZ*PTOT1/PTOT | |
28209 | C ENDIF | |
28210 | C ENDIF | |
28211 | PHKK(1,NHKK) = PX | |
28212 | PHKK(2,NHKK) = PY | |
28213 | PHKK(3,NHKK) = PZ | |
28214 | PHKK(4,NHKK) = E | |
28215 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) | |
28216 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN | |
28217 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 | |
28218 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) | |
28219 | ELSE | |
28220 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) | |
28221 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) | |
28222 | C & WRITE(LOUT,'(1X,A,G10.3)') | |
28223 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) | |
28224 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) | |
28225 | ENDIF | |
28226 | IDCHK = ID/10000 | |
28227 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN | |
28228 | * special treatment for chains: | |
28229 | * z coordinate of chain in Lab = pos. of target nucleon | |
28230 | * time of chain-creation in Lab = time of passage of projectile | |
28231 | * nucleus at pos. of taget nucleus | |
28232 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) | |
28233 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) | |
28234 | VHKK(1,NHKK) = VHKK(1,MO2) | |
28235 | VHKK(2,NHKK) = VHKK(2,MO2) | |
28236 | VHKK(3,NHKK) = VHKK(3,MO2) | |
28237 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
28238 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) | |
28239 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) | |
28240 | WHKK(1,NHKK) = WHKK(1,MO1) | |
28241 | WHKK(2,NHKK) = WHKK(2,MO1) | |
28242 | WHKK(3,NHKK) = WHKK(3,MO1) | |
28243 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
28244 | ELSE | |
28245 | IF (MO1.GT.0) THEN | |
28246 | DO 1 I=1,4 | |
28247 | VHKK(I,NHKK) = VHKK(I,MO1) | |
28248 | WHKK(I,NHKK) = WHKK(I,MO1) | |
28249 | 1 CONTINUE | |
28250 | ELSE | |
28251 | DO 2 I=1,4 | |
28252 | VHKK(I,NHKK) = ZERO | |
28253 | WHKK(I,NHKK) = ZERO | |
28254 | 2 CONTINUE | |
28255 | ENDIF | |
28256 | ENDIF | |
28257 | ||
28258 | RETURN | |
28259 | END | |
28260 | ||
28261 | *$ CREATE DT_CHASTA.FOR | |
28262 | *COPY DT_CHASTA | |
28263 | * | |
28264 | *===chasta=============================================================* | |
28265 | * | |
28266 | SUBROUTINE DT_CHASTA(MODE) | |
28267 | ||
28268 | ************************************************************************ | |
28269 | * This subroutine performs CHAin STAtistics and checks sequence of * | |
28270 | * partons in dtevt1 and sorts them with projectile partons coming * | |
28271 | * first if necessary. * | |
28272 | * * | |
28273 | * This version dated 8.5.00 is written by S. Roesler. * | |
28274 | ************************************************************************ | |
28275 | ||
28276 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28277 | SAVE | |
28278 | PARAMETER ( LINP = 10 , | |
28279 | & LOUT = 6 , | |
28280 | & LDAT = 9 ) | |
28281 | ||
28282 | CHARACTER*5 CCHTYP | |
28283 | ||
28284 | * event history | |
28285 | PARAMETER (NMXHKK=200000) | |
28286 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28287 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28288 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28289 | * extended event history | |
28290 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28291 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28292 | & IHIST(2,NMXHKK) | |
28293 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
28294 | PARAMETER (MAXCHN=10000) | |
28295 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
28296 | ||
28297 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), | |
28298 | & CCHTYP(9),ICHSTA(10),ITOT(10) | |
28299 | DATA ICHCFG /1800*0/ | |
28300 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ | |
28301 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ | |
28302 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ | |
28303 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ | |
28304 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ | |
28305 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ | |
28306 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', | |
28307 | & 'ad aq',' d ad','ad d ',' g g '/ | |
28308 | * | |
28309 | * initialization | |
28310 | * | |
28311 | IF (MODE.EQ.-1) THEN | |
28312 | NCHAIN = 0 | |
28313 | * | |
28314 | * loop over DTEVT1 and analyse chain configurations | |
28315 | * | |
28316 | ELSEIF (MODE.EQ.0) THEN | |
28317 | DO 21 IDX=NPOINT(3),NHKK | |
28318 | IDCHK = IDHKK(IDX)/10000 | |
28319 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28320 | & (IDHKK(IDX).NE.80000).AND. | |
28321 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN | |
28322 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN | |
28323 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', | |
28324 | & ' at entry ',IDX | |
28325 | GOTO 21 | |
28326 | ENDIF | |
28327 | * | |
28328 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28329 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28330 | IMO1 = IST1/10 | |
28331 | IMO1 = IST1-10*IMO1 | |
28332 | IMO2 = IST2/10 | |
28333 | IMO2 = IST2-10*IMO2 | |
28334 | * swop parton entries if necessary since we need projectile partons | |
28335 | * to come first in the common | |
28336 | IF (IMO1.GT.IMO2) THEN | |
28337 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 | |
28338 | DO 22 K=1,NPTN/2 | |
28339 | I0 = JMOHKK(1,IDX)-1+K | |
28340 | I1 = JMOHKK(2,IDX)+1-K | |
28341 | ITMP = ISTHKK(I0) | |
28342 | ISTHKK(I0) = ISTHKK(I1) | |
28343 | ISTHKK(I1) = ITMP | |
28344 | ITMP = IDHKK(I0) | |
28345 | IDHKK(I0) = IDHKK(I1) | |
28346 | IDHKK(I1) = ITMP | |
28347 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) | |
28348 | & JDAHKK(1,JMOHKK(1,I0)) = I1 | |
28349 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) | |
28350 | & JDAHKK(2,JMOHKK(1,I0)) = I1 | |
28351 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) | |
28352 | & JDAHKK(1,JMOHKK(2,I0)) = I1 | |
28353 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) | |
28354 | & JDAHKK(2,JMOHKK(2,I0)) = I1 | |
28355 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) | |
28356 | & JDAHKK(1,JMOHKK(1,I1)) = I0 | |
28357 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) | |
28358 | & JDAHKK(2,JMOHKK(1,I1)) = I0 | |
28359 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) | |
28360 | & JDAHKK(1,JMOHKK(2,I1)) = I0 | |
28361 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) | |
28362 | & JDAHKK(2,JMOHKK(2,I1)) = I0 | |
28363 | ITMP = JMOHKK(1,I0) | |
28364 | JMOHKK(1,I0) = JMOHKK(1,I1) | |
28365 | JMOHKK(1,I1) = ITMP | |
28366 | ITMP = JMOHKK(2,I0) | |
28367 | JMOHKK(2,I0) = JMOHKK(2,I1) | |
28368 | JMOHKK(2,I1) = ITMP | |
28369 | ITMP = JDAHKK(1,I0) | |
28370 | JDAHKK(1,I0) = JDAHKK(1,I1) | |
28371 | JDAHKK(1,I1) = ITMP | |
28372 | ITMP = JDAHKK(2,I0) | |
28373 | JDAHKK(2,I0) = JDAHKK(2,I1) | |
28374 | JDAHKK(2,I1) = ITMP | |
28375 | DO 23 J=1,4 | |
28376 | RTMP1 = PHKK(J,I0) | |
28377 | RTMP2 = VHKK(J,I0) | |
28378 | RTMP3 = WHKK(J,I0) | |
28379 | PHKK(J,I0) = PHKK(J,I1) | |
28380 | VHKK(J,I0) = VHKK(J,I1) | |
28381 | WHKK(J,I0) = WHKK(J,I1) | |
28382 | PHKK(J,I1) = RTMP1 | |
28383 | VHKK(J,I1) = RTMP2 | |
28384 | WHKK(J,I1) = RTMP3 | |
28385 | 23 CONTINUE | |
28386 | RTMP1 = PHKK(5,I0) | |
28387 | PHKK(5,I0) = PHKK(5,I1) | |
28388 | PHKK(5,I1) = RTMP1 | |
28389 | ITMP = IDRES(I0) | |
28390 | IDRES(I0) = IDRES(I1) | |
28391 | IDRES(I1) = ITMP | |
28392 | ITMP = IDXRES(I0) | |
28393 | IDXRES(I0) = IDXRES(I1) | |
28394 | IDXRES(I1) = ITMP | |
28395 | ITMP = NOBAM(I0) | |
28396 | NOBAM(I0) = NOBAM(I1) | |
28397 | NOBAM(I1) = ITMP | |
28398 | ITMP = IDBAM(I0) | |
28399 | IDBAM(I0) = IDBAM(I1) | |
28400 | IDBAM(I1) = ITMP | |
28401 | ITMP = IDCH(I0) | |
28402 | IDCH(I0) = IDCH(I1) | |
28403 | IDCH(I1) = ITMP | |
28404 | ITMP = IHIST(1,I0) | |
28405 | IHIST(1,I0) = IHIST(1,I1) | |
28406 | IHIST(1,I1) = ITMP | |
28407 | ITMP = IHIST(2,I0) | |
28408 | IHIST(2,I0) = IHIST(2,I1) | |
28409 | IHIST(2,I1) = ITMP | |
28410 | 22 CONTINUE | |
28411 | ENDIF | |
28412 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28413 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28414 | * | |
28415 | * parton 1 (projectile side) | |
28416 | IF (IST1.EQ.21) THEN | |
28417 | IDX1 = 1 | |
28418 | ELSEIF (IST1.EQ.22) THEN | |
28419 | IDX1 = 2 | |
28420 | ELSEIF (IST1.EQ.31) THEN | |
28421 | IDX1 = 3 | |
28422 | ELSEIF (IST1.EQ.32) THEN | |
28423 | IDX1 = 4 | |
28424 | ELSEIF (IST1.EQ.41) THEN | |
28425 | IDX1 = 5 | |
28426 | ELSEIF (IST1.EQ.42) THEN | |
28427 | IDX1 = 6 | |
28428 | ELSEIF (IST1.EQ.51) THEN | |
28429 | IDX1 = 7 | |
28430 | ELSEIF (IST1.EQ.52) THEN | |
28431 | IDX1 = 8 | |
28432 | ELSEIF (IST1.EQ.61) THEN | |
28433 | IDX1 = 9 | |
28434 | ELSEIF (IST1.EQ.62) THEN | |
28435 | IDX1 = 10 | |
28436 | ELSE | |
28437 | c WRITE(LOUT,*) | |
28438 | c & ' CHASTA: unknown parton status flag (', | |
28439 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28440 | GOTO 21 | |
28441 | ENDIF | |
28442 | ID = IDHKK(JMOHKK(1,IDX)) | |
28443 | IF (ABS(ID).LE.4) THEN | |
28444 | IF (ID.GT.0) THEN | |
28445 | ITYP1 = 1 | |
28446 | ELSE | |
28447 | ITYP1 = 2 | |
28448 | ENDIF | |
28449 | ELSEIF (ABS(ID).GE.1000) THEN | |
28450 | IF (ID.GT.0) THEN | |
28451 | ITYP1 = 3 | |
28452 | ELSE | |
28453 | ITYP1 = 4 | |
28454 | ENDIF | |
28455 | ELSEIF (ID.EQ.21) THEN | |
28456 | ITYP1 = 5 | |
28457 | ELSE | |
28458 | WRITE(LOUT,*) | |
28459 | & ' CHASTA: inconsistent parton identity (', | |
28460 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28461 | GOTO 21 | |
28462 | ENDIF | |
28463 | * | |
28464 | * parton 2 (target side) | |
28465 | IF (IST2.EQ.21) THEN | |
28466 | IDX2 = 1 | |
28467 | ELSEIF (IST2.EQ.22) THEN | |
28468 | IDX2 = 2 | |
28469 | ELSEIF (IST2.EQ.31) THEN | |
28470 | IDX2 = 3 | |
28471 | ELSEIF (IST2.EQ.32) THEN | |
28472 | IDX2 = 4 | |
28473 | ELSEIF (IST2.EQ.41) THEN | |
28474 | IDX2 = 5 | |
28475 | ELSEIF (IST2.EQ.42) THEN | |
28476 | IDX2 = 6 | |
28477 | ELSEIF (IST2.EQ.51) THEN | |
28478 | IDX2 = 7 | |
28479 | ELSEIF (IST2.EQ.52) THEN | |
28480 | IDX2 = 8 | |
28481 | ELSEIF (IST2.EQ.61) THEN | |
28482 | IDX2 = 9 | |
28483 | ELSEIF (IST2.EQ.62) THEN | |
28484 | IDX2 = 10 | |
28485 | ELSE | |
28486 | c WRITE(LOUT,*) | |
28487 | c & ' CHASTA: unknown parton status flag (', | |
28488 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' | |
28489 | GOTO 21 | |
28490 | ENDIF | |
28491 | ID = IDHKK(JMOHKK(2,IDX)) | |
28492 | IF (ABS(ID).LE.4) THEN | |
28493 | IF (ID.GT.0) THEN | |
28494 | ITYP2 = 1 | |
28495 | ELSE | |
28496 | ITYP2 = 2 | |
28497 | ENDIF | |
28498 | ELSEIF (ABS(ID).GE.1000) THEN | |
28499 | IF (ID.GT.0) THEN | |
28500 | ITYP2 = 3 | |
28501 | ELSE | |
28502 | ITYP2 = 4 | |
28503 | ENDIF | |
28504 | ELSEIF (ID.EQ.21) THEN | |
28505 | ITYP2 = 5 | |
28506 | ELSE | |
28507 | WRITE(LOUT,*) | |
28508 | & ' CHASTA: inconsistent parton identity (', | |
28509 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28510 | GOTO 21 | |
28511 | ENDIF | |
28512 | * | |
28513 | * fill counter | |
28514 | ITYPE = ICHTYP(ITYP1,ITYP2) | |
28515 | IF (ITYPE.NE.0) THEN | |
28516 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 | |
28517 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 | |
28518 | ICHCFG(IDX1,IDX2,ITYPE,2) = | |
28519 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON | |
28520 | ||
28521 | NCHAIN = NCHAIN+1 | |
28522 | IF (NCHAIN.GT.MAXCHN) THEN | |
28523 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', | |
28524 | & NCHAIN,MAXCHN | |
28525 | STOP | |
28526 | ENDIF | |
28527 | IDXCHN(1,NCHAIN) = IDX | |
28528 | IDXCHN(2,NCHAIN) = ITYPE | |
28529 | ELSE | |
28530 | WRITE(LOUT,*) | |
28531 | & ' CHASTA: inconsistent chain at entry ',IDX | |
28532 | GOTO 21 | |
28533 | ENDIF | |
28534 | ENDIF | |
28535 | 21 CONTINUE | |
28536 | * | |
28537 | * write statistics to output unit | |
28538 | * | |
28539 | ELSEIF (MODE.EQ.1) THEN | |
28540 | WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' | |
28541 | DO 31 I=1,10 | |
28542 | WRITE(LOUT,'(/,2A)') | |
28543 | & ' -----------------------------------------', | |
28544 | & '------------------------------------' | |
28545 | WRITE(LOUT,'(2A)') | |
28546 | & ' p\\t 21 22 31 32 41', | |
28547 | & ' 42 51 52 61 62' | |
28548 | WRITE(LOUT,'(2A)') | |
28549 | & ' -----------------------------------------', | |
28550 | & '------------------------------------' | |
28551 | DO 32 J=1,10 | |
28552 | ITOT(J) = 0 | |
28553 | DO 33 K=1,9 | |
28554 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) | |
28555 | 33 CONTINUE | |
28556 | 32 CONTINUE | |
28557 | WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) | |
28558 | DO 34 K=1,9 | |
28559 | ISUM = 0 | |
28560 | DO 35 J=1,10 | |
28561 | ISUM = ISUM+ICHCFG(I,J,K,1) | |
28562 | 35 CONTINUE | |
28563 | IF (ISUM.GT.0) | |
28564 | & WRITE(LOUT,'(1X,A5,2X,10I7)') | |
28565 | & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) | |
28566 | 34 CONTINUE | |
28567 | C WRITE(LOUT,'(2A)') | |
28568 | C & ' -----------------------------------------', | |
28569 | C & '-------------------------------' | |
28570 | 31 CONTINUE | |
28571 | * | |
28572 | ELSE | |
28573 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' | |
28574 | STOP | |
28575 | ENDIF | |
28576 | ||
28577 | RETURN | |
28578 | END | |
28579 | *$ CREATE PHO_PHIST.FOR | |
28580 | *COPY PHO_PHIST | |
28581 | * | |
28582 | *===pohist=============================================================* | |
28583 | * | |
28584 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) | |
28585 | ||
28586 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28587 | SAVE | |
28588 | ||
28589 | PARAMETER ( LINP = 10 , | |
28590 | & LOUT = 6 , | |
28591 | & LDAT = 9 ) | |
28592 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
28593 | * Glauber formalism: cross sections | |
28594 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
28595 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
28596 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
28597 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
28598 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
28599 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
28600 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
28601 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
28602 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
28603 | & BSLOPE,NEBINI,NQBINI | |
28604 | ||
28605 | ILAB = 0 | |
28606 | IF (IMODE.EQ.10) THEN | |
28607 | IMODE = 1 | |
28608 | ILAB = 1 | |
28609 | ENDIF | |
28610 | IF (ABS(IMODE).LT.1000) THEN | |
28611 | * PHOJET-statistics | |
28612 | C CALL POHISX(IMODE,WEIGHT) | |
28613 | IF (IMODE.EQ.-1) THEN | |
28614 | MODE = 1 | |
28615 | XSTOT(1,1,1) = WEIGHT | |
28616 | ENDIF | |
28617 | IF (IMODE.EQ. 1) MODE = 2 | |
28618 | IF (IMODE.EQ.-2) MODE = 3 | |
28619 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) | |
28620 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28621 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28622 | CALL DT_HISTOG(MODE) | |
28623 | CALL DT_USRHIS(MODE) | |
28624 | ELSE | |
28625 | * DTUNUC-statistics | |
28626 | MODE = IMODE/1000 | |
28627 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28628 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28629 | CALL DT_HISTOG(MODE) | |
28630 | CALL DT_USRHIS(MODE) | |
28631 | ENDIF | |
28632 | ||
28633 | RETURN | |
28634 | END | |
28635 | ||
28636 | *$ CREATE DT_SWPPHO.FOR | |
28637 | *COPY DT_SWPPHO | |
28638 | * | |
28639 | *===swppho=============================================================* | |
28640 | * | |
28641 | SUBROUTINE DT_SWPPHO(ILAB) | |
28642 | ||
28643 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28644 | SAVE | |
28645 | PARAMETER ( LINP = 10 , | |
28646 | & LOUT = 6 , | |
28647 | & LDAT = 9 ) | |
28648 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28649 | ||
28650 | LOGICAL LSTART | |
28651 | ||
28652 | * event history | |
28653 | PARAMETER (NMXHKK=200000) | |
28654 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28655 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28656 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28657 | * extended event history | |
28658 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28659 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28660 | & IHIST(2,NMXHKK) | |
28661 | * flags for input different options | |
28662 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28663 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28664 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28665 | * properties of photon/lepton projectiles | |
28666 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
28667 | ||
28668 | **PHOJET105a | |
28669 | C PARAMETER (NMXHEP=2000) | |
28670 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28671 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) | |
28672 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28673 | C COMMON /PLASAV/ PLAB | |
28674 | **PHOJET110 | |
28675 | C standard particle data interface | |
28676 | INTEGER NMXHEP | |
28677 | PARAMETER (NMXHEP=4000) | |
28678 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
28679 | DOUBLE PRECISION PHEP,VHEP | |
28680 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28681 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
09b429a4 | 28682 | & VHEP(4,NMXHEP),NSD1, NSD2, NDD |
9aaba0d6 | 28683 | C extension to standard particle data interface (PHOJET specific) |
28684 | INTEGER IMPART,IPHIST,ICOLOR | |
28685 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
28686 | C global event kinematics and particle IDs | |
28687 | INTEGER IFPAP,IFPAB | |
28688 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
28689 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28690 | ** | |
28691 | DATA ICOUNT/0/ | |
28692 | ||
28693 | DATA LSTART /.TRUE./ | |
28694 | ||
28695 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN | |
28696 | IF ((IFRAME.EQ.1).AND.LSTART) THEN | |
28697 | UMO = ECM | |
28698 | ELA = ZERO | |
28699 | PLA = ZERO | |
28700 | IDP = IDT_ICIHAD(IFPAP(1)) | |
28701 | IDT = IDT_ICIHAD(IFPAP(2)) | |
28702 | VIRT = PVIRT(1) | |
28703 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) | |
28704 | PLAB = PLA | |
28705 | LSTART = .FALSE. | |
28706 | ENDIF | |
28707 | ||
28708 | NHKK = 0 | |
28709 | ICOUNT = ICOUNT+1 | |
28710 | C NEVHKK = NEVHEP | |
28711 | NEVHKK = ICOUNT | |
28712 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT | |
28713 | DO 1 I=3,NHEP | |
28714 | IF (ISTHEP(I).EQ.1) THEN | |
28715 | NHKK = NHKK+1 | |
28716 | ISTHKK(NHKK) = 1 | |
28717 | IDHKK(NHKK) = IDHEP(I) | |
28718 | JMOHKK(1,NHKK) = 0 | |
28719 | JMOHKK(2,NHKK) = 0 | |
28720 | JDAHKK(1,NHKK) = 0 | |
28721 | JDAHKK(2,NHKK) = 0 | |
28722 | DO 2 K=1,4 | |
28723 | PHKK(K,NHKK) = PHEP(K,I) | |
28724 | VHKK(K,NHKK) = ZERO | |
28725 | WHKK(K,NHKK) = ZERO | |
28726 | 2 CONTINUE | |
28727 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) | |
28728 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), | |
28729 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) | |
28730 | PHKK(5,NHKK) = PHEP(5,I) | |
28731 | IDRES(NHKK) = 0 | |
28732 | IDXRES(NHKK) = 0 | |
28733 | NOBAM(NHKK) = 0 | |
28734 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) | |
28735 | IDCH(NHKK) = 0 | |
28736 | ENDIF | |
28737 | 1 CONTINUE | |
28738 | ||
28739 | RETURN | |
28740 | END | |
28741 | ||
28742 | *$ CREATE DT_HISTOG.FOR | |
28743 | *COPY DT_HISTOG | |
28744 | * | |
28745 | *===histog=============================================================* | |
28746 | * | |
28747 | SUBROUTINE DT_HISTOG(MODE) | |
28748 | ||
28749 | ************************************************************************ | |
28750 | * This version dated 25.03.96 is written by S. Roesler * | |
28751 | ************************************************************************ | |
28752 | ||
28753 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28754 | SAVE | |
28755 | PARAMETER ( LINP = 10 , | |
28756 | & LOUT = 6 , | |
28757 | & LDAT = 9 ) | |
28758 | ||
28759 | LOGICAL LFSP,LRNL | |
28760 | ||
28761 | * event history | |
28762 | PARAMETER (NMXHKK=200000) | |
28763 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28764 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28765 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28766 | * extended event history | |
28767 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28768 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28769 | & IHIST(2,NMXHKK) | |
28770 | * event flag used for histograms | |
28771 | COMMON /DTNORM/ ICEVT,IEVHKK | |
28772 | * flags for activated histograms | |
28773 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
28774 | ||
28775 | IEVHKK = NEVHKK | |
28776 | GOTO (1,2,3) MODE | |
28777 | ||
28778 | *------------------------------------------------------------------ | |
28779 | * initialization | |
28780 | 1 CONTINUE | |
28781 | ICEVT = 0 | |
28782 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) | |
28783 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) | |
28784 | ||
28785 | RETURN | |
28786 | *------------------------------------------------------------------ | |
28787 | * filling of histogram with event-record | |
28788 | 2 CONTINUE | |
28789 | ICEVT = ICEVT+1 | |
28790 | ||
28791 | DO 20 I=1,NHKK | |
28792 | CALL DT_SWPFSP(I,LFSP,LRNL) | |
28793 | IF (LFSP) THEN | |
28794 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) | |
28795 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) | |
28796 | ENDIF | |
28797 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) | |
28798 | 20 CONTINUE | |
28799 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) | |
28800 | ||
28801 | RETURN | |
28802 | *------------------------------------------------------------------ | |
28803 | * output | |
28804 | 3 CONTINUE | |
28805 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) | |
28806 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) | |
28807 | ||
28808 | RETURN | |
28809 | END | |
28810 | ||
28811 | *$ CREATE DT_SWPFSP.FOR | |
28812 | *COPY DT_SWPFSP | |
28813 | * | |
28814 | *===swpfsp=============================================================* | |
28815 | * | |
28816 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) | |
28817 | ||
28818 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28819 | SAVE | |
28820 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28821 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, | |
28822 | & PI =TWOPI/TWO, | |
28823 | & BOG =TWOPI/360.0D0) | |
28824 | ||
28825 | * event history | |
28826 | PARAMETER (NMXHKK=200000) | |
28827 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28828 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28829 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28830 | * extended event history | |
28831 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28832 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28833 | & IHIST(2,NMXHKK) | |
28834 | * particle properties (BAMJET index convention) | |
28835 | CHARACTER*8 ANAME | |
28836 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28837 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28838 | * Lorentz-parameters of the current interaction | |
28839 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28840 | & UMO,PPCM,EPROJ,PPROJ | |
28841 | * flags for input different options | |
28842 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28843 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28844 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28845 | * (original name: PAREVT) | |
28846 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
28847 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
28848 | PARAMETER ( NALLWP = 39 ) | |
28849 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
28850 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
28851 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
28852 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
28853 | * temporary storage for one final state particle | |
28854 | LOGICAL LFRAG,LGREY,LBLACK | |
28855 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
28856 | & SINTHE,COSTHE,THETA,THECMS, | |
28857 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
28858 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
28859 | & LFRAG,LGREY,LBLACK | |
28860 | ||
28861 | LOGICAL LFSP,LRNL | |
28862 | ||
28863 | LFSP = .FALSE. | |
28864 | LRNL = .FALSE. | |
28865 | ISTRNL = 1000 | |
28866 | MULDEF = 1 | |
28867 | IF (LEVPRT) ISTRNL = 1001 | |
28868 | ||
28869 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN | |
28870 | IST = ISTHKK(IDX) | |
28871 | IDPDG = IDHKK(IDX) | |
28872 | LFRAG = .FALSE. | |
28873 | IF (IDHKK(IDX).LT.80000) THEN | |
28874 | IDBJT = IDBAM(IDX) | |
28875 | IBARY = IIBAR(IDBJT) | |
28876 | ICHAR = IICH(IDBJT) | |
28877 | AMASS = AAM(IDBJT) | |
28878 | ELSEIF (IDHKK(IDX).EQ.80000) THEN | |
28879 | IDBJT = 0 | |
28880 | IBARY = IDRES(IDX) | |
28881 | ICHAR = IDXRES(IDX) | |
28882 | AMASS = PHKK(5,IDX) | |
28883 | INUT = IBARY-ICHAR | |
28884 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 | |
28885 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 | |
28886 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 | |
28887 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 | |
28888 | IF (IDBJT.EQ.0) LFRAG = .TRUE. | |
28889 | ELSE | |
28890 | GOTO 9999 | |
28891 | ENDIF | |
28892 | PE = PHKK(4,IDX) | |
28893 | PX = PHKK(1,IDX) | |
28894 | PY = PHKK(2,IDX) | |
28895 | PZ = PHKK(3,IDX) | |
28896 | PT2 = PX**2+PY**2 | |
28897 | PT = SQRT(PT2) | |
28898 | PTOT = SQRT(PT2+PZ**2) | |
28899 | SINTHE = PT/MAX(PTOT,TINY14) | |
28900 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28901 | IF (COSTHE.GT.ONE) THEN | |
28902 | THETA = ZERO | |
28903 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28904 | THETA = TWOPI/2.0D0 | |
28905 | ELSE | |
28906 | THETA = ACOS(COSTHE) | |
28907 | ENDIF | |
28908 | EKIN = PE-AMASS | |
28909 | **sr 15.4.96 new E_t-definition | |
28910 | IF (IBARY.GT.0) THEN | |
28911 | ET = EKIN*SINTHE | |
28912 | ELSEIF (IBARY.LT.0) THEN | |
28913 | ET = (EKIN+TWO*AMASS)*SINTHE | |
28914 | ELSE | |
28915 | ET = PE*SINTHE | |
28916 | ENDIF | |
28917 | ** | |
28918 | XLAB = PZ/MAX(PPROJ,TINY14) | |
28919 | C XLAB = PE/MAX(EPROJ,TINY14) | |
28920 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) | |
28921 | & *(ONE+AMASS/MAX(PE,TINY14)) )) | |
28922 | PPLUS = PE+PZ | |
28923 | PMINUS = PE-PZ | |
28924 | IF (PMINUS.GT.TINY14) THEN | |
28925 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28926 | ELSE | |
28927 | YY = 100.0D0 | |
28928 | ENDIF | |
28929 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28930 | ETA = -LOG(TAN(THETA/TWO)) | |
28931 | ELSE | |
28932 | ETA = 100.0D0 | |
28933 | ENDIF | |
28934 | IF (IFRAME.EQ.1) THEN | |
28935 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) | |
28936 | PPLUS = EECMS+PZCMS | |
28937 | PMINUS = EECMS-PZCMS | |
28938 | IF ((PPLUS*PMINUS).GT.TINY14) THEN | |
28939 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28940 | ELSE | |
28941 | YYCMS = 100.0D0 | |
28942 | ENDIF | |
28943 | PTOTCM = SQRT(PT2+PZCMS**2) | |
28944 | COSTH = PZCMS/MAX(PTOTCM,TINY14) | |
28945 | IF (COSTH.GT.ONE) THEN | |
28946 | THECMS = ZERO | |
28947 | ELSEIF (COSTH.LT.-ONE) THEN | |
28948 | THECMS = TWOPI/2.0D0 | |
28949 | ELSE | |
28950 | THECMS = ACOS(COSTH) | |
28951 | ENDIF | |
28952 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN | |
28953 | ETACMS = -LOG(TAN(THECMS/TWO)) | |
28954 | ELSE | |
28955 | ETACMS = 100.0D0 | |
28956 | ENDIF | |
28957 | XF = PZCMS/MAX(PPCM,TINY14) | |
28958 | THECMS = THECMS/BOG | |
28959 | ELSE | |
28960 | PZCMS = PZ | |
28961 | EECMS = PE | |
28962 | YYCMS = YY | |
28963 | ETACMS = ETA | |
28964 | XF = XLAB | |
28965 | THECMS = THETA/BOG | |
28966 | ENDIF | |
28967 | THETA = THETA/BOG | |
28968 | ||
28969 | * set flag for "grey/black" | |
28970 | LGREY = .FALSE. | |
28971 | LBLACK = .FALSE. | |
28972 | EK = EKIN | |
28973 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) | |
28974 | IF (MULDEF.EQ.1) THEN | |
28975 | * EMU01-Def. | |
28976 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. | |
28977 | & (EK.LE.375.0D-3) ).OR. | |
28978 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. | |
28979 | & (EK.LE. 56.0D-3) ).OR. | |
28980 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. | |
28981 | & (EK.LE. 56.0D-3) ).OR. | |
28982 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. | |
28983 | & (EK.LE.198.0D-3) ).OR. | |
28984 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. | |
28985 | & (EK.LE.198.0D-3) ).OR. | |
28986 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28987 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28988 | & (IDBJT.NE.16).AND. | |
28989 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) | |
28990 | & LGREY = .TRUE. | |
28991 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. | |
28992 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. | |
28993 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. | |
28994 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. | |
28995 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. | |
28996 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28997 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28998 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) | |
28999 | & LBLACK = .TRUE. | |
29000 | ELSE | |
29001 | * common Def. | |
29002 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. | |
29003 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. | |
29004 | ENDIF | |
29005 | LFSP = .TRUE. | |
29006 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN | |
29007 | IST = ISTHKK(IDX) | |
29008 | IDPDG = IDHKK(IDX) | |
29009 | LFRAG = .TRUE. | |
29010 | IDBJT = 0 | |
29011 | IBARY = IDRES(IDX) | |
29012 | ICHAR = IDXRES(IDX) | |
29013 | AMASS = PHKK(5,IDX) | |
29014 | PE = PHKK(4,IDX) | |
29015 | PX = PHKK(1,IDX) | |
29016 | PY = PHKK(2,IDX) | |
29017 | PZ = PHKK(3,IDX) | |
29018 | PT2 = PX**2+PY**2 | |
29019 | PT = SQRT(PT2) | |
29020 | PTOT = SQRT(PT2+PZ**2) | |
29021 | SINTHE = PT/MAX(PTOT,TINY14) | |
29022 | COSTHE = PZ/MAX(PTOT,TINY14) | |
29023 | IF (COSTHE.GT.ONE) THEN | |
29024 | THETA = ZERO | |
29025 | ELSEIF (COSTHE.LT.-ONE) THEN | |
29026 | THETA = TWOPI/2.0D0 | |
29027 | ELSE | |
29028 | THETA = ACOS(COSTHE) | |
29029 | ENDIF | |
29030 | EKIN = PE-AMASS | |
29031 | **sr 15.4.96 new E_t-definition | |
29032 | C ET = PE*SINTHE | |
29033 | ET = EKIN*SINTHE | |
29034 | ** | |
29035 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
29036 | ETA = -LOG(TAN(THETA/TWO)) | |
29037 | ELSE | |
29038 | ETA = 100.0D0 | |
29039 | ENDIF | |
29040 | THETA = THETA/BOG | |
29041 | LRNL = .TRUE. | |
29042 | ENDIF | |
29043 | ||
29044 | 9999 CONTINUE | |
29045 | RETURN | |
29046 | END | |
29047 | ||
29048 | *$ CREATE DT_HIMULT.FOR | |
29049 | *COPY DT_HIMULT | |
29050 | * | |
29051 | *===himult=============================================================* | |
29052 | * | |
29053 | SUBROUTINE DT_HIMULT(MODE) | |
29054 | ||
29055 | ************************************************************************ | |
29056 | * Tables of average energies/multiplicities. * | |
29057 | * This version dated 30.08.2000 is written by S. Roesler * | |
29058 | ************************************************************************ | |
29059 | ||
29060 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29061 | SAVE | |
29062 | PARAMETER ( LINP = 10 , | |
29063 | & LOUT = 6 , | |
29064 | & LDAT = 9 ) | |
29065 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29066 | ||
29067 | PARAMETER (SWMEXP=1.7D0) | |
29068 | ||
29069 | CHARACTER*8 ANAMEH(4) | |
29070 | ||
29071 | * particle properties (BAMJET index convention) | |
29072 | CHARACTER*8 ANAME | |
29073 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29074 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29075 | * temporary storage for one final state particle | |
29076 | LOGICAL LFRAG,LGREY,LBLACK | |
29077 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29078 | & SINTHE,COSTHE,THETA,THECMS, | |
29079 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29080 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29081 | & LFRAG,LGREY,LBLACK | |
29082 | * event flag used for histograms | |
29083 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29084 | * Lorentz-parameters of the current interaction | |
29085 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
29086 | & UMO,PPCM,EPROJ,PPROJ | |
29087 | ||
29088 | PARAMETER (NOPART=210) | |
29089 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), | |
29090 | & AVPT(4,NOPART),IAVPT(4,NOPART) | |
29091 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ | |
29092 | ||
29093 | GOTO (1,2,3) MODE | |
29094 | ||
29095 | *------------------------------------------------------------------ | |
29096 | * initialization | |
29097 | 1 CONTINUE | |
29098 | DO 10 I=1,NOPART | |
29099 | DO 11 J=1,4 | |
29100 | AVMULT(J,I) = ZERO | |
29101 | AVE(J,I) = ZERO | |
29102 | AVSWM(J,I) = ZERO | |
29103 | AVPT(J,I) = ZERO | |
29104 | IAVPT(J,I) = 0 | |
29105 | 11 CONTINUE | |
29106 | 10 CONTINUE | |
29107 | ||
29108 | RETURN | |
29109 | ||
29110 | *------------------------------------------------------------------ | |
29111 | * filling of histogram with event-record | |
29112 | 2 CONTINUE | |
29113 | IF (PE.LT.0.0D0) THEN | |
29114 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE | |
29115 | RETURN | |
29116 | ENDIF | |
29117 | IF (.NOT.LFRAG) THEN | |
29118 | IVEL = 2 | |
29119 | IF (LGREY) IVEL = 3 | |
29120 | IF (LBLACK) IVEL = 4 | |
29121 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE | |
29122 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE | |
29123 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT | |
29124 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT | |
29125 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 | |
29126 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 | |
29127 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP | |
29128 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP | |
29129 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE | |
29130 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE | |
29131 | IF (IDBJT.LT.116) THEN | |
29132 | * total energy, multiplicity | |
29133 | AVE(1,30) = AVE(1,30) +PE | |
29134 | AVE(IVEL,30) = AVE(IVEL,30)+PE | |
29135 | AVPT(1,30) = AVPT(1,30) +PT | |
29136 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT | |
29137 | IAVPT(1,30) = IAVPT(1,30) +1 | |
29138 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 | |
29139 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP | |
29140 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP | |
29141 | AVMULT(1,30) = AVMULT(1,30) +ONE | |
29142 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE | |
29143 | * charged energy, multiplicity | |
29144 | IF (ICHAR.LT.0) THEN | |
29145 | AVE(1,26) = AVE(1,26) +PE | |
29146 | AVE(IVEL,26) = AVE(IVEL,26)+PE | |
29147 | AVPT(1,26) = AVPT(1,26) +PT | |
29148 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT | |
29149 | IAVPT(1,26) = IAVPT(1,26) +1 | |
29150 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 | |
29151 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP | |
29152 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP | |
29153 | AVMULT(1,26) = AVMULT(1,26) +ONE | |
29154 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE | |
29155 | ENDIF | |
29156 | IF (ICHAR.NE.0) THEN | |
29157 | AVE(1,27) = AVE(1,27) +PE | |
29158 | AVE(IVEL,27) = AVE(IVEL,27)+PE | |
29159 | AVPT(1,27) = AVPT(1,27) +PT | |
29160 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT | |
29161 | IAVPT(1,27) = IAVPT(1,27) +1 | |
29162 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 | |
29163 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP | |
29164 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP | |
29165 | AVMULT(1,27) = AVMULT(1,27) +ONE | |
29166 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE | |
29167 | ENDIF | |
29168 | ENDIF | |
29169 | ENDIF | |
29170 | ||
29171 | RETURN | |
29172 | ||
29173 | *------------------------------------------------------------------ | |
29174 | * output | |
29175 | 3 CONTINUE | |
29176 | WRITE(LOUT,3000) | |
29177 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, | |
29178 | & 29X,'---------------------',/) | |
29179 | IF (MULDEF.EQ.1) THEN | |
29180 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' | |
29181 | ELSE | |
29182 | BETGRE = 0.7D0 | |
29183 | BETBLC = 0.23D0 | |
29184 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC | |
29185 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' | |
29186 | & ,F4.2,' black: beta < ',F4.2,/) | |
29187 | ENDIF | |
29188 | WRITE(LOUT,3003) SWMEXP | |
29189 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, | |
29190 | & 13X,'| total fast', | |
29191 | C & ' grey black K f(',F3.1,')',/,1X, | |
29192 | & ' grey black <pt> f(',F3.1,')',/,1X, | |
29193 | & '------------+--------------', | |
29194 | & '-------------------------------------------------') | |
29195 | DO 30 I=1,NOPART | |
29196 | DO 31 J=1,4 | |
29197 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) | |
29198 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ | |
29199 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) | |
29200 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP | |
29201 | 31 CONTINUE | |
29202 | IF (I.LE.115) THEN | |
29203 | WRITE(LOUT,3004) ANAME(I),I, | |
29204 | & AVMULT(1,I),AVMULT(2,I), | |
29205 | & AVMULT(3,I),AVMULT(4,I), | |
29206 | C & AVE(1,I),AVSWM(1,I) | |
29207 | & AVPT(1,I),AVSWM(1,I) | |
29208 | ELSEIF (I.LE.119) THEN | |
29209 | WRITE(LOUT,3004) ANAMEH(I-115),I, | |
29210 | & AVMULT(1,I),AVMULT(2,I), | |
29211 | & AVMULT(3,I),AVMULT(4,I), | |
29212 | C & AVE(1,I),AVSWM(1,I) | |
29213 | & AVPT(1,I),AVSWM(1,I) | |
29214 | ENDIF | |
29215 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) | |
29216 | 30 CONTINUE | |
29217 | **temporary | |
29218 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', | |
29219 | C & AVMULT(3,27)+AVMULT(4,27) | |
29220 | ** | |
29221 | ||
29222 | RETURN | |
29223 | END | |
29224 | ||
29225 | *$ CREATE DT_HISTAT.FOR | |
29226 | *COPY DT_HISTAT | |
29227 | * | |
29228 | *===histat=============================================================* | |
29229 | * | |
29230 | SUBROUTINE DT_HISTAT(IDX,MODE) | |
29231 | ||
29232 | ************************************************************************ | |
29233 | * This version dated 26.02.96 is written by S. Roesler * | |
29234 | * * | |
29235 | * Last change 27.12.2006 by S. Roesler. * | |
29236 | ************************************************************************ | |
29237 | ||
29238 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29239 | SAVE | |
29240 | PARAMETER ( LINP = 10 , | |
29241 | & LOUT = 6 , | |
29242 | & LDAT = 9 ) | |
29243 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29244 | PARAMETER (NDIM=199) | |
29245 | ||
29246 | * event history | |
29247 | PARAMETER (NMXHKK=200000) | |
29248 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
29249 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
29250 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
29251 | * extended event history | |
29252 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
29253 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
29254 | & IHIST(2,NMXHKK) | |
29255 | * particle properties (BAMJET index convention) | |
29256 | CHARACTER*8 ANAME | |
29257 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29258 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29259 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
29260 | * Glauber formalism: cross sections | |
29261 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
29262 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
29263 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
29264 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
29265 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
29266 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
29267 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
29268 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
29269 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
29270 | & BSLOPE,NEBINI,NQBINI | |
29271 | * emulsion treatment | |
29272 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
29273 | & NCOMPO,IEMUL | |
29274 | * properties of interacting particles | |
29275 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
29276 | * rejection counter | |
29277 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
29278 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
29279 | & IREXCI(3),IRDIFF(2),IRINC | |
29280 | * statistics: residual nuclei | |
29281 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
29282 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
29283 | & NINCST(2,4),NINCEV(2), | |
29284 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
29285 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
29286 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
29287 | & NEVAFI(2,2) | |
29288 | * parameter for intranuclear cascade | |
29289 | LOGICAL LPAULI | |
29290 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
29291 | * (original name: PAREVT) | |
29292 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
29293 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
29294 | PARAMETER ( NALLWP = 39 ) | |
29295 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
29296 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
29297 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
29298 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
29299 | * (original name: FRBKCM) | |
29300 | PARAMETER ( MXFFBK = 6 ) | |
29301 | PARAMETER ( MXZFBK = 9 ) | |
29302 | PARAMETER ( MXNFBK = 10 ) | |
29303 | PARAMETER ( MXAFBK = 16 ) | |
29304 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
29305 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
29306 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
29307 | PARAMETER ( MXPSST = 300 ) | |
29308 | PARAMETER ( MXPSFB = 41000 ) | |
29309 | LOGICAL LFRMBK, LNCMSS | |
29310 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
29311 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
29312 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
29313 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
29314 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
29315 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
29316 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
29317 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
29318 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
29319 | * (original name: INPFLG) | |
29320 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
29321 | * temporary storage for one final state particle | |
29322 | LOGICAL LFRAG,LGREY,LBLACK | |
29323 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29324 | & SINTHE,COSTHE,THETA,THECMS, | |
29325 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29326 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29327 | & LFRAG,LGREY,LBLACK | |
29328 | * event flag used for histograms | |
29329 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29330 | * statistics: double-Pomeron exchange | |
29331 | COMMON /DTFLG2/ INTFLG,IPOPO | |
29332 | ||
29333 | DIMENSION EMUSAM(NCOMPX) | |
29334 | ||
29335 | CHARACTER*13 CMSG(3) | |
29336 | DATA CMSG /'not requested','not requested','not requested'/ | |
29337 | ||
29338 | GOTO (1,2,3,4,5) MODE | |
29339 | ||
29340 | *------------------------------------------------------------------ | |
29341 | * initialization | |
29342 | 1 CONTINUE | |
29343 | * emulsion treatment | |
29344 | IF (NCOMPO.GT.0) THEN | |
29345 | DO 10 I=1,NCOMPX | |
29346 | EMUSAM(I) = ZERO | |
29347 | 10 CONTINUE | |
29348 | ENDIF | |
29349 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. | |
29350 | NINCGE = 0 | |
29351 | DO 11 I=1,2 | |
29352 | EXCDPM(I) = ZERO | |
29353 | EXCDPM(I+2) = ZERO | |
29354 | EXCEVA(I) = ZERO | |
29355 | NINCWO(I) = 0 | |
29356 | NINCEV(I) = 0 | |
29357 | NRESTO(I) = 0 | |
29358 | NRESPR(I) = 0 | |
29359 | NRESNU(I) = 0 | |
29360 | NRESBA(I) = 0 | |
29361 | NRESPB(I) = 0 | |
29362 | NRESCH(I) = 0 | |
29363 | NRESEV(I) = 0 | |
29364 | NRESEV(I+2) = 0 | |
29365 | NEVAGA(I) = 0 | |
29366 | NEVAHT(I) = 0 | |
29367 | NEVAFI(1,I) = 0 | |
29368 | NEVAFI(2,I) = 0 | |
29369 | DO 12 J=1,6 | |
29370 | IF (J.LE.2) NINCHR(I,J) = 0 | |
29371 | IF (J.LE.3) NINCCO(I,J) = 0 | |
29372 | IF (J.LE.4) NINCST(I,J) = 0 | |
29373 | NEVA(I,J) = 0 | |
29374 | 12 CONTINUE | |
29375 | DO 13 J=1,210 | |
29376 | NEVAHY(1,I,J) = 0 | |
29377 | NEVAHY(2,I,J) = 0 | |
29378 | 13 CONTINUE | |
29379 | 11 CONTINUE | |
29380 | MAXGEN = 0 | |
29381 | **dble Po statistics. | |
29382 | KPOPO = 0 | |
29383 | ||
29384 | RETURN | |
29385 | *------------------------------------------------------------------ | |
29386 | * filling of histogram with event-record | |
29387 | 2 CONTINUE | |
29388 | IF (IST.EQ.-1) THEN | |
29389 | IF (.NOT.LFRAG) THEN | |
29390 | IF (IDPDG.EQ.2212) THEN | |
29391 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 | |
29392 | ELSEIF (IDPDG.EQ.2112) THEN | |
29393 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 | |
29394 | ELSEIF (IDPDG.EQ.22) THEN | |
29395 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 | |
29396 | ELSEIF (IDPDG.EQ.80000) THEN | |
29397 | IF (IDBJT.EQ.116) THEN | |
29398 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 | |
29399 | ELSEIF (IDBJT.EQ.117) THEN | |
29400 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 | |
29401 | ELSEIF (IDBJT.EQ.118) THEN | |
29402 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 | |
29403 | ELSEIF (IDBJT.EQ.119) THEN | |
29404 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 | |
29405 | ENDIF | |
29406 | ENDIF | |
29407 | ELSE | |
29408 | * heavy fragments (here: fission products only) | |
29409 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 | |
29410 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 | |
29411 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29412 | ENDIF | |
29413 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN | |
29414 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) | |
29415 | ENDIF | |
29416 | ||
29417 | RETURN | |
29418 | *------------------------------------------------------------------ | |
29419 | * output | |
29420 | 3 CONTINUE | |
29421 | ||
29422 | **dble Po statistics. | |
29423 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') | |
29424 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', | |
29425 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) | |
29426 | ||
29427 | * emulsion treatment | |
29428 | IF (NCOMPO.GT.0) THEN | |
29429 | WRITE(LOUT,3000) | |
29430 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, | |
29431 | & 22X,'----------------------------',/,/,19X, | |
29432 | & 'mass charge fraction',/,39X, | |
29433 | & 'input treated',/) | |
29434 | DO 30 I=1,NCOMPO | |
29435 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), | |
29436 | & EMUSAM(I)/DBLE(ICEVT) | |
29437 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) | |
29438 | 30 CONTINUE | |
29439 | ENDIF | |
29440 | ||
29441 | * i.n.c. statistics: output | |
29442 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC | |
29443 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, | |
29444 | & 22X,'---------------------------------',/,/,1X, | |
29445 | & 'no. of events for normalization: (accepted final events,', | |
29446 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, | |
29447 | & /,1X,'no. of rejected events due to intranuclear', | |
29448 | & ' cascade',15X,I6,/) | |
29449 | ICEV = MAX(ICEVT,1) | |
29450 | ICEV1 = ICEV | |
29451 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) | |
29452 | WRITE(LOUT,3002) | |
29453 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), | |
29454 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), | |
29455 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), | |
29456 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29457 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), | |
29458 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29459 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) | |
29460 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', | |
29461 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', | |
29462 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', | |
29463 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, | |
29464 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, | |
29465 | & /,1X,'maximum no. of generations treated (maximum allowed:' | |
29466 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', | |
29467 | & ' interactions in proj./ target (mean per evt1)', | |
29468 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', | |
29469 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', | |
29470 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', | |
29471 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) | |
29472 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, | |
29473 | & IREXCI(1)+IREXCI(2)+IREXCI(3) | |
29474 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', | |
29475 | & 'evaporation',/,22X,'-----------------------------', | |
29476 | & '------------',/,/,1X,'no. of events for normal.: ', | |
29477 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', | |
29478 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', | |
29479 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) | |
29480 | ||
29481 | WRITE(LOUT,3004) | |
29482 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) | |
29483 | ICEV = MAX(NRESEV(2),1) | |
29484 | WRITE(LOUT,3005) | |
29485 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), | |
29486 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), | |
29487 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), | |
29488 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), | |
29489 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), | |
29490 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), | |
29491 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), | |
29492 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) | |
29493 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, | |
29494 | & 'proj. / target',/,/,8X,'total number of particles',15X, | |
29495 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29496 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, | |
29497 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, | |
29498 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, | |
29499 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) | |
29500 | ||
29501 | * evaporation / fission / fragmentation statistics: output | |
29502 | ICEV = MAX(NRESEV(2),1) | |
29503 | ICEV1 = MAX(NRESEV(4),1) | |
29504 | NTEVA1 = | |
29505 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) | |
29506 | NTEVA2 = | |
29507 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) | |
29508 | IF (LEVPRT) THEN | |
29509 | IF (IFISS.EQ.1) CMSG(1) = 'requested ' | |
29510 | IF (LFRMBK) CMSG(2) = 'requested ' | |
29511 | IF (LDEEXG) CMSG(3) = 'requested ' | |
29512 | WRITE(LOUT,3006) | |
29513 | & CMSG, | |
29514 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), | |
29515 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), | |
29516 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), | |
29517 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), | |
29518 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), | |
29519 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), | |
29520 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), | |
29521 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), | |
29522 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) | |
29523 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', | |
29524 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', | |
29525 | & 'deexcitation:',2X,A13,/,/, | |
29526 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', | |
29527 | & 'proj. / target',/,/,8X,'total number of evap. particles', | |
29528 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29529 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, | |
29530 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, | |
29531 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, | |
29532 | & 'heavy fragments',25X,2F9.3,/) | |
29533 | IF (IFISS.EQ.1) THEN | |
29534 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), | |
29535 | & NEVAFI(2,1),NEVAFI(2,2), | |
29536 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, | |
29537 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 | |
29538 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ | |
29539 | & 12X,'out of which fission occured',8X,2I9,/, | |
29540 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) | |
29541 | ENDIF | |
29542 | C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN | |
29543 | C WRITE(LOUT,3008) | |
29544 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', | |
29545 | C & ' proj. / target',/) | |
29546 | C DO 31 I=1,210 | |
29547 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN | |
29548 | C WRITE(LOUT,3009) I, | |
29549 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29550 | C3009 FORMAT(38X,I3,3X,2E12.3) | |
29551 | C ENDIF | |
29552 | C 31 CONTINUE | |
29553 | C WRITE(LOUT,3010) | |
29554 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', | |
29555 | C & ' proj. / target',/) | |
29556 | C DO 32 I=1,210 | |
29557 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN | |
29558 | C WRITE(LOUT,3011) I, | |
29559 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29560 | C3011 FORMAT(38X,I3,3X,2E12.3) | |
29561 | C ENDIF | |
29562 | C 32 CONTINUE | |
29563 | C WRITE(LOUT,*) | |
29564 | C ENDIF | |
29565 | ELSE | |
29566 | WRITE(LOUT,3012) | |
29567 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, | |
29568 | & 'Evaporation: not requested',/) | |
29569 | ENDIF | |
29570 | ||
29571 | RETURN | |
29572 | *------------------------------------------------------------------ | |
29573 | * filling of histogram with event-record | |
29574 | 4 CONTINUE | |
29575 | * emulsion treatment | |
29576 | IF (NCOMPO.GT.0) THEN | |
29577 | DO 40 I=1,NCOMPO | |
29578 | IF (IT.EQ.IEMUMA(I)) THEN | |
29579 | EMUSAM(I) = EMUSAM(I)+ONE | |
29580 | ENDIF | |
29581 | 40 CONTINUE | |
29582 | ENDIF | |
29583 | NINCGE = NINCGE+MAXGEN | |
29584 | MAXGEN = 0 | |
29585 | **dble Po statistics. | |
29586 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 | |
29587 | ||
29588 | RETURN | |
29589 | *------------------------------------------------------------------ | |
29590 | * filling of histogram with event-record | |
29591 | 5 CONTINUE | |
29592 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN | |
29593 | IB = IIBAR(IDBAM(IDX)) | |
29594 | IC = IICH(IDBAM(IDX)) | |
29595 | J = ISTHKK(IDX)-14 | |
29596 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN | |
29597 | NINCST(J,1) = NINCST(J,1)+1 | |
29598 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN | |
29599 | NINCST(J,2) = NINCST(J,2)+1 | |
29600 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN | |
29601 | NINCST(J,3) = NINCST(J,3)+1 | |
29602 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN | |
29603 | NINCST(J,4) = NINCST(J,4)+1 | |
29604 | ENDIF | |
29605 | ELSEIF (ISTHKK(IDX).EQ.17) THEN | |
29606 | NINCWO(1) = NINCWO(1)+1 | |
29607 | ELSEIF (ISTHKK(IDX).EQ.18) THEN | |
29608 | NINCWO(2) = NINCWO(2)+1 | |
29609 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN | |
29610 | IB = IDRES(IDX) | |
29611 | IC = IDXRES(IDX) | |
29612 | IF (IC.GT.0) THEN | |
29613 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 | |
29614 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 | |
29615 | ENDIF | |
29616 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29617 | ENDIF | |
29618 | ||
29619 | RETURN | |
29620 | END | |
29621 | ||
29622 | *$ CREATE DT_NEWHGR.FOR | |
29623 | *COPY DT_NEWHGR | |
29624 | * | |
29625 | *===newhgr=============================================================* | |
29626 | * | |
29627 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) | |
29628 | ||
29629 | ************************************************************************ | |
29630 | * * | |
29631 | * Histogram initialization. * | |
29632 | * * | |
29633 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * | |
29634 | * XLIM3 bin size * | |
29635 | * IBIN > 0 number of bins in equidistant lin. binning * | |
29636 | * = -1 reset histograms * | |
29637 | * < -1 |IBIN| number of bins in equidistant log. * | |
29638 | * binning or log. binning in user def. struc. * | |
29639 | * XLIMB(*) user defined bin structure * | |
29640 | * * | |
29641 | * The bin structure is sensitive to * | |
29642 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * | |
29643 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * | |
29644 | * XLIMB, IBIN if XLIM3 < 0 * | |
29645 | * * | |
29646 | * * | |
29647 | * output: IREFN histogram index * | |
29648 | * (= -1 for inconsistent histogr. request) * | |
29649 | * * | |
29650 | * This subroutine is based on a original version by R. Engel. * | |
29651 | * This version dated 22.4.95 is written by S. Roesler. * | |
29652 | ************************************************************************ | |
29653 | ||
29654 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29655 | SAVE | |
29656 | PARAMETER ( LINP = 10 , | |
29657 | & LOUT = 6 , | |
29658 | & LDAT = 9 ) | |
29659 | ||
29660 | LOGICAL LSTART | |
29661 | ||
29662 | PARAMETER (ZERO = 0.0D0, | |
29663 | & TINY = 1.0D-10) | |
29664 | ||
29665 | DIMENSION XLIMB(*) | |
29666 | ||
29667 | * histograms | |
29668 | PARAMETER (NHIS=150, NDIM=250) | |
29669 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29670 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29671 | * auxiliary common for histograms | |
29672 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29673 | ||
29674 | DATA LSTART /.TRUE./ | |
29675 | ||
29676 | * reset histogram counter | |
29677 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN | |
29678 | IHISL = 0 | |
29679 | IF (IBIN.EQ.-1) RETURN | |
29680 | LSTART = .FALSE. | |
29681 | ENDIF | |
29682 | ||
29683 | IHIS = IHISL+1 | |
29684 | * check for maximum number of allowed histograms | |
29685 | IF (IHIS.GT.NHIS) THEN | |
29686 | WRITE(LOUT,1003) IHIS,NHIS,IHIS | |
29687 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', | |
29688 | & I4,') exceeds array size (',I4,')',/,21X, | |
29689 | & 'histogram',I3,' skipped!') | |
29690 | GOTO 9999 | |
29691 | ENDIF | |
29692 | ||
29693 | IREFN = IHIS | |
29694 | IBINS(IHIS) = ABS(IBIN) | |
29695 | * check requested number of bins | |
29696 | IF (IBINS(IHIS).GE.NDIM) THEN | |
29697 | WRITE(LOUT,1000) IBIN,NDIM,NDIM | |
29698 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', | |
29699 | & I3,') exceeds array size (',I3,')',/,21X, | |
29700 | & 'and will be reset to ',I3) | |
29701 | IBINS(IHIS) = NDIM | |
29702 | ENDIF | |
29703 | IF (IBINS(IHIS).EQ.0) THEN | |
29704 | WRITE(LOUT,1001) IBIN,IHIS | |
29705 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', | |
29706 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') | |
29707 | GOTO 9999 | |
29708 | ENDIF | |
29709 | ||
29710 | * initialize arrays | |
29711 | DO 1 I=1,NDIM | |
29712 | DO 2 K=1,3 | |
29713 | HIST(K,IHIS,I) = ZERO | |
29714 | HIST(K+3,IHIS,I) = ZERO | |
29715 | TMPHIS(K,IHIS,I) = ZERO | |
29716 | 2 CONTINUE | |
29717 | HIST(7,IHIS,I) = ZERO | |
29718 | 1 CONTINUE | |
29719 | DENTRY(1,IHIS)= ZERO | |
29720 | DENTRY(2,IHIS)= ZERO | |
29721 | OVERF(IHIS) = ZERO | |
29722 | UNDERF(IHIS) = ZERO | |
29723 | TMPUFL(IHIS) = ZERO | |
29724 | TMPOFL(IHIS) = ZERO | |
29725 | ||
29726 | * bin str. sensitive to lower edge, bin size, and numb. of bins | |
29727 | IF (XLIM3.GT.ZERO) THEN | |
29728 | DO 3 K=1,IBINS(IHIS)+1 | |
29729 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 | |
29730 | 3 CONTINUE | |
29731 | ISWI(IHIS) = 1 | |
29732 | * bin str. sensitive to lower/upper edge and numb. of bins | |
29733 | ELSEIF (XLIM3.EQ.ZERO) THEN | |
29734 | * linear binning | |
29735 | IF (IBIN.GT.0) THEN | |
29736 | XLOW = XLIM1 | |
29737 | XHI = XLIM2 | |
29738 | IF (XLIM2.LE.XLIM1) THEN | |
29739 | WRITE(LOUT,1002) XLIM1,XLIM2 | |
29740 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29741 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29742 | GOTO 9999 | |
29743 | ENDIF | |
29744 | ISWI(IHIS) = 1 | |
29745 | ELSEIF (IBIN.LT.-1) THEN | |
29746 | * logarithmic binning | |
29747 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN | |
29748 | WRITE(LOUT,1004) XLIM1,XLIM2 | |
29749 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', | |
29750 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29751 | GOTO 9999 | |
29752 | ENDIF | |
29753 | IF (XLIM2.LE.XLIM1) THEN | |
29754 | WRITE(LOUT,1005) XLIM1,XLIM2 | |
29755 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29756 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29757 | GOTO 9999 | |
29758 | ENDIF | |
29759 | XLOW = LOG10(XLIM1) | |
29760 | XHI = LOG10(XLIM2) | |
29761 | ISWI(IHIS) = 3 | |
29762 | ENDIF | |
29763 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) | |
29764 | DO 4 K=1,IBINS(IHIS)+1 | |
29765 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX | |
29766 | 4 CONTINUE | |
29767 | ELSE | |
29768 | * user defined bin structure | |
29769 | DO 5 K=1,IBINS(IHIS)+1 | |
29770 | IF (IBIN.GT.0) THEN | |
29771 | HIST(1,IHIS,K) = XLIMB(K) | |
29772 | ISWI(IHIS) = 2 | |
29773 | ELSEIF (IBIN.LT.-1) THEN | |
29774 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) | |
29775 | ISWI(IHIS) = 4 | |
29776 | ENDIF | |
29777 | 5 CONTINUE | |
29778 | ENDIF | |
29779 | ||
29780 | * histogram accepted | |
29781 | IHISL = IHIS | |
29782 | ||
29783 | RETURN | |
29784 | ||
29785 | 9999 CONTINUE | |
29786 | IREFN = -1 | |
29787 | RETURN | |
29788 | END | |
29789 | ||
29790 | *$ CREATE DT_FILHGR.FOR | |
29791 | *COPY DT_FILHGR | |
29792 | * | |
29793 | *===filhgr=============================================================* | |
29794 | * | |
29795 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) | |
29796 | ||
29797 | ************************************************************************ | |
29798 | * * | |
29799 | * Scoring for histogram IHIS. * | |
29800 | * * | |
29801 | * This subroutine is based on a original version by R. Engel. * | |
29802 | * This version dated 23.4.95 is written by S. Roesler. * | |
29803 | ************************************************************************ | |
29804 | ||
29805 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29806 | SAVE | |
29807 | PARAMETER ( LINP = 10 , | |
29808 | & LOUT = 6 , | |
29809 | & LDAT = 9 ) | |
29810 | ||
29811 | PARAMETER (ZERO = 0.0D0, | |
29812 | & ONE = 1.0D0, | |
29813 | & TINY = 1.0D-10) | |
29814 | ||
29815 | * histograms | |
29816 | PARAMETER (NHIS=150, NDIM=250) | |
29817 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29818 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29819 | * auxiliary common for histograms | |
29820 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29821 | ||
29822 | DATA NCEVT /1/ | |
29823 | ||
29824 | X = XI | |
29825 | Y = YI | |
29826 | ||
29827 | * dump content of temorary arrays into histograms | |
29828 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN | |
29829 | CALL DT_EVTHIS(IDUM) | |
29830 | NCEVT = NEVT | |
29831 | ENDIF | |
29832 | ||
29833 | * check histogram index | |
29834 | IF (IHIS.EQ.-1) RETURN | |
29835 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN | |
29836 | C WRITE(LOUT,1000) IHIS,IHISL | |
29837 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, | |
29838 | & ' out of range (1..',I3,')') | |
29839 | RETURN | |
29840 | ENDIF | |
29841 | ||
29842 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN | |
29843 | * bin structure not explicitly given | |
29844 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) | |
29845 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) | |
29846 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29847 | I1 = 0 | |
29848 | ELSE | |
29849 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 | |
29850 | ENDIF | |
29851 | ||
29852 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN | |
29853 | * user defined bin structure | |
29854 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) | |
29855 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29856 | I1 = 0 | |
29857 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN | |
29858 | I1 = IBINS(IHIS)+1 | |
29859 | ELSE | |
29860 | * binary sort algorithm | |
29861 | KMIN = 0 | |
29862 | KMAX = IBINS(IHIS)+1 | |
29863 | 1 CONTINUE | |
29864 | IF ((KMAX-KMIN).EQ.1) GOTO 2 | |
29865 | KK = (KMAX+KMIN)/2 | |
29866 | IF (X.LE.HIST(1,IHIS,KK)) THEN | |
29867 | KMAX=KK | |
29868 | ELSE | |
29869 | KMIN=KK | |
29870 | ENDIF | |
29871 | GOTO 1 | |
29872 | 2 CONTINUE | |
29873 | I1 = KMIN | |
29874 | ENDIF | |
29875 | ||
29876 | ELSE | |
29877 | WRITE(LOUT,1001) | |
29878 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') | |
29879 | RETURN | |
29880 | ENDIF | |
29881 | ||
29882 | * scoring | |
29883 | IF (I1.LE.0) THEN | |
29884 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE | |
29885 | ELSEIF (I1.LE.IBINS(IHIS)) THEN | |
29886 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE | |
29887 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
29888 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X | |
29889 | ELSE | |
29890 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X | |
29891 | ENDIF | |
29892 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y | |
29893 | ELSE | |
29894 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE | |
29895 | ENDIF | |
29896 | ||
29897 | RETURN | |
29898 | END | |
29899 | ||
29900 | *$ CREATE DT_EVTHIS.FOR | |
29901 | *COPY DT_EVTHIS | |
29902 | * | |
29903 | *===evthis=============================================================* | |
29904 | * | |
29905 | SUBROUTINE DT_EVTHIS(NEVT) | |
29906 | ||
29907 | ************************************************************************ | |
29908 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * | |
29909 | * is called after each event and for the last event before any call * | |
29910 | * to OUTHGR. * | |
29911 | * NEVT number of events dumped, this is only needed to * | |
29912 | * get the normalization after the last event * | |
29913 | * This version dated 23.4.95 is written by S. Roesler. * | |
29914 | ************************************************************************ | |
29915 | ||
29916 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29917 | SAVE | |
29918 | PARAMETER ( LINP = 10 , | |
29919 | & LOUT = 6 , | |
29920 | & LDAT = 9 ) | |
29921 | ||
29922 | LOGICAL LNOETY | |
29923 | ||
29924 | PARAMETER (ZERO = 0.0D0, | |
29925 | & ONE = 1.0D0, | |
29926 | & TINY = 1.0D-10) | |
29927 | ||
29928 | * histograms | |
29929 | PARAMETER (NHIS=150, NDIM=250) | |
29930 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29931 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29932 | * auxiliary common for histograms | |
29933 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29934 | ||
29935 | DATA NCEVT /0/ | |
29936 | ||
29937 | NCEVT = NCEVT+1 | |
29938 | NEVT = NCEVT | |
29939 | ||
29940 | DO 1 I=1,IHISL | |
29941 | LNOETY = .TRUE. | |
29942 | DO 2 J=1,IBINS(I) | |
29943 | IF (TMPHIS(1,I,J).GT.ZERO) THEN | |
29944 | LNOETY = .FALSE. | |
29945 | HIST(2,I,J) = HIST(2,I,J)+ONE | |
29946 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) | |
29947 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) | |
29948 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) | |
29949 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX | |
29950 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 | |
29951 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) | |
29952 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 | |
29953 | TMPHIS(1,I,J) = ZERO | |
29954 | TMPHIS(2,I,J) = ZERO | |
29955 | TMPHIS(3,I,J) = ZERO | |
29956 | ENDIF | |
29957 | 2 CONTINUE | |
29958 | IF (LNOETY) THEN | |
29959 | IF (TMPUFL(I).GT.ZERO) THEN | |
29960 | UNDERF(I) = UNDERF(I)+ONE | |
29961 | TMPUFL(I) = ZERO | |
29962 | ELSEIF (TMPOFL(I).GT.ZERO) THEN | |
29963 | OVERF(I) = OVERF(I)+ONE | |
29964 | TMPOFL(I) = ZERO | |
29965 | ENDIF | |
29966 | ELSE | |
29967 | DENTRY(1,I) = DENTRY(1,I)+ONE | |
29968 | ENDIF | |
29969 | 1 CONTINUE | |
29970 | ||
29971 | RETURN | |
29972 | END | |
29973 | ||
29974 | *$ CREATE DT_OUTHGR.FOR | |
29975 | *COPY DT_OUTHGR | |
29976 | * | |
29977 | *===outhgr=============================================================* | |
29978 | * | |
29979 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, | |
29980 | & ILOGY,INORM,NMODE) | |
29981 | ||
29982 | ************************************************************************ | |
29983 | * * | |
29984 | * Plot histogram(s) to standard output unit * | |
29985 | * * | |
29986 | * I1..6 indices of histograms to be plotted * | |
29987 | * CHEAD,IHEAD header string,integer * | |
29988 | * NEVTS number of events * | |
29989 | * FAC scaling factor * | |
29990 | * ILOGY = 1 logarithmic y-axis * | |
29991 | * INORM normalization * | |
29992 | * = 0 no further normalization (FAC is obsolete) * | |
29993 | * = 1 per event and bin width * | |
29994 | * = 2 per entry and bin width * | |
29995 | * = 3 per bin entry * | |
29996 | * = 4 per event and "bin width" x1^2...x2^2 * | |
29997 | * = 5 per event and "log. bin width" ln x1..ln x2 * | |
29998 | * = 6 per event * | |
29999 | * MODE = 0 no output but normalization applied * | |
30000 | * = 1 all valid histograms separately (small frame) * | |
30001 | * all valid histograms separately (small frame) * | |
30002 | * = -1 and tables as histograms * | |
30003 | * = 2 all valid histograms (one plot, wide frame) * | |
30004 | * all valid histograms (one plot, wide frame) * | |
30005 | * = -2 and tables as histograms * | |
30006 | * * | |
30007 | * * | |
30008 | * Note: All histograms to be plotted with one call to this * | |
30009 | * subroutine and |MODE|=2 must have the same bin structure! * | |
30010 | * There is no test included ensuring this fact. * | |
30011 | * * | |
30012 | * This version dated 23.4.95 is written by S. Roesler. * | |
30013 | ************************************************************************ | |
30014 | ||
30015 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30016 | SAVE | |
30017 | PARAMETER ( LINP = 10 , | |
30018 | & LOUT = 6 , | |
30019 | & LDAT = 9 ) | |
30020 | ||
30021 | CHARACTER*72 CHEAD | |
30022 | ||
30023 | PARAMETER (ZERO = 0.0D0, | |
30024 | & IZERO = 0, | |
30025 | & ONE = 1.0D0, | |
30026 | & TWO = 2.0D0, | |
30027 | & OHALF = 0.5D0, | |
30028 | & EPS = 1.0D-5, | |
30029 | & TINY = 1.0D-8, | |
30030 | & SMALL = -1.0D8, | |
30031 | & RLARGE = 1.0D8 ) | |
30032 | ||
30033 | * histograms | |
30034 | PARAMETER (NHIS=150, NDIM=250) | |
30035 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30036 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30037 | ||
30038 | PARAMETER (NDIM2 = 2*NDIM) | |
30039 | DIMENSION XX(NDIM2),YY(NDIM2) | |
30040 | ||
30041 | PARAMETER (NHISTO = 6) | |
30042 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), | |
30043 | & IDX(NHISTO) | |
30044 | ||
30045 | CHARACTER*43 CNORM(0:8) | |
30046 | DATA CNORM /'no further normalization ', | |
30047 | & 'per event and bin width ', | |
30048 | & 'per entry1 and bin width ', | |
30049 | & 'per bin entry ', | |
30050 | & 'per event and "bin width" x1^2...x2^2 ', | |
30051 | & 'per event and "log. bin width" ln x1..ln x2', | |
30052 | & 'per event ', | |
30053 | & 'per bin entry1 ', | |
30054 | & 'per entry2 and bin width '/ | |
30055 | ||
30056 | IDX1(1) = I1 | |
30057 | IDX1(2) = I2 | |
30058 | IDX1(3) = I3 | |
30059 | IDX1(4) = I4 | |
30060 | IDX1(5) = I5 | |
30061 | IDX1(6) = I6 | |
30062 | ||
30063 | MODE = NMODE | |
30064 | ||
30065 | * initialization if "wide frame" is requested | |
30066 | IF (ABS(MODE).EQ.2) THEN | |
30067 | DO 1 I=1,NHISTO | |
30068 | DO 2 J=1,NDIM | |
30069 | XX1(J,I) = ZERO | |
30070 | YY1(J,I) = ZERO | |
30071 | 2 CONTINUE | |
30072 | 1 CONTINUE | |
30073 | ENDIF | |
30074 | ||
30075 | * plot header | |
30076 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) | |
30077 | ||
30078 | * check histogram indices | |
30079 | NHI = 0 | |
30080 | DO 3 I=1,NHISTO | |
30081 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN | |
30082 | IF (ISWI(IDX1(I)).NE.0) THEN | |
30083 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN | |
30084 | WRITE(LOUT,1000) | |
30085 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) | |
30086 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', | |
30087 | & ' histogram ',I3,/,21X,'underflows:',F10.0, | |
30088 | & ' overflows: ',F10.0) | |
30089 | ELSE | |
30090 | NHI = NHI+1 | |
30091 | IDX(NHI) = IDX1(I) | |
30092 | ENDIF | |
30093 | ENDIF | |
30094 | ENDIF | |
30095 | 3 CONTINUE | |
30096 | IF (NHI.EQ.0) THEN | |
30097 | WRITE(LOUT,1001) | |
30098 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') | |
30099 | RETURN | |
30100 | ENDIF | |
30101 | ||
30102 | * check normalization request | |
30103 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. | |
30104 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. | |
30105 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. | |
30106 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN | |
30107 | WRITE(LOUT,1002) NEVTS,INORM,FAC | |
30108 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', | |
30109 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, | |
30110 | & 'FAC = ',E11.4) | |
30111 | RETURN | |
30112 | ENDIF | |
30113 | ||
30114 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS | |
30115 | ||
30116 | * apply normalization | |
30117 | DO 4 N=1,NHI | |
30118 | ||
30119 | I = IDX(N) | |
30120 | ||
30121 | IF (ISWI(I).EQ.1) THEN | |
30122 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30123 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, | |
30124 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30125 | ELSEIF (ISWI(I).EQ.2) THEN | |
30126 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30127 | WRITE(LOUT,1007) | |
30128 | 1007 FORMAT(1X,'user defined bin structure') | |
30129 | ELSEIF (ISWI(I).EQ.3) THEN | |
30130 | WRITE(LOUT,1004) | |
30131 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30132 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, | |
30133 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30134 | ELSEIF (ISWI(I).EQ.4) THEN | |
30135 | WRITE(LOUT,1004) | |
30136 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30137 | WRITE(LOUT,1007) | |
30138 | ELSE | |
30139 | WRITE(LOUT,1008) ISWI(I) | |
30140 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) | |
30141 | ENDIF | |
30142 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) | |
30143 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, | |
30144 | & ' overfl.:',F8.0) | |
30145 | WRITE(LOUT,1009) CNORM(INORM) | |
30146 | 1009 FORMAT(1X,'normalization: ',A,/) | |
30147 | ||
30148 | DO 5 K=1,IBINS(I) | |
30149 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) | |
30150 | YMEAN = FAC*YMEAN | |
30151 | YERR = FAC*YERR | |
30152 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30153 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30154 | 1006 FORMAT(1X,5E11.3) | |
30155 | * small frame | |
30156 | II = 2*K | |
30157 | XX(II-1) = HIST(1,I,K) | |
30158 | XX(II) = HIST(1,I,K+1) | |
30159 | YY(II-1) = YMEAN | |
30160 | YY(II) = YMEAN | |
30161 | * wide frame | |
30162 | XX1(K,N) = XMEAN | |
30163 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) | |
30164 | & XX1(K,N) = LOG10(XMEAN) | |
30165 | YY1(K,N) = YMEAN | |
30166 | 5 CONTINUE | |
30167 | ||
30168 | * plot small frame | |
30169 | IF (ABS(MODE).EQ.1) THEN | |
30170 | IBIN2 = 2*IBINS(I) | |
30171 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30172 | IF(ILOGY.EQ.1) THEN | |
30173 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30174 | ELSE | |
30175 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30176 | ENDIF | |
30177 | ENDIF | |
30178 | ||
30179 | 4 CONTINUE | |
30180 | ||
30181 | * plot wide frame | |
30182 | IF (ABS(MODE).EQ.2) THEN | |
30183 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30184 | NSIZE = NDIM*NHISTO | |
30185 | DXLOW = HIST(1,IDX(1),1) | |
30186 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) | |
30187 | YLOW = RLARGE | |
30188 | YHI = SMALL | |
30189 | DO 6 I=1,NHISTO | |
30190 | DO 7 J=1,NDIM | |
30191 | IF (YY1(J,I).LT.YLOW) THEN | |
30192 | IF (ILOGY.EQ.1) THEN | |
30193 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) | |
30194 | ELSE | |
30195 | YLOW = YY1(J,I) | |
30196 | ENDIF | |
30197 | ENDIF | |
30198 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) | |
30199 | 7 CONTINUE | |
30200 | 6 CONTINUE | |
30201 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30202 | IF (DY.LE.ZERO) THEN | |
30203 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') | |
30204 | & 'OUTHGR: warning! zero bin width for histograms ', | |
30205 | & IDX,': ',YLOW,YHI | |
30206 | RETURN | |
30207 | ENDIF | |
30208 | IF (ILOGY.EQ.1) THEN | |
30209 | YLOW = LOG10(YLOW) | |
30210 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30211 | DO 8 I=1,NHISTO | |
30212 | DO 9 J=1,NDIM | |
30213 | IF (YY1(J,I).LE.ZERO) THEN | |
30214 | YY1(J,I) = YLOW | |
30215 | ELSE | |
30216 | YY1(J,I) = LOG10(YY1(J,I)) | |
30217 | ENDIF | |
30218 | 9 CONTINUE | |
30219 | 8 CONTINUE | |
30220 | ENDIF | |
30221 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) | |
30222 | ENDIF | |
30223 | ||
30224 | RETURN | |
30225 | END | |
30226 | ||
30227 | *$ CREATE DT_GETBIN.FOR | |
30228 | *COPY DT_GETBIN | |
30229 | * | |
30230 | *===getbin=============================================================* | |
30231 | * | |
30232 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, | |
30233 | & XMEAN,YMEAN,YERR) | |
30234 | ||
30235 | ************************************************************************ | |
30236 | * This version dated 23.4.95 is written by S. Roesler. * | |
30237 | ************************************************************************ | |
30238 | ||
30239 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30240 | SAVE | |
30241 | PARAMETER ( LINP = 10 , | |
30242 | & LOUT = 6 , | |
30243 | & LDAT = 9 ) | |
30244 | ||
30245 | PARAMETER (ZERO = 0.0D0, | |
30246 | & ONE = 1.0D0, | |
30247 | & TINY35 = 1.0D-35) | |
30248 | ||
30249 | * histograms | |
30250 | PARAMETER (NHIS=150, NDIM=250) | |
30251 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30252 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30253 | ||
30254 | XLOW = HIST(1,IHIS,IBIN) | |
30255 | XHI = HIST(1,IHIS,IBIN+1) | |
30256 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
30257 | XLOW = 10**XLOW | |
30258 | XHI = 10**XHI | |
30259 | ENDIF | |
30260 | IF (NORM.EQ.2) THEN | |
30261 | DX = XHI-XLOW | |
30262 | NEVT = INT(DENTRY(1,IHIS)) | |
30263 | ELSEIF (NORM.EQ.3) THEN | |
30264 | DX = ONE | |
30265 | NEVT = INT(HIST(2,IHIS,IBIN)) | |
30266 | ELSEIF (NORM.EQ.4) THEN | |
30267 | DX = XHI**2-XLOW**2 | |
30268 | NEVT = KEVT | |
30269 | ELSEIF (NORM.EQ.5) THEN | |
30270 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) | |
30271 | NEVT = KEVT | |
30272 | ELSEIF (NORM.EQ.6) THEN | |
30273 | DX = ONE | |
30274 | NEVT = KEVT | |
30275 | ELSEIF (NORM.EQ.7) THEN | |
30276 | DX = ONE | |
30277 | NEVT = INT(HIST(7,IHIS,IBIN)) | |
30278 | ELSEIF (NORM.EQ.8) THEN | |
30279 | DX = XHI-XLOW | |
30280 | NEVT = INT(DENTRY(2,IHIS)) | |
30281 | ELSE | |
30282 | DX = ABS(XHI-XLOW) | |
30283 | NEVT = KEVT | |
30284 | ENDIF | |
30285 | IF (ABS(DX).LT.TINY35) DX = ONE | |
30286 | NEVT = MAX(NEVT,1) | |
30287 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) | |
30288 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) | |
30289 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) | |
30290 | YSUM = HIST(5,IHIS,IBIN) | |
30291 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE | |
30292 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) | |
30293 | XMEAN = HIST(3,IHIS,IBIN)/YSUM | |
30294 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW | |
30295 | ||
30296 | RETURN | |
30297 | END | |
30298 | ||
30299 | *$ CREATE DT_JOIHIS.FOR | |
30300 | *COPY DT_JOIHIS | |
30301 | * | |
30302 | *===joihis=============================================================* | |
30303 | * | |
30304 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) | |
30305 | ||
30306 | ************************************************************************ | |
30307 | * * | |
30308 | * Operation on histograms. * | |
30309 | * * | |
30310 | * input: IH1,IH2 histogram indices to be joined * | |
30311 | * COPER character defining the requested operation, * | |
30312 | * i.e. '+', '-', '*', '/' * | |
30313 | * FAC1,FAC2 factors for joining, i.e. * | |
30314 | * FAC1*histo1 COPER FAC2*histo2 * | |
30315 | * * | |
30316 | * This version dated 23.4.95 is written by S. Roesler. * | |
30317 | ************************************************************************ | |
30318 | ||
30319 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30320 | SAVE | |
30321 | PARAMETER ( LINP = 10 , | |
30322 | & LOUT = 6 , | |
30323 | & LDAT = 9 ) | |
30324 | ||
30325 | CHARACTER COPER*1 | |
30326 | ||
30327 | PARAMETER (ZERO = 0.0D0, | |
30328 | & ONE = 1.0D0, | |
30329 | & OHALF = 0.5D0, | |
30330 | & TINY8 = 1.0D-8, | |
30331 | & SMALL = -1.0D8, | |
30332 | & RLARGE = 1.0D8 ) | |
30333 | ||
30334 | * histograms | |
30335 | PARAMETER (NHIS=150, NDIM=250) | |
30336 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30337 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30338 | ||
30339 | PARAMETER (NDIM2 = 2*NDIM) | |
30340 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) | |
30341 | ||
30342 | CHARACTER*43 CNORM(0:6) | |
30343 | DATA CNORM /'no further normalization ', | |
30344 | & 'per event and bin width ', | |
30345 | & 'per entry and bin width ', | |
30346 | & 'per bin entry ', | |
30347 | & 'per event and "bin width" x1^2...x2^2 ', | |
30348 | & 'per event and "log. bin width" ln x1..ln x2', | |
30349 | & 'per event '/ | |
30350 | ||
30351 | * check histogram indices | |
30352 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. | |
30353 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN | |
30354 | WRITE(LOUT,1000) IH1,IH2,IHISL | |
30355 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', | |
30356 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) | |
30357 | GOTO 9999 | |
30358 | ENDIF | |
30359 | ||
30360 | * check bin structure of histograms to be joined | |
30361 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN | |
30362 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) | |
30363 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30364 | & ' and ',I3,' failed',/,21X, | |
30365 | & 'due to different numbers of bins (',I3,',',I3,')') | |
30366 | GOTO 9999 | |
30367 | ENDIF | |
30368 | DO 1 K=1,IBINS(IH1)+1 | |
30369 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN | |
30370 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) | |
30371 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30372 | & ' and ',I3,' failed at bin edge ',I3,/,21X, | |
30373 | & 'X1,X2 = ',2E11.4) | |
30374 | GOTO 9999 | |
30375 | ENDIF | |
30376 | 1 CONTINUE | |
30377 | ||
30378 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 | |
30379 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', | |
30380 | & 'operation ',A,/,11X,'and factors ',2E11.4) | |
30381 | WRITE(LOUT,1004) CNORM(NORM) | |
30382 | 1004 FORMAT(1X,'normalization: ',A,/) | |
30383 | ||
30384 | DO 2 K=1,IBINS(IH1) | |
30385 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) | |
30386 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) | |
30387 | XLOW = XLOW1 | |
30388 | XHI = XHI1 | |
30389 | XMEAN = OHALF*(XMEAN1+XMEAN2) | |
30390 | IF (COPER.EQ.'+') THEN | |
30391 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 | |
30392 | ELSEIF (COPER.EQ.'*') THEN | |
30393 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 | |
30394 | ELSEIF (COPER.EQ.'/') THEN | |
30395 | IF (YMEAN2.EQ.ZERO) THEN | |
30396 | YMEAN = ZERO | |
30397 | ELSE | |
30398 | IF (FAC2.EQ.ZERO) FAC2 = ONE | |
30399 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) | |
30400 | ENDIF | |
30401 | ELSE | |
30402 | GOTO 9998 | |
30403 | ENDIF | |
30404 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30405 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30406 | 1006 FORMAT(1X,5E11.3) | |
30407 | * small frame | |
30408 | II = 2*K | |
30409 | XX(II-1) = HIST(1,IH1,K) | |
30410 | XX(II) = HIST(1,IH1,K+1) | |
30411 | YY(II-1) = YMEAN | |
30412 | YY(II) = YMEAN | |
30413 | * wide frame | |
30414 | XX1(K) = XMEAN | |
30415 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) | |
30416 | YY1(K) = YMEAN | |
30417 | 2 CONTINUE | |
30418 | ||
30419 | * plot small frame | |
30420 | IF (ABS(MODE).EQ.1) THEN | |
30421 | IBIN2 = 2*IBINS(IH1) | |
30422 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30423 | IF(ILOGY.EQ.1) THEN | |
30424 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30425 | ELSE | |
30426 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30427 | ENDIF | |
30428 | ENDIF | |
30429 | ||
30430 | * plot wide frame | |
30431 | IF (ABS(MODE).EQ.2) THEN | |
30432 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30433 | NSIZE = NDIM | |
30434 | DXLOW = HIST(1,IH1,1) | |
30435 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) | |
30436 | YLOW = RLARGE | |
30437 | YHI = SMALL | |
30438 | DO 3 I=1,NDIM | |
30439 | IF (YY1(I).LT.YLOW) THEN | |
30440 | IF (ILOGY.EQ.1) THEN | |
30441 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) | |
30442 | ELSE | |
30443 | YLOW = YY1(I) | |
30444 | ENDIF | |
30445 | ENDIF | |
30446 | IF (YY1(I).GT.YHI) YHI = YY1(I) | |
30447 | 3 CONTINUE | |
30448 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30449 | IF (DY.LE.ZERO) THEN | |
30450 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') | |
30451 | & 'JOIHIS: warning! zero bin width for histograms ', | |
30452 | & IH1,IH2,': ',YLOW,YHI | |
30453 | RETURN | |
30454 | ENDIF | |
30455 | IF (ILOGY.EQ.1) THEN | |
30456 | YLOW = LOG10(YLOW) | |
30457 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30458 | DO 4 I=1,NDIM | |
30459 | IF (YY1(I).LE.ZERO) THEN | |
30460 | YY1(I) = YLOW | |
30461 | ELSE | |
30462 | YY1(I) = LOG10(YY1(I)) | |
30463 | ENDIF | |
30464 | 4 CONTINUE | |
30465 | ENDIF | |
30466 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) | |
30467 | ENDIF | |
30468 | ||
30469 | RETURN | |
30470 | ||
30471 | 9998 CONTINUE | |
30472 | WRITE(LOUT,1005) COPER | |
30473 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) | |
30474 | ||
30475 | 9999 CONTINUE | |
30476 | RETURN | |
30477 | END | |
30478 | ||
30479 | *$ CREATE DT_XGRAPH.FOR | |
30480 | *COPY DT_XGRAPH | |
30481 | * | |
30482 | *===qgraph=============================================================* | |
30483 | * | |
30484 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) | |
30485 | C*********************************************************************** | |
30486 | C | |
30487 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30488 | C ranges will be chosen automatically | |
30489 | C | |
30490 | C input N dimension of input fields | |
30491 | C IARG number of curves (fields) to plot | |
30492 | C X field of X | |
30493 | C Y1 field of Y1 | |
30494 | C Y2 field of Y2 | |
30495 | C | |
30496 | C This subroutine is written by R. Engel. | |
30497 | C*********************************************************************** | |
30498 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30499 | SAVE | |
30500 | ||
30501 | PARAMETER ( LINP = 10 , | |
30502 | & LOUT = 6 , | |
30503 | & LDAT = 9 ) | |
30504 | C | |
30505 | DIMENSION X(N),Y1(N),Y2(N) | |
30506 | PARAMETER (EPS=1.D-30) | |
30507 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30508 | CHARACTER SYMB(5) | |
30509 | CHARACTER COL(0:149,0:49) | |
30510 | C | |
30511 | DATA SYMB /'0','e','z','#','x'/ | |
30512 | C | |
30513 | ISPALT=IBREIT-10 | |
30514 | C | |
30515 | C*** automatic range fitting | |
30516 | C | |
30517 | XMAX=X(1) | |
30518 | XMIN=X(1) | |
30519 | DO 600 I=1,N | |
30520 | XMAX=MAX(X(I),XMAX) | |
30521 | XMIN=MIN(X(I),XMIN) | |
30522 | 600 CONTINUE | |
30523 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30524 | C | |
30525 | ITEST=0 | |
30526 | DO 1100 K=0,IZEIL-1 | |
30527 | ITEST=ITEST+1 | |
30528 | IF (ITEST.EQ.IYRAST) THEN | |
30529 | DO 1010 L=1,ISPALT-1 | |
30530 | COL(L,K)='-' | |
30531 | 1010 CONTINUE | |
30532 | COL(ISPALT,K)='+' | |
30533 | ITEST=0 | |
30534 | DO 1020 L=0,ISPALT-1,IXRAST | |
30535 | COL(L,K)='+' | |
30536 | 1020 CONTINUE | |
30537 | ELSE | |
30538 | DO 1030 L=1,ISPALT-1 | |
30539 | COL(L,K)=' ' | |
30540 | 1030 CONTINUE | |
30541 | DO 1040 L=0,ISPALT-1,IXRAST | |
30542 | COL(L,K)='|' | |
30543 | 1040 CONTINUE | |
30544 | COL(ISPALT,K)='|' | |
30545 | ENDIF | |
30546 | 1100 CONTINUE | |
30547 | C | |
30548 | C*** plot curve Y1 | |
30549 | C | |
30550 | YMAX=Y1(1) | |
30551 | YMIN=Y1(1) | |
30552 | DO 500 I=1,N | |
30553 | YMAX=MAX(Y1(I),YMAX) | |
30554 | YMIN=MIN(Y1(I),YMIN) | |
30555 | 500 CONTINUE | |
30556 | IF(IARG.GT.1) THEN | |
30557 | DO 550 I=1,N | |
30558 | YMAX=MAX(Y2(I),YMAX) | |
30559 | YMIN=MIN(Y2(I),YMIN) | |
30560 | 550 CONTINUE | |
30561 | ENDIF | |
30562 | YMAX=(YMAX-YMIN)/40.0D0+YMAX | |
30563 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 | |
30564 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) | |
30565 | IF(YZOOM.LT.EPS) THEN | |
30566 | WRITE(LOUT,'(1X,A)') | |
30567 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30568 | RETURN | |
30569 | ENDIF | |
30570 | C | |
30571 | C*** plot curve Y1 | |
30572 | C | |
30573 | ILAST=-1 | |
30574 | LLAST=-1 | |
30575 | DO 1200 K=1,N | |
30576 | L=NINT((X(K)-XMIN)/XZOOM) | |
30577 | I=NINT((YMAX-Y1(K))/YZOOM) | |
30578 | IF(ILAST.GE.0) THEN | |
30579 | LD = L-LLAST | |
30580 | ID = I-ILAST | |
30581 | DO 55 II=0,LD,SIGN(1,LD) | |
30582 | DO 66 KK=0,ID,SIGN(1,ID) | |
30583 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30584 | 66 CONTINUE | |
30585 | 55 CONTINUE | |
30586 | ELSE | |
30587 | COL(L,I)=SYMB(1) | |
30588 | ENDIF | |
30589 | ILAST = I | |
30590 | LLAST = L | |
30591 | 1200 CONTINUE | |
30592 | C | |
30593 | IF(IARG.GT.1) THEN | |
30594 | C | |
30595 | C*** plot curve Y2 | |
30596 | C | |
30597 | DO 1250 K=1,N | |
30598 | L=NINT((X(K)-XMIN)/XZOOM) | |
30599 | I=NINT((YMAX-Y2(K))/YZOOM) | |
30600 | COL(L,I)=SYMB(2) | |
30601 | 1250 CONTINUE | |
30602 | ENDIF | |
30603 | C | |
30604 | C*** write it | |
30605 | C | |
30606 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30607 | C | |
30608 | C*** write range of X | |
30609 | C | |
30610 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30611 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30612 | C | |
30613 | DO 1300 K=0,IZEIL-1 | |
30614 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) | |
30615 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30616 | 110 FORMAT(1X,1PE9.2,70A1) | |
30617 | 1300 CONTINUE | |
30618 | C | |
30619 | C*** write range of X | |
30620 | C | |
30621 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30622 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30623 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30624 | 120 FORMAT(6X,7(1PE10.3)) | |
30625 | END | |
30626 | ||
30627 | *$ CREATE DT_XGLOGY.FOR | |
30628 | *COPY DT_XGLOGY | |
30629 | * | |
30630 | *===qglogy=============================================================* | |
30631 | * | |
30632 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) | |
30633 | C*********************************************************************** | |
30634 | C | |
30635 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30636 | C logarithmic y axis | |
30637 | C ranges will be chosen automatically | |
30638 | C | |
30639 | C input N dimension of input fields | |
30640 | C IARG number of curves (fields) to plot | |
30641 | C X field of X | |
30642 | C Y1 field of Y1 | |
30643 | C Y2 field of Y2 | |
30644 | C | |
30645 | C This subroutine is written by R. Engel. | |
30646 | C*********************************************************************** | |
30647 | C | |
30648 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30649 | SAVE | |
30650 | ||
30651 | PARAMETER ( LINP = 10 , | |
30652 | & LOUT = 6 , | |
30653 | & LDAT = 9 ) | |
30654 | DIMENSION X(N),Y1(N),Y2(N) | |
30655 | PARAMETER (EPS=1.D-30) | |
30656 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30657 | CHARACTER SYMB(5) | |
30658 | CHARACTER COL(0:149,0:49) | |
30659 | PARAMETER (DEPS = 1.D-10) | |
30660 | C | |
30661 | DATA SYMB /'0','e','z','#','x'/ | |
30662 | C | |
30663 | ISPALT=IBREIT-10 | |
30664 | C | |
30665 | C*** automatic range fitting | |
30666 | C | |
30667 | XMAX=X(1) | |
30668 | XMIN=X(1) | |
30669 | DO 600 I=1,N | |
30670 | XMAX=MAX(X(I),XMAX) | |
30671 | XMIN=MIN(X(I),XMIN) | |
30672 | 600 CONTINUE | |
30673 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30674 | C | |
30675 | ITEST=0 | |
30676 | DO 1100 K=0,IZEIL-1 | |
30677 | ITEST=ITEST+1 | |
30678 | IF (ITEST.EQ.IYRAST) THEN | |
30679 | DO 1010 L=1,ISPALT-1 | |
30680 | COL(L,K)='-' | |
30681 | 1010 CONTINUE | |
30682 | COL(ISPALT,K)='+' | |
30683 | ITEST=0 | |
30684 | DO 1020 L=0,ISPALT-1,IXRAST | |
30685 | COL(L,K)='+' | |
30686 | 1020 CONTINUE | |
30687 | ELSE | |
30688 | DO 1030 L=1,ISPALT-1 | |
30689 | COL(L,K)=' ' | |
30690 | 1030 CONTINUE | |
30691 | DO 1040 L=0,ISPALT-1,IXRAST | |
30692 | COL(L,K)='|' | |
30693 | 1040 CONTINUE | |
30694 | COL(ISPALT,K)='|' | |
30695 | ENDIF | |
30696 | 1100 CONTINUE | |
30697 | C | |
30698 | C*** plot curve Y1 | |
30699 | C | |
30700 | YMAX=Y1(1) | |
30701 | YMIN=MAX(Y1(1),EPS) | |
30702 | DO 500 I=1,N | |
30703 | YMAX =MAX(Y1(I),YMAX) | |
30704 | IF(Y1(I).GT.EPS) THEN | |
30705 | IF(YMIN.EQ.EPS) THEN | |
30706 | YMIN = Y1(I)/10.D0 | |
30707 | ELSE | |
30708 | YMIN = MIN(Y1(I),YMIN) | |
30709 | ENDIF | |
30710 | ENDIF | |
30711 | 500 CONTINUE | |
30712 | IF(IARG.GT.1) THEN | |
30713 | DO 550 I=1,N | |
30714 | YMAX=MAX(Y2(I),YMAX) | |
30715 | IF(Y2(I).GT.EPS) THEN | |
30716 | IF(YMIN.EQ.EPS) THEN | |
30717 | YMIN = Y2(I) | |
30718 | ELSE | |
30719 | YMIN = MIN(Y2(I),YMIN) | |
30720 | ENDIF | |
30721 | ENDIF | |
30722 | 550 CONTINUE | |
30723 | ENDIF | |
30724 | C | |
30725 | DO 560 I=1,N | |
30726 | Y1(I) = MAX(Y1(I),YMIN) | |
30727 | 560 CONTINUE | |
30728 | IF(IARG.GT.1) THEN | |
30729 | DO 570 I=1,N | |
30730 | Y2(I) = MAX(Y2(I),YMIN) | |
30731 | 570 CONTINUE | |
30732 | ENDIF | |
30733 | C | |
30734 | IF(YMAX.LE.YMIN) THEN | |
30735 | WRITE(LOUT,'(/1X,A,2E12.3,/)') | |
30736 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX | |
30737 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' | |
30738 | RETURN | |
30739 | ENDIF | |
30740 | C | |
30741 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) | |
30742 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 | |
30743 | YZOOM=(YMA-YMI)/DBLE(IZEIL) | |
30744 | IF(YZOOM.LT.EPS) THEN | |
30745 | WRITE(LOUT,'(1X,A)') | |
30746 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30747 | RETURN | |
30748 | ENDIF | |
30749 | C | |
30750 | C*** plot curve Y1 | |
30751 | C | |
30752 | ILAST=-1 | |
30753 | LLAST=-1 | |
30754 | DO 1200 K=1,N | |
30755 | L=NINT((X(K)-XMIN)/XZOOM) | |
30756 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) | |
30757 | IF(ILAST.GE.0) THEN | |
30758 | LD = L-LLAST | |
30759 | ID = I-ILAST | |
30760 | DO 55 II=0,LD,SIGN(1,LD) | |
30761 | DO 66 KK=0,ID,SIGN(1,ID) | |
30762 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30763 | 66 CONTINUE | |
30764 | 55 CONTINUE | |
30765 | ELSE | |
30766 | COL(L,I)=SYMB(1) | |
30767 | ENDIF | |
30768 | ILAST = I | |
30769 | LLAST = L | |
30770 | 1200 CONTINUE | |
30771 | C | |
30772 | IF(IARG.GT.1) THEN | |
30773 | C | |
30774 | C*** plot curve Y2 | |
30775 | C | |
30776 | DO 1250 K=1,N | |
30777 | L=NINT((X(K)-XMIN)/XZOOM) | |
30778 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) | |
30779 | COL(L,I)=SYMB(2) | |
30780 | 1250 CONTINUE | |
30781 | ENDIF | |
30782 | C | |
30783 | C*** write it | |
30784 | C | |
30785 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' | |
30786 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30787 | C | |
30788 | C*** write range of X | |
30789 | C | |
30790 | XZOOM1 = (XMAX-XMIN)/DBLE(7) | |
30791 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30792 | C | |
30793 | DO 1300 K=0,IZEIL-1 | |
30794 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) | |
30795 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30796 | 110 FORMAT(1X,1PE9.2,70A1) | |
30797 | 1300 CONTINUE | |
30798 | C | |
30799 | C*** write range of X | |
30800 | C | |
30801 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30802 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30803 | 120 FORMAT(6X,7(1PE10.3)) | |
30804 | C | |
30805 | END | |
30806 | ||
30807 | *$ CREATE DT_SRPLOT.FOR | |
30808 | *COPY DT_SRPLOT | |
30809 | * | |
30810 | *===plot===============================================================* | |
30811 | * | |
30812 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) | |
30813 | ||
30814 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30815 | SAVE | |
30816 | ||
30817 | PARAMETER ( LINP = 10 , | |
30818 | & LOUT = 6 , | |
30819 | & LDAT = 9 ) | |
30820 | * | |
30821 | * initial version | |
30822 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) | |
30823 | * This is a subroutine of fluka to plot Y across the page | |
30824 | * as a function of X down the page. Up to 37 curves can be | |
30825 | * plotted in the same picture with different plotting characters. | |
30826 | * Output of first 10 overprinted characters addad by FB 88 | |
30827 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
30828 | * | |
30829 | * Input Variables: | |
30830 | * X = array containing the values of X | |
30831 | * Y = array containing the values of Y | |
30832 | * N = number of values in X and in Y | |
30833 | * can exceed the fixed number of lines | |
30834 | * M = number of different curves X,Y are containing | |
30835 | * MM = number of points in each curve i.e. N=M*MM | |
30836 | * XO = smallest value of X to be plotted | |
30837 | * DX = increment of X between subsequent lines | |
30838 | * YO = smallest value of Y to be plotted | |
30839 | * DY = increment of Y between subsequent character spaces | |
30840 | * | |
30841 | * other variables used inside: | |
30842 | * XX = numbers along the X-coordinate axis | |
30843 | * YY = numbers along the Y-coordinate axis | |
30844 | * LL = ten lines temporary storage for the plot | |
30845 | * L = character set used to plot different curves | |
30846 | * LOV = memorizes overprinted symbols | |
30847 | * the first 10 overprinted symbols are printed on | |
30848 | * the end of the line to avoid ambiguities | |
30849 | * (added by FB as considered quite helpful) | |
30850 | * | |
30851 | ********************************************************************* | |
30852 | * | |
30853 | DIMENSION XX(61),YY(61),LL(101,10) | |
30854 | DIMENSION X(N),Y(N),L(40),LOV(40,10) | |
333481d6 | 30855 | INTEGER*4 LL, L, LOV |
9aaba0d6 | 30856 | DATA L/ |
30857 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, | |
30858 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, | |
30859 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, | |
30860 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / | |
30861 | * | |
30862 | * | |
30863 | MN=51 | |
30864 | DO 10 I=1,MN | |
30865 | AI=I-1 | |
30866 | 10 XX(I)=XO+AI*DX | |
30867 | DO 20 I=1,11 | |
30868 | AI=I-1 | |
30869 | 20 YY(I)=YO+10.0D0*AI*DY | |
30870 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30871 | MMN=MN-1 | |
30872 | * | |
30873 | * | |
30874 | DO 90 JJ=1,MMN,10 | |
30875 | JJJ=JJ-1 | |
30876 | DO 30 I=1,101 | |
30877 | DO 30 J=1,10 | |
30878 | 30 LL(I,J)=L(40) | |
30879 | DO 40 I=1,101 | |
30880 | 40 LL(I,1)=L(39) | |
30881 | DO 50 I=1,101,10 | |
30882 | DO 50 J=1,10 | |
30883 | 50 LL(I,J)=L(38) | |
30884 | DO 60 I=1,40 | |
30885 | DO 60 J=1,10 | |
30886 | 60 LOV(I,J)=L(40) | |
30887 | * | |
30888 | * | |
30889 | DO 70 I=1,M | |
30890 | DO 70 J=1,MM | |
30891 | II=J+(I-1)*MM | |
30892 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 | |
30893 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 | |
30894 | AIX=AIX-DBLE(JJJ) | |
30895 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW | |
30896 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND | |
30897 | + . AIY .LT. 102.D0) THEN | |
30898 | IX=INT(AIX) | |
30899 | IY=INT(AIY) | |
30900 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) | |
30901 | + THEN | |
30902 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) | |
30903 | + =LL(IY,IX) | |
30904 | LL(IY,IX)=L(I) | |
30905 | ENDIF | |
30906 | ENDIF | |
30907 | 70 CONTINUE | |
30908 | * | |
30909 | * | |
30910 | DO 80 I=1,10 | |
30911 | II=I+JJJ | |
30912 | III=II+1 | |
30913 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , | |
30914 | & (LOV(J,I),J=1,10) | |
30915 | 80 CONTINUE | |
30916 | 90 CONTINUE | |
30917 | * | |
30918 | * | |
30919 | WRITE(LOUT, 520) | |
30920 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30921 | RETURN | |
30922 | * | |
30923 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) | |
30924 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) | |
30925 | 520 FORMAT(20X,10('1---------'),'1') | |
30926 | END | |
30927 | ||
30928 | *$ CREATE DT_DEFSET.FOR | |
30929 | *COPY DT_DEFSET | |
30930 | * | |
30931 | *===defset=============================================================* | |
30932 | * | |
30933 | BLOCK DATA DT_DEFSET | |
30934 | ||
30935 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30936 | SAVE | |
30937 | ||
30938 | * flags for input different options | |
30939 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
30940 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
30941 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
30942 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
30943 | * emulsion treatment | |
30944 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
30945 | & NCOMPO,IEMUL | |
30946 | ||
30947 | * / DTFLG1 / | |
30948 | DATA IFRAG / 2, 1 / | |
30949 | DATA IRESCO / 1 / | |
30950 | DATA IMSHL / 1 / | |
30951 | DATA IRESRJ / 0 / | |
30952 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / | |
30953 | DATA LEMCCK / .FALSE. / | |
30954 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., | |
30955 | & .TRUE.,.TRUE.,.TRUE./ | |
30956 | DATA LSEADI / .TRUE. / | |
30957 | DATA LEVAPO / .TRUE. / | |
30958 | DATA IFRAME / 1 / | |
30959 | DATA ITRSPT / 0 / | |
30960 | ||
30961 | * / DTCOMP / | |
30962 | DATA EMUFRA / NCOMPX*0.0D0 / | |
30963 | DATA IEMUMA / NCOMPX*1 / | |
30964 | DATA IEMUCH / NCOMPX*1 / | |
30965 | DATA NCOMPO / 0 / | |
30966 | DATA IEMUL / 0 / | |
30967 | ||
30968 | END | |
30969 | ||
30970 | *$ CREATE DT_HADPRP.FOR | |
30971 | *COPY DT_HADPRP | |
30972 | * | |
30973 | *===hadprp=============================================================* | |
30974 | * | |
30975 | BLOCK DATA DT_HADPRP | |
30976 | ||
30977 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30978 | SAVE | |
30979 | ||
30980 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
30981 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
30982 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
30983 | & IQTCHR(-6:6),MQUARK(3,39) | |
30984 | * hadron index conversion (BAMJET <--> PDG) | |
30985 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
30986 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
30987 | & IAMCIN(210) | |
30988 | * names of hadrons used in input-cards | |
30989 | CHARACTER*8 BTYPE | |
30990 | COMMON /DTPAIN/ BTYPE(30) | |
30991 | ||
30992 | * / DTQUAR / | |
30993 | *----------------------------------------------------------------------* | |
30994 | * * | |
30995 | * Quark content of particles: * | |
30996 | * index quark el. charge bar. charge isospin isospin3 * | |
30997 | * 1 = u 2/3 1/3 1/2 1/2 * | |
30998 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * | |
30999 | * 2 = d -1/3 1/3 1/2 -1/2 * | |
31000 | * -2 = dbar 1/3 -1/3 1/2 1/2 * | |
31001 | * 3 = s -1/3 1/3 0 0 * | |
31002 | * -3 = sbar 1/3 -1/3 0 0 * | |
31003 | * 4 = c 2/3 1/3 0 0 * | |
31004 | * -4 = cbar -2/3 -1/3 0 0 * | |
31005 | * 5 = b -1/3 1/3 0 0 * | |
31006 | * -5 = bbar 1/3 -1/3 0 0 * | |
31007 | * 6 = t 2/3 1/3 0 0 * | |
31008 | * -6 = tbar -2/3 -1/3 0 0 * | |
31009 | * * | |
31010 | * Mquark = particle quark composition (Paprop numbering) * | |
31011 | * Iqechr = electric charge ( in 1/3 unit ) * | |
31012 | * Iqbchr = baryonic charge ( in 1/3 unit ) * | |
31013 | * Iqichr = isospin ( in 1/2 unit ), z component * | |
31014 | * Iqschr = strangeness * | |
31015 | * Iqcchr = charm * | |
31016 | * Iquchr = beauty * | |
31017 | * Iqtchr = ...... * | |
31018 | * * | |
31019 | *----------------------------------------------------------------------* | |
31020 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / | |
31021 | DATA IQBCHR / 6*-1, 0, 6*1 / | |
31022 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / | |
31023 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / | |
31024 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / | |
31025 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / | |
31026 | DATA IQTCHR / -1, 11*0, 1 / | |
31027 | DATA MQUARK / | |
31028 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31029 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, | |
31030 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, | |
31031 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, | |
31032 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, | |
31033 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31034 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, | |
31035 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / | |
31036 | ||
31037 | * / DTHAIC / | |
31038 | * (renamed) (HAdron InDex COnversion) | |
31039 | * translation table version filled up by r.e. 25.01.94 * | |
31040 | DATA IAMCIN / | |
31041 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, | |
31042 | &13,130,211,-211,321, -321,3122,-3122,310,3112, | |
31043 | &3222,3212,111,311,-311, 0,0,0,0,0, | |
31044 | &221,213,113,-213,223, 323,313,-323,-313,10323, | |
31045 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, | |
31046 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, | |
31047 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, | |
31048 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, | |
31049 | &5*99999, 5*99999, | |
31050 | &4*99999,331, 333,3322,3312,-3222,-3212, | |
31051 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, | |
31052 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, | |
31053 | &-431,441,423,413,-413, -423,433,-433,20443,443, | |
31054 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, | |
31055 | &4212,4112,3*99999, 3*99999,-4122,-4232, | |
31056 | &-4132,-4222,-4212,-4112,99999, 5*99999, | |
31057 | &5*99999, 5*99999, | |
31058 | &10*99999, | |
31059 | &5*99999 , 20211,20111,-20211,99999,20321, | |
31060 | &-20321,20311,-20311,7*99999 , | |
31061 | &7*99999,12212,12112,99999/ | |
31062 | ||
31063 | * / DTHAIC / | |
31064 | * (HAdron InDex COnversion) | |
31065 | DATA (IPDG2(1,K),K=1,7) | |
31066 | & / -11, -12, -13, -15, -16, -14, 0/ | |
31067 | DATA (IBAM2(1,K),K=1,7) | |
31068 | & / 4, 6, 10, 131, 134, 136, 0/ | |
31069 | DATA (IPDG2(2,K),K=1,7) | |
31070 | & / 11, 12, 22, 13, 15, 16, 14/ | |
31071 | DATA (IBAM2(2,K),K=1,7) | |
31072 | & / 3, 5, 7, 11, 132, 133, 135/ | |
31073 | DATA (IPDG3(1,K),K=1,22) | |
31074 | & / -211, -321, -311, -213, -323, -313, -411, -421, | |
31075 | & -431, -413, -423, -433, 0, 0, 0, 0, | |
31076 | & 0, 0, 0, 0, 0, 0/ | |
31077 | DATA (IBAM3(1,K),K=1,22) | |
31078 | & / 14, 16, 25, 34, 38, 39, 118, 119, | |
31079 | & 121, 125, 126, 128, 0, 0, 0, 0, | |
31080 | & 0, 0, 0, 0, 0, 0/ | |
31081 | DATA (IPDG3(2,K),K=1,22) | |
31082 | & / 130, 211, 321, 310, 111, 311, 221, 213, | |
31083 | & 113, 223, 323, 313, 331, 333, 421, 411, | |
31084 | & 431, 441, 423, 413, 433, 443/ | |
31085 | DATA (IBAM3(2,K),K=1,22) | |
31086 | & / 12, 13, 15, 19, 23, 24, 31, 32, | |
31087 | & 33, 35, 36, 37, 95, 96, 116, 117, | |
31088 | & 120, 122, 123, 124, 127, 130/ | |
31089 | DATA (IPDG4(1,K),K=1,29) | |
31090 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, | |
31091 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, | |
31092 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, | |
31093 | & -4212, -4112, 0, 0, 0/ | |
31094 | DATA (IBAM4(1,K),K=1,29) | |
31095 | & / 2, 9, 18, 67, 68, 69, 70, 75, | |
31096 | & 76, 99, 100, 101, 102, 103, 110, 111, | |
31097 | & 112, 113, 114, 115, 149, 150, 151, 152, | |
31098 | & 153, 154, 0, 0, 0/ | |
31099 | DATA (IPDG4(2,K),K=1,29) | |
31100 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, | |
31101 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, | |
31102 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, | |
31103 | & 4232, 4132, 4222, 4212, 4112/ | |
31104 | DATA (IBAM4(2,K),K=1,29) | |
31105 | & / 1, 8, 17, 20, 21, 22, 48, 49, | |
31106 | & 50, 51, 52, 53, 54, 55, 56, 97, | |
31107 | & 98, 104, 105, 106, 107, 108, 109, 137, | |
31108 | & 138, 139, 140, 141, 142/ | |
31109 | DATA (IPDG5(1,K),K=1,19) | |
31110 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, | |
31111 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, | |
31112 | & 0, 0, 0/ | |
31113 | DATA (IBAM5(1,K),K=1,19) | |
31114 | & / 42, 43, 46, 47, 71, 72, 73, 74, | |
31115 | & 188, 191, 193, 0, 0, 0, 0, 0, | |
31116 | & 0, 0, 0/ | |
31117 | DATA (IPDG5(2,K),K=1,19) | |
31118 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, | |
31119 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, | |
31120 | & 20311, 12212, 12112/ | |
31121 | DATA (IBAM5(2,K),K=1,19) | |
31122 | & / 40, 41, 44, 45, 57, 58, 59, 60, | |
31123 | & 63, 64, 65, 66, 129, 186, 187, 190, | |
31124 | & 192, 208, 209/ | |
31125 | ||
31126 | * / DTPAIN / | |
31127 | * internal particle names | |
31128 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , | |
31129 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , | |
31130 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , | |
31131 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , | |
31132 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , | |
31133 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , | |
31134 | &'BLANK ' / | |
31135 | ||
31136 | END | |
31137 | ||
31138 | *$ CREATE DT_BLKD46.FOR | |
31139 | *COPY DT_BLKD46 | |
31140 | * | |
31141 | *===blkd46=============================================================* | |
31142 | * | |
31143 | BLOCK DATA DT_BLKD46 | |
31144 | ||
31145 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31146 | SAVE | |
31147 | ||
31148 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31149 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31150 | ||
31151 | * particle properties (BAMJET index convention) | |
31152 | CHARACTER*8 ANAME | |
31153 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
31154 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
31155 | ||
31156 | * / DTPART / | |
31157 | * Particle masses Engel version JETSET compatible | |
31158 | C DATA (AAM(K),K=1,85) / | |
31159 | C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, | |
31160 | C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , | |
31161 | C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, | |
31162 | C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, | |
31163 | C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, | |
31164 | C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31165 | C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, | |
31166 | C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, | |
31167 | C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, | |
31168 | C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, | |
31169 | C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31170 | C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31171 | C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31172 | C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31173 | C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31174 | C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31175 | C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31176 | C DATA (AAM(K),K=86,183) / | |
31177 | C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31178 | C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, | |
31179 | C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, | |
31180 | C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, | |
31181 | C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, | |
31182 | C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, | |
31183 | C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, | |
31184 | C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, | |
31185 | C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, | |
31186 | C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, | |
31187 | C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, | |
31188 | C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, | |
31189 | C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, | |
31190 | C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, | |
31191 | C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31192 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31193 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31194 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31195 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31196 | C & .1250D+01, .1250D+01, .1250D+01 / | |
31197 | C DATA (AAM ( I ), I = 184,210 ) / | |
31198 | C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31199 | C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31200 | C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31201 | C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31202 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31203 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31204 | C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31205 | C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31206 | C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31207 | * sr 25.1.06: particle masses adjusted to Pythia | |
31208 | DATA (AAM(K),K=1,85) / | |
31209 | & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00, | |
31210 | & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON , | |
31211 | & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00, | |
31212 | & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01, | |
31213 | & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00, | |
31214 | & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00, | |
31215 | & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00, | |
31216 | & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01, | |
31217 | & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01, | |
31218 | & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01, | |
31219 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31220 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31221 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31222 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31223 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31224 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31225 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31226 | DATA (AAM(K),K=86,183) / | |
31227 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31228 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00, | |
31229 | & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01, | |
31230 | & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01, | |
31231 | & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01, | |
31232 | & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01, | |
31233 | & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01, | |
31234 | & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01, | |
31235 | & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01, | |
31236 | & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00, | |
31237 | & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01, | |
31238 | & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01, | |
31239 | & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01, | |
31240 | & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01, | |
31241 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31242 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31243 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31244 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31245 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31246 | & .1250D+01, .1250D+01, .1250D+01 / | |
31247 | DATA (AAM ( I ), I = 184,210 ) / | |
31248 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31249 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31250 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31251 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31252 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31253 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31254 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31255 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31256 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31257 | * Particle mean lives | |
31258 | DATA (TAU(K),K=1,183) / | |
31259 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, | |
31260 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, | |
31261 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, | |
31262 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, | |
31263 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, | |
31264 | & 70*.0000D+00, | |
31265 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, | |
31266 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, | |
31267 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, | |
31268 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, | |
31269 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31270 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31271 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31272 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, | |
31273 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31274 | & 40*.0000D+00, | |
31275 | & .0000D+00, .0000D+00, .0000D+00 / | |
31276 | DATA ( TAU ( I ), I = 184,210 ) / | |
31277 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31278 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31279 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31280 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31281 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31282 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31283 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31284 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31285 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ | |
31286 | * Resonance width Gamma in GeV | |
31287 | DATA (GA(K),K= 1,85) / | |
31288 | & 30*.0000D+00, | |
31289 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, | |
31290 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, | |
31291 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, | |
31292 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, | |
31293 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, | |
31294 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, | |
31295 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, | |
31296 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, | |
31297 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, | |
31298 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, | |
31299 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / | |
31300 | DATA (GA(K),K= 86,183) / | |
31301 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, | |
31302 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, | |
31303 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31304 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, | |
31305 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, | |
31306 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, | |
31307 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31308 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, | |
31309 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, | |
31310 | & 50*.0000D+00, | |
31311 | & .3000D+00, .3000D+00, .3000D+00 / | |
31312 | DATA ( GA ( I ), I = 184,210 ) / | |
31313 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, | |
31314 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, | |
31315 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, | |
31316 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, | |
31317 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31318 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31319 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, | |
31320 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, | |
31321 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ | |
31322 | * Particle names | |
31323 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) | |
31324 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on | |
31325 | * designation N*@@ means N*@1(@2) | |
31326 | DATA (ANAME(K),K=1,85) / | |
31327 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31328 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', | |
31329 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', | |
31330 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', | |
31331 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', | |
31332 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', | |
31333 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', | |
31334 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', | |
31335 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', | |
31336 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', | |
31337 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', | |
31338 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', | |
31339 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', | |
31340 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', | |
31341 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', | |
31342 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', | |
31343 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / | |
31344 | DATA (ANAME(K),K=86,183) / | |
31345 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', | |
31346 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', | |
31347 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', | |
31348 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', | |
31349 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', | |
31350 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', | |
31351 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', | |
31352 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', | |
31353 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', | |
31354 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', | |
31355 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', | |
31356 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', | |
31357 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', | |
31358 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', | |
31359 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', | |
31360 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', | |
31361 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', | |
31362 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', | |
31363 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', | |
31364 | & 'RO ','R+ ','R- ' / | |
31365 | DATA ( ANAME ( I ), I = 184,210 ) / | |
31366 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', | |
31367 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', | |
31368 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', | |
31369 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', | |
31370 | &'N*+14 ','N*014 ','BLANK '/ | |
31371 | * Charge of particles and resonances | |
31372 | DATA (IICH ( I ), I = 1,210 ) / | |
31373 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, | |
31374 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31375 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, | |
31376 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, | |
31377 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, | |
31378 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, | |
31379 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, | |
31380 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, | |
31381 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, | |
31382 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, | |
31383 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, | |
31384 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, | |
31385 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, | |
31386 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ | |
31387 | * Particle baryonic charges | |
31388 | DATA (IIBAR ( I ), I = 1,210 ) / | |
31389 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, | |
31390 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, | |
31391 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31392 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, | |
31393 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31394 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, | |
31395 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, | |
31396 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, | |
31397 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31398 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, | |
31399 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, | |
31400 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31401 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, | |
31402 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ | |
31403 | * First number of decay channels used for resonances | |
31404 | * and decaying particles | |
31405 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, | |
31406 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, | |
31407 | & 2*330, 46, 51, 52, 54, 55, 58, | |
31408 | * 50 | |
31409 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, | |
31410 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, | |
31411 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, | |
31412 | * 85 | |
31413 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, | |
31414 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, | |
31415 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, | |
31416 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, | |
31417 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, | |
31418 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, | |
31419 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, | |
31420 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, | |
31421 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, | |
31422 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, | |
31423 | & 590, 596, 602 / | |
31424 | * Last number of decay channels used for resonances | |
31425 | * and decaying particles | |
31426 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, | |
31427 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, | |
31428 | & 2* 330, 50, 51, 53, 54, 57, | |
31429 | * 50 | |
31430 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, | |
31431 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, | |
31432 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, | |
31433 | * 85 | |
31434 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, | |
31435 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, | |
31436 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, | |
31437 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, | |
31438 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, | |
31439 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, | |
31440 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, | |
31441 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, | |
31442 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, | |
31443 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, | |
31444 | & 589, 595, 601, 602 / | |
31445 | ||
31446 | END | |
31447 | ||
31448 | *$ CREATE DT_BLKD47.FOR | |
31449 | *COPY DT_BLKD47 | |
31450 | * | |
31451 | *===blkd47=============================================================* | |
31452 | * | |
31453 | BLOCK DATA DT_BLKD47 | |
31454 | ||
31455 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31456 | SAVE | |
31457 | ||
31458 | * HADRIN: decay channel information | |
31459 | PARAMETER (IDMAX9=602) | |
31460 | CHARACTER*8 ZKNAME | |
31461 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
31462 | ||
31463 | * Name of decay channel | |
31464 | * Designation N*@ means N*@1(1236) | |
31465 | * @1=# means ++, @1 = = means -- | |
31466 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively | |
31467 | DATA (ZKNAME(K),K= 1, 85) / | |
31468 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31469 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', | |
31470 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', | |
31471 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', | |
31472 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', | |
31473 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', | |
31474 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', | |
31475 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', | |
31476 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', | |
31477 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', | |
31478 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', | |
31479 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', | |
31480 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', | |
31481 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', | |
31482 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', | |
31483 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', | |
31484 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / | |
31485 | DATA (ZKNAME(K),K= 86,170) / | |
31486 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', | |
31487 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', | |
31488 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', | |
31489 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', | |
31490 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', | |
31491 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', | |
31492 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', | |
31493 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', | |
31494 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', | |
31495 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', | |
31496 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', | |
31497 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', | |
31498 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', | |
31499 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31500 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31501 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', | |
31502 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / | |
31503 | DATA (ZKNAME(K),K=171,255) / | |
31504 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', | |
31505 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', | |
31506 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31507 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31508 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', | |
31509 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', | |
31510 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', | |
31511 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', | |
31512 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', | |
31513 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', | |
31514 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', | |
31515 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', | |
31516 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', | |
31517 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', | |
31518 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', | |
31519 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', | |
31520 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / | |
31521 | DATA (ZKNAME(K),K=256,340) / | |
31522 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', | |
31523 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', | |
31524 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', | |
31525 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', | |
31526 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', | |
31527 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', | |
31528 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', | |
31529 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', | |
31530 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', | |
31531 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', | |
31532 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', | |
31533 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31534 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31535 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31536 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31537 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', | |
31538 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / | |
31539 | DATA (ZKNAME(K),K=341,425) / | |
31540 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', | |
31541 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', | |
31542 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', | |
31543 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', | |
31544 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', | |
31545 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', | |
31546 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', | |
31547 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', | |
31548 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', | |
31549 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', | |
31550 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', | |
31551 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', | |
31552 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', | |
31553 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', | |
31554 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', | |
31555 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', | |
31556 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / | |
31557 | DATA (ZKNAME(K),K=426,510) / | |
31558 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', | |
31559 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', | |
31560 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', | |
31561 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', | |
31562 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', | |
31563 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', | |
31564 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', | |
31565 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', | |
31566 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', | |
31567 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', | |
31568 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', | |
31569 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', | |
31570 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', | |
31571 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', | |
31572 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', | |
31573 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', | |
31574 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / | |
31575 | DATA (ZKNAME(K),K=511,540) / | |
31576 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', | |
31577 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', | |
31578 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', | |
31579 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', | |
31580 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', | |
31581 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / | |
31582 | DATA (ZKNAME(I),I=541,602)/ | |
31583 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', | |
31584 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', | |
31585 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', | |
31586 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', | |
31587 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', | |
31588 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', | |
31589 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', | |
31590 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', | |
31591 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ | |
31592 | * Weight of decay channel | |
31593 | DATA (WT(K),K= 1, 85) / | |
31594 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31595 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31596 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, | |
31597 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, | |
31598 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, | |
31599 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, | |
31600 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, | |
31601 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, | |
31602 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, | |
31603 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, | |
31604 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, | |
31605 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, | |
31606 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, | |
31607 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, | |
31608 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, | |
31609 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, | |
31610 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / | |
31611 | DATA (WT(K),K= 86,170) / | |
31612 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, | |
31613 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, | |
31614 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, | |
31615 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, | |
31616 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, | |
31617 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, | |
31618 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, | |
31619 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, | |
31620 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, | |
31621 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, | |
31622 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, | |
31623 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31624 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31625 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31626 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31627 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31628 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / | |
31629 | DATA (WT(K),K=171,255) / | |
31630 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, | |
31631 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, | |
31632 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, | |
31633 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, | |
31634 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, | |
31635 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, | |
31636 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, | |
31637 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, | |
31638 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31639 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31640 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31641 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31642 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31643 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, | |
31644 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, | |
31645 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, | |
31646 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / | |
31647 | DATA (WT(K),K=256,340) / | |
31648 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, | |
31649 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, | |
31650 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, | |
31651 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, | |
31652 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, | |
31653 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, | |
31654 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, | |
31655 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, | |
31656 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, | |
31657 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, | |
31658 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, | |
31659 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31660 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31661 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31662 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31663 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, | |
31664 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / | |
31665 | DATA (WT(K),K=341,425) / | |
31666 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, | |
31667 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, | |
31668 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, | |
31669 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, | |
31670 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, | |
31671 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, | |
31672 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, | |
31673 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, | |
31674 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, | |
31675 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, | |
31676 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, | |
31677 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, | |
31678 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, | |
31679 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, | |
31680 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, | |
31681 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, | |
31682 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / | |
31683 | DATA (WT(K),K=426,510) / | |
31684 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, | |
31685 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, | |
31686 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, | |
31687 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, | |
31688 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, | |
31689 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, | |
31690 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31691 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, | |
31692 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, | |
31693 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, | |
31694 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, | |
31695 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, | |
31696 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, | |
31697 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, | |
31698 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, | |
31699 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, | |
31700 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / | |
31701 | DATA (WT(K),K=511,540) / | |
31702 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31703 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, | |
31704 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31705 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31706 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, | |
31707 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / | |
31708 | C | |
31709 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, | |
31710 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, | |
31711 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, | |
31712 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, | |
31713 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, | |
31714 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, | |
31715 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / | |
31716 | * Particle numbers in decay channel | |
31717 | DATA (NZK(K,1),K= 1,170) / | |
31718 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, | |
31719 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, | |
31720 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, | |
31721 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, | |
31722 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, | |
31723 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, | |
31724 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, | |
31725 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, | |
31726 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, | |
31727 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, | |
31728 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, | |
31729 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, | |
31730 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, | |
31731 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, | |
31732 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, | |
31733 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31734 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / | |
31735 | DATA (NZK(K,1),K=171,340) / | |
31736 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, | |
31737 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31738 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, | |
31739 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, | |
31740 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, | |
31741 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, | |
31742 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, | |
31743 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, | |
31744 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, | |
31745 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, | |
31746 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, | |
31747 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, | |
31748 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, | |
31749 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, | |
31750 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31751 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31752 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / | |
31753 | DATA (NZK(K,1),K=341,510) / | |
31754 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, | |
31755 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, | |
31756 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, | |
31757 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, | |
31758 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, | |
31759 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, | |
31760 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, | |
31761 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, | |
31762 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, | |
31763 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, | |
31764 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, | |
31765 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, | |
31766 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, | |
31767 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, | |
31768 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, | |
31769 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, | |
31770 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / | |
31771 | DATA (NZK(K,1),K=511,540) / | |
31772 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, | |
31773 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, | |
31774 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / | |
31775 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, | |
31776 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, | |
31777 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, | |
31778 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, | |
31779 | & 55, 8, 1, 8, 8, 54, 55, 210/ | |
31780 | DATA (NZK(K,2),K= 1,170) / | |
31781 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, | |
31782 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, | |
31783 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, | |
31784 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, | |
31785 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, | |
31786 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, | |
31787 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, | |
31788 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, | |
31789 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, | |
31790 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, | |
31791 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, | |
31792 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, | |
31793 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, | |
31794 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, | |
31795 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, | |
31796 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31797 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / | |
31798 | DATA (NZK(K,2),K=171,340) / | |
31799 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, | |
31800 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31801 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, | |
31802 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, | |
31803 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, | |
31804 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, | |
31805 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, | |
31806 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, | |
31807 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, | |
31808 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, | |
31809 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, | |
31810 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, | |
31811 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, | |
31812 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, | |
31813 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31814 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31815 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / | |
31816 | DATA (NZK(K,2),K=341,510) / | |
31817 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, | |
31818 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, | |
31819 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, | |
31820 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, | |
31821 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, | |
31822 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, | |
31823 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, | |
31824 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, | |
31825 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, | |
31826 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, | |
31827 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, | |
31828 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, | |
31829 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, | |
31830 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, | |
31831 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, | |
31832 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, | |
31833 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / | |
31834 | DATA (NZK(K,2),K=511,540) / | |
31835 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, | |
31836 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, | |
31837 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / | |
31838 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, | |
31839 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, | |
31840 | & 14, 14, 23, 14, 16, 25, | |
31841 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, | |
31842 | & 23, 13, 14, 23, 0 / | |
31843 | DATA (NZK(K,3),K= 1,170) / | |
31844 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, | |
31845 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, | |
31846 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, | |
31847 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, | |
31848 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, | |
31849 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, | |
31850 | & 110*0 / | |
31851 | DATA (NZK(K,3),K=171,340) / | |
31852 | & 80*0, | |
31853 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, | |
31854 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, | |
31855 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, | |
31856 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, | |
31857 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, | |
31858 | & 30*0, | |
31859 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / | |
31860 | DATA (NZK(K,3),K=341,510) / | |
31861 | & 30*0, | |
31862 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, | |
31863 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, | |
31864 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, | |
31865 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31866 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, | |
31867 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, | |
31868 | & 80*0 / | |
31869 | DATA (NZK(K,3),K=511,540) / | |
31870 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, | |
31871 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31872 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / | |
31873 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, | |
31874 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ | |
31875 | ||
31876 | END | |
31877 | ||
31878 | *$ CREATE DT_BDEVAP.FOR | |
31879 | *COPY DT_BDEVAP | |
31880 | * | |
31881 | *=== bdevap ===========================================================* | |
31882 | * | |
31883 | BLOCK DATA DT_BDEVAP | |
31884 | ||
31885 | C INCLUDE '(DBLPRC)' | |
31886 | * DBLPRC.ADD | |
31887 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31888 | SAVE | |
31889 | * (original name: GLOBAL) | |
31890 | PARAMETER ( KALGNM = 2 ) | |
31891 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
31892 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
31893 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
31894 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
31895 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
31896 | PARAMETER ( AINFNT = 1.0D+30 ) | |
31897 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
31898 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
31899 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
31900 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
31901 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
31902 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
31903 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
31904 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
31905 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
31906 | PARAMETER ( ZERZER = 0.D+00 ) | |
31907 | PARAMETER ( ONEONE = 1.D+00 ) | |
31908 | PARAMETER ( TWOTWO = 2.D+00 ) | |
31909 | PARAMETER ( THRTHR = 3.D+00 ) | |
31910 | PARAMETER ( FOUFOU = 4.D+00 ) | |
31911 | PARAMETER ( FIVFIV = 5.D+00 ) | |
31912 | PARAMETER ( SIXSIX = 6.D+00 ) | |
31913 | PARAMETER ( SEVSEV = 7.D+00 ) | |
31914 | PARAMETER ( EIGEIG = 8.D+00 ) | |
31915 | PARAMETER ( ANINEN = 9.D+00 ) | |
31916 | PARAMETER ( TENTEN = 10.D+00 ) | |
31917 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
31918 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
31919 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
31920 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
31921 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
31922 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
31923 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
31924 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
31925 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
31926 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
31927 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
31928 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
31929 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
31930 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
31931 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
31932 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
31933 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
31934 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
31935 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
31936 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
31937 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
31938 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
31939 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
31940 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
31941 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
31942 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
31943 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
31944 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
31945 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
31946 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
31947 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
31948 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
31949 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
31950 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
31951 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
31952 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
31953 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
31954 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
31955 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
31956 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
31957 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31958 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
31959 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31960 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
31961 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
31962 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
31963 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
31964 | & * 1.D-09 ) | |
31965 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
31966 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
31967 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
31968 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
31969 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
31970 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
31971 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
31972 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
31973 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
31974 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
31975 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
31976 | LOGICAL LGBIAS, LGBANA | |
31977 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
31978 | C INCLUDE '(DIMPAR)' | |
31979 | * DIMPAR.ADD | |
31980 | PARAMETER ( MXXRGN = 5000 ) | |
31981 | PARAMETER ( MXXMDF = 82 ) | |
31982 | PARAMETER ( MXXMDE = 54 ) | |
31983 | PARAMETER ( MFSTCK = 1000 ) | |
31984 | PARAMETER ( MESTCK = 100 ) | |
31985 | PARAMETER ( NELEMX = 80 ) | |
31986 | PARAMETER ( MPDPDX = 8 ) | |
31987 | PARAMETER ( ICOMAX = 180 ) | |
31988 | PARAMETER ( NSTBIS = 304 ) | |
31989 | PARAMETER ( IDMAXP = 220 ) | |
31990 | PARAMETER ( IDMXDC = 640 ) | |
31991 | PARAMETER ( MKBMX1 = 1 ) | |
31992 | PARAMETER ( MKBMX2 = 1 ) | |
31993 | C INCLUDE '(IOUNIT)' | |
31994 | * IOUNIT.ADD | |
31995 | PARAMETER ( LUNIN = 5 ) | |
31996 | PARAMETER ( LUNOUT = 6 ) | |
31997 | **sr 19.5. set error output-unit from 15 to 6 | |
31998 | PARAMETER ( LUNERR = 6 ) | |
31999 | PARAMETER ( LUNBER = 14 ) | |
32000 | PARAMETER ( LUNECH = 8 ) | |
32001 | PARAMETER ( LUNFLU = 13 ) | |
32002 | PARAMETER ( LUNGEO = 16 ) | |
32003 | PARAMETER ( LUNPMF = 12 ) | |
32004 | PARAMETER ( LUNRAN = 2 ) | |
32005 | PARAMETER ( LUNXSC = 9 ) | |
32006 | PARAMETER ( LUNDET = 17 ) | |
32007 | PARAMETER ( LUNRAY = 10 ) | |
32008 | PARAMETER ( LUNRDB = 1 ) | |
32009 | PARAMETER ( LUNPGO = 7 ) | |
32010 | PARAMETER ( LUNPGS = 4 ) | |
32011 | PARAMETER ( LUNSCR = 3 ) | |
32012 | * | |
32013 | *----------------------------------------------------------------------* | |
32014 | * * | |
32015 | * Block Data for the EVAPoration routines: * | |
32016 | * * | |
32017 | * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala * | |
32018 | * Infn - Milan * | |
32019 | * * | |
32020 | * Modified from the original version of J.M.Zazula * | |
32021 | * and, for cookcm, from a LAHET block data kindly provided by * | |
32022 | * R.E.Prael-LANL * | |
32023 | * * | |
32024 | * Last change on 20-feb-95 by Alfredo Ferrari * | |
32025 | * * | |
32026 | * * | |
32027 | *----------------------------------------------------------------------* | |
32028 | * | |
32029 | * (original name: COOKCM) | |
32030 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
32031 | LOGICAL LDEFOZ, LDEFON | |
32032 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
32033 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
32034 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
32035 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
32036 | * (original name: EVA0) | |
32037 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
32038 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
32039 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
32040 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
32041 | * APRIME (250), IA (6), IZ (6) | |
32042 | * (original name: HETTP) | |
32043 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
32044 | * (original name: HETC7) | |
32045 | COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI | |
32046 | * (original name: INPFLG) | |
32047 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
32048 | * | |
32049 | DATA B0 / 8.D+00 /, Y0 / 1.5D+00 / | |
32050 | DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 / | |
32051 | DATA ISTRAG /0/, KEYDK /0/ | |
32052 | DATA NBERTP /LUNBER/ | |
32053 | DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/, | |
32054 | & SINPHI/ZERZER/ | |
32055 | * /cookcm/ | |
32056 | DATA ( PZCOOK(I),I = 1, IZCOOK ) / | |
32057 | & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00, | |
32058 | & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00, | |
32059 | & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00, | |
32060 | & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00, | |
32061 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01, | |
32062 | & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00, | |
32063 | & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00, | |
32064 | & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00, | |
32065 | & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00, | |
32066 | & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00, | |
32067 | &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01, | |
32068 | & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01, | |
32069 | & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01, | |
32070 | & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01, | |
32071 | & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01, | |
32072 | &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01, | |
32073 | & 0.000D+00, 7.700D-01/ | |
32074 | DATA ( PNCOOK(I),I = 1, 90 ) / | |
32075 | & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00, | |
32076 | & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00, | |
32077 | & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00, | |
32078 | & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00, | |
32079 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00, | |
32080 | & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00, | |
32081 | &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00, | |
32082 | & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00, | |
32083 | & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00, | |
32084 | & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00, | |
32085 | &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00, | |
32086 | &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00, | |
32087 | &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01, | |
32088 | &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00, | |
32089 | &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/ | |
32090 | DATA ( PNCOOK(I),I = 91, INCOOK ) / | |
32091 | &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01, | |
32092 | &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00, | |
32093 | & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01, | |
32094 | & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00, | |
32095 | &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01, | |
32096 | & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01, | |
32097 | & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01, | |
32098 | & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01, | |
32099 | & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01, | |
32100 | & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/ | |
32101 | DATA ( SZCOOK(I),I = 1, 98) / | |
32102 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32103 | & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00, | |
32104 | &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01, | |
32105 | &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01, | |
32106 | &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01, | |
32107 | &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01, | |
32108 | &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01, | |
32109 | &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01, | |
32110 | &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01, | |
32111 | &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01, | |
32112 | &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00, | |
32113 | &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00, | |
32114 | &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00, | |
32115 | &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00, | |
32116 | &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00, | |
32117 | &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00, | |
32118 | &-7.200D+00,-7.740D+00/ | |
32119 | DATA ( SNCOOK(I),I = 1, 90 ) / | |
32120 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32121 | & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00, | |
32122 | & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00, | |
32123 | & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01, | |
32124 | & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01, | |
32125 | & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01, | |
32126 | & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01, | |
32127 | & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01, | |
32128 | & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01, | |
32129 | & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01, | |
32130 | & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01, | |
32131 | & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01, | |
32132 | & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01, | |
32133 | & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00, | |
32134 | & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/ | |
32135 | DATA ( SNCOOK(I),I = 91, INCOOK ) / | |
32136 | & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01, | |
32137 | & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00, | |
32138 | & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00, | |
32139 | & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00, | |
32140 | & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00, | |
32141 | & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00, | |
32142 | &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00, | |
32143 | & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00, | |
32144 | & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00, | |
32145 | & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/ | |
32146 | DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. / | |
32147 | DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. / | |
32148 | *=== End of Block Data Bdevap =========================================* | |
32149 | END | |
32150 | ||
32151 | *$ CREATE DT_BDNOPT.FOR | |
32152 | *COPY DT_BDNOPT | |
32153 | * | |
32154 | *=== bdnopt ===========================================================* | |
32155 | *== * | |
32156 | BLOCK DATA DT_BDNOPT | |
32157 | ||
32158 | C INCLUDE '(DBLPRC)' | |
32159 | * DBLPRC.ADD | |
32160 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32161 | SAVE | |
32162 | * (original name: GLOBAL) | |
32163 | PARAMETER ( KALGNM = 2 ) | |
32164 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32165 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32166 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32167 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32168 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32169 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32170 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32171 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32172 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32173 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32174 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32175 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32176 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32177 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32178 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32179 | PARAMETER ( ZERZER = 0.D+00 ) | |
32180 | PARAMETER ( ONEONE = 1.D+00 ) | |
32181 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32182 | PARAMETER ( THRTHR = 3.D+00 ) | |
32183 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32184 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32185 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32186 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32187 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32188 | PARAMETER ( ANINEN = 9.D+00 ) | |
32189 | PARAMETER ( TENTEN = 10.D+00 ) | |
32190 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32191 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32192 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32193 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32194 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32195 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32196 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32197 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32198 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32199 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32200 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32201 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32202 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32203 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32204 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32205 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32206 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32207 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32208 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32209 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32210 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32211 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32212 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32213 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32214 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32215 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32216 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32217 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32218 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32219 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32220 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32221 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32222 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32223 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32224 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32225 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32226 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32227 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32228 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32229 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32230 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32231 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32232 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32233 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32234 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32235 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32236 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32237 | & * 1.D-09 ) | |
32238 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32239 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32240 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32241 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32242 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32243 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32244 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32245 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32246 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32247 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32248 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32249 | LOGICAL LGBIAS, LGBANA | |
32250 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32251 | C INCLUDE '(DIMPAR)' | |
32252 | * DIMPAR.ADD | |
32253 | PARAMETER ( MXXRGN = 5000 ) | |
32254 | PARAMETER ( MXXMDF = 82 ) | |
32255 | PARAMETER ( MXXMDE = 54 ) | |
32256 | PARAMETER ( MFSTCK = 1000 ) | |
32257 | PARAMETER ( MESTCK = 100 ) | |
32258 | PARAMETER ( NELEMX = 80 ) | |
32259 | PARAMETER ( MPDPDX = 8 ) | |
32260 | PARAMETER ( ICOMAX = 180 ) | |
32261 | PARAMETER ( NSTBIS = 304 ) | |
32262 | PARAMETER ( IDMAXP = 220 ) | |
32263 | PARAMETER ( IDMXDC = 640 ) | |
32264 | PARAMETER ( MKBMX1 = 1 ) | |
32265 | PARAMETER ( MKBMX2 = 1 ) | |
32266 | C INCLUDE '(IOUNIT)' | |
32267 | * IOUNIT.ADD | |
32268 | PARAMETER ( LUNIN = 5 ) | |
32269 | PARAMETER ( LUNOUT = 6 ) | |
32270 | **sr 19.5. set error output-unit from 15 to 6 | |
32271 | PARAMETER ( LUNERR = 6 ) | |
32272 | PARAMETER ( LUNBER = 14 ) | |
32273 | PARAMETER ( LUNECH = 8 ) | |
32274 | PARAMETER ( LUNFLU = 13 ) | |
32275 | PARAMETER ( LUNGEO = 16 ) | |
32276 | PARAMETER ( LUNPMF = 12 ) | |
32277 | PARAMETER ( LUNRAN = 2 ) | |
32278 | PARAMETER ( LUNXSC = 9 ) | |
32279 | PARAMETER ( LUNDET = 17 ) | |
32280 | PARAMETER ( LUNRAY = 10 ) | |
32281 | PARAMETER ( LUNRDB = 1 ) | |
32282 | PARAMETER ( LUNPGO = 7 ) | |
32283 | PARAMETER ( LUNPGS = 4 ) | |
32284 | PARAMETER ( LUNSCR = 3 ) | |
32285 | * | |
32286 | *----------------------------------------------------------------------* | |
32287 | * * | |
32288 | * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan * | |
32289 | * * | |
32290 | * Last change on 20-apr-95 by Alfredo Ferrari * | |
32291 | * * | |
32292 | *----------------------------------------------------------------------* | |
32293 | * | |
32294 | C INCLUDE '(BLNKCM)' | |
32295 | * BLNKCM.ADD | |
32296 | **sr 17.5. commented since not used here | |
32297 | C PARAMETER ( NBLNMX = 1100000 ) | |
32298 | C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ), | |
32299 | C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ), | |
32300 | C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX ) | |
32301 | C REAL SIGGTT | |
32302 | C LOGICAL LBSTOR | |
32303 | C COMMON NSTOR ( KALGNM*NBLNMX ) | |
32304 | ** | |
32305 | **sr 18.5. commented since not used for evap. | |
32306 | C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, | |
32307 | C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST, | |
32308 | C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST, | |
32309 | C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST, | |
32310 | C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST, | |
32311 | C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32312 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, | |
32313 | C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, | |
32314 | C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST, | |
32315 | C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST, | |
32316 | C & KTMBGN | |
32317 | ** | |
32318 | ||
32319 | C EQUIVALENCE ( NSTOR (1), GMSTOR (1) ) | |
32320 | C EQUIVALENCE ( NSTOR (1), BRMBRR (1) ) | |
32321 | C EQUIVALENCE ( NSTOR (1), BRMEXP (1) ) | |
32322 | C EQUIVALENCE ( NSTOR (1), BRMSIG (1) ) | |
32323 | C EQUIVALENCE ( NSTOR (1), COMSCO (1) ) | |
32324 | C EQUIVALENCE ( NSTOR (1), SIGGTT (1) ) | |
32325 | C EQUIVALENCE ( NSTOR (1), LBSTOR (1) ) | |
32326 | C INCLUDE '(BLNTMP)' | |
32327 | * BLNTMP.ADD | |
32328 | **sr 18.5. commented since not used for evap. | |
32329 | C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, | |
32330 | C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM, | |
32331 | C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM, | |
32332 | C & KLPBTM, NXXRGN | |
32333 | ** | |
32334 | C INCLUDE '(CMMDNR)' | |
32335 | * CMMDNR.ADD | |
32336 | **sr 18.5. commented since not used for evap. | |
32337 | C LOGICAL LFLDNR | |
32338 | C COMMON / CMMDNR / DDNEAR, LFLDNR | |
32339 | ** | |
32340 | C INCLUDE '(CTITLE)' | |
32341 | * CTITLE.ADD | |
32342 | **sr 18.5. commented since not used for evap. | |
32343 | C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10 | |
32344 | C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY | |
32345 | C COMMON / CEXPCK / ITEXPI, ITEXMX | |
32346 | ** | |
32347 | C INCLUDE '(DETECT)' | |
32348 | * DETECT.ADD | |
32349 | **sr 18.5. commented since not used for evap. | |
32350 | C PARAMETER (NRGNMX = 10) | |
32351 | C PARAMETER (NDTCMX = 10) | |
32352 | C PARAMETER (NSCRMX = 10) | |
32353 | C PARAMETER (NDTBIN = 1024) | |
32354 | C CHARACTER*10 TITDET,TITSCO | |
32355 | C LOGICAL LDTCTR | |
32356 | C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX), | |
32357 | C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX), | |
32358 | C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN), | |
32359 | C & KDTSCD(NSCRMX) | |
32360 | C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX) | |
32361 | ** | |
32362 | C INCLUDE '(DETLOC)' | |
32363 | * DETLOC.ADD | |
32364 | **sr 18.5. commented since not used for evap. | |
32365 | C PARAMETER (NDTCM2 = 10) | |
32366 | C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2), | |
32367 | C & ICOINC(NDTCM2), NCLAS | |
32368 | ** | |
32369 | C INCLUDE '(EMGTRN)' | |
32370 | * EMGTRN.ADD | |
32371 | **sr 18.5. commented since not used for evap. | |
32372 | C LOGICAL LMCSMG | |
32373 | C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG | |
32374 | ** | |
32375 | C INCLUDE '(EMSHO)' | |
32376 | * EMSHO.ADD | |
32377 | **sr 18.5. commented since not used for evap. | |
32378 | C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32379 | C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO, | |
32380 | C & EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32381 | ** | |
32382 | C INCLUDE '(EPISOR)' | |
32383 | * EPISOR.ADD | |
32384 | **sr 18.5. commented since not used for evap. | |
32385 | C LOGICAL LUSSRC | |
32386 | C COMMON/EPISOR/TKESUM,LUSSRC | |
32387 | ** | |
32388 | * (original name: FHEAVY,FHEAVC) | |
32389 | PARAMETER ( MXHEAV = 100 ) | |
32390 | CHARACTER*8 ANHEAV | |
32391 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
32392 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
32393 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
32394 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
32395 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
32396 | & IBHEAV ( 12 ) , NPHEAV | |
32397 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
32398 | * (original name: FINUC) | |
32399 | PARAMETER (MXP=999) | |
32400 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
32401 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
32402 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
32403 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
32404 | & KPART (MXP) | |
32405 | C INCLUDE '(GENTHR)' | |
32406 | * GENTHR.ADD | |
32407 | **sr 18.5. commented since not used for evap. | |
32408 | C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP), | |
32409 | C & PTHDFF (NALLWP), IJNUCR (NALLWP) | |
32410 | ** | |
32411 | C INCLUDE '(LOWNEU)' | |
32412 | * LOWNEU.ADD | |
32413 | **sr 18.5. commented since not used for evap. | |
32414 | C PARAMETER ( MXGTHN = 15 ) | |
32415 | C PARAMETER ( MXGLWN = 200 ) | |
32416 | C PARAMETER ( MXSHPP = 5 ) | |
32417 | C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET | |
32418 | C CHARACTER*10 TITLOW | |
32419 | C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL, | |
32420 | C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL, | |
32421 | C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF), | |
32422 | C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF), | |
32423 | C & TMNMLN (MXXMDF), ICHCPT (MXXMDF), | |
32424 | C & IGTMRT (MXXMDF), NEUMED (MXXMDF), | |
32425 | C & ID1MED (MXXMDF), ID2MED (MXXMDF), | |
32426 | C & ID3MED (MXXMDF), MGTMED (MXXMDF), | |
32427 | C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP, | |
32428 | C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW, | |
32429 | C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN, | |
32430 | C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB, | |
32431 | C & IWWLWT, IPXBGN, NPXSEC | |
32432 | C COMMON / CHLWNT / TITLOW (MXXMDF) | |
32433 | ** | |
32434 | C INCLUDE '(LTCLCM)' | |
32435 | * LTCLCM.ADD | |
32436 | **sr 18.5. commented since not used for evap. | |
32437 | C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 | |
32438 | ** | |
32439 | C INCLUDE '(MULBOU)' | |
32440 | * MULBOU.ADD | |
32441 | **sr 18.5. commented since not used for evap. | |
32442 | C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32443 | C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG , | |
32444 | C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE, | |
32445 | C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN, | |
32446 | C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32447 | ** | |
32448 | C INCLUDE '(MULHD)' | |
32449 | * MULHD.ADD | |
32450 | **sr 18.5. commented since not used for evap. | |
32451 | C PARAMETER ( MXXPT1 = 1 ) | |
32452 | C PARAMETER ( TIMESS = 2.00D+00 ) | |
32453 | C PARAMETER ( TMSRLX = 1.50D+00 ) | |
32454 | C PARAMETER ( EPSINS = 0.15D+00 ) | |
32455 | C PARAMETER ( EPSRLX = 0.50D+00 ) | |
32456 | C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 ) | |
32457 | C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 ) | |
32458 | C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN ) | |
32459 | C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR ) | |
32460 | C PARAMETER ( R0NCMS = 1.20 D+00 ) | |
32461 | C LOGICAL LTOPT, LSRCRH, LNSCRH | |
32462 | C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ), | |
32463 | C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ), | |
32464 | C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ), | |
32465 | C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ), | |
32466 | C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ), | |
32467 | C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ), | |
32468 | C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ), | |
32469 | C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP, | |
32470 | C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ), | |
32471 | C & LTOPT ( MXXMDF ), NFSCAT | |
32472 | ** | |
32473 | * (original name: PAREVT) | |
32474 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
32475 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
32476 | PARAMETER ( NALLWP = 39 ) | |
32477 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
32478 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
32479 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
32480 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
32481 | * (original name: RESNUC) | |
32482 | LOGICAL LRNFSS, LFRAGM | |
32483 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
32484 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
32485 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
32486 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
32487 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
32488 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
32489 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
32490 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
32491 | & LFRAGM | |
32492 | C INCLUDE '(SCOHLP)' | |
32493 | * SCOHLP.ADD | |
32494 | **sr 18.5. commented since not used for evap. | |
32495 | C LOGICAL LSCZER | |
32496 | C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER | |
32497 | ** | |
32498 | C INCLUDE '(TRACKR)' | |
32499 | * TRACKR.ADD | |
32500 | **sr 18.5. commented since not used for evap. | |
32501 | C PARAMETER ( MXTRCK = 2500 ) | |
32502 | C LOGICAL LFSSSC | |
32503 | C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ), | |
32504 | C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ), | |
32505 | C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK, | |
32506 | C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG, | |
32507 | C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK, | |
32508 | C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC | |
32509 | ** | |
32510 | C INCLUDE '(USRBDX)' | |
32511 | * USRBDX.ADD | |
32512 | **sr 18.5. commented since not used for evap. | |
32513 | C PARAMETER ( MXUSBX = 600 ) | |
32514 | C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX | |
32515 | C CHARACTER*10 TITUSX | |
32516 | C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX), | |
32517 | C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX), | |
32518 | C & AUSBDX(MXUSBX), | |
32519 | C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX), | |
32520 | C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX), | |
32521 | C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX), | |
32522 | C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX), | |
32523 | C & NUSRBX, LUSBDX | |
32524 | C COMMON /USXCH/ TITUSX(MXUSBX) | |
32525 | ** | |
32526 | C INCLUDE '(USRBIN)' | |
32527 | * USRBIN.ADD | |
32528 | **sr 18.5. commented since not used for evap. | |
32529 | C PARAMETER ( MXUSBN = 100 ) | |
32530 | C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN | |
32531 | C CHARACTER*10 TITUSB | |
32532 | C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN), | |
32533 | C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN), | |
32534 | C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN), | |
32535 | C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN), | |
32536 | C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN), | |
32537 | C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN), | |
32538 | C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN), | |
32539 | C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB | |
32540 | C COMMON /USRCH/ TITUSB(MXUSBN) | |
32541 | ** | |
32542 | C INCLUDE '(USRSNC)' | |
32543 | * USRSNC.ADD | |
32544 | **sr 18.5. commented since not used for evap. | |
32545 | C PARAMETER ( MXRSNC = 400 ) | |
32546 | C PARAMETER ( NMZMIN = -5 ) | |
32547 | C LOGICAL LURSNC | |
32548 | C CHARACTER*10 TIURSN | |
32549 | C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC), | |
32550 | C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC), | |
32551 | C & IPURSN(MXRSNC), NURSNC, LURSNC | |
32552 | C COMMON /USRSCH/ TIURSN(MXRSNC) | |
32553 | C INCLUDE '(USRTRC)' | |
32554 | * USRTRC.ADD | |
32555 | **sr 18.5. commented since not used for evap. | |
32556 | C PARAMETER ( MXUSTC = 400 ) | |
32557 | C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC | |
32558 | C CHARACTER*10 TITUTC | |
32559 | C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC), | |
32560 | C & VUSRTC(MXUSTC), | |
32561 | C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC), | |
32562 | C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC), | |
32563 | C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC), | |
32564 | C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC, | |
32565 | C & LUSTRK, LUSCLL | |
32566 | C COMMON /USTCH/ TITUTC(MXUSTC) | |
32567 | ** | |
32568 | C INCLUDE '(USRYLD)' | |
32569 | * USRYLD.ADD | |
32570 | **sr 18.5. commented since not used for evap. | |
32571 | C PARAMETER ( MXUSYL = 500 ) | |
32572 | C LOGICAL LUSRYL, LLNUYL, LSCUYL | |
32573 | C CHARACTER*10 TITUYL | |
32574 | C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL), | |
32575 | C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL), | |
32576 | C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL, | |
32577 | C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL, | |
32578 | C & VCMUYL, WCMUYL, IJUSYL, JTUSYL, | |
32579 | C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL), | |
32580 | C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL), | |
32581 | C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL), | |
32582 | C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL), | |
32583 | C & NUSRYL, LUSRYL, LSCUYL | |
32584 | C COMMON /USYCH/ TITUYL(MXUSYL) | |
32585 | ** | |
32586 | C INCLUDE '(WWINDW)' | |
32587 | * WWINDW.ADD | |
32588 | **sr 18.5. commented since not used for evap. | |
32589 | C PARAMETER ( MXWWSP = 3 ) | |
32590 | C PARAMETER ( WWSPMX = 50.D+00 ) | |
32591 | C LOGICAL LWWNDW, LWWPRM | |
32592 | C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP), | |
32593 | C & WWEXWD (NALLWP), EXTWWN (NALLWP), | |
32594 | C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM | |
32595 | ** | |
32596 | ||
32597 | * /blnkcm/ | |
32598 | * *** If blank common dimension has to be superseded substitute in the | |
32599 | * *** following two lines the new dimension in real*8 units to Nblnmx | |
32600 | **sr 18.5. commented since not used for evap. | |
32601 | C PARAMETER (MXDUMM = KALGNM * NBLNMX) | |
32602 | C DATA KTMBGN / NBLNMX / | |
32603 | C DATA MBLNMX / MXDUMM / | |
32604 | C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST, | |
32605 | C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN, | |
32606 | C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST, | |
32607 | C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN, | |
32608 | C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32609 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN, | |
32610 | C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST, | |
32611 | C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, | |
32612 | C & KBRLST / 57*0 / | |
32613 | ||
32614 | * /blntmp/ | |
32615 | **sr 18.5. commented since not used for evap. | |
32616 | C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM, | |
32617 | C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM, | |
32618 | C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 / | |
32619 | ||
32620 | * /cmmdnr/ | |
32621 | **sr 18.5. commented since not used for evap. | |
32622 | C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. / | |
32623 | ||
32624 | * /ctitle/ | |
32625 | **sr 18.5. commented since not used for evap. | |
32626 | C DATA RUNTIT (1:40) / '****************************************' / | |
32627 | C DATA RUNTIT(41:80) / '****************************************' / | |
32628 | C DATA ITEXPI, ITEXMX / 100000000, 150 / | |
32629 | * /detect/ | |
32630 | **sr 18.5. commented since not used for evap. | |
32631 | C PARAMETER (NNN1 = NRGNMX*NDTCMX) | |
32632 | C PARAMETER (NNN2 = NSCRMX*NDTCMX) | |
32633 | C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/ | |
32634 | C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/ | |
32635 | C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/ | |
32636 | C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/ | |
32637 | ||
32638 | * /detloc/ | |
32639 | **sr 18.5. commented since not used for evap. | |
32640 | C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/ | |
32641 | C DATA NCLAS /0/ | |
32642 | ||
32643 | * /emgtrn/ | |
32644 | **sr 18.5. commented since not used for evap. | |
32645 | C DATA LMCSMG / .FALSE. / | |
32646 | ||
32647 | * /emsho/ | |
32648 | **sr 18.5. commented since not used for evap. | |
32649 | C DATA LIMPRE, LEXPTE / 2 * .FALSE. / | |
32650 | ||
32651 | * /episor/ | |
32652 | **sr 18.5. commented since not used for evap. | |
32653 | C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. / | |
32654 | ||
32655 | * /fheavy/ | |
32656 | DATA AMHEAV / 12 * 0.D+00 / | |
32657 | DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ', | |
32658 | & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2', | |
32659 | & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/ | |
32660 | DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /, | |
32661 | & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 / | |
32662 | DATA NPHEAV / 0 / | |
32663 | ||
32664 | * /finuc/ | |
32665 | DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/, | |
32666 | & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 / | |
32667 | ||
32668 | * /genthr/ | |
32669 | * Up to 20-apr-'95 | |
32670 | * DATA PEANCT, PEAPIT / 2*1.D+00 / | |
32671 | * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00, | |
32672 | * & 9*2.5D+00 / | |
32673 | * DATA PTHDFF / 39*5.D+00 / | |
32674 | * & 9*2.5D+00 / | |
32675 | * New values: | |
32676 | **sr 18.5. commented since not used for evap. | |
32677 | C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 / | |
32678 | C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00, | |
32679 | C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00, | |
32680 | C & 9*2.5D+00 / | |
32681 | C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00, | |
32682 | C & 3.5D+00, 13*5.D+00 / | |
32683 | C DATA PLDNCT / 0.26D+00 / | |
32684 | C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 / | |
32685 | ||
32686 | * /lowneu/ | |
32687 | **sr 18.5. commented since not used for evap. | |
32688 | C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 / | |
32689 | C DATA IWWLWB, IWWLWT / 2 * 100000000 / | |
32690 | C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 / | |
32691 | C DATA IGRTHN / 1 / | |
32692 | C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /, | |
32693 | C & LLOWWW / .FALSE. /, LLOWET / .FALSE. / | |
32694 | ||
32695 | * /ltclcm/ | |
32696 | **sr 18.5. commented since not used for evap. | |
32697 | C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 / | |
32698 | ||
32699 | * /mulbou/ | |
32700 | **sr 18.5. commented since not used for evap. | |
32701 | C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR | |
32702 | C & / 7 * .FALSE. / | |
32703 | C DATA TSENSE / AINFNT /, NSSENS / -1 / | |
32704 | C DATA DSMALL / ANGLGB / | |
32705 | ||
32706 | * /mulhd/ | |
32707 | **sr 18.5. commented since not used for evap. | |
32708 | C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 / | |
32709 | C DATA ESTEPF / MXXMDF * 0.1D+00 / | |
32710 | C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. / | |
32711 | C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 / | |
32712 | ||
32713 | * /parevt/ | |
32714 | DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /, | |
32715 | & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 / | |
32716 | DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE., | |
32717 | & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE., | |
32718 | & 4 * .FALSE., 9 * .TRUE./ | |
32719 | **sr 17.5.95 | |
32720 | * default value for LEVPRT changed (reset sr 25.7.97) | |
32721 | * default value for LHEAVY changed 25.7.97 | |
32722 | C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32723 | C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32724 | C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32725 | C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32726 | DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32727 | & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32728 | & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32729 | & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32730 | ** | |
32731 | **sr 27.5.97 | |
32732 | * default value for ILVMOD changed | |
32733 | C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32734 | DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32735 | ** | |
32736 | ||
32737 | * /resnuc/ | |
32738 | DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /, | |
32739 | & IPR4HE / 0 / | |
32740 | DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /, | |
32741 | & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /, | |
32742 | & IDEEXG / 0 / | |
32743 | DATA LRNFSS / .FALSE. / | |
32744 | ||
32745 | * /scohlp/ | |
32746 | **sr 18.5. commented since not used for evap. | |
32747 | C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. / | |
32748 | ||
32749 | * /trackr/ | |
32750 | **sr 18.5. commented since not used for evap. | |
32751 | C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/, | |
32752 | C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/ | |
32753 | ||
32754 | * /usrbin/ | |
32755 | **sr 18.5. commented since not used for evap. | |
32756 | C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/ | |
32757 | ||
32758 | * /usrbdx/ | |
32759 | **sr 18.5. commented since not used for evap. | |
32760 | C DATA LUSBDX /.FALSE./, NUSRBX /0/ | |
32761 | ||
32762 | * /usrsnc/ | |
32763 | **sr 18.5. commented since not used for evap. | |
32764 | C DATA LURSNC /.FALSE./, NURSNC /0/ | |
32765 | ||
32766 | * /usrtrc/ | |
32767 | **sr 18.5. commented since not used for evap. | |
32768 | C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. / | |
32769 | C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 / | |
32770 | ||
32771 | * /usryld/ | |
32772 | **sr 18.5. commented since not used for evap. | |
32773 | C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/, | |
32774 | C & IJUSYL /0/, JTUSYL /0/ | |
32775 | C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER / | |
32776 | ||
32777 | * /wwindw/ | |
32778 | **sr 18.5. commented since not used for evap. | |
32779 | C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 / | |
32780 | C DATA LWWPRM / .TRUE. / | |
32781 | ||
32782 | *= end*block.bdnopt * | |
32783 | END | |
32784 | ||
32785 | *$ CREATE DT_BDPREE.FOR | |
32786 | *COPY DT_BDPREE | |
32787 | * | |
32788 | *=== bdpree ===========================================================* | |
32789 | * | |
32790 | BLOCK DATA DT_BDPREE | |
32791 | ||
32792 | C INCLUDE '(DBLPRC)' | |
32793 | * DBLPRC.ADD | |
32794 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32795 | SAVE | |
32796 | * (original name: GLOBAL) | |
32797 | PARAMETER ( KALGNM = 2 ) | |
32798 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32799 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32800 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32801 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32802 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32803 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32804 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32805 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32806 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32807 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32808 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32809 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32810 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32811 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32812 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32813 | PARAMETER ( ZERZER = 0.D+00 ) | |
32814 | PARAMETER ( ONEONE = 1.D+00 ) | |
32815 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32816 | PARAMETER ( THRTHR = 3.D+00 ) | |
32817 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32818 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32819 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32820 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32821 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32822 | PARAMETER ( ANINEN = 9.D+00 ) | |
32823 | PARAMETER ( TENTEN = 10.D+00 ) | |
32824 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32825 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32826 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32827 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32828 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32829 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32830 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32831 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32832 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32833 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32834 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32835 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32836 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32837 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32838 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32839 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32840 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32841 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32842 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32843 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32844 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32845 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32846 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32847 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32848 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32849 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32850 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32851 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32852 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32853 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32854 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32855 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32856 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32857 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32858 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32859 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32860 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32861 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32862 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32863 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32864 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32865 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32866 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32867 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32868 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32869 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32870 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32871 | & * 1.D-09 ) | |
32872 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32873 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32874 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32875 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32876 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32877 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32878 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32879 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32880 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32881 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32882 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32883 | LOGICAL LGBIAS, LGBANA | |
32884 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32885 | C INCLUDE '(DIMPAR)' | |
32886 | * DIMPAR.ADD | |
32887 | PARAMETER ( MXXRGN = 5000 ) | |
32888 | PARAMETER ( MXXMDF = 82 ) | |
32889 | PARAMETER ( MXXMDE = 54 ) | |
32890 | PARAMETER ( MFSTCK = 1000 ) | |
32891 | PARAMETER ( MESTCK = 100 ) | |
32892 | PARAMETER ( NALLWP = 39 ) | |
32893 | PARAMETER ( NELEMX = 80 ) | |
32894 | PARAMETER ( MPDPDX = 8 ) | |
32895 | PARAMETER ( ICOMAX = 180 ) | |
32896 | PARAMETER ( NSTBIS = 304 ) | |
32897 | PARAMETER ( IDMAXP = 220 ) | |
32898 | PARAMETER ( IDMXDC = 640 ) | |
32899 | PARAMETER ( MKBMX1 = 1 ) | |
32900 | PARAMETER ( MKBMX2 = 1 ) | |
32901 | C INCLUDE '(IOUNIT)' | |
32902 | * IOUNIT.ADD | |
32903 | PARAMETER ( LUNIN = 5 ) | |
32904 | PARAMETER ( LUNOUT = 6 ) | |
32905 | **sr 19.5. set error output-unit from 15 to 6 | |
32906 | PARAMETER ( LUNERR = 6 ) | |
32907 | PARAMETER ( LUNBER = 14 ) | |
32908 | PARAMETER ( LUNECH = 8 ) | |
32909 | PARAMETER ( LUNFLU = 13 ) | |
32910 | PARAMETER ( LUNGEO = 16 ) | |
32911 | PARAMETER ( LUNPMF = 12 ) | |
32912 | PARAMETER ( LUNRAN = 2 ) | |
32913 | PARAMETER ( LUNXSC = 9 ) | |
32914 | PARAMETER ( LUNDET = 17 ) | |
32915 | PARAMETER ( LUNRAY = 10 ) | |
32916 | PARAMETER ( LUNRDB = 1 ) | |
32917 | PARAMETER ( LUNPGO = 7 ) | |
32918 | PARAMETER ( LUNPGS = 4 ) | |
32919 | PARAMETER ( LUNSCR = 3 ) | |
32920 | * | |
32921 | *----------------------------------------------------------------------* | |
32922 | * * | |
32923 | * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala * | |
32924 | * Infn - Milan * | |
32925 | * * | |
32926 | * Last change on 03-feb-94 by Alfredo Ferrari * | |
32927 | * * | |
32928 | * * | |
32929 | *----------------------------------------------------------------------* | |
32930 | * | |
32931 | * (original name: CMPISG,CHPISG) | |
32932 | PARAMETER ( TPPPI0 = 0.279656044337515D+00 ) | |
32933 | PARAMETER ( TNNPI0 = 0.279642680857450D+00 ) | |
32934 | PARAMETER ( TPPPIP = 0.292295207182790D+00 ) | |
32935 | PARAMETER ( TPPDEP = 0.287514778898469D+00 ) | |
32936 | PARAMETER ( TNNPIM = 0.286723140900975D+00 ) | |
32937 | PARAMETER ( TNNDEM = 0.281949292916434D+00 ) | |
32938 | PARAMETER ( TPNPI0 = 0.279456888147740D+00 ) | |
32939 | PARAMETER ( TPNDE0 = 0.274693916135245D+00 ) | |
32940 | PARAMETER ( TPNPIP = 0.292086756473890D+00 ) | |
32941 | PARAMETER ( TNPPI0 = 0.279842093144975D+00 ) | |
32942 | PARAMETER ( TNPDE0 = 0.275072555824202D+00 ) | |
32943 | PARAMETER ( TNPPIP = 0.292489370554958D+00 ) | |
32944 | PARAMETER ( PIRSMX = 1.2D+00 ) | |
32945 | PARAMETER ( NPIREA = 10 ) | |
32946 | PARAMETER ( NPIRTA = 68 ) | |
32947 | PARAMETER ( NPIRLN = 21 ) | |
32948 | PARAMETER ( NPIRLG = NPIRTA - NPIRLN ) | |
32949 | PARAMETER ( NPISIS = NPIRLN + 20 ) | |
32950 | PARAMETER ( NPISEX = NPIRLN + 21 ) | |
32951 | PARAMETER ( NPIIMN = 14 ) | |
32952 | PARAMETER ( NPIIRC = 6 ) | |
32953 | PARAMETER ( DELWLL = 0.035D+00 ) | |
32954 | CHARACTER CHPIRE*8 | |
32955 | LOGICAL LDLRES | |
32956 | COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG, | |
32957 | & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS, | |
32958 | & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA), | |
32959 | & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA), | |
32960 | & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA), | |
32961 | & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) , | |
32962 | & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA), | |
32963 | & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA), | |
32964 | & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA), | |
32965 | & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2), | |
32966 | & SGABSR (2,2,4) , PRRSDL, | |
32967 | & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR , | |
32968 | & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) , | |
32969 | & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES | |
32970 | COMMON /FKCHPI/ CHPIRE (NPIREA) | |
32971 | DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2) | |
32972 | EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) ) | |
32973 | EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) ) | |
32974 | EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) ) | |
32975 | * (original name: FRBKCM) | |
32976 | PARAMETER ( MXFFBK = 6 ) | |
32977 | PARAMETER ( MXZFBK = 9 ) | |
32978 | PARAMETER ( MXNFBK = 10 ) | |
32979 | PARAMETER ( MXAFBK = 16 ) | |
32980 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
32981 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
32982 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
32983 | PARAMETER ( MXPSST = 300 ) | |
32984 | PARAMETER ( MXPSFB = 41000 ) | |
32985 | LOGICAL LFRMBK, LNCMSS | |
32986 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
32987 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
32988 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
32989 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
32990 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
32991 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
32992 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
32993 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
32994 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
32995 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
32996 | PARAMETER ( PI = PIPIPI ) | |
32997 | PARAMETER ( PISQ = PIPISQ ) | |
32998 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
32999 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
33000 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
33001 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
33002 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
33003 | & / R0PROT ) | |
33004 | PARAMETER ( RLLE04 = RZNUCL ) | |
33005 | PARAMETER ( RLLE16 = RZNUCL ) | |
33006 | PARAMETER ( RLGT16 = RZNUCL ) | |
33007 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
33008 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
33009 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
33010 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
33011 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
33012 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
33013 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
33014 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
33015 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
33016 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
33017 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
33018 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
33019 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
33020 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
33021 | PARAMETER ( POTBA0 = 1.D+00 ) | |
33022 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
33023 | PARAMETER ( RADPIM = 0.035D+00 ) | |
33024 | PARAMETER ( RDPMHL = 14.D+00 ) | |
33025 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
33026 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
33027 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
33028 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
33029 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
33030 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
33031 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
33032 | PARAMETER ( MXSCIN = 50 ) | |
33033 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
33034 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
33035 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
33036 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
33037 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
33038 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
33039 | & PFRTAB (2:260) | |
33040 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
33041 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
33042 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
33043 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
33044 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
33045 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
33046 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
33047 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
33048 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
33049 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
33050 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
33051 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
33052 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
33053 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
33054 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
33055 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
33056 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
33057 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
33058 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
33059 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
33060 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
33061 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
33062 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
33063 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
33064 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
33065 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
33066 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
33067 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
33068 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
33069 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
33070 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
33071 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
33072 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
33073 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
33074 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
33075 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
33076 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
33077 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
33078 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
33079 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
33080 | & LNCDCY, LNUSCT | |
33081 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
33082 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
33083 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
33084 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
33085 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
33086 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
33087 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
33088 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
33089 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
33090 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
33091 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
33092 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
33093 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
33094 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
33095 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
33096 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
33097 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
33098 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
33099 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
33100 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
33101 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
33102 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
33103 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
33104 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
33105 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
33106 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
33107 | * (original name: NUCLEV) | |
33108 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
33109 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
33110 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
33111 | & CUMRAD (0:160,2), RUSNUC (2), | |
33112 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
33113 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
33114 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
33115 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
33116 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
33117 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
33118 | & LFLVSL, LRLVSL, LEQSBL | |
33119 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
33120 | & MGSSPR (19) , MGSSNE (25) | |
33121 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
33122 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
33123 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
33124 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
33125 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
33126 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
33127 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
33128 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
33129 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
33130 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
33131 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
33132 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
33133 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
33134 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
33135 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
33136 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
33137 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
33138 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
33139 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
33140 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
33141 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
33142 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
33143 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
33144 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
33145 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
33146 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
33147 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
33148 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
33149 | * (original name: PARNUC) | |
33150 | PARAMETER ( PIGRK = PIPIPI ) | |
33151 | PARAMETER ( ALEVEL = 8.D-03 ) | |
33152 | PARAMETER ( RCNUCL = 1.12D+00 ) | |
33153 | PARAMETER ( R0SIG = 1.3D+00 ) | |
33154 | PARAMETER ( R0SIGK = 1.5D+00 ) | |
33155 | PARAMETER ( RCOULB = 1.5D+00 ) | |
33156 | PARAMETER ( COULBH = 0.88235D-03 ) | |
33157 | PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL ) | |
33158 | PARAMETER ( TAUFO0 = 10.0D+00 ) | |
33159 | PARAMETER ( EKEEXP = 0.03D+00 ) | |
33160 | PARAMETER ( EKREXP = 0.05D+00 ) | |
33161 | PARAMETER ( EKEMNM = 0.01D+00 ) | |
33162 | PARAMETER ( NCPMX = 120 ) | |
33163 | COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR, | |
33164 | & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX), | |
33165 | & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX), | |
33166 | & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX), | |
33167 | & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX), | |
33168 | & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX), | |
33169 | & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN, | |
33170 | & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX), | |
33171 | & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI , | |
33172 | & IBNUCL, NPNUC , NNUCTS | |
33173 | * | |
33174 | DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. / | |
33175 | DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 / | |
33176 | DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 / | |
33177 | DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 / | |
33178 | DATA LPREEQ / .FALSE. / | |
33179 | * /cmpisg/ | |
33180 | DATA JSTOKP / 1, 8, 13, 14, 23 / | |
33181 | DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 / | |
33182 | DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P', | |
33183 | & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P', | |
33184 | & 'PI0NPI0N','PI0NPI-P' / | |
33185 | DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8, | |
33186 | & 13, 8, 13, 8, 23, 8, 23, 8 / | |
33187 | DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8, | |
33188 | & 13, 8, 23, 1, 23, 8, 14, 1 / | |
33189 | DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 / | |
33190 | DATA IPIINE / 1, 2, 3, 4, 5, 6 / | |
33191 | * /frbkcm/ | |
33192 | DATA LFRMBK / .FALSE. / | |
33193 | DATA NBUFBK / 500 / | |
33194 | DATA EXMXFB / 80.0 D+00 / | |
33195 | DATA R0FRBK / 1.18 D+00 / | |
33196 | DATA R0CFBK / 2.173D+00 / | |
33197 | DATA C1CFBK / 6.103D-03 / | |
33198 | DATA C2CFBK / 9.443D-03 / | |
33199 | * /parnuc/ | |
33200 | DATA TAUFOR / TAUFO0 / | |
33201 | *=== End of Block Data Bdpree =========================================* | |
33202 | END | |
33203 | ||
33204 | *$ CREATE DT_XHOINI.FOR | |
33205 | *COPY DT_XHOINI | |
33206 | * | |
33207 | *====phoini============================================================* | |
33208 | * | |
33209 | SUBROUTINE DT_XHOINI | |
33210 | C SUBROUTINE DT_PHOINI | |
33211 | ||
33212 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33213 | SAVE | |
33214 | PARAMETER ( LINP = 10 , | |
33215 | & LOUT = 6 , | |
33216 | & LDAT = 9 ) | |
33217 | ||
33218 | RETURN | |
33219 | END | |
33220 | ||
33221 | *$ CREATE DT_XVENTB.FOR | |
33222 | *COPY DT_XVENTB | |
33223 | * | |
33224 | *====eventb============================================================* | |
33225 | * | |
33226 | SUBROUTINE DT_XVENTB(NCSY,IREJ) | |
33227 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
33228 | ||
33229 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33230 | SAVE | |
33231 | PARAMETER ( LINP = 10 , | |
33232 | & LOUT = 6 , | |
33233 | & LDAT = 9 ) | |
33234 | ||
33235 | WRITE(LOUT,1000) | |
33236 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') | |
33237 | STOP | |
33238 | ||
33239 | END | |
33240 | ||
33241 | *$ CREATE DT_XVENT.FOR | |
33242 | *COPY DT_XVENT | |
33243 | * | |
33244 | *===event==============================================================* | |
33245 | * | |
33246 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) | |
33247 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) | |
33248 | ||
33249 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33250 | SAVE | |
33251 | ||
33252 | DIMENSION PP(4),PT(4) | |
33253 | ||
33254 | RETURN | |
33255 | END | |
33256 | ||
33257 | *$ CREATE DT_XOHISX.FOR | |
33258 | *COPY DT_XOHISX | |
33259 | * | |
33260 | *===pohisx=============================================================* | |
33261 | * | |
33262 | SUBROUTINE DT_XOHISX(I,X) | |
33263 | C SUBROUTINE POHISX(I,X) | |
33264 | ||
33265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33266 | SAVE | |
33267 | ||
33268 | RETURN | |
33269 | END | |
33270 | ||
33271 | *$ CREATE PHO_LHIST.FOR | |
33272 | *COPY PHO_LHIST | |
33273 | * | |
33274 | *===poluhi=============================================================* | |
33275 | * | |
33276 | SUBROUTINE PHO_LHIST(I,X) | |
33277 | ** | |
33278 | ||
33279 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33280 | SAVE | |
33281 | ||
33282 | RETURN | |
33283 | END | |
33284 | ||
33285 | *$ CREATE PDFSET.FOR | |
33286 | *COPY PDFSET | |
33287 | * | |
33288 | C********************************************************************** | |
33289 | C | |
33290 | C dummy subroutines, remove to link PDFLIB | |
33291 | C | |
33292 | C********************************************************************** | |
33293 | SUBROUTINE PDFSET(PARAM,VALUE) | |
33294 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33295 | DIMENSION PARAM(20),VALUE(20) | |
33296 | CHARACTER*20 PARAM | |
33297 | END | |
33298 | ||
33299 | *$ CREATE STRUCTM.FOR | |
33300 | *COPY STRUCTM | |
33301 | * | |
33302 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33303 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33304 | END | |
33305 | ||
33306 | *$ CREATE STRUCTP.FOR | |
33307 | *COPY STRUCTP | |
33308 | * | |
33309 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33310 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33311 | END | |
33312 | ||
33313 | *$ CREATE DT_DIQBRK.FOR | |
33314 | *COPY DT_DIQBRK | |
33315 | * | |
33316 | *===diqbrk=============================================================* | |
33317 | * | |
33318 | SUBROUTINE DT_XIQBRK | |
33319 | C SUBROUTINE DT_DIQBRK | |
33320 | ||
33321 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33322 | SAVE | |
33323 | ||
33324 | STOP 'diquark-breaking not implemeted !' | |
33325 | ||
33326 | RETURN | |
33327 | END | |
33328 | ||
33329 | *$ CREATE DT_ELHAIN.FOR | |
33330 | *COPY DT_ELHAIN | |
33331 | * | |
33332 | *===elhain=============================================================* | |
33333 | * | |
33334 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) | |
33335 | ||
33336 | ************************************************************************ | |
33337 | * Elastic hadron-hadron scattering. * | |
33338 | * This is a revised version of the original. * | |
33339 | * This version dated 03.04.98 is written by S. Roesler * | |
33340 | ************************************************************************ | |
33341 | ||
33342 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33343 | SAVE | |
33344 | PARAMETER ( LINP = 10 , | |
33345 | & LOUT = 6 , | |
33346 | & LDAT = 9 ) | |
33347 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33348 | & TINY10=1.0D-10) | |
33349 | ||
33350 | PARAMETER (ENNTHR = 3.5D0) | |
33351 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, | |
33352 | & BLOWB=0.05D0,BHIB=0.2D0, | |
33353 | & BLOWM=0.1D0, BHIM=2.0D0) | |
33354 | ||
33355 | * particle properties (BAMJET index convention) | |
33356 | CHARACTER*8 ANAME | |
33357 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33358 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33359 | * final state from HADRIN interaction | |
33360 | PARAMETER (MAXFIN=10) | |
33361 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33362 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33363 | ||
33364 | C DATA TSLOPE /10.0D0/ | |
33365 | ||
33366 | IREJ = 0 | |
33367 | ||
33368 | 1 CONTINUE | |
33369 | ||
33370 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) | |
33371 | EKIN = ELAB-AAM(IP) | |
33372 | * kinematical quantities in cms of the hadrons | |
33373 | AMP2 = AAM(IP)**2 | |
33374 | AMT2 = AAM(IT)**2 | |
33375 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) | |
33376 | ECM = SQRT(S) | |
33377 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) | |
33378 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) | |
33379 | ||
33380 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) | |
33381 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. | |
33382 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN | |
33383 | * TSAMCS treats pp and np only, therefore change pn into np and | |
33384 | * nn into pp | |
33385 | IF (IT.EQ.1) THEN | |
33386 | KPROJ = IP | |
33387 | ELSE | |
33388 | KPROJ = 8 | |
33389 | IF (IP.EQ.8) KPROJ = 1 | |
33390 | ENDIF | |
33391 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) | |
33392 | T = TWO*PCM**2*(CTCMS-ONE) | |
33393 | ||
33394 | * very crude treatment otherwise: sample t from exponential dist. | |
33395 | ELSE | |
33396 | * momentum transfer t | |
33397 | TMAX = TWO*TWO*PCM**2 | |
33398 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) | |
33399 | IF (IIBAR(IP).NE.0) THEN | |
33400 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) | |
33401 | ELSE | |
33402 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) | |
33403 | ENDIF | |
33404 | FMAX = EXP(-TSLOPE*TMAX)-ONE | |
33405 | R = DT_RNDM(RR) | |
33406 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE | |
33407 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE | |
33408 | ENDIF | |
33409 | ||
33410 | * target hadron in Lab after scattering | |
33411 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) | |
33412 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) | |
33413 | IF (PLRH(2).LE.TINY10) THEN | |
33414 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) | |
33415 | GOTO 1 | |
33416 | ENDIF | |
33417 | * projectile hadron in Lab after scattering | |
33418 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) | |
33419 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) | |
33420 | * scattering angle of projectile in Lab | |
33421 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) | |
33422 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) | |
33423 | CALL DT_DSFECF(SPLABP,CPLABP) | |
33424 | * direction cosines of projectile in Lab | |
33425 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, | |
33426 | & CXRH(1),CYRH(1),CZRH(1)) | |
33427 | * scattering angle of target in Lab | |
33428 | PLLABT = PLAB-CTLABP*PLRH(1) | |
33429 | CTLABT = PLLABT/PLRH(2) | |
33430 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) | |
33431 | * direction cosines of target in Lab | |
33432 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, | |
33433 | & CXRH(2),CYRH(2),CZRH(2)) | |
33434 | * fill /HNFSPA/ | |
33435 | IRH = 2 | |
33436 | ITRH(1) = IP | |
33437 | ITRH(2) = IT | |
33438 | ||
33439 | RETURN | |
33440 | END | |
33441 | ||
33442 | *$ CREATE DT_TSAMCS.FOR | |
33443 | *COPY DT_TSAMCS | |
33444 | * | |
33445 | *===tsamcs=============================================================* | |
33446 | * | |
33447 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) | |
33448 | ||
33449 | ************************************************************************ | |
33450 | * Sampling of cos(theta) for nucleon-proton scattering according to * | |
33451 | * hetkfa2/bertini parametrization. * | |
33452 | * This is a revised version of the original (HJM 24/10/88) * | |
33453 | * This version dated 28.10.95 is written by S. Roesler * | |
33454 | ************************************************************************ | |
33455 | ||
33456 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33457 | SAVE | |
33458 | PARAMETER ( LINP = 10 , | |
33459 | & LOUT = 6 , | |
33460 | & LDAT = 9 ) | |
33461 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33462 | & TINY10=1.0D-10) | |
33463 | ||
33464 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) | |
33465 | DIMENSION PDCI(60),PDCH(55) | |
33466 | ||
33467 | DATA (DCLIN(I),I=1,80) / | |
33468 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, | |
33469 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, | |
33470 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, | |
33471 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, | |
33472 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, | |
33473 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, | |
33474 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, | |
33475 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, | |
33476 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, | |
33477 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, | |
33478 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, | |
33479 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, | |
33480 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, | |
33481 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, | |
33482 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, | |
33483 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ | |
33484 | DATA (DCLIN(I),I=81,160) / | |
33485 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, | |
33486 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, | |
33487 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, | |
33488 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, | |
33489 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, | |
33490 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, | |
33491 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, | |
33492 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, | |
33493 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, | |
33494 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, | |
33495 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, | |
33496 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, | |
33497 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, | |
33498 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, | |
33499 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, | |
33500 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ | |
33501 | DATA (DCLIN(I),I=161,195) / | |
33502 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, | |
33503 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, | |
33504 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, | |
33505 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, | |
33506 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, | |
33507 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, | |
33508 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ | |
33509 | ||
33510 | DATA PDCI / | |
33511 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, | |
33512 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, | |
33513 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, | |
33514 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, | |
33515 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, | |
33516 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, | |
33517 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, | |
33518 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, | |
33519 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, | |
33520 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, | |
33521 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, | |
33522 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ | |
33523 | ||
33524 | DATA PDCH / | |
33525 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, | |
33526 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, | |
33527 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, | |
33528 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, | |
33529 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, | |
33530 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, | |
33531 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, | |
33532 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, | |
33533 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, | |
33534 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, | |
33535 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ | |
33536 | ||
33537 | DATA (DCHN(I),I=1,90) / | |
33538 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, | |
33539 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, | |
33540 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, | |
33541 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, | |
33542 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, | |
33543 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, | |
33544 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, | |
33545 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, | |
33546 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, | |
33547 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, | |
33548 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, | |
33549 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, | |
33550 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, | |
33551 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, | |
33552 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, | |
33553 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, | |
33554 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, | |
33555 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ | |
33556 | DATA (DCHN(I),I=91,143) / | |
33557 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, | |
33558 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, | |
33559 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, | |
33560 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, | |
33561 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, | |
33562 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, | |
33563 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, | |
33564 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, | |
33565 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, | |
33566 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, | |
33567 | & 6.488D-02, 6.485D-02, 6.480D-02/ | |
33568 | ||
33569 | DATA DCHNA / | |
33570 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, | |
33571 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, | |
33572 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, | |
33573 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, | |
33574 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, | |
33575 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, | |
33576 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, | |
33577 | & 1.000D+00/ | |
33578 | ||
33579 | DATA DCHNB / | |
33580 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, | |
33581 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, | |
33582 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, | |
33583 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, | |
33584 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, | |
33585 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, | |
33586 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33587 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, | |
33588 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33589 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, | |
33590 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33591 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ | |
33592 | ||
33593 | CST = ONE | |
33594 | IF (EKIN.GT.3.5D0) RETURN | |
33595 | C | |
33596 | IF(KPROJ.EQ.8) GOTO 101 | |
33597 | IF(KPROJ.EQ.1) GOTO 102 | |
33598 | C* INVALID REACTION | |
33599 | WRITE(LOUT,'(A,I5/A)') | |
33600 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, | |
33601 | & ' COS(THETA) = 1D0 RETURNED' | |
33602 | RETURN | |
33603 | C-------------------------------- NP ELASTIC SCATTERING---------- | |
33604 | 101 CONTINUE | |
33605 | IF (EKIN.GT.0.740D0)GOTO 1000 | |
33606 | IF (EKIN.LT.0.300D0)THEN | |
33607 | C EKIN .LT. 300 MEV | |
33608 | IDAT=1 | |
33609 | ELSE | |
33610 | C 300 MEV < EKIN < 740 MEV | |
33611 | IDAT=6 | |
33612 | END IF | |
33613 | C | |
33614 | ENER=EKIN | |
33615 | IE=INT(ABS(ENER/0.020D0)) | |
33616 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33617 | C FORWARD/BACKWARD DECISION | |
33618 | K=IDAT+5*IE | |
33619 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33620 | IF (DT_RNDM(CST).LT.BWFW)THEN | |
33621 | VALUE2=-1D0 | |
33622 | K=K+1 | |
33623 | ELSE | |
33624 | VALUE2=1D0 | |
33625 | K=K+3 | |
33626 | END IF | |
33627 | C | |
33628 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33629 | RND=DT_RNDM(COEF) | |
33630 | C | |
33631 | IF(RND.LT.COEF)THEN | |
33632 | CST=DT_RNDM(RND) | |
33633 | CST=CST*VALUE2 | |
33634 | ELSE | |
33635 | R1=DT_RNDM(CST) | |
33636 | R2=DT_RNDM(R1) | |
33637 | R3=DT_RNDM(R2) | |
33638 | R4=DT_RNDM(R3) | |
33639 | C | |
33640 | IF(VALUE2.GT.0.0)THEN | |
33641 | CST=MAX(R1,R2,R3,R4) | |
33642 | GOTO 1500 | |
33643 | ELSE | |
33644 | R5=DT_RNDM(R4) | |
33645 | C | |
33646 | IF (IDAT.EQ.1)THEN | |
33647 | CST=-MAX(R1,R2,R3,R4,R5) | |
33648 | ELSE | |
33649 | R6=DT_RNDM(R5) | |
33650 | R7=DT_RNDM(R6) | |
33651 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) | |
33652 | END IF | |
33653 | C | |
33654 | END IF | |
33655 | C | |
33656 | END IF | |
33657 | C | |
33658 | GOTO 1500 | |
33659 | C | |
33660 | C******** EKIN .GT. 0.74 GEV | |
33661 | C | |
33662 | 1000 ENER=EKIN - 0.66D0 | |
33663 | C IE=ABS(ENER/0.02) | |
33664 | IE=INT(ENER/0.02D0) | |
33665 | EMEV=EKIN*1D3 | |
33666 | C | |
33667 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33668 | K=IE | |
33669 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) | |
33670 | RND=DT_RNDM(BWFW) | |
33671 | C FORWARD NEUTRON | |
33672 | IF (RND.GE.BWFW)THEN | |
33673 | DO 1200 K=10,36,9 | |
33674 | IF (DCHNA(K).GT.EMEV) THEN | |
33675 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) | |
33676 | UNIV=DT_RNDM(UNIVE) | |
33677 | DO 1100 I=1,8 | |
33678 | II=K+I | |
33679 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) | |
33680 | C | |
33681 | IF (P.GT.UNIV)THEN | |
33682 | UNIV=DT_RNDM(UNIVE) | |
33683 | FLTI=DBLE(I)-UNIV | |
33684 | GOTO(290,290,290,290,330,340,350,360) I | |
33685 | END IF | |
33686 | 1100 CONTINUE | |
33687 | END IF | |
33688 | 1200 CONTINUE | |
33689 | C | |
33690 | ELSE | |
33691 | C BACKWARD NEUTRON | |
33692 | DO 1400 K=13,60,12 | |
33693 | IF (DCHNB(K).GT.EMEV) THEN | |
33694 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) | |
33695 | UNIV=DT_RNDM(UNIVE) | |
33696 | DO 1300 I=1,11 | |
33697 | II=K+I | |
33698 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) | |
33699 | C | |
33700 | IF (P.GT.UNIV)THEN | |
33701 | UNIV=DT_RNDM(P) | |
33702 | FLTI=DBLE(I)-UNIV | |
33703 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I | |
33704 | END IF | |
33705 | 1300 CONTINUE | |
33706 | END IF | |
33707 | 1400 CONTINUE | |
33708 | END IF | |
33709 | C | |
33710 | 120 CST=1.0D-2*FLTI-1.0D0 | |
33711 | GOTO 1500 | |
33712 | 140 CST=2.0D-2*UNIV-0.98D0 | |
33713 | GOTO 1500 | |
33714 | 150 CST=4.0D-2*UNIV-0.96D0 | |
33715 | GOTO 1500 | |
33716 | 160 CST=6.0D-2*FLTI-1.16D0 | |
33717 | GOTO 1500 | |
33718 | 180 CST=8.0D-2*UNIV-0.80D0 | |
33719 | GOTO 1500 | |
33720 | 190 CST=1.0D-1*UNIV-0.72D0 | |
33721 | GOTO 1500 | |
33722 | 200 CST=1.2D-1*UNIV-0.62D0 | |
33723 | GOTO 1500 | |
33724 | 210 CST=2.0D-1*UNIV-0.50D0 | |
33725 | GOTO 1500 | |
33726 | 220 CST=3.0D-1*(UNIV-1.0D0) | |
33727 | GOTO 1500 | |
33728 | C | |
33729 | 290 CST=1.0D0-2.5d-2*FLTI | |
33730 | GOTO 1500 | |
33731 | 330 CST=0.85D0+0.5D-1*UNIV | |
33732 | GOTO 1500 | |
33733 | 340 CST=0.70D0+1.5D-1*UNIV | |
33734 | GOTO 1500 | |
33735 | 350 CST=0.50D0+2.0D-1*UNIV | |
33736 | GOTO 1500 | |
33737 | 360 CST=0.50D0*UNIV | |
33738 | C | |
33739 | 1500 RETURN | |
33740 | C | |
33741 | C----------------------------------- PP ELASTIC SCATTERING ------- | |
33742 | C | |
33743 | 102 CONTINUE | |
33744 | EMEV=EKIN*1D3 | |
33745 | C | |
33746 | IF (EKIN.LE.0.500D0) THEN | |
33747 | RND=DT_RNDM(EMEV) | |
33748 | CST=2.0D0*RND-1.0D0 | |
33749 | RETURN | |
33750 | C | |
33751 | ELSEIF (EKIN.LT.1.0D0) THEN | |
33752 | DO 2200 K=13,60,12 | |
33753 | IF (PDCI(K).GT.EMEV) THEN | |
33754 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) | |
33755 | UNIV=DT_RNDM(UNIVE) | |
33756 | SUM=0 | |
33757 | DO 2100 I=1,11 | |
33758 | II=K+I | |
33759 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) | |
33760 | C | |
33761 | IF (UNIV.LT.SUM)THEN | |
33762 | UNIV=DT_RNDM(SUM) | |
33763 | FLTI=DBLE(I)-UNIV | |
33764 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I | |
33765 | END IF | |
33766 | 2100 CONTINUE | |
33767 | END IF | |
33768 | 2200 CONTINUE | |
33769 | ELSE | |
33770 | DO 2400 K=12,55,11 | |
33771 | IF (PDCH(K).GT.EMEV) THEN | |
33772 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) | |
33773 | UNIV=DT_RNDM(UNIVE) | |
33774 | SUM=0.0D0 | |
33775 | DO 2300 I=1,10 | |
33776 | II=K+I | |
33777 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) | |
33778 | C | |
33779 | IF (UNIV.LT.SUM)THEN | |
33780 | UNIV=DT_RNDM(SUM) | |
33781 | FLTI=UNIV+DBLE(I) | |
33782 | GOTO(50,55,60,60,65,65,65,65,70,70) I | |
33783 | END IF | |
33784 | 2300 CONTINUE | |
33785 | END IF | |
33786 | 2400 CONTINUE | |
33787 | END IF | |
33788 | C | |
33789 | 50 CST=0.4D0*UNIV | |
33790 | GOTO 2500 | |
33791 | 55 CST=0.2D0*FLTI | |
33792 | GOTO 2500 | |
33793 | 60 CST=0.3D0+0.1D0*FLTI | |
33794 | GOTO 2500 | |
33795 | 65 CST=0.6D0+0.04D0*FLTI | |
33796 | GOTO 2500 | |
33797 | 70 CST=0.78D0+0.02D0*FLTI | |
33798 | C | |
33799 | 2500 CONTINUE | |
33800 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST | |
33801 | C | |
33802 | RETURN | |
33803 | END | |
33804 | ||
33805 | *$ CREATE DT_DHADRI.FOR | |
33806 | *COPY DT_DHADRI | |
33807 | * | |
33808 | *===dhadri=============================================================* | |
33809 | * | |
33810 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) | |
33811 | ||
33812 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33813 | SAVE | |
33814 | ||
33815 | PARAMETER ( LINP = 10 , | |
33816 | & LOUT = 6 , | |
33817 | & LDAT = 9 ) | |
33818 | C | |
33819 | C----------------------------- | |
33820 | C*** INPUT VARIABLES LIST: | |
33821 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 | |
33822 | C*** GEV/C LABORATORY MOMENTUM REGION | |
33823 | C*** N - PROJECTILE HADRON INDEX | |
33824 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) | |
33825 | C*** ELAB - LABORATORY ENERGY OF N (GEV) | |
33826 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM | |
33827 | C*** ITTA - TARGET NUCLEON INDEX | |
33828 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ | |
33829 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES | |
33830 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) | |
33831 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE | |
33832 | C*** RESPECT., UNITS (GEV/C AND GEV) | |
33833 | C---------------------------- | |
33834 | ||
33835 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
33836 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33837 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33838 | & NRK(2,268),NURE(30,2) | |
33839 | * particle properties (BAMJET index convention), | |
33840 | * (dublicate of DTPART for HADRIN) | |
33841 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33842 | & K1H(110),K2H(110) | |
33843 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
33844 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), | |
33845 | & ITS(149),IS | |
33846 | COMMON /HNDRUN/ RUNTES,EFTES | |
33847 | * particle properties (BAMJET index convention) | |
33848 | CHARACTER*8 ANAME | |
33849 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33850 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33851 | * final state from HADRIN interaction | |
33852 | PARAMETER (MAXFIN=10) | |
33853 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33854 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33855 | ||
33856 | DIMENSION ITPRF(110) | |
33857 | DATA NNN/0/ | |
33858 | DATA UMODA/0./ | |
33859 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ | |
33860 | LOWP=0 | |
33861 | IF (N.LE.0.OR.N.GE.111)N=1 | |
33862 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN | |
33863 | GOTO 280 | |
33864 | * WRITE (6,1000) | |
33865 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA | |
33866 | * STOP | |
33867 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) | |
33868 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) | |
33869 | ENDIF | |
33870 | IATMPT=0 | |
33871 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 | |
33872 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB | |
33873 | C STOP | |
33874 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE | |
33875 | + ALLOWED REGION, PLAB=',1E15.5) | |
33876 | ||
33877 | 20 CONTINUE | |
33878 | UMODAT=N*1.11111D0+ITTA*2.19291D0 | |
33879 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) | |
33880 | UMODA=UMODAT | |
33881 | 30 IATMPT=0 | |
33882 | LOWP=LOWP+1 | |
33883 | 40 CONTINUE | |
33884 | IMACH=0 | |
33885 | REDU=2.0D0 | |
33886 | IF (LOWP.GT.20) THEN | |
33887 | C WRITE(LOUT,*) ' jump 1' | |
33888 | GO TO 280 | |
33889 | ENDIF | |
33890 | NNN=N | |
33891 | IF (NNN.EQ.N) GO TO 50 | |
33892 | RUNTES=0.0D0 | |
33893 | EFTES=0.0D0 | |
33894 | 50 CONTINUE | |
33895 | IS=1 | |
33896 | IRH=0 | |
33897 | IST=1 | |
33898 | NSTAB=23 | |
33899 | IRE=NURE(N,1) | |
33900 | IF(ITTA.GT.1) IRE=NURE(N,2) | |
33901 | C | |
33902 | C----------------------------- | |
33903 | C*** IE,AMT,ECM,SI DETERMINATION | |
33904 | C---------------------------- | |
33905 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) | |
33906 | IANTH=-1 | |
33907 | **sr | |
33908 | C IF (AMH(1).NE.0.93828D0) IANTH=1 | |
33909 | IF (AMH(1).NE.0.9383D0) IANTH=1 | |
33910 | ** | |
33911 | IF (IANTH.GE.0) SI=1.0D0 | |
33912 | ECMMH=ECM | |
33913 | C | |
33914 | C----------------------------- | |
33915 | C ENERGY INDEX | |
33916 | C IRE CHARACTERIZES THE REACTION | |
33917 | C IE IS THE ENERGY INDEX | |
33918 | C---------------------------- | |
33919 | IF (SI.LT.1.D-6) THEN | |
33920 | C WRITE(LOUT,*) ' jump 2' | |
33921 | GO TO 280 | |
33922 | ENDIF | |
33923 | IF (N.LE.NSTAB) GO TO 60 | |
33924 | RUNTES=RUNTES+1.0D0 | |
33925 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N | |
33926 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) | |
33927 | IF(IBARH(N).EQ.1) N=8 | |
33928 | IF(IBARH(N).EQ.-1) N=9 | |
33929 | 60 CONTINUE | |
33930 | IMACH=IMACH+1 | |
33931 | **sr 19.2.97: loop for direct channel suppression | |
33932 | C IF (IMACH.GT.10) THEN | |
33933 | IF (IMACH.GT.1000) THEN | |
33934 | ** | |
33935 | C WRITE(LOUT,*) ' jump 3' | |
33936 | GO TO 280 | |
33937 | ENDIF | |
33938 | ECM =ECMMH | |
33939 | AMN2=AMN**2 | |
33940 | AMT2=AMT**2 | |
33941 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) | |
33942 | IF(ECMN.LE.AMN) ECMN=AMN | |
33943 | PCMN=SQRT(ECMN**2-AMN2) | |
33944 | GAM=(ELAB+AMT)/ECM | |
33945 | BGAM=PLAB/ECM | |
33946 | IF (IANTH.GE.0) ECM=2.1D0 | |
33947 | C | |
33948 | C----------------------------- | |
33949 | C*** RANDOM CHOICE OF REACTION CHANNEL | |
33950 | C---------------------------- | |
33951 | IST=0 | |
33952 | VV=DT_RNDM(AMN2) | |
33953 | VV=VV-1.D-17 | |
33954 | C | |
33955 | C----------------------------- | |
33956 | C*** PLACE REDUCED VERSION | |
33957 | C---------------------------- | |
33958 | IIEI=IEII(IRE) | |
33959 | IDWK=IEII(IRE+1)-IIEI | |
33960 | IIWK=IRII(IRE) | |
33961 | IIKI=IKII(IRE) | |
33962 | C | |
33963 | C----------------------------- | |
33964 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS | |
33965 | C---------------------------- | |
33966 | HECM=ECM | |
33967 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) | |
33968 | IF (HUMO.LT.ECM) ECM=HUMO | |
33969 | C | |
33970 | C----------------------------- | |
33971 | C*** INTERPOLATION PREPARATION | |
33972 | C---------------------------- | |
33973 | ECMO=UMO(IE) | |
33974 | ECM1=UMO(IE-1) | |
33975 | DECM=ECMO-ECM1 | |
33976 | DEC=ECMO-ECM | |
33977 | C | |
33978 | C----------------------------- | |
33979 | C*** RANDOM LOOP | |
33980 | C---------------------------- | |
33981 | IK=0 | |
33982 | WKK=0.0D0 | |
33983 | WICOR=0.0D0 | |
33984 | 70 IK=IK+1 | |
33985 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI | |
33986 | WOK=WK(IWK) | |
33987 | WDK=WOK-WK(IWK-1) | |
33988 | C | |
33989 | C----------------------------- | |
33990 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK | |
33991 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT | |
33992 | C CONTRIBUTE | |
33993 | C---------------------------- | |
33994 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 | |
33995 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 | |
33996 | IF (WICO.EQ.WICOR) GO TO 70 | |
33997 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 | |
33998 | WICOR=WICO | |
33999 | C | |
34000 | C----------------------------- | |
34001 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
34002 | C---------------------------- | |
34003 | EKLIM=-THRESH(IIKI+IK) | |
34004 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
34005 | DELIM=UMO(IELIM)+EKLIM | |
34006 | *+1.D-16 | |
34007 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
34008 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 | |
34009 | 80 DECC=DELIM | |
34010 | GO TO 100 | |
34011 | 90 DECC=DECM | |
34012 | 100 CONTINUE | |
34013 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
34014 | C | |
34015 | C----------------------------- | |
34016 | C*** RANDOM CHOICE | |
34017 | C---------------------------- | |
34018 | C | |
34019 | IF (VV.GT.WKK) GO TO 70 | |
34020 | C | |
34021 | C***IK IS THE REACTION CHANNEL | |
34022 | C---------------------------- | |
34023 | INRK=IKII(IRE)+IK | |
34024 | ECM=HECM | |
34025 | I1001 =0 | |
34026 | C | |
34027 | 110 CONTINUE | |
34028 | IT1=NRK(1,INRK) | |
34029 | AM1=DT_DAMG(IT1) | |
34030 | IT2=NRK(2,INRK) | |
34031 | AM2=DT_DAMG(IT2) | |
34032 | AMS=AM1+AM2 | |
34033 | I1001=I1001+1 | |
34034 | IF (I1001.GT.50) GO TO 60 | |
34035 | C | |
34036 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 | |
34037 | IT11=IT1 | |
34038 | IT22=IT2 | |
34039 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 | |
34040 | AM11=AM1 | |
34041 | AM22=AM2 | |
34042 | IF (IT2.GT.0) GO TO 120 | |
34043 | **sr 19.2.97: supress direct channel for pp-collisions | |
34044 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN | |
34045 | RR = DT_RNDM(AM11) | |
34046 | IF (RR.LE.0.75D0) GOTO 60 | |
34047 | ENDIF | |
34048 | ** | |
34049 | C | |
34050 | C----------------------------- | |
34051 | C INCLUSION OF DIRECT RESONANCES | |
34052 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 | |
34053 | C------------------------ | |
34054 | KZ1=K1H(IT1) | |
34055 | IST=IST+1 | |
34056 | IECO=0 | |
34057 | ECO=ECM | |
34058 | GAM=(ELAB+AMT)/ECO | |
34059 | BGAM=PLAB/ECO | |
34060 | CXS(1)=CX | |
34061 | CYS(1)=CY | |
34062 | CZS(1)=CZ | |
34063 | GO TO 170 | |
34064 | 120 CONTINUE | |
34065 | WW=DT_RNDM(ECO) | |
34066 | IF(WW.LT. 0.5D0) GO TO 130 | |
34067 | IT1=IT22 | |
34068 | IT2=IT11 | |
34069 | AM1=AM22 | |
34070 | AM2=AM11 | |
34071 | 130 CONTINUE | |
34072 | C | |
34073 | C----------------------------- | |
34074 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T | |
34075 | IBN=IBARH(N) | |
34076 | IB1=IBARH(IT1) | |
34077 | IT11=IT1 | |
34078 | IT22=IT2 | |
34079 | AM11=AM1 | |
34080 | AM22=AM2 | |
34081 | IF(IB1.EQ.IBN) GO TO 140 | |
34082 | IT1=IT22 | |
34083 | IT2=IT11 | |
34084 | AM1=AM22 | |
34085 | AM2=AM11 | |
34086 | 140 CONTINUE | |
34087 | C----------------------------- | |
34088 | C***IT1,IT2 ARE THE CREATED PARTICLES | |
34089 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM | |
34090 | C------------------------ | |
34091 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34092 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) | |
34093 | IST=IST+1 | |
34094 | ITS(IST)=IT1 | |
34095 | AMM(IST)=AM1 | |
34096 | C | |
34097 | C----------------------------- | |
34098 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION | |
34099 | C---------------------------- | |
34100 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, | |
34101 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34102 | IST=IST+1 | |
34103 | ITS(IST)=IT2 | |
34104 | AMM(IST)=AM2 | |
34105 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, | |
34106 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34107 | 150 CONTINUE | |
34108 | C | |
34109 | C----------------------------- | |
34110 | C***TEST STABLE OR UNSTABLE | |
34111 | C---------------------------- | |
34112 | IF(ITS(IST).GT.NSTAB) GO TO 160 | |
34113 | IRH=IRH+1 | |
34114 | C | |
34115 | C----------------------------- | |
34116 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE | |
34117 | C---------------------------- | |
34118 | C* IF (REDU.LT.0.D0) GO TO 1009 | |
34119 | ITRH(IRH)=ITS(IST) | |
34120 | PLRH(IRH)=PLS(IST) | |
34121 | CXRH(IRH)=CXS(IST) | |
34122 | CYRH(IRH)=CYS(IST) | |
34123 | CZRH(IRH)=CZS(IST) | |
34124 | ELRH(IRH)=ELS(IST) | |
34125 | IST=IST-1 | |
34126 | IF(IST.GE.1) GO TO 150 | |
34127 | GO TO 260 | |
34128 | 160 CONTINUE | |
34129 | C | |
34130 | C RANDOM CHOICE OF DECAY CHANNELS | |
34131 | C---------------------------- | |
34132 | C | |
34133 | IT=ITS(IST) | |
34134 | ECO=AMM(IST) | |
34135 | GAM=ELS(IST)/ECO | |
34136 | BGAM=PLS(IST)/ECO | |
34137 | IECO=0 | |
34138 | KZ1=K1H(IT) | |
34139 | 170 CONTINUE | |
34140 | IECO=IECO+1 | |
34141 | VV=DT_RNDM(GAM) | |
34142 | VV=VV-1.D-17 | |
34143 | IIK=KZ1-1 | |
34144 | 180 IIK=IIK+1 | |
34145 | IF (VV.GT.WTI(IIK)) GO TO 180 | |
34146 | C | |
34147 | C IIK IS THE DECAY CHANNEL | |
34148 | C---------------------------- | |
34149 | IT1=NZKI(IIK,1) | |
34150 | I310=0 | |
34151 | 190 CONTINUE | |
34152 | I310=I310+1 | |
34153 | AM1=DT_DAMG(IT1) | |
34154 | IT2=NZKI(IIK,2) | |
34155 | AM2=DT_DAMG(IT2) | |
34156 | IF (IT2-1.LT.0) GO TO 240 | |
34157 | IT3=NZKI(IIK,3) | |
34158 | AM3=DT_DAMG(IT3) | |
34159 | AMS=AM1+AM2+AM3 | |
34160 | C | |
34161 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE | |
34162 | C---------------------------- | |
34163 | IF (IECO.LE.10) GO TO 200 | |
34164 | IATMPT=IATMPT+1 | |
34165 | IF(IATMPT.GT.3) THEN | |
34166 | C WRITE(LOUT,*) ' jump 4' | |
34167 | GO TO 280 | |
34168 | ENDIF | |
34169 | GO TO 40 | |
34170 | 200 CONTINUE | |
34171 | IF (I310.GT.50) GO TO 170 | |
34172 | IF (AMS.GT.ECO) GO TO 190 | |
34173 | C | |
34174 | C FOR THE DECAY CHANNEL | |
34175 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT | |
34176 | C---------------------------- | |
34177 | IF (REDU.LT.0.D0) GO TO 30 | |
34178 | ITWTHC=0 | |
34179 | REDU=2.0D0 | |
34180 | IF(IT3.EQ.0) GO TO 220 | |
34181 | 210 CONTINUE | |
34182 | ITWTH=1 | |
34183 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, | |
34184 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
34185 | GO TO 230 | |
34186 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, | |
34187 | &COD2,COF2,SIF2,AM1,AM2) | |
34188 | ITWTH=-1 | |
34189 | IT3=0 | |
34190 | 230 CONTINUE | |
34191 | ITWTHC=ITWTHC+1 | |
34192 | IF (REDU.GT.0.D0) GO TO 240 | |
34193 | REDU=2.0D0 | |
34194 | IF (ITWTHC.GT.100) GO TO 30 | |
34195 | IF (ITWTH) 220,220,210 | |
34196 | 240 CONTINUE | |
34197 | ITS(IST )=IT1 | |
34198 | IF (IT2-1.LT.0) GO TO 250 | |
34199 | ITS(IST+1) =IT2 | |
34200 | ITS(IST+2)=IT3 | |
34201 | RX=CXS(IST) | |
34202 | RY=CYS(IST) | |
34203 | RZ=CZS(IST) | |
34204 | AMM(IST)=AM1 | |
34205 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, | |
34206 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34207 | IST=IST+1 | |
34208 | AMM(IST)=AM2 | |
34209 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, | |
34210 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34211 | IF (IT3.LE.0) GO TO 250 | |
34212 | IST=IST+1 | |
34213 | AMM(IST)=AM3 | |
34214 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, | |
34215 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34216 | 250 CONTINUE | |
34217 | GO TO 150 | |
34218 | 260 CONTINUE | |
34219 | 270 CONTINUE | |
34220 | RETURN | |
34221 | 280 CONTINUE | |
34222 | C | |
34223 | C---------------------------- | |
34224 | C | |
34225 | C ZERO CROSS SECTION CASE | |
34226 | C---------------------------- | |
34227 | C | |
34228 | IRH=1 | |
34229 | ITRH(1)=N | |
34230 | CXRH(1)=CX | |
34231 | CYRH(1)=CY | |
34232 | CZRH(1)=CZ | |
34233 | ELRH(1)=ELAB | |
34234 | PLRH(1)=PLAB | |
34235 | RETURN | |
34236 | END | |
34237 | ||
34238 | *$ CREATE DT_RUNTT.FOR | |
34239 | *COPY DT_RUNTT | |
34240 | * | |
34241 | *===runtt==============================================================* | |
34242 | * | |
34243 | BLOCK DATA DT_RUNTT | |
34244 | ||
34245 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34246 | SAVE | |
34247 | ||
34248 | COMMON /HNDRUN/ RUNTES,EFTES | |
34249 | ||
34250 | DATA RUNTES,EFTES /100.D0,100.D0/ | |
34251 | ||
34252 | END | |
34253 | ||
34254 | *$ CREATE DT_NONAME.FOR | |
34255 | *COPY DT_NONAME | |
34256 | * | |
34257 | *===noname=============================================================* | |
34258 | * | |
34259 | BLOCK DATA DT_NONAME | |
34260 | ||
34261 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34262 | SAVE | |
34263 | ||
34264 | * slope parameters for HADRIN interactions | |
34265 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34266 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34267 | ||
34268 | C DATAS DATAS DATAS DATAS DATAS | |
34269 | C****** ********* | |
34270 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, | |
34271 | & 207, 224, 241, 252, 268 / | |
34272 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, | |
34273 | & 220, 241, 262, 279, 296 / | |
34274 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, | |
34275 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ | |
34276 | ||
34277 | C | |
34278 | C MASSES FOR THE SLOPE B(M) IN GEV | |
34279 | C SLOPE B(M) FOR AN MESONIC SYSTEM | |
34280 | C SLOPE B(M) FOR A BARYONIC SYSTEM | |
34281 | ||
34282 | * | |
34283 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, | |
34284 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, | |
34285 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, | |
34286 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, | |
34287 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, | |
34288 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, | |
34289 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, | |
34290 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, | |
34291 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, | |
34292 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, | |
34293 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, | |
34294 | & 14.2D0, 13.4D0, 12.6D0, | |
34295 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, | |
34296 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / | |
34297 | * | |
34298 | END | |
34299 | ||
34300 | *$ CREATE DT_DAMG.FOR | |
34301 | *COPY DT_DAMG | |
34302 | * | |
34303 | *===damg===============================================================* | |
34304 | * | |
34305 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) | |
34306 | ||
34307 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34308 | SAVE | |
34309 | ||
34310 | * particle properties (BAMJET index convention), | |
34311 | * (dublicate of DTPART for HADRIN) | |
34312 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34313 | & K1H(110),K2H(110) | |
34314 | ||
34315 | DIMENSION GASUNI(14) | |
34316 | DATA GASUNI/ | |
34317 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, | |
34318 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ | |
34319 | DATA GAUNO/2.352D0/ | |
34320 | DATA GAUNON/2.4D0/ | |
34321 | DATA IO/14/ | |
34322 | DATA NSTAB/23/ | |
34323 | ||
34324 | I=1 | |
34325 | IF (IT.LE.0) GO TO 30 | |
34326 | IF (IT.LE.NSTAB) GO TO 20 | |
34327 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) | |
34328 | VV=DT_RNDM(DGAUNI) | |
34329 | VV=VV*2.0D0-1.0D0+1.D-16 | |
34330 | 10 CONTINUE | |
34331 | VO=GASUNI(I) | |
34332 | I=I+1 | |
34333 | V1=GASUNI(I) | |
34334 | IF (VV.GT.V1) GO TO 10 | |
34335 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ | |
34336 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) | |
34337 | DAM=GAH(IT)*UNIGA/GAUNO | |
34338 | AAM=AMH(IT)+DAM | |
34339 | DT_DAMG=AAM | |
34340 | RETURN | |
34341 | 20 CONTINUE | |
34342 | DT_DAMG=AMH(IT) | |
34343 | RETURN | |
34344 | 30 CONTINUE | |
34345 | DT_DAMG=0.0D0 | |
34346 | RETURN | |
34347 | END | |
34348 | ||
34349 | *$ CREATE DT_DCALUM.FOR | |
34350 | *COPY DT_DCALUM | |
34351 | * | |
34352 | *===dcalum=============================================================* | |
34353 | * | |
34354 | SUBROUTINE DT_DCALUM(N,ITTA) | |
34355 | ||
34356 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34357 | SAVE | |
34358 | ||
34359 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION | |
34360 | ||
34361 | * particle properties (BAMJET index convention), | |
34362 | * (dublicate of DTPART for HADRIN) | |
34363 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34364 | & K1H(110),K2H(110) | |
34365 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34366 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34367 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34368 | & NRK(2,268),NURE(30,2) | |
34369 | ||
34370 | IRE=NURE(N,ITTA/8+1) | |
34371 | IEO=IEII(IRE)+1 | |
34372 | IEE=IEII(IRE +1) | |
34373 | AM1=AMH(N ) | |
34374 | AM12=AM1**2 | |
34375 | AM2=AMH(ITTA) | |
34376 | AM22=AM2**2 | |
34377 | DO 10 IE=IEO,IEE | |
34378 | PLAB2=PLABF(IE)**2 | |
34379 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) | |
34380 | UMO(IE)=ELAB | |
34381 | 10 CONTINUE | |
34382 | IKO=IKII(IRE)+1 | |
34383 | IKE=IKII(IRE +1) | |
34384 | UMOO=UMO(IEO) | |
34385 | DO 30 IK=IKO,IKE | |
34386 | IF(NRK(2,IK).GT.0) GO TO 30 | |
34387 | IKI=NRK(1,IK) | |
34388 | AMSS=5.0D0 | |
34389 | K11=K1H(IKI) | |
34390 | K22=K2H(IKI) | |
34391 | DO 20 IK1=K11,K22 | |
34392 | IN=NZKI(IK1,1) | |
34393 | AMS=AMH(IN) | |
34394 | IN=NZKI(IK1,2) | |
34395 | IF(IN.GT.0)AMS=AMS+AMH(IN) | |
34396 | IN=NZKI(IK1,3) | |
34397 | IF(IN.GT.0) AMS=AMS+AMH(IN) | |
34398 | IF (AMS.LT.AMSS) AMSS=AMS | |
34399 | 20 CONTINUE | |
34400 | IF(UMOO.LT.AMSS) UMOO=AMSS | |
34401 | THRESH(IK)=UMOO | |
34402 | 30 CONTINUE | |
34403 | RETURN | |
34404 | END | |
34405 | ||
34406 | *$ CREATE DT_DCHANH.FOR | |
34407 | *COPY DT_DCHANH | |
34408 | * | |
34409 | *===dchanh=============================================================* | |
34410 | * | |
34411 | SUBROUTINE DT_DCHANH | |
34412 | ||
34413 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34414 | SAVE | |
34415 | ||
34416 | PARAMETER ( LINP = 10 , | |
34417 | & LOUT = 6 , | |
34418 | & LDAT = 9 ) | |
34419 | * particle properties (BAMJET index convention), | |
34420 | * (dublicate of DTPART for HADRIN) | |
34421 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34422 | & K1H(110),K2H(110) | |
34423 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34424 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34425 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34426 | & NRK(2,268),NURE(30,2) | |
34427 | ||
34428 | DIMENSION HWT(460),HWK(40),SI(5184) | |
34429 | EQUIVALENCE (WK(1),SI(1)) | |
34430 | C-------------------- | |
34431 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN | |
34432 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, | |
34433 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. | |
34434 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE | |
34435 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) | |
34436 | C-------------------------- | |
34437 | IREG=16 | |
34438 | DO 90 IRE=1,IREG | |
34439 | IWKO=IRII(IRE) | |
34440 | IEE=IEII(IRE+1)-IEII(IRE) | |
34441 | IKE=IKII(IRE+1)-IKII(IRE) | |
34442 | IEO=IEII(IRE)+1 | |
34443 | IIKA=IKII(IRE) | |
34444 | * modifications to suppress elestic scattering 24/07/91 | |
34445 | DO 80 IE=1,IEE | |
34446 | SIS=1.D-14 | |
34447 | SINORC=0.0D0 | |
34448 | DO 10 IK=1,IKE | |
34449 | IWK=IWKO+IEE*(IK-1)+IE | |
34450 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34451 | SIS=SIS+SI(IWK)*SINORC | |
34452 | 10 CONTINUE | |
34453 | SIIN(IEO+IE-1)=SIS | |
34454 | SIO=0.D0 | |
34455 | IF (SIS.GE.1.D-12) GO TO 20 | |
34456 | SIS=1.D0 | |
34457 | SIO=1.D0 | |
34458 | 20 CONTINUE | |
34459 | SINORC=0.0D0 | |
34460 | DO 30 IK=1,IKE | |
34461 | IWK=IWKO+IEE*(IK-1)+IE | |
34462 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34463 | SIO=SIO+SI(IWK)*SINORC/SIS | |
34464 | HWK(IK)=SIO | |
34465 | 30 CONTINUE | |
34466 | DO 40 IK=1,IKE | |
34467 | IWK=IWKO+IEE*(IK-1)+IE | |
34468 | 40 WK(IWK)=HWK(IK) | |
34469 | IIKI=IKII(IRE) | |
34470 | DO 70 IK=1,IKE | |
34471 | AM111=0.D0 | |
34472 | INRK1=NRK(1,IIKI+IK) | |
34473 | IF (INRK1.GT.0) AM111=AMH(INRK1) | |
34474 | AM222=0.D0 | |
34475 | INRK2=NRK(2,IIKI+IK) | |
34476 | IF (INRK2.GT.0) AM222=AMH(INRK2) | |
34477 | THRESH(IIKI+IK)=AM111 +AM222 | |
34478 | IF (INRK2-1.GE.0) GO TO 60 | |
34479 | INRKK=K1H(INRK1) | |
34480 | AMSS=5.D0 | |
34481 | INRKO=K2H(INRK1) | |
34482 | DO 50 INRK1=INRKK,INRKO | |
34483 | INZK1=NZKI(INRK1,1) | |
34484 | INZK2=NZKI(INRK1,2) | |
34485 | INZK3=NZKI(INRK1,3) | |
34486 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 | |
34487 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 | |
34488 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 | |
34489 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 | |
34490 | 1000 FORMAT (4I10) | |
34491 | AMS=AMH(INZK1)+AMH(INZK2) | |
34492 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) | |
34493 | IF (AMSS.GT.AMS) AMSS=AMS | |
34494 | 50 CONTINUE | |
34495 | AMS=AMSS | |
34496 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) | |
34497 | THRESH(IIKI+IK)=AMS | |
34498 | 60 CONTINUE | |
34499 | 70 CONTINUE | |
34500 | 80 CONTINUE | |
34501 | 90 CONTINUE | |
34502 | DO 100 J=1,460 | |
34503 | 100 HWT(J)=0.D0 | |
34504 | DO 120 I=1,110 | |
34505 | IK1=K1H(I) | |
34506 | IK2=K2H(I) | |
34507 | HV=0.D0 | |
34508 | IF (IK2.GT.460)IK2=460 | |
34509 | IF (IK1.LE.0)IK1=1 | |
34510 | DO 110 J=IK1,IK2 | |
34511 | HV=HV+WTI(J) | |
34512 | HWT(J)=HV | |
34513 | JI=J | |
34514 | 110 CONTINUE | |
34515 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV | |
34516 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) | |
34517 | 120 CONTINUE | |
34518 | DO 130 J=1,460 | |
34519 | 130 WTI(J)=HWT(J) | |
34520 | RETURN | |
34521 | END | |
34522 | ||
34523 | *$ CREATE DT_DHADDE.FOR | |
34524 | *COPY DT_DHADDE | |
34525 | * | |
34526 | *===dhadde=============================================================* | |
34527 | * | |
34528 | SUBROUTINE DT_DHADDE | |
34529 | ||
34530 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34531 | SAVE | |
34532 | ||
34533 | * particle properties (BAMJET index convention) | |
34534 | CHARACTER*8 ANAME | |
34535 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
34536 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
34537 | * HADRIN: decay channel information | |
34538 | PARAMETER (IDMAX9=602) | |
34539 | CHARACTER*8 ZKNAME | |
34540 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
34541 | * particle properties (BAMJET index convention), | |
34542 | * (dublicate of DTPART for HADRIN) | |
34543 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34544 | & K1H(110),K2H(110) | |
34545 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34546 | * decay channel information for HADRIN | |
34547 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34548 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34549 | & NZK1(153),NZK2(153),NZK3(153) | |
34550 | ||
34551 | DATA IRETUR/0/ | |
34552 | ||
34553 | IRETUR=IRETUR+1 | |
34554 | AMH(31)=0.48D0 | |
34555 | IF (IRETUR.GT.1) RETURN | |
34556 | DO 10 I=1,94 | |
34557 | AMH(I) = AAM(I) | |
34558 | GAH(I) = GA(I) | |
34559 | TAUH(I) = TAU(I) | |
34560 | ICHH(I) = IICH(I) | |
34561 | IBARH(I) = IIBAR(I) | |
34562 | K1H(I) = K1(I) | |
34563 | K2H(I) = K2(I) | |
34564 | 10 CONTINUE | |
34565 | **sr | |
34566 | C AMH(1)=0.93828D0 | |
34567 | AMH(1)=0.9383D0 | |
34568 | ** | |
34569 | AMH(2)=AMH(1) | |
34570 | DO 20 I=26,30 | |
34571 | K1H(I)=452 | |
34572 | K2H(I)=452 | |
34573 | 20 CONTINUE | |
34574 | DO 30 I=1,307 | |
34575 | WTI(I) = WT(I) | |
34576 | NZKI(I,1) = NZK(I,1) | |
34577 | NZKI(I,2) = NZK(I,2) | |
34578 | NZKI(I,3) = NZK(I,3) | |
34579 | 30 CONTINUE | |
34580 | DO 40 I=1,16 | |
34581 | L=I+94 | |
34582 | AMH(L)=AMZ(I) | |
34583 | GAH( L)=GAZ(I) | |
34584 | TAUH( L)=TAUZ(I) | |
34585 | ICHH( L)=ICHZ(I) | |
34586 | IBARH( L)=IBARZ(I) | |
34587 | K1H( L)=K1Z(I) | |
34588 | K2H( L)=K2Z(I) | |
34589 | 40 CONTINUE | |
34590 | DO 50 I=1,153 | |
34591 | L=I+307 | |
34592 | WTI(L) = WTZ(I) | |
34593 | NZKI(L,3) = NZK3(I) | |
34594 | NZKI(L,2) = NZK2(I) | |
34595 | NZKI(L,1) = NZK1(I) | |
34596 | 50 CONTINUE | |
34597 | RETURN | |
34598 | END | |
34599 | ||
34600 | *$ CREATE IDT_IEFUND.FOR | |
34601 | *COPY IDT_IEFUND | |
34602 | * | |
34603 | *===iefund=============================================================* | |
34604 | * | |
34605 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) | |
34606 | ||
34607 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34608 | SAVE | |
34609 | ||
34610 | C*****IEFUN CALCULATES A MOMENTUM INDEX | |
34611 | ||
34612 | PARAMETER ( LINP = 10 , | |
34613 | & LOUT = 6 , | |
34614 | & LDAT = 9 ) | |
34615 | COMMON /HNDRUN/ RUNTES,EFTES | |
34616 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34617 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34618 | & NRK(2,268),NURE(30,2) | |
34619 | ||
34620 | IPLA=IEII(IRE)+1 | |
34621 | *+1 | |
34622 | IPLE=IEII(IRE+1) | |
34623 | IF (PL.LT.0.) GO TO 30 | |
34624 | DO 10 I=IPLA,IPLE | |
34625 | J=I-IPLA+1 | |
34626 | IF (PL.LE.PLABF(I)) GO TO 60 | |
34627 | 10 CONTINUE | |
34628 | I=IPLE | |
34629 | IF ( EFTES.GT.40.D0) GO TO 20 | |
34630 | EFTES=EFTES+1.0D0 | |
34631 | WRITE(LOUT,1000)PL,J | |
34632 | 20 CONTINUE | |
34633 | GO TO 70 | |
34634 | 30 CONTINUE | |
34635 | DO 40 I=IPLA,IPLE | |
34636 | J=I-IPLA+1 | |
34637 | IF (-PL.LE.UMO(I)) GO TO 60 | |
34638 | 40 CONTINUE | |
34639 | I=IPLE | |
34640 | IF ( EFTES.GT.40.D0) GO TO 50 | |
34641 | EFTES=EFTES+1.0D0 | |
34642 | WRITE(LOUT,1000)PL,I | |
34643 | 50 CONTINUE | |
34644 | 60 CONTINUE | |
34645 | 70 CONTINUE | |
34646 | IDT_IEFUND=I | |
34647 | RETURN | |
34648 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , | |
34649 | +7H IEFUN=,I5) | |
34650 | END | |
34651 | ||
34652 | *$ CREATE DT_DSIGIN.FOR | |
34653 | *COPY DT_DSIGIN | |
34654 | * | |
34655 | *===dsigin=============================================================* | |
34656 | * | |
34657 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) | |
34658 | ||
34659 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34660 | SAVE | |
34661 | ||
34662 | * particle properties (BAMJET index convention), | |
34663 | * (dublicate of DTPART for HADRIN) | |
34664 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34665 | & K1H(110),K2H(110) | |
34666 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34667 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34668 | & NRK(2,268),NURE(30,2) | |
34669 | ||
34670 | IE=IDT_IEFUND(PLAB,IRE) | |
34671 | IF (IE.LE.IEII(IRE)) IE=IE+1 | |
34672 | AMT=AMH(ITAR) | |
34673 | AMN=AMH(N) | |
34674 | AMN2=AMN*AMN | |
34675 | AMT2=AMT*AMT | |
34676 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) | |
34677 | C*** INTERPOLATION PREPARATION | |
34678 | ECMO=UMO(IE) | |
34679 | ECM1=UMO(IE-1) | |
34680 | DECM=ECMO-ECM1 | |
34681 | DEC=ECMO-ECM | |
34682 | IIKI=IKII(IRE)+1 | |
34683 | EKLIM=-THRESH(IIKI) | |
34684 | WOK=SIIN(IE) | |
34685 | WDK=WOK-SIIN(IE-1) | |
34686 | IF (ECM.GT.ECMO) WDK=0.0D0 | |
34687 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
34688 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
34689 | DELIM=UMO(IELIM)+EKLIM | |
34690 | *+1.D-16 | |
34691 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
34692 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 | |
34693 | 10 DECC=DELIM | |
34694 | GO TO 30 | |
34695 | 20 DECC=DECM | |
34696 | 30 CONTINUE | |
34697 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
34698 | IF (WKK.LT.0.0D0) WKK=0.0D0 | |
34699 | SI=WKK+1.D-12 | |
34700 | IF (-EKLIM.GT.ECM) SI=1.D-14 | |
34701 | RETURN | |
34702 | END | |
34703 | ||
34704 | *$ CREATE DT_DTCHOI.FOR | |
34705 | *COPY DT_DTCHOI | |
34706 | * | |
34707 | *===dtchoi=============================================================* | |
34708 | * | |
34709 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) | |
34710 | ||
34711 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34712 | SAVE | |
34713 | ||
34714 | C **************************** | |
34715 | C TCHOIC CALCULATES A RANDOM VALUE | |
34716 | C FOR THE FOUR-MOMENTUM-TRANSFER T | |
34717 | C **************************** | |
34718 | ||
34719 | * particle properties (BAMJET index convention), | |
34720 | * (dublicate of DTPART for HADRIN) | |
34721 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34722 | & K1H(110),K2H(110) | |
34723 | * slope parameters for HADRIN interactions | |
34724 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34725 | ||
34726 | AMA=AM1 | |
34727 | AMB=AM2 | |
34728 | IF (I.GT.30.AND.II.GT.30) GO TO 20 | |
34729 | III=II | |
34730 | AM3=AM2 | |
34731 | IF (I.LE.30) GO TO 10 | |
34732 | III=I | |
34733 | AM3=AM1 | |
34734 | 10 CONTINUE | |
34735 | GO TO 30 | |
34736 | 20 CONTINUE | |
34737 | III=II | |
34738 | AM3=AM2 | |
34739 | IF (AMA.LE.AMB) GO TO 30 | |
34740 | III=I | |
34741 | AM3=AM1 | |
34742 | 30 CONTINUE | |
34743 | IB=IBARH(III) | |
34744 | AMA=AM3 | |
34745 | K=INT((AMA-0.75D0)/0.05D0) | |
34746 | IF (K-2.LT.0) K=1 | |
34747 | IF (K-26.GE.0) K=25 | |
34748 | IF (IB)50,40,50 | |
34749 | 40 BM=BBM(K) | |
34750 | GO TO 60 | |
34751 | 50 BM=BBB(K) | |
34752 | 60 CONTINUE | |
34753 | C NORMALIZATION | |
34754 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 | |
34755 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 | |
34756 | VB=DT_RNDM(TMIN) | |
34757 | **sr test | |
34758 | C IF (VB.LT.0.2D0) BM=BM*0.1 | |
34759 | C **0.5 | |
34760 | BM = BM*5.05D0 | |
34761 | ** | |
34762 | TMI=BM*TMIN | |
34763 | TMA=BM*TMAX | |
34764 | ETMA=0.D0 | |
34765 | IF (ABS(TMA).GT.120.D0) GO TO 70 | |
34766 | ETMA=EXP(TMA) | |
34767 | 70 CONTINUE | |
34768 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) | |
34769 | C*** RANDOM CHOICE OF THE T - VALUE | |
34770 | R=DT_RNDM(TMI) | |
34771 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) | |
34772 | RETURN | |
34773 | END | |
34774 | ||
34775 | *$ CREATE DT_DTWOPA.FOR | |
34776 | *COPY DT_DTWOPA | |
34777 | * | |
34778 | *===dtwopa=============================================================* | |
34779 | * | |
34780 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34781 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) | |
34782 | ||
34783 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34784 | SAVE | |
34785 | ||
34786 | C ****************************************************** | |
34787 | C QUASI TWO PARTICLE PRODUCTION | |
34788 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA | |
34789 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 | |
34790 | C IN THE CM - SYSTEM | |
34791 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR | |
34792 | C SPHERICAL COORDINATES | |
34793 | C ****************************************************** | |
34794 | ||
34795 | * particle properties (BAMJET index convention), | |
34796 | * (dublicate of DTPART for HADRIN) | |
34797 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34798 | & K1H(110),K2H(110) | |
34799 | ||
34800 | AMA=AM1 | |
34801 | AMB=AM2 | |
34802 | AMA2=AMA*AMA | |
34803 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) | |
34804 | E2=UMOO - E1 | |
34805 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 | |
34806 | AMTE=(E1-AMA)*(E1+AMA) | |
34807 | AMTE=AMTE+1.D-18 | |
34808 | P1=SQRT(AMTE) | |
34809 | P2=P1 | |
34810 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS | |
34811 | C DETERMINATION OF THE ANGLES | |
34812 | C COS(THETA1)=COD1 COS(THETA2)=COD2 | |
34813 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 | |
34814 | C COS(PHI1)=COF1 COS(PHI2)=COF2 | |
34815 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) | |
34816 | CALL DT_DSFECF(COF1,SIF1) | |
34817 | COF2=-COF1 | |
34818 | SIF2=-SIF1 | |
34819 | C CALCULATION OF THETA1 | |
34820 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) | |
34821 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) | |
34822 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 | |
34823 | COD2=-COD1 | |
34824 | RETURN | |
34825 | END | |
34826 | ||
34827 | *$ CREATE DT_ZK.FOR | |
34828 | *COPY DT_ZK | |
34829 | * | |
34830 | *===zk=================================================================* | |
34831 | * | |
34832 | BLOCK DATA DT_ZK | |
34833 | ||
34834 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34835 | SAVE | |
34836 | ||
34837 | * decay channel information for HADRIN | |
34838 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34839 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34840 | & NZK1(153),NZK2(153),NZK3(153) | |
34841 | * decay channel information for HADRIN | |
34842 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 | |
34843 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) | |
34844 | ||
34845 | * Particle masses in GeV * | |
34846 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, | |
34847 | & 2*1.7D0, 3*0.D0/ | |
34848 | * Resonance width Gamma in GeV * | |
34849 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / | |
34850 | * Mean life time in seconds * | |
34851 | DATA TAUZ / 16*0.D0 / | |
34852 | * Charge of particles and resonances * | |
34853 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / | |
34854 | * Baryonic charge * | |
34855 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / | |
34856 | * First number of decay channels used for resonances * | |
34857 | * and decaying particles * | |
34858 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, | |
34859 | & 3*460/ | |
34860 | * Last number of decay channels used for resonances * | |
34861 | * and decaying particles * | |
34862 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, | |
34863 | & 3*460/ | |
34864 | * Weight of decay channel * | |
34865 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, | |
34866 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, | |
34867 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, | |
34868 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, | |
34869 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, | |
34870 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, | |
34871 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, | |
34872 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, | |
34873 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, | |
34874 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, | |
34875 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, | |
34876 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, | |
34877 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, | |
34878 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, | |
34879 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, | |
34880 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, | |
34881 | & .05D0, .65D0, 9*1.D0 / | |
34882 | * Particle numbers in decay channel * | |
34883 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, | |
34884 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, | |
34885 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, | |
34886 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, | |
34887 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, | |
34888 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, | |
34889 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, | |
34890 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ | |
34891 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, | |
34892 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, | |
34893 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, | |
34894 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, | |
34895 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, | |
34896 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, | |
34897 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, | |
34898 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, | |
34899 | & 1, 8, 1, 8, 1, 9*0 / | |
34900 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, | |
34901 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, | |
34902 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, | |
34903 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, | |
34904 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, | |
34905 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / | |
34906 | * Particle names * | |
34907 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', | |
34908 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', | |
34909 | & 3*'BLANK' / | |
34910 | * Name of decay channel * | |
34911 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', | |
34912 | & 'ANNPI0','APPPI0','ANPPI-'/ | |
34913 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', | |
34914 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', | |
34915 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', | |
34916 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', | |
34917 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', | |
34918 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', | |
34919 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', | |
34920 | & 'OMOMOM', | |
34921 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', | |
34922 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', | |
34923 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', | |
34924 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', | |
34925 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', | |
34926 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ | |
34927 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', | |
34928 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', | |
34929 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', | |
34930 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', | |
34931 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', | |
34932 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', | |
34933 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', | |
34934 | & 9*'BLANK'/ | |
34935 | *= end*block.zk * | |
34936 | END | |
34937 | ||
34938 | *$ CREATE DT_BLKD43.FOR | |
34939 | *COPY DT_BLKD43 | |
34940 | * | |
34941 | *===blkd43=============================================================* | |
34942 | * | |
34943 | BLOCK DATA DT_BLKD43 | |
34944 | ||
34945 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34946 | SAVE | |
34947 | ||
34948 | * | |
34949 | *=== reac =============================================================* | |
34950 | * | |
34951 | *----------------------------------------------------------------------* | |
34952 | * * | |
34953 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * | |
34954 | * Infn - Milan * | |
34955 | * * | |
34956 | * Last change on 10-dec-91 by Alfredo Ferrari * | |
34957 | * * | |
34958 | * This is the original common reac of Hadrin * | |
34959 | * * | |
34960 | *----------------------------------------------------------------------* | |
34961 | * | |
34962 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34963 | & NRK(2,268),NURE(30,2) | |
34964 | ||
34965 | DIMENSION | |
34966 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), | |
34967 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), | |
34968 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), | |
34969 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), | |
34970 | & SPIKP5(187), SPIKP6(289), | |
34971 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), | |
34972 | & SPIKP9(143), SPIKP0(169), SPKPV(143), | |
34973 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), | |
34974 | & SANPEL(84) , SPIKPF(273), | |
34975 | & SPKP15(187), SPKP16(272), | |
34976 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), | |
34977 | & NURELN(60) | |
34978 | * | |
34979 | DIMENSION NRKLIN(532) | |
34980 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
34981 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) | |
34982 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) | |
34983 | EQUIVALENCE ( UMO(263), UMOK0(1)) | |
34984 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) | |
34985 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) | |
34986 | EQUIVALENCE ( PLABF(263), PLAK0(1)) | |
34987 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) | |
34988 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) | |
34989 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) | |
34990 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) | |
34991 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) | |
34992 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) | |
34993 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) | |
34994 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) | |
34995 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) | |
34996 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) | |
34997 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) | |
34998 | EQUIVALENCE ( WK(4913), SPKP16(1)) | |
34999 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
35000 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) | |
35001 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) | |
35002 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) | |
35003 | EQUIVALENCE (NURE(1,1), NURELN(1)) | |
35004 | * | |
35005 | **** pi- p data * | |
35006 | **** pi+ n data * | |
35007 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, | |
35008 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, | |
35009 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, | |
35010 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, | |
35011 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, | |
35012 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, | |
35013 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, | |
35014 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, | |
35015 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, | |
35016 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / | |
35017 | DATA PLAKC / | |
35018 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35019 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35020 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35021 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35022 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35023 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35024 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35025 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35026 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35027 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35028 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35029 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
35030 | DATA PLAK0 / | |
35031 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35032 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35033 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35034 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35035 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35036 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
35037 | * pp pn np nn * | |
35038 | DATA PLAP / | |
35039 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35040 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35041 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35042 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35043 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35044 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35045 | * app apn anp ann * | |
35046 | DATA PLAN / | |
35047 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35048 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35049 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35050 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35051 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35052 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35053 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35054 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35055 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35056 | DATA SIIN / 296*0.D0 / | |
35057 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35058 | & 1.557D0,1.615D0,1.6435D0, | |
35059 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35060 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35061 | & 2.735D0,2.90D0, | |
35062 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35063 | & 1.496D0,1.527D0,1.557D0, | |
35064 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35065 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35066 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35067 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35068 | & 1.496D0,1.527D0,1.557D0, | |
35069 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35070 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35071 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35072 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35073 | & 1.557D0,1.615D0,1.6435D0, | |
35074 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35075 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35076 | & 2.735D0, 2.90D0/ | |
35077 | DATA UMOKC/ 1.44D0, | |
35078 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35079 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35080 | & 3.1D0,1.44D0, | |
35081 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35082 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35083 | & 3.1D0,1.44D0, | |
35084 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35085 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35086 | & 3.1D0,1.44D0, | |
35087 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35088 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35089 | & 3.1D0/ | |
35090 | DATA UMOK0/ 1.44D0, | |
35091 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35092 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35093 | & 3.1D0,1.44D0, | |
35094 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35095 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35096 | & 3.1D0/ | |
35097 | * pp pn np nn * | |
35098 | DATA UMOP/ | |
35099 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35100 | & 3.D0,3.1D0,3.2D0, | |
35101 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35102 | & 3.D0,3.1D0,3.2D0, | |
35103 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35104 | & 3.D0,3.1D0,3.2D0/ | |
35105 | * app apn anp ann * | |
35106 | DATA UMON / | |
35107 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35108 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35109 | & 3.D0,3.1D0,3.2D0, | |
35110 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35111 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35112 | & 3.D0,3.1D0,3.2D0, | |
35113 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35114 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35115 | & 3.D0,3.1D0,3.2D0/ | |
35116 | **** reaction channel state particles * | |
35117 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, | |
35118 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, | |
35119 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, | |
35120 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, | |
35121 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, | |
35122 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, | |
35123 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, | |
35124 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, | |
35125 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, | |
35126 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ | |
35127 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, | |
35128 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, | |
35129 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, | |
35130 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, | |
35131 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, | |
35132 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, | |
35133 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, | |
35134 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / | |
35135 | * * | |
35136 | * k0 p k0 n ak0 p ak/ n * | |
35137 | * * | |
35138 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, | |
35139 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, | |
35140 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, | |
35141 | & 53, 47, 1, 103, 0, 93, 0/ | |
35142 | * pp pn np nn * | |
35143 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, | |
35144 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, | |
35145 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, | |
35146 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / | |
35147 | * app apn anp ann * | |
35148 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, | |
35149 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, | |
35150 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, | |
35151 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, | |
35152 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, | |
35153 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, | |
35154 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / | |
35155 | **** channel cross section * | |
35156 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, | |
35157 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, | |
35158 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, | |
35159 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, | |
35160 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, | |
35161 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, | |
35162 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, | |
35163 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, | |
35164 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, | |
35165 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, | |
35166 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, | |
35167 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, | |
35168 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, | |
35169 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, | |
35170 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, | |
35171 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, | |
35172 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, | |
35173 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, | |
35174 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, | |
35175 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / | |
35176 | **** pi+ n data * | |
35177 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, | |
35178 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35179 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35180 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35181 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, | |
35182 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, | |
35183 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, | |
35184 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, | |
35185 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, | |
35186 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, | |
35187 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, | |
35188 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, | |
35189 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, | |
35190 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, | |
35191 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, | |
35192 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, | |
35193 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, | |
35194 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, | |
35195 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, | |
35196 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35197 | * | |
35198 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35199 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, | |
35200 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, | |
35201 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, | |
35202 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, | |
35203 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, | |
35204 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, | |
35205 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, | |
35206 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, | |
35207 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, | |
35208 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, | |
35209 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, | |
35210 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, | |
35211 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, | |
35212 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, | |
35213 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35214 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, | |
35215 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, | |
35216 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, | |
35217 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / | |
35218 | **** pi- p data * | |
35219 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, | |
35220 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35221 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35222 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35223 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, | |
35224 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, | |
35225 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, | |
35226 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, | |
35227 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, | |
35228 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, | |
35229 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, | |
35230 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, | |
35231 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, | |
35232 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, | |
35233 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, | |
35234 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, | |
35235 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, | |
35236 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, | |
35237 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35238 | * | |
35239 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35240 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, | |
35241 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, | |
35242 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, | |
35243 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, | |
35244 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, | |
35245 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, | |
35246 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, | |
35247 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, | |
35248 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, | |
35249 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, | |
35250 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, | |
35251 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, | |
35252 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35253 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, | |
35254 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, | |
35255 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, | |
35256 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, | |
35257 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, | |
35258 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / | |
35259 | **** pi- n data * | |
35260 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, | |
35261 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, | |
35262 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, | |
35263 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, | |
35264 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, | |
35265 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, | |
35266 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, | |
35267 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, | |
35268 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, | |
35269 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, | |
35270 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, | |
35271 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, | |
35272 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, | |
35273 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, | |
35274 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, | |
35275 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, | |
35276 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, | |
35277 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, | |
35278 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, | |
35279 | & 3.3D0, 5.4D0, 7.D0 / | |
35280 | **** k+ p data * | |
35281 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, | |
35282 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35283 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, | |
35284 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, | |
35285 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35286 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35287 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, | |
35288 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, | |
35289 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, | |
35290 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35291 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, | |
35292 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, | |
35293 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / | |
35294 | **** k+ n data * | |
35295 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, | |
35296 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, | |
35297 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, | |
35298 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, | |
35299 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35300 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, | |
35301 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, | |
35302 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, | |
35303 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, | |
35304 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, | |
35305 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, | |
35306 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, | |
35307 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, | |
35308 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35309 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, | |
35310 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, | |
35311 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, | |
35312 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, | |
35313 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / | |
35314 | **** k- p data * | |
35315 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, | |
35316 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, | |
35317 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, | |
35318 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, | |
35319 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, | |
35320 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, | |
35321 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, | |
35322 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, | |
35323 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, | |
35324 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, | |
35325 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, | |
35326 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ | |
35327 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, | |
35328 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35329 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, | |
35330 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, | |
35331 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, | |
35332 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, | |
35333 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, | |
35334 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, | |
35335 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35336 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, | |
35337 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, | |
35338 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, | |
35339 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35340 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, | |
35341 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, | |
35342 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, | |
35343 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, | |
35344 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, | |
35345 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, | |
35346 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, | |
35347 | & 10*0.D0/ | |
35348 | ***** k- n data * | |
35349 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35350 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, | |
35351 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, | |
35352 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, | |
35353 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, | |
35354 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, | |
35355 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, | |
35356 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ | |
35357 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35358 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35359 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, | |
35360 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35361 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35362 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35363 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35364 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, | |
35365 | & .39D0, .22D0, .07D0, 0.D0, | |
35366 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35367 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, | |
35368 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, | |
35369 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35370 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35371 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, | |
35372 | & 5.10D0, 5.44D0, 5.3D0, | |
35373 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ | |
35374 | ***** p p data * | |
35375 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35376 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35377 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, | |
35378 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35379 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35380 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35381 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35382 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35383 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, | |
35384 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35385 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35386 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35387 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35388 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35389 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35390 | ***** p n data * | |
35391 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35392 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35393 | & 0.D0, 1.8D0, .2D0, 12*0.D0, | |
35394 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35395 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35396 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35397 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35398 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35399 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35400 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35401 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35402 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35403 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35404 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35405 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35406 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, | |
35407 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, | |
35408 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ | |
35409 | * nn - data * | |
35410 | * * | |
35411 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35412 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35413 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, | |
35414 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35415 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35416 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35417 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35418 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, | |
35419 | & 11.D0, 5.5D0, 3.5D0, | |
35420 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35421 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35422 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35423 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35424 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35425 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35426 | **************** ap - p - data * | |
35427 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35428 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35429 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35430 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35431 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35432 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35433 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, | |
35434 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, | |
35435 | & 1.55D0, 1.3D0, .95D0, .75D0, | |
35436 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35437 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35438 | & .01D0, .008D0, .006D0, .005D0/ | |
35439 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35440 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35441 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, | |
35442 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, | |
35443 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, | |
35444 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, | |
35445 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, | |
35446 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, | |
35447 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, | |
35448 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, | |
35449 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35450 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35451 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35452 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, | |
35453 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, | |
35454 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, | |
35455 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, | |
35456 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, | |
35457 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, | |
35458 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / | |
35459 | **************** ap - n - data * | |
35460 | DATA SAPNEL/ | |
35461 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35462 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35463 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35464 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, | |
35465 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, | |
35466 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35467 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35468 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35469 | & .01D0, .008D0, .006D0, .005D0 / | |
35470 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35471 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35472 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35473 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35474 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35475 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35476 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35477 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35478 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35479 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35480 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35481 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35482 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35483 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35484 | * * | |
35485 | * * | |
35486 | **************** an - p - data * | |
35487 | * * | |
35488 | DATA SANPEL/ | |
35489 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, | |
35490 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35491 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, | |
35492 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35493 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35494 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35495 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, | |
35496 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35497 | & .01D0, .008D0, .006D0, .005D0 / | |
35498 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35499 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35500 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35501 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35502 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35503 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35504 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35505 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35506 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35507 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35508 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35509 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35510 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35511 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35512 | **** ko - n - data * | |
35513 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, | |
35514 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35515 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, | |
35516 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35517 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35518 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35519 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35520 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, | |
35521 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, | |
35522 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, | |
35523 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, | |
35524 | & 4.85D0, 4.9D0, | |
35525 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, | |
35526 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, | |
35527 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, | |
35528 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, | |
35529 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / | |
35530 | **** ako - p - data * | |
35531 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35532 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, | |
35533 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, | |
35534 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, | |
35535 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, | |
35536 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, | |
35537 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, | |
35538 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35539 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, | |
35540 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, | |
35541 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, | |
35542 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, | |
35543 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, | |
35544 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35545 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, | |
35546 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, | |
35547 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, | |
35548 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, | |
35549 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, | |
35550 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, | |
35551 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / | |
35552 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, | |
35553 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / | |
35554 | *= end*block.blkdt3 * | |
35555 | END | |
35556 | ||
35557 | *$ CREATE DT_QEL_POL.FOR | |
35558 | *COPY DT_QEL_POL | |
35559 | * | |
35560 | *===qel_pol============================================================* | |
35561 | * | |
35562 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35563 | ||
35564 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35565 | SAVE | |
35566 | ||
35567 | CALL DT_MASS_INI | |
35568 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35569 | ||
35570 | RETURN | |
35571 | END | |
35572 | ||
35573 | *$ CREATE DT_GEN_QEL.FOR | |
35574 | *COPY DT_GEN_QEL | |
35575 | C================================================================== | |
35576 | C Generation of a Quasi-Elastic neutrino scattering | |
35577 | C================================================================== | |
35578 | * | |
35579 | *===gen_qel============================================================* | |
35580 | * | |
35581 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35582 | ||
35583 | C...Generate a quasi-elastic neutrino/antineutrino | |
35584 | C. Interaction on a nuclear target | |
35585 | C. INPUT : LTYP = neutrino type (1,...,6) | |
35586 | C. ENU (GeV) = neutrino energy | |
35587 | C---------------------------------------------------- | |
35588 | ||
35589 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35590 | SAVE | |
35591 | ||
35592 | PARAMETER ( LINP = 10 , | |
35593 | & LOUT = 6 , | |
35594 | & LDAT = 9 ) | |
35595 | PARAMETER (MAXLND=4000) | |
35596 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
35597 | * nuclear potential | |
35598 | LOGICAL LFERMI | |
35599 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
35600 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
35601 | & ETACOU(2),ICOUL,LFERMI | |
35602 | * steering flags for qel neutrino scattering modules | |
35603 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
35604 | **sr - removed (not needed) | |
35605 | C COMMON /CBAD/ LBAD, NBAD | |
35606 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 | |
35607 | ** | |
35608 | ||
35609 | DIMENSION PI(3),PO(3) | |
35610 | CJR+ | |
35611 | DATA ININU/0/ | |
35612 | CJR- | |
35613 | C REAL*8 DBETA(3) | |
35614 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 | |
35615 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) | |
35616 | DATA AMN /0.93827231D0, 0.93956563D0/ | |
35617 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ | |
35618 | DATA INIPRI/0/ | |
35619 | ||
35620 | C DATA PFERMI/0.22D0/ | |
35621 | CGB+...Binding Energy | |
35622 | DATA EBIND/0.008D0/ | |
35623 | CGB-... | |
35624 | ||
35625 | ININU=ININU+1 | |
35626 | IF(ININU.EQ.1)NDSIG=0 | |
35627 | LBAD = 0 | |
35628 | enu0=enu | |
35629 | c write(*,*) enu0 | |
35630 | C...Lepton mass | |
35631 | AML = AML0(LTYP) ! massa leptoni | |
35632 | AML2 = AML**2 ! massa leptoni **2 | |
35633 | C...Particle labels (LUND) | |
35634 | N = 5 | |
35635 | K(1,1) = 21 | |
35636 | K(2,1) = 21 | |
35637 | K(3,1) = 21 | |
35638 | K(3,3) = 1 | |
35639 | K(4,1) = 1 | |
35640 | K(4,3) = 1 | |
35641 | K(5,1) = 1 | |
35642 | K(5,3) = 2 | |
35643 | K0 = (LTYP-1)/2 ! 2 | |
35644 | K1 = LTYP/2 ! 2 | |
35645 | KA = 12 + 2*K0 ! 16 | |
35646 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 | |
35647 | K(1,2) = IS*KA | |
35648 | K(4,2) = IS*(KA-1) | |
35649 | K(3,2) = IS*24 | |
35650 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 | |
35651 | IF (LNU .EQ. 2) THEN | |
35652 | K(2,2) = 2212 | |
35653 | K(5,2) = 2112 | |
35654 | AMI = AMN(1) | |
35655 | AMF = AMN(2) | |
35656 | CJR+ | |
35657 | PFERMI=PFERMN(2) | |
35658 | CJR- | |
35659 | ELSE | |
35660 | K(2,2) = 2112 | |
35661 | K(5,2) = 2212 | |
35662 | AMI = AMN(2) | |
35663 | AMF = AMN(1) | |
35664 | CJR+ | |
35665 | PFERMI=PFERMP(2) | |
35666 | CJR- | |
35667 | ENDIF | |
35668 | AMI2 = AMI**2 | |
35669 | AMF2 = AMF**2 | |
35670 | ||
35671 | DO IGB=1,5 | |
35672 | P(3,IGB) = 0. | |
35673 | P(4,IGB) = 0. | |
35674 | P(5,IGB) = 0. | |
35675 | END DO | |
35676 | ||
35677 | NTRY = 0 | |
35678 | CGB+... | |
35679 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy | |
35680 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well | |
35681 | CGB-... | |
35682 | ||
35683 | 100 CONTINUE | |
35684 | ||
35685 | C...4-momentum initial lepton | |
35686 | P(1,5) = 0. ! massa | |
35687 | P(1,4) = ENU0 ! energia | |
35688 | P(1,1) = 0. ! px | |
35689 | P(1,2) = 0. ! py | |
35690 | P(1,3) = ENU0 ! pz | |
35691 | ||
35692 | C PF = PFERMI*PYR(0)**(1./3.) | |
35693 | c write(23,*) PYR(0) | |
35694 | c write(*,*) 'Pfermi=',PF | |
35695 | c PF = 0. | |
35696 | NTRY=NTRY+1 | |
35697 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 | |
35698 | IF (NTRY .GT. 500) THEN | |
35699 | LBAD = 1 | |
35700 | WRITE (LOUT,1001) NBAD, ENU | |
35701 | RETURN | |
35702 | ENDIF | |
35703 | C CT = -1. + 2.*PYR(0) | |
35704 | c CT = -1. | |
35705 | C ST = SQRT(1.-CT*CT) | |
35706 | C F = 2.*3.1415926*PYR(0) | |
35707 | c F = 0. | |
35708 | ||
35709 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia | |
35710 | C P(2,1) = PF*ST*COS(F) ! px | |
35711 | C P(2,2) = PF*ST*SIN(F) ! py | |
35712 | C P(2,3) = PF*CT ! pz | |
35713 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa | |
35714 | P(2,1) = P21 | |
35715 | P(2,2) = P22 | |
35716 | P(2,3) = P23 | |
35717 | P(2,4) = P24 | |
35718 | P(2,5) = P25 | |
35719 | beta1=-p(2,1)/p(2,4) | |
35720 | beta2=-p(2,2)/p(2,4) | |
35721 | beta3=-p(2,3)/p(2,4) | |
35722 | N=2 | |
35723 | C WRITE(6,*)' before transforming into target rest frame' | |
35724 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
35725 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
35726 | N=5 | |
35727 | ||
35728 | phi11=atan(p(1,2)/p(1,3)) | |
35729 | pi(1)=p(1,1) | |
35730 | pi(2)=p(1,2) | |
35731 | pi(3)=p(1,3) | |
35732 | ||
35733 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
35734 | DO ll=1,3 | |
35735 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35736 | END DO | |
35737 | c WRITE(*,*) po | |
35738 | p(1,1)=po(1) | |
35739 | p(1,2)=po(2) | |
35740 | p(1,3)=po(3) | |
35741 | phi12=atan(p(1,1)/p(1,3)) | |
35742 | ||
35743 | pi(1)=p(1,1) | |
35744 | pi(2)=p(1,2) | |
35745 | pi(3)=p(1,3) | |
35746 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
35747 | DO ll=1,3 | |
35748 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35749 | END DO | |
35750 | c WRITE(*,*) po | |
35751 | p(1,1)=po(1) | |
35752 | p(1,2)=po(2) | |
35753 | p(1,3)=po(3) | |
35754 | ||
35755 | enu=p(1,4) | |
35756 | ||
35757 | C...Kinematical limits in Q**2 | |
35758 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? | |
35759 | S = P(2,5)**2 + 2.*ENU*P(2,5) | |
35760 | SQS = SQRT(S) ! E centro massa | |
35761 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 | |
35762 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p | |
35763 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. | |
35764 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale | |
35765 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - | |
35766 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) | |
35767 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico | |
35768 | ||
35769 | C...Generate Q**2 | |
35770 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) | |
35771 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
35772 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) | |
35773 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
35774 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) | |
35775 | NDSIG=NDSIG+1 | |
35776 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', | |
35777 | C &Q2,Q2min,Q2MAX,DSIGEV | |
35778 | ||
35779 | C...c.m. frame. Neutrino along z axis | |
35780 | DETOT = (P(1,4)) + (P(2,4)) ! e totale | |
35781 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x | |
35782 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! | |
35783 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! | |
35784 | c WRITE(*,*) | |
35785 | c WRITE(*,*) | |
35786 | C WRITE(*,*) 'Input values laboratory frame' | |
35787 | N=2 | |
35788 | ||
35789 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) | |
35790 | ||
35791 | N=5 | |
35792 | c STHETA = ULANGL(P(1,3),P(1,1)) | |
35793 | c write(*,*) 'stheta' ,stheta | |
35794 | c stheta=0. | |
35795 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) | |
35796 | c WRITE(*,*) | |
35797 | c WRITE(*,*) | |
35798 | C WRITE(*,*) 'Output values cm frame' | |
35799 | C...Kinematic in c.m. frame | |
35800 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm | |
35801 | STSTAR = SQRT(1.-CTSTAR**2) | |
35802 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi | |
35803 | P(4,5) = AML ! massa leptone | |
35804 | P(4,4) = ELF ! e leptone | |
35805 | P(4,3) = PLF*CTSTAR ! px | |
35806 | P(4,1) = PLF*STSTAR*COS(PHI) ! py | |
35807 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz | |
35808 | ||
35809 | P(5,5) = AMF ! barione | |
35810 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione | |
35811 | P(5,3) = -P(4,3) ! px | |
35812 | P(5,1) = -P(4,1) ! py | |
35813 | P(5,2) = -P(4,2) ! pz | |
35814 | ||
35815 | P(3,5) = -Q2 | |
35816 | P(3,1) = P(1,1)-P(4,1) | |
35817 | P(3,2) = P(1,2)-P(4,2) | |
35818 | P(3,3) = P(1,3)-P(4,3) | |
35819 | P(3,4) = P(1,4)-P(4,4) | |
35820 | ||
35821 | C...Transform back to laboratory frame | |
35822 | C WRITE(*,*) 'before going back to nucl rest frame' | |
35823 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) | |
35824 | N=5 | |
35825 | ||
35826 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) | |
35827 | ||
35828 | C WRITE(*,*) 'Now back in nucl rest frame' | |
35829 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) | |
35830 | ||
35831 | c******************************************** | |
35832 | ||
35833 | DO kw=1,5 | |
35834 | pi(1)=p(kw,1) | |
35835 | pi(2)=p(kw,2) | |
35836 | pi(3)=p(kw,3) | |
35837 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
35838 | DO ll=1,3 | |
35839 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35840 | END DO | |
35841 | p(kw,1)=po(1) | |
35842 | p(kw,2)=po(2) | |
35843 | p(kw,3)=po(3) | |
35844 | END DO | |
35845 | c******************************************** | |
35846 | ||
35847 | DO kw=1,5 | |
35848 | pi(1)=p(kw,1) | |
35849 | pi(2)=p(kw,2) | |
35850 | pi(3)=p(kw,3) | |
35851 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
35852 | DO ll=1,3 | |
35853 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35854 | END DO | |
35855 | p(kw,1)=po(1) | |
35856 | p(kw,2)=po(2) | |
35857 | p(kw,3)=po(3) | |
35858 | END DO | |
35859 | ||
35860 | c******************************************** | |
35861 | ||
35862 | C WRITE(*,*) 'Now back in lab frame' | |
35863 | ||
35864 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
35865 | ||
35866 | CGB+... | |
35867 | C...test (on final momentum of nucleon) if Fermi-blocking | |
35868 | C...is operating | |
35869 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) | |
35870 | & - P(5,5) | |
35871 | IF (ENUCL.LT. EFMAX) THEN | |
35872 | IF(INIPRI.LT.10)THEN | |
35873 | INIPRI=INIPRI+1 | |
35874 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX | |
35875 | C...the interaction is not possible due to Pauli-Blocking and | |
35876 | C...it must be resampled | |
35877 | ENDIF | |
35878 | GOTO 100 | |
35879 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN | |
35880 | IF(INIPRI.LT.10)THEN | |
35881 | INIPRI=INIPRI+1 | |
35882 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL | |
35883 | ENDIF | |
35884 | C Reject (J:R) here all these events | |
35885 | C are otherwise rejected in dpmjet | |
35886 | GOTO 100 | |
35887 | C...the interaction is possible, but the nucleon remains inside | |
35888 | C...the nucleus. The nucleus is therefore left excited. | |
35889 | C...We treat this case as a nucleon with 0 kinetic energy. | |
35890 | C P(5,5) = AMF | |
35891 | C P(5,4) = AMF | |
35892 | C P(5,1) = 0. | |
35893 | C P(5,2) = 0. | |
35894 | C P(5,3) = 0. | |
35895 | ELSE IF (ENUCL.GE.ENWELL) THEN | |
35896 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL | |
35897 | C...the interaction is possible, the nucleon can exit the nucleus | |
35898 | C...but the nuclear well depth must be subtracted. The nucleus could be | |
35899 | C...left in an excited state. | |
35900 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) | |
35901 | C P(5,4) = ENUCL-ENWELL + AMF | |
35902 | Pnucl = SQRT(P(5,4)**2-AMF**2) | |
35903 | C...The 3-momentum is scaled assuming that the direction remains | |
35904 | C...unaffected | |
35905 | P(5,1) = P(5,1) * Pnucl/Pstart | |
35906 | P(5,2) = P(5,2) * Pnucl/Pstart | |
35907 | P(5,3) = P(5,3) * Pnucl/Pstart | |
35908 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) | |
35909 | ENDIF | |
35910 | CGB-... | |
35911 | DSIGSU=DSIGSU+DSIGEV | |
35912 | ||
35913 | GA=P(4,4)/P(4,5) | |
35914 | BGX=P(4,1)/P(4,5) | |
35915 | BGY=P(4,2)/P(4,5) | |
35916 | BGZ=P(4,3)/P(4,5) | |
35917 | * | |
35918 | DBETB(1)=BGX/GA | |
35919 | DBETB(2)=BGY/GA | |
35920 | DBETB(3)=BGZ/GA | |
35921 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN | |
35922 | ||
35923 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) | |
35924 | ||
35925 | ENDIF | |
35926 | c | |
35927 | C PRINT*,' FINE EVENTO ' | |
35928 | enu=enu0 | |
35929 | RETURN | |
35930 | ||
35931 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) | |
35932 | END | |
35933 | ||
35934 | *$ CREATE DT_MASS_INI.FOR | |
35935 | *COPY DT_MASS_INI | |
35936 | C==================================================================== | |
35937 | C. Masses | |
35938 | C==================================================================== | |
35939 | * | |
35940 | *===mass_ini===========================================================* | |
35941 | * | |
35942 | SUBROUTINE DT_MASS_INI | |
35943 | C...Initialize the kinematics for the quasi-elastic cross section | |
35944 | ||
35945 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35946 | SAVE | |
35947 | ||
35948 | * particle masses used in qel neutrino scattering modules | |
35949 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
35950 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
35951 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
35952 | ||
35953 | EML(1) = 0.51100D-03 ! e- | |
35954 | EML(2) = EML(1) ! e+ | |
35955 | EML(3) = 0.105659D0 ! mu- | |
35956 | EML(4) = EML(3) ! mu+ | |
35957 | EML(5) = 1.7777D0 ! tau- | |
35958 | EML(6) = EML(5) ! tau+ | |
35959 | EMPROT = 0.93827231D0 ! p | |
35960 | EMNEUT = 0.93956563D0 ! n | |
35961 | EMPROTSQ = EMPROT**2 | |
35962 | EMNEUTSQ = EMNEUT**2 | |
35963 | EMN = (EMPROT + EMNEUT)/2. | |
35964 | EMNSQ = EMN**2 | |
35965 | DO J=1,3 | |
35966 | J0 = 2*(J-1) | |
35967 | EMN1(J0+1) = EMNEUT | |
35968 | EMN1(J0+2) = EMPROT | |
35969 | EMN2(J0+1) = EMPROT | |
35970 | EMN2(J0+2) = EMNEUT | |
35971 | ENDDO | |
35972 | DO J=1,6 | |
35973 | EMLSQ(J) = EML(J)**2 | |
35974 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) | |
35975 | ENDDO | |
35976 | RETURN | |
35977 | END | |
35978 | ||
35979 | *$ CREATE DT_DSQEL_Q2.FOR | |
35980 | *COPY DT_DSQEL_Q2 | |
35981 | * | |
35982 | *===dsqel_q2===========================================================* | |
35983 | * | |
35984 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) | |
35985 | ||
35986 | C...differential cross section for Quasi-Elastic scattering | |
35987 | C. nu + N -> l + N' | |
35988 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). | |
35989 | C. | |
35990 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau | |
35991 | C. ENU (GeV) = Neutrino energy | |
35992 | C. Q2 (GeV**2) = (Transfer momentum)**2 | |
35993 | C. | |
35994 | C. OUTPUT : DSQEL_Q2 = differential cross section : | |
35995 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) | |
35996 | C------------------------------------------------------------------ | |
35997 | ||
35998 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35999 | SAVE | |
36000 | ||
36001 | * particle masses used in qel neutrino scattering modules | |
36002 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
36003 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
36004 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
36005 | **sr - removed (not needed) | |
36006 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
36007 | ** | |
36008 | ||
36009 | DIMENSION SS(6) | |
36010 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
36011 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
36012 | DATA AXIAL2 /1.03D0/ ! to be checked | |
36013 | ||
36014 | FA0=-1.253D0 | |
36015 | CSI = 3.71D0 ! ??? | |
36016 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) | |
36017 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
36018 | X = Q2/(EMN*EMN) ! emn=massa barione | |
36019 | XA = X/4.D0 | |
36020 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
36021 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
36022 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 | |
36023 | FFA = FA*FA | |
36024 | FFV1 = FV1*FV1 | |
36025 | FFV2 = FV2*FV2 | |
36026 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
36027 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 | |
36028 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
36029 | AA = (XA+0.25D0*RM)*(A1 + A2) | |
36030 | BB = -X*FA*(FV1 + FV2) | |
36031 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) | |
36032 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
36033 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! | |
36034 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 | |
36035 | ||
36036 | RETURN | |
36037 | END | |
36038 | ||
36039 | *$ CREATE DT_PREPOLA.FOR | |
36040 | *COPY DT_PREPOLA | |
36041 | * | |
36042 | *===prepola============================================================* | |
36043 | * | |
36044 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) | |
36045 | ||
36046 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36047 | SAVE | |
36048 | c | |
36049 | c By G. Battistoni and E. Scapparone (sept. 1997) | |
36050 | c According to: | |
36051 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 | |
36052 | c | |
36053 | c | |
36054 | PARAMETER (MAXLND=4000) | |
36055 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36056 | COMMON /QNPOL/ POLARX(4),PMODUL | |
36057 | * particle masses used in qel neutrino scattering modules | |
36058 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
36059 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
36060 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
36061 | * steering flags for qel neutrino scattering modules | |
36062 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
36063 | **sr - removed (not needed) | |
36064 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
36065 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, | |
36066 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN | |
36067 | ** | |
36068 | REAL*8 POL(4,4),BB2(3) | |
36069 | DIMENSION SS(6) | |
36070 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
36071 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
36072 | **sr uncommented since common block CAXIAL is now commented | |
36073 | DATA AXIAL2 /1.03D0/ ! to be checked | |
36074 | ** | |
36075 | ||
36076 | RML=P(4,5) | |
36077 | RMM=0.93960D+00 | |
36078 | FM2 = RMM**2 | |
36079 | MPI = 0.135D+00 | |
36080 | OLDQ2=Q2 | |
36081 | FA0=-1.253D+00 | |
36082 | CSI = 3.71D+00 ! | |
36083 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) | |
36084 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
36085 | X = Q2/(EMN*EMN) ! emn=massa barione | |
36086 | XA = X/4.D0 | |
36087 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
36088 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
36089 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 | |
36090 | FFA = FA*FA | |
36091 | FFV1 = FV1*FV1 | |
36092 | FFV2 = FV2*FV2 | |
36093 | FP=2.D0*FA*RMM/(MPI**2 + Q2) | |
36094 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
36095 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 | |
36096 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
36097 | AA = (XA+0.25D+00*RM)*(A1 + A2) | |
36098 | BB = -X*FA*(FV1 + FV2) | |
36099 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) | |
36100 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
36101 | ||
36102 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith | |
36103 | OMEGA2=4.D+00*CC | |
36104 | OMEGA3=2.D+00*FA*(FV1+FV2) | |
36105 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ | |
36106 | 1 (Q2/FM2))*FP**2) | |
36107 | OMEGA5=OMEGA2 | |
36108 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 | |
36109 | WW1=2.D+00*OMEGA1*EMN**2 | |
36110 | WW2=2.D+00*OMEGA2*EMN**2 | |
36111 | WW3=2.D+00*OMEGA3*EMN**2 | |
36112 | WW4=2.D+00*OMEGA4*EMN**2 | |
36113 | WW5=2.D+00*OMEGA5*EMN**2 | |
36114 | ||
36115 | DO I=1,3 | |
36116 | BB2(I)=-P(4,I)/P(4,4) | |
36117 | END DO | |
36118 | c WRITE(*,*) | |
36119 | c WRITE(*,*) | |
36120 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' | |
36121 | N=5 | |
36122 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) | |
36123 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME | |
36124 | c WRITE(*,*) | |
36125 | c WRITE(*,*) | |
36126 | c WRITE(*,*) 'Prepola: now in lepton rest frame' | |
36127 | EE=ENU | |
36128 | QM2=Q2+RML**2 | |
36129 | U=Q2/(2.*RMM) | |
36130 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* | |
36131 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + | |
36132 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! | |
36133 | ||
36134 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 | |
36135 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! | |
36136 | ||
36137 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) | |
36138 | ||
36139 | DO I=1,3 | |
36140 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC | |
36141 | POLARX(I)=POL(4,I) | |
36142 | END DO | |
36143 | ||
36144 | PMODUL=0.D0 | |
36145 | DO I=1,3 | |
36146 | PMODUL=PMODUL+POL(4,I)**2 | |
36147 | END DO | |
36148 | ||
36149 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN | |
36150 | IF(NEUDEC.EQ.1) THEN | |
36151 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), | |
36152 | + ETL,PXL,PYL,PZL, | |
36153 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36154 | c | |
36155 | c Tau has decayed in muon | |
36156 | c | |
36157 | ENDIF | |
36158 | IF(NEUDEC.EQ.2) THEN | |
36159 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), | |
36160 | + ETL,PXL,PYL,PZL, | |
36161 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36162 | c | |
36163 | c Tau has decayed in electron | |
36164 | c | |
36165 | ENDIF | |
36166 | K(4,1)=15 | |
36167 | K(4,4) = 6 | |
36168 | K(4,5) = 8 | |
36169 | N=N+3 | |
36170 | c | |
36171 | c fill common for muon(electron) | |
36172 | c | |
36173 | P(6,1)=PXL | |
36174 | P(6,2)=PYL | |
36175 | P(6,3)=PZL | |
36176 | P(6,4)=ETL | |
36177 | K(6,1)=1 | |
36178 | IF(JTYP.EQ.5) THEN | |
36179 | IF(NEUDEC.EQ.1) THEN | |
36180 | P(6,5)=EML(JTYP-2) | |
36181 | K(6,2)=13 | |
36182 | ELSEIF(NEUDEC.EQ.2) THEN | |
36183 | P(6,5)=EML(JTYP-4) | |
36184 | K(6,2)=11 | |
36185 | ENDIF | |
36186 | ELSEIF(JTYP.EQ.6) THEN | |
36187 | IF(NEUDEC.EQ.1) THEN | |
36188 | K(6,2)=-13 | |
36189 | ELSEIF(NEUDEC.EQ.2) THEN | |
36190 | K(6,2)=-11 | |
36191 | ENDIF | |
36192 | END IF | |
36193 | K(6,3)=4 | |
36194 | K(6,4)=0 | |
36195 | K(6,5)=0 | |
36196 | c | |
36197 | c fill common for tau_(anti)neutrino | |
36198 | c | |
36199 | P(7,1)=PXB | |
36200 | P(7,2)=PYB | |
36201 | P(7,3)=PZB | |
36202 | P(7,4)=ETB | |
36203 | P(7,5)=0. | |
36204 | K(7,1)=1 | |
36205 | IF(JTYP.EQ.5) THEN | |
36206 | K(7,2)=16 | |
36207 | ELSEIF(JTYP.EQ.6) THEN | |
36208 | K(7,2)=-16 | |
36209 | END IF | |
36210 | K(7,3)=4 | |
36211 | K(7,4)=0 | |
36212 | K(7,5)=0 | |
36213 | c | |
36214 | c Fill common for muon(electron)_(anti)neutrino | |
36215 | c | |
36216 | P(8,1)=PXN | |
36217 | P(8,2)=PYN | |
36218 | P(8,3)=PZN | |
36219 | P(8,4)=ETN | |
36220 | P(8,5)=0. | |
36221 | K(8,1)=1 | |
36222 | IF(JTYP.EQ.5) THEN | |
36223 | IF(NEUDEC.EQ.1) THEN | |
36224 | K(8,2)=-14 | |
36225 | ELSEIF(NEUDEC.EQ.2) THEN | |
36226 | K(8,2)=-12 | |
36227 | ENDIF | |
36228 | ELSEIF(JTYP.EQ.6) THEN | |
36229 | IF(NEUDEC.EQ.1) THEN | |
36230 | K(8,2)=14 | |
36231 | ELSEIF(NEUDEC.EQ.2) THEN | |
36232 | K(8,2)=12 | |
36233 | ENDIF | |
36234 | END IF | |
36235 | K(8,3)=4 | |
36236 | K(8,4)=0 | |
36237 | K(8,5)=0 | |
36238 | ENDIF | |
36239 | c WRITE(*,*) | |
36240 | c WRITE(*,*) | |
36241 | ||
36242 | c IF(PMODUL.GE.1.D+00) THEN | |
36243 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36244 | c write(*,*) pmodul | |
36245 | c DO I=1,3 | |
36246 | c POL(4,I)=POL(4,I)/PMODUL | |
36247 | c POLARX(I)=POL(4,I) | |
36248 | c END DO | |
36249 | c PMODUL=0. | |
36250 | c DO I=1,3 | |
36251 | c PMODUL=PMODUL+POL(4,I)**2 | |
36252 | c END DO | |
36253 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36254 | c | |
36255 | c ENDIF | |
36256 | ||
36257 | c WRITE(*,*) 'PMODUL = ',PMODUL | |
36258 | ||
36259 | c WRITE(*,*) | |
36260 | c WRITE(*,*) | |
36261 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' | |
36262 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) | |
36263 | ||
36264 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) | |
36265 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) | |
36266 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) | |
36267 | DO NDC =6,8 | |
36268 | V(NDC,1) = XDC | |
36269 | V(NDC,2) = YDC | |
36270 | V(NDC,3) = ZDC | |
36271 | END DO | |
36272 | ||
36273 | RETURN | |
36274 | END | |
36275 | ||
36276 | *$ CREATE DT_TESTROT.FOR | |
36277 | *COPY DT_TESTROT | |
36278 | * | |
36279 | *===testrot============================================================* | |
36280 | * | |
36281 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) | |
36282 | ||
36283 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36284 | SAVE | |
36285 | ||
36286 | DIMENSION ROT(3,3),PI(3),PO(3) | |
36287 | ||
36288 | IF (MODE.EQ.1) THEN | |
36289 | ROT(1,1) = 1.D0 | |
36290 | ROT(1,2) = 0.D0 | |
36291 | ROT(1,3) = 0.D0 | |
36292 | ROT(2,1) = 0.D0 | |
36293 | ROT(2,2) = COS(PHI) | |
36294 | ROT(2,3) = -SIN(PHI) | |
36295 | ROT(3,1) = 0.D0 | |
36296 | ROT(3,2) = SIN(PHI) | |
36297 | ROT(3,3) = COS(PHI) | |
36298 | ELSEIF (MODE.EQ.2) THEN | |
36299 | ROT(1,1) = 0.D0 | |
36300 | ROT(1,2) = 1.D0 | |
36301 | ROT(1,3) = 0.D0 | |
36302 | ROT(2,1) = COS(PHI) | |
36303 | ROT(2,2) = 0.D0 | |
36304 | ROT(2,3) = -SIN(PHI) | |
36305 | ROT(3,1) = SIN(PHI) | |
36306 | ROT(3,2) = 0.D0 | |
36307 | ROT(3,3) = COS(PHI) | |
36308 | ELSEIF (MODE.EQ.3) THEN | |
36309 | ROT(1,1) = 0.D0 | |
36310 | ROT(2,1) = 1.D0 | |
36311 | ROT(3,1) = 0.D0 | |
36312 | ROT(1,2) = COS(PHI) | |
36313 | ROT(2,2) = 0.D0 | |
36314 | ROT(3,2) = -SIN(PHI) | |
36315 | ROT(1,3) = SIN(PHI) | |
36316 | ROT(2,3) = 0.D0 | |
36317 | ROT(3,3) = COS(PHI) | |
36318 | ELSEIF (MODE.EQ.4) THEN | |
36319 | ROT(1,1) = 1.D0 | |
36320 | ROT(2,1) = 0.D0 | |
36321 | ROT(3,1) = 0.D0 | |
36322 | ROT(1,2) = 0.D0 | |
36323 | ROT(2,2) = COS(PHI) | |
36324 | ROT(3,2) = -SIN(PHI) | |
36325 | ROT(1,3) = 0.D0 | |
36326 | ROT(2,3) = SIN(PHI) | |
36327 | ROT(3,3) = COS(PHI) | |
36328 | ELSE | |
36329 | STOP ' TESTROT: mode not supported!' | |
36330 | ENDIF | |
36331 | DO 1 J=1,3 | |
36332 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) | |
36333 | 1 CONTINUE | |
36334 | ||
36335 | RETURN | |
36336 | END | |
36337 | ||
36338 | *$ CREATE DT_LEPDCYP.FOR | |
36339 | *COPY DT_LEPDCYP | |
36340 | * | |
36341 | *===lepdcyp============================================================* | |
36342 | * | |
36343 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, | |
36344 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36345 | C | |
36346 | C----------------------------------------------------------------- | |
36347 | C | |
36348 | C Author :- G. Battistoni 10-NOV-1995 | |
36349 | C | |
36350 | C================================================================= | |
36351 | C | |
36352 | C Purpose : performs decay of polarized lepton in | |
36353 | C its rest frame: a => b + l + anti-nu | |
36354 | C (Example: mu- => nu-mu + e- + anti-nu-e) | |
36355 | C Polarization is assumed along Z-axis | |
36356 | C WARNING: | |
36357 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS | |
36358 | C OF NEGLIGIBLE MASS | |
36359 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED | |
36360 | C IN THIS VERSION | |
36361 | C | |
36362 | C Method : modifies phase space distribution obtained | |
36363 | C by routine EXPLOD using a rejection against the | |
36364 | C matrix element for unpolarized lepton decay | |
36365 | C | |
36366 | C Inputs : Mass of a : AMA | |
36367 | C Mass of l : AML | |
36368 | C Polar. of a: POL | |
36369 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, | |
36370 | C POL = -1) | |
36371 | C | |
36372 | C Outputs : kinematic variables in the rest frame of decaying lepton | |
36373 | C ETL,PXL,PYL,PZL 4-moment of l | |
36374 | C ETB,PXB,PYB,PZB 4-moment of b | |
36375 | C ETN,PXN,PYN,PZN 4-moment of anti-nu | |
36376 | C | |
36377 | C============================================================ | |
36378 | C + | |
36379 | C Declarations. | |
36380 | C - | |
36381 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36382 | SAVE | |
36383 | ||
36384 | PARAMETER ( LINP = 10 , | |
36385 | & LOUT = 6 , | |
36386 | & LDAT = 9 ) | |
36387 | PARAMETER ( KALGNM = 2 ) | |
36388 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
36389 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
36390 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
36391 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
36392 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
36393 | PARAMETER ( AINFNT = 1.0D+30 ) | |
36394 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
36395 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
36396 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
36397 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
36398 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
36399 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
36400 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
36401 | PARAMETER ( ZERZER = 0.D+00 ) | |
36402 | PARAMETER ( ONEONE = 1.D+00 ) | |
36403 | PARAMETER ( TWOTWO = 2.D+00 ) | |
36404 | PARAMETER ( THRTHR = 3.D+00 ) | |
36405 | PARAMETER ( FOUFOU = 4.D+00 ) | |
36406 | PARAMETER ( FIVFIV = 5.D+00 ) | |
36407 | PARAMETER ( SIXSIX = 6.D+00 ) | |
36408 | PARAMETER ( SEVSEV = 7.D+00 ) | |
36409 | PARAMETER ( EIGEIG = 8.D+00 ) | |
36410 | PARAMETER ( ANINEN = 9.D+00 ) | |
36411 | PARAMETER ( TENTEN = 10.D+00 ) | |
36412 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
36413 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
36414 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
36415 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
36416 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) | |
36417 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) | |
36418 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
36419 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
36420 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
36421 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
36422 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
36423 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
36424 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
36425 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
36426 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
36427 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
36428 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
36429 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
36430 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
36431 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
36432 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
36433 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
36434 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
36435 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
36436 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
36437 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
36438 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
36439 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
36440 | C + | |
36441 | C variables for EXPLOD | |
36442 | C - | |
36443 | PARAMETER ( KPMX = 10 ) | |
36444 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), | |
36445 | & PZEXPL (KPMX), ETEXPL (KPMX) | |
36446 | C + | |
36447 | C test variables | |
36448 | C - | |
36449 | **sr - removed (not needed) | |
36450 | C COMMON /GBATNU/ ELERAT,NTRY | |
36451 | ** | |
36452 | C + | |
36453 | C Initializes test variables | |
36454 | C - | |
36455 | NTRY = 0 | |
36456 | ELERAT = 0.D+00 | |
36457 | C + | |
36458 | C Maximum value for matrix element | |
36459 | C - | |
36460 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + | |
36461 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) | |
36462 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | |
36463 | C Inputs for EXPLOD | |
36464 | C part. no. 1 is l (e- in mu- decay) | |
36465 | C part. no. 2 is b (nu-mu in mu- decay) | |
36466 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) | |
36467 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
36468 | NPEXPL = 3 | |
36469 | ETOTEX = AMA | |
36470 | AMEXPL(1) = AML | |
36471 | AMEXPL(2) = 0.D+00 | |
36472 | AMEXPL(3) = 0.D+00 | |
36473 | C + | |
36474 | C phase space distribution | |
36475 | C - | |
36476 | 100 CONTINUE | |
36477 | NTRY = NTRY + 1 | |
36478 | ||
36479 | CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
36480 | & PYEXPL, PZEXPL ) | |
36481 | ||
36482 | C + | |
36483 | C Calculates matrix element: | |
36484 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} | |
36485 | C Here CTH is the cosine of the angle between anti-nu and Z axis | |
36486 | C - | |
36487 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + | |
36488 | & PZEXPL(3)**2 ) | |
36489 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) | |
36490 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - | |
36491 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) | |
36492 | ELEMAT = 16.D+00 * PROD1 * PROD2 | |
36493 | IF(ELEMAT.GT.ELEMAX) THEN | |
36494 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT | |
36495 | STOP | |
36496 | ENDIF | |
36497 | C + | |
36498 | C Here performs the rejection | |
36499 | C - | |
36500 | TEST = DT_RNDM(ETOTEX) * ELEMAX | |
36501 | IF ( TEST .GT. ELEMAT ) GO TO 100 | |
36502 | C + | |
36503 | C final assignment of variables | |
36504 | C - | |
36505 | ELERAT = ELEMAT/ELEMAX | |
36506 | ETL = ETEXPL(1) | |
36507 | PXL = PXEXPL(1) | |
36508 | PYL = PYEXPL(1) | |
36509 | PZL = PZEXPL(1) | |
36510 | ETB = ETEXPL(2) | |
36511 | PXB = PXEXPL(2) | |
36512 | PYB = PYEXPL(2) | |
36513 | PZB = PZEXPL(2) | |
36514 | ETN = ETEXPL(3) | |
36515 | PXN = PXEXPL(3) | |
36516 | PYN = PYEXPL(3) | |
36517 | PZN = PZEXPL(3) | |
36518 | 999 RETURN | |
36519 | END | |
36520 | ||
36521 | *$ CREATE DT_GEN_DELTA.FOR | |
36522 | *COPY DT_GEN_DELTA | |
36523 | C================================================================== | |
36524 | C. Generation of Delta resonance events | |
36525 | C================================================================== | |
36526 | * | |
36527 | *===gen_delta==========================================================* | |
36528 | * | |
36529 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) | |
36530 | ||
36531 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36532 | SAVE | |
36533 | ||
36534 | PARAMETER ( LINP = 10 , | |
36535 | & LOUT = 6 , | |
36536 | & LDAT = 9 ) | |
36537 | C...Generate a Delta-production neutrino/antineutrino | |
36538 | C. CC-interaction on a nucleon | |
36539 | C | |
36540 | C. INPUT ENU (GeV) = Neutrino Energy | |
36541 | C. LLEP = neutrino type | |
36542 | C. LTARG = nucleon target type 1=p, 2=n. | |
36543 | C. JINT = 1:CC, 2::NC | |
36544 | C. | |
36545 | C. OUTPUT PPL(4) 4-monentum of final lepton | |
36546 | C---------------------------------------------------- | |
36547 | PARAMETER (MAXLND=4000) | |
36548 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36549 | **sr - removed (not needed) | |
36550 | C COMMON /CBAD/ LBAD, NBAD | |
36551 | ** | |
36552 | ||
36553 | DIMENSION PI(3),PO(3) | |
36554 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN | |
36555 | DIMENSION AML0(6),AMN(2) | |
36556 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ | |
36557 | DATA AMN /0.93827231, 0.93956563/ | |
36558 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ | |
36559 | ||
36560 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 | |
36561 | LBAD = 0 | |
36562 | C...Final lepton mass | |
36563 | IF (JINT.EQ.1) THEN | |
36564 | AML = AML0(LLEP) | |
36565 | ELSE | |
36566 | AML = 0. | |
36567 | ENDIF | |
36568 | AML2 = AML**2 | |
36569 | ||
36570 | C...Particle labels (LUND) | |
36571 | N = 5 | |
36572 | K(1,1) = 21 | |
36573 | K(2,1) = 21 | |
36574 | K(3,1) = 21 | |
36575 | K(4,1) = 1 | |
36576 | K(3,3) = 1 | |
36577 | K(4,3) = 1 | |
36578 | IF (LTARG .EQ. 1) THEN | |
36579 | K(2,2) = 2212 | |
36580 | ELSE | |
36581 | K(2,2) = 2112 | |
36582 | ENDIF | |
36583 | K0 = (LLEP-1)/2 | |
36584 | K1 = LLEP/2 | |
36585 | KA = 12 + 2*K0 | |
36586 | IS = -1 + 2*LLEP - 4*K1 | |
36587 | LNU = 2 - LLEP + 2*K1 | |
36588 | K(1,2) = IS*KA | |
36589 | K(5,1) = 1 | |
36590 | K(5,3) = 2 | |
36591 | IF (JINT .EQ. 1) THEN ! CC interactions | |
36592 | K(3,2) = IS*24 | |
36593 | K(4,2) = IS*(KA-1) | |
36594 | IF(LNU.EQ.1) THEN | |
36595 | IF (LTARG .EQ. 1) THEN | |
36596 | K(5,2) = 2224 | |
36597 | ELSE | |
36598 | K(5,2) = 2214 | |
36599 | ENDIF | |
36600 | ELSE | |
36601 | IF (LTARG .EQ. 1) THEN | |
36602 | K(5,2) = 2114 | |
36603 | ELSE | |
36604 | K(5,2) = 1114 | |
36605 | ENDIF | |
36606 | ENDIF | |
36607 | ELSE | |
36608 | K(3,2) = 23 ! NC (Z0) interactions | |
36609 | K(4,2) = K(1,2) | |
36610 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), | |
36611 | * Delta0 for neutron (LTARG=2) | |
36612 | C IF (LTARG .EQ. 1) THEN | |
36613 | C K(5,2) = 2114 | |
36614 | C ELSE | |
36615 | C K(5,2) = 2214 | |
36616 | C ENDIF | |
36617 | IF (LTARG .EQ. 1) THEN | |
36618 | K(5,2) = 2214 | |
36619 | ELSE | |
36620 | K(5,2) = 2114 | |
36621 | ENDIF | |
36622 | ** | |
36623 | ENDIF | |
36624 | ||
36625 | C...4-momentum initial lepton | |
36626 | P(1,5) = 0. | |
36627 | P(1,4) = ENU | |
36628 | P(1,1) = 0. | |
36629 | P(1,2) = 0. | |
36630 | P(1,3) = ENU | |
36631 | C...4-momentum initial nucleon | |
36632 | P(2,5) = AMN(LTARG) | |
36633 | C P(2,4) = P(2,5) | |
36634 | C P(2,1) = 0. | |
36635 | C P(2,2) = 0. | |
36636 | C P(2,3) = 0. | |
36637 | P(2,1) = P21 | |
36638 | P(2,2) = P22 | |
36639 | P(2,3) = P23 | |
36640 | P(2,4) = P24 | |
36641 | P(2,5) = P25 | |
36642 | N=2 | |
36643 | beta1=-p(2,1)/p(2,4) | |
36644 | beta2=-p(2,2)/p(2,4) | |
36645 | beta3=-p(2,3)/p(2,4) | |
36646 | N=2 | |
36647 | ||
36648 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
36649 | ||
36650 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
36651 | ||
36652 | phi11=atan(p(1,2)/p(1,3)) | |
36653 | pi(1)=p(1,1) | |
36654 | pi(2)=p(1,2) | |
36655 | pi(3)=p(1,3) | |
36656 | ||
36657 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
36658 | DO ll=1,3 | |
36659 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36660 | END DO | |
36661 | p(1,1)=po(1) | |
36662 | p(1,2)=po(2) | |
36663 | p(1,3)=po(3) | |
36664 | phi12=atan(p(1,1)/p(1,3)) | |
36665 | ||
36666 | pi(1)=p(1,1) | |
36667 | pi(2)=p(1,2) | |
36668 | pi(3)=p(1,3) | |
36669 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
36670 | DO ll=1,3 | |
36671 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36672 | END DO | |
36673 | p(1,1)=po(1) | |
36674 | p(1,2)=po(2) | |
36675 | p(1,3)=po(3) | |
36676 | ||
36677 | ENUU=P(1,4) | |
36678 | ||
36679 | C...Generate the Mass of the Delta | |
36680 | NTRY = 0 | |
36681 | 100 R = PYR(0) | |
36682 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) | |
36683 | NTRY = NTRY + 1 | |
36684 | IF (NTRY .GT. 1000) THEN | |
36685 | LBAD = 1 | |
36686 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET | |
36687 | RETURN | |
36688 | ENDIF | |
36689 | IF (AMD .LT. AMDMIN) GOTO 100 | |
36690 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) | |
36691 | IF (ENUU .LT. ET) GOTO 100 | |
36692 | ||
36693 | C...Kinematical limits in Q**2 | |
36694 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU | |
36695 | SQS = SQRT(S) | |
36696 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) | |
36697 | ELF = (S - AMD**2 + AML2)/(2.*SQS) | |
36698 | PLF = SQRT(ELF**2 - AML2) | |
36699 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) | |
36700 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) | |
36701 | IF (Q2MIN .LT. 0.) Q2MIN = 0. | |
36702 | ||
36703 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) | |
36704 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
36705 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) | |
36706 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
36707 | ||
36708 | C...Generate the kinematics of the final particles | |
36709 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) | |
36710 | GAM = EISTAR/AMN(LTARG) | |
36711 | BET = PSTAR/EISTAR | |
36712 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) | |
36713 | EL = GAM*(ELF + BET*PLF*CTSTAR) | |
36714 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) | |
36715 | PL = SQRT(EL**2 - AML2) | |
36716 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) | |
36717 | PHI = 6.28319*PYR(0) | |
36718 | P(4,1) = PLT*COS(PHI) | |
36719 | P(4,2) = PLT*SIN(PHI) | |
36720 | P(4,3) = PLZ | |
36721 | P(4,4) = EL | |
36722 | P(4,5) = AML | |
36723 | ||
36724 | C...4-momentum of Delta | |
36725 | P(5,1) = -P(4,1) | |
36726 | P(5,2) = -P(4,2) | |
36727 | P(5,3) = ENUU-P(4,3) | |
36728 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) | |
36729 | P(5,5) = AMD | |
36730 | ||
36731 | C...4-momentum of intermediate boson | |
36732 | P(3,5) = -Q2 | |
36733 | P(3,4) = P(1,4)-P(4,4) | |
36734 | P(3,1) = P(1,1)-P(4,1) | |
36735 | P(3,2) = P(1,2)-P(4,2) | |
36736 | P(3,3) = P(1,3)-P(4,3) | |
36737 | N=5 | |
36738 | ||
36739 | DO kw=1,5 | |
36740 | pi(1)=p(kw,1) | |
36741 | pi(2)=p(kw,2) | |
36742 | pi(3)=p(kw,3) | |
36743 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
36744 | DO ll=1,3 | |
36745 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36746 | END DO | |
36747 | p(kw,1)=po(1) | |
36748 | p(kw,2)=po(2) | |
36749 | p(kw,3)=po(3) | |
36750 | END DO | |
36751 | ||
36752 | c******************************************** | |
36753 | ||
36754 | DO kw=1,5 | |
36755 | pi(1)=p(kw,1) | |
36756 | pi(2)=p(kw,2) | |
36757 | pi(3)=p(kw,3) | |
36758 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
36759 | DO ll=1,3 | |
36760 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36761 | END DO | |
36762 | p(kw,1)=po(1) | |
36763 | p(kw,2)=po(2) | |
36764 | p(kw,3)=po(3) | |
36765 | END DO | |
36766 | c******************************************** | |
36767 | C transform back into Lab. | |
36768 | ||
36769 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
36770 | ||
36771 | C WRITE(6,*)' Lab fram ( fermi incl.) ' | |
36772 | N=5 | |
36773 | CALL PYEXEC | |
36774 | ||
36775 | RETURN | |
36776 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) | |
36777 | END | |
36778 | ||
36779 | *$ CREATE DT_DSIGMA_DELTA.FOR | |
36780 | *COPY DT_DSIGMA_DELTA | |
36781 | * | |
36782 | *===dsigma_delta=======================================================* | |
36783 | * | |
36784 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) | |
36785 | ||
36786 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36787 | SAVE | |
36788 | ||
36789 | C...Reaction nu + N -> lepton + Delta | |
36790 | C. returns the cross section | |
36791 | C. dsigma/dt | |
36792 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) | |
36793 | C. QQ = t (always negative) GeV**2 | |
36794 | C. S = (c.m energy)**2 GeV**2 | |
36795 | C. OUTPUT = 10**-38 cm+2/GeV**2 | |
36796 | C----------------------------------------------------- | |
36797 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 | |
36798 | DATA MN /0.938/ | |
36799 | DATA PI /3.1415926/ | |
36800 | ||
36801 | GF = (1.1664 * 1.97) | |
36802 | GF2 = GF*GF | |
36803 | MN2 = MN*MN | |
36804 | MN4 = MN2*MN2 | |
36805 | MD2 = MD*MD | |
36806 | MD4 = MD2*MD2 | |
36807 | AML2 = AML*AML | |
36808 | AML4 = AML2*AML2 | |
36809 | VQ = (MN2 - MD2 - QQ)/2. | |
36810 | VPI = (MN2 + MD2 - QQ)/2. | |
36811 | VK = (S + QQ - MN2 - AML2)/2. | |
36812 | PIK = (S - MN2)/2. | |
36813 | QK = (AML2 - QQ)/2. | |
36814 | PIQ = (QQ + MN2 - MD2)/2. | |
36815 | Q = SQRT(-QQ) | |
36816 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) | |
36817 | C3 = SQRT(3.)*C3V/MN | |
36818 | C4 = -C3/MD ! attenzione al segno | |
36819 | C5A = 1.18/(1.-QQ/0.4225)**2 | |
36820 | C32 = C3**2 | |
36821 | C42 = C4**2 | |
36822 | C5A2 = C5A**2 | |
36823 | ||
36824 | IF (LNU .EQ. 1) THEN | |
36825 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36826 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36827 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36828 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36829 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36830 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36831 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36832 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36833 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36834 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- | |
36835 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36836 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36837 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36838 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36839 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* | |
36840 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A | |
36841 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* | |
36842 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* | |
36843 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 | |
36844 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36845 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36846 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36847 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36848 | ELSE | |
36849 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36850 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36851 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36852 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36853 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36854 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36855 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36856 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36857 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36858 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ | |
36859 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36860 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36861 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36862 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36863 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* | |
36864 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A | |
36865 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* | |
36866 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* | |
36867 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 | |
36868 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36869 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36870 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36871 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36872 | ENDIF | |
36873 | ANS1=32.*ANS2 | |
36874 | ANS=ANS1/(3.*MD2) | |
36875 | P1CM = (S-MN2)/(2.*SQRT(S)) | |
36876 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) | |
36877 | ||
36878 | RETURN | |
36879 | END | |
36880 | ||
36881 | *$ CREATE DT_QGAUS.FOR | |
36882 | *COPY DT_QGAUS | |
36883 | * | |
36884 | *===qgaus==============================================================* | |
36885 | * | |
36886 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) | |
36887 | ||
36888 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36889 | SAVE | |
36890 | ||
36891 | DIMENSION X(5),W(5) | |
36892 | DATA X/.1488743389D0,.4333953941D0, | |
36893 | & .6794095682D0,.8650633666D0,.9739065285D0 | |
36894 | */ | |
36895 | DATA W/.2955242247D0,.2692667193D0, | |
36896 | & .2190863625D0,.1494513491D0,.0666713443D0 | |
36897 | */ | |
36898 | XM=0.5D0*(B+A) | |
36899 | XR=0.5D0*(B-A) | |
36900 | SS=0 | |
36901 | DO 11 J=1,5 | |
36902 | DX=XR*X(J) | |
36903 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ | |
36904 | * DT_DSQEL_Q2(LTYP,ENU,XM-DX)) | |
36905 | 11 CONTINUE | |
36906 | SS=XR*SS | |
36907 | ||
36908 | RETURN | |
36909 | END | |
36910 | ||
36911 | *$ CREATE DT_DIQBRK.FOR | |
36912 | *COPY DT_DIQBRK | |
36913 | * | |
36914 | *===diqbrk=============================================================* | |
36915 | * | |
36916 | SUBROUTINE DT_DIQBRK | |
36917 | ||
36918 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36919 | SAVE | |
36920 | ||
36921 | * event history | |
36922 | PARAMETER (NMXHKK=200000) | |
36923 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36924 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36925 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36926 | * extended event history | |
36927 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36928 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
36929 | & IHIST(2,NMXHKK) | |
36930 | * event flag | |
36931 | COMMON /DTEVNO/ NEVENT,ICASCA | |
36932 | ||
36933 | C IF(DT_RNDM(VV).LE.0.5D0)THEN | |
36934 | C CALL GSQBS1(NHKK) | |
36935 | C CALL GSQBS2(NHKK) | |
36936 | C CALL USQBS1(NHKK) | |
36937 | C CALL USQBS2(NHKK) | |
36938 | C CALL GSABS1(NHKK) | |
36939 | C CALL GSABS2(NHKK) | |
36940 | C CALL USABS1(NHKK) | |
36941 | C CALL USABS2(NHKK) | |
36942 | C ELSE | |
36943 | C CALL GSQBS2(NHKK) | |
36944 | C CALL GSQBS1(NHKK) | |
36945 | C CALL USQBS2(NHKK) | |
36946 | C CALL USQBS1(NHKK) | |
36947 | C CALL GSABS2(NHKK) | |
36948 | C CALL GSABS1(NHKK) | |
36949 | C CALL USABS2(NHKK) | |
36950 | C CALL USABS1(NHKK) | |
36951 | C ENDIF | |
36952 | ||
36953 | IF(DT_RNDM(VV).LE.0.5D0) THEN | |
36954 | CALL DT_DBREAK(1) | |
36955 | CALL DT_DBREAK(2) | |
36956 | CALL DT_DBREAK(3) | |
36957 | CALL DT_DBREAK(4) | |
36958 | CALL DT_DBREAK(5) | |
36959 | CALL DT_DBREAK(6) | |
36960 | CALL DT_DBREAK(7) | |
36961 | CALL DT_DBREAK(8) | |
36962 | ELSE | |
36963 | CALL DT_DBREAK(2) | |
36964 | CALL DT_DBREAK(1) | |
36965 | CALL DT_DBREAK(4) | |
36966 | CALL DT_DBREAK(3) | |
36967 | CALL DT_DBREAK(6) | |
36968 | CALL DT_DBREAK(5) | |
36969 | CALL DT_DBREAK(8) | |
36970 | CALL DT_DBREAK(7) | |
36971 | ENDIF | |
36972 | ||
36973 | RETURN | |
36974 | END | |
36975 | ||
36976 | *$ CREATE MUSQBS2.FOR | |
36977 | *COPY MUSQBS2 | |
36978 | C | |
36979 | C | |
36980 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
36981 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36982 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
36983 | C | |
36984 | C USQBS-2 diagram (split target diquark) | |
36985 | C | |
36986 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36987 | SAVE | |
36988 | ||
36989 | PARAMETER ( LINP = 10 , | |
36990 | & LOUT = 6 , | |
36991 | & LDAT = 9 ) | |
36992 | * event history | |
36993 | PARAMETER (NMXHKK=200000) | |
36994 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36995 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36996 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36997 | * extended event history | |
36998 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36999 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37000 | & IHIST(2,NMXHKK) | |
37001 | * Lorentz-parameters of the current interaction | |
37002 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37003 | & UMO,PPCM,EPROJ,PPROJ | |
37004 | * diquark-breaking mechanism | |
37005 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37006 | ||
37007 | C | |
37008 | PARAMETER (NTMHKK= 300) | |
37009 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37010 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37011 | +(4,NTMHKK) | |
37012 | *KEEP,XSEADI. | |
37013 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37014 | +SSMIMQ,VVMTHR | |
37015 | *KEEP,DPRIN. | |
37016 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37017 | COMMON /EVFLAG/ NUMEV | |
37018 | C | |
37019 | C USQBS-2 diagram (split target diquark) | |
37020 | C | |
37021 | C | |
37022 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
37023 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) | |
37024 | C | |
37025 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
37026 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37027 | C | |
37028 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37029 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37030 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37031 | C | |
37032 | C | |
37033 | C Put new chains into COMMON /HKKTMP/ | |
37034 | C | |
37035 | IIGLU1=NC1T-NC1P-1 | |
37036 | IIGLU2=NC2T-NC2P-1 | |
37037 | IGCOUN=0 | |
37038 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37039 | CVQ=1.D0 | |
37040 | IREJ=0 | |
37041 | IF(IPIP.EQ.2)THEN | |
37042 | C IF(NUMEV.EQ.-324)THEN | |
37043 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37044 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', | |
37045 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37046 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN | |
37047 | ENDIF | |
37048 | C | |
37049 | C | |
37050 | C | |
37051 | C determine x-values of NC1T diquark | |
37052 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37053 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37054 | C | |
37055 | C determine x-values of sea quark pair | |
37056 | C | |
37057 | IPCO=1 | |
37058 | ICOU=0 | |
37059 | 2234 CONTINUE | |
37060 | ICOU=ICOU+1 | |
37061 | IF(ICOU.GE.500)THEN | |
37062 | IREJ=1 | |
37063 | IF(ISQ.EQ.3)IREJ=3 | |
37064 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' | |
37065 | IPCO=0 | |
37066 | RETURN | |
37067 | ENDIF | |
37068 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37069 | * UMO, XDIQT,XVQP | |
37070 | XSQ=0.D0 | |
37071 | XSAQ=0.D0 | |
37072 | **NEW | |
37073 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37074 | IF (IPIP.EQ.1) THEN | |
37075 | XQMAX = XDIQT/2.0D0 | |
37076 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37077 | ELSE | |
37078 | XQMAX = 2.D0*XVQP/3.0D0 | |
37079 | XAQMAX = XDIQT/2.0D0 | |
37080 | ENDIF | |
37081 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37082 | ISAQ = 6+ISQ | |
37083 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37084 | ** | |
37085 | IF(IPCO.GE.3) | |
37086 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37087 | IF(IREJ.GE.1)THEN | |
37088 | IF(IPCO.GE.3) | |
37089 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37090 | IPCO=0 | |
37091 | RETURN | |
37092 | ENDIF | |
37093 | IF(IPIP.EQ.1)THEN | |
37094 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37095 | ELSEIF(IPIP.EQ.2)THEN | |
37096 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37097 | ENDIF | |
37098 | IF(IPCO.GE.3)THEN | |
37099 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37100 | * XDIQT,XVQP,XSQ,XSAQ | |
37101 | ENDIF | |
37102 | C | |
37103 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37104 | C | |
37105 | C XSQ=0.D0 | |
37106 | IF(IPIP.EQ.1)THEN | |
37107 | XDIQT=XDIQT-XSQ | |
37108 | XVQP =XVQP -XSAQ | |
37109 | ELSEIF(IPIP.EQ.2)THEN | |
37110 | XDIQT=XDIQT-XSAQ | |
37111 | XVQP =XVQP -XSQ | |
37112 | ENDIF | |
37113 | IF(IPCO.GE.3) | |
37114 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37115 | C | |
37116 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37117 | C | |
37118 | XVTHRO=CVQ/UMO | |
37119 | IVTHR=0 | |
37120 | 3466 CONTINUE | |
37121 | IF(IVTHR.EQ.10)THEN | |
37122 | IREJ=1 | |
37123 | IF(ISQ.EQ.3)IREJ=3 | |
37124 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' | |
37125 | IPCO=0 | |
37126 | RETURN | |
37127 | ENDIF | |
37128 | IVTHR=IVTHR+1 | |
37129 | XVTHR=XVTHRO/(201-IVTHR) | |
37130 | UNOPRV=UNON | |
37131 | 380 CONTINUE | |
37132 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37133 | IREJ=1 | |
37134 | IF(ISQ.EQ.3)IREJ=3 | |
37135 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ', | |
37136 | * XVTHR | |
37137 | IPCO=0 | |
37138 | RETURN | |
37139 | ENDIF | |
37140 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37141 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37142 | XVTQII=XDIQT-XVTQI | |
37143 | ELSE | |
37144 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37145 | XVTQI=XDIQT-XVTQII | |
37146 | ENDIF | |
37147 | IF(IPCO.GE.3)THEN | |
37148 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37149 | ENDIF | |
37150 | C | |
37151 | C Prepare 4 momenta of new chains and chain ends | |
37152 | C | |
37153 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37154 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37155 | C +(4,NTMHKK) | |
37156 | C | |
37157 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37158 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37159 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37160 | C | |
37161 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37162 | C * IP1,IP21,IP22,IPP1,IPP2) | |
37163 | C | |
37164 | IF(IPIP.EQ.1)THEN | |
37165 | XSQ1=XSQ | |
37166 | XSAQ1=XSAQ | |
37167 | ISQ1=ISQ | |
37168 | ISAQ1=ISAQ | |
37169 | ELSEIF(IPIP.EQ.2)THEN | |
37170 | XSQ1=XSAQ | |
37171 | XSAQ1=XSQ | |
37172 | ISQ1=ISAQ | |
37173 | ISAQ1=ISQ | |
37174 | ENDIF | |
37175 | IDHKT(1) =IPP1 | |
37176 | ISTHKT(1) =951 | |
37177 | JMOHKT(1,1)=NC2P | |
37178 | JMOHKT(2,1)=0 | |
37179 | JDAHKT(1,1)=3+IIGLU1 | |
37180 | JDAHKT(2,1)=0 | |
37181 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37182 | PHKT(1,1) =PHKK(1,NC2P) | |
37183 | PHKT(2,1) =PHKK(2,NC2P) | |
37184 | PHKT(3,1) =PHKK(3,NC2P) | |
37185 | PHKT(4,1) =PHKK(4,NC2P) | |
37186 | C PHKT(5,1) =PHKK(5,NC2P) | |
37187 | XMIST =(PHKT(4,1)**2- | |
37188 | * PHKT(3,1)**2-PHKT(2,1)**2- | |
37189 | *PHKT(1,1)**2) | |
37190 | IF(XMIST.GT.0.D0)THEN | |
37191 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37192 | *PHKT(1,1)**2) | |
37193 | ELSE | |
37194 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
37195 | PHKT(5,1)=0.D0 | |
37196 | ENDIF | |
37197 | VHKT(1,1) =VHKK(1,NC2P) | |
37198 | VHKT(2,1) =VHKK(2,NC2P) | |
37199 | VHKT(3,1) =VHKK(3,NC2P) | |
37200 | VHKT(4,1) =VHKK(4,NC2P) | |
37201 | WHKT(1,1) =WHKK(1,NC2P) | |
37202 | WHKT(2,1) =WHKK(2,NC2P) | |
37203 | WHKT(3,1) =WHKK(3,NC2P) | |
37204 | WHKT(4,1) =WHKK(4,NC2P) | |
37205 | C Add here IIGLU1 gluons to this chaina | |
37206 | PG1=0.D0 | |
37207 | PG2=0.D0 | |
37208 | PG3=0.D0 | |
37209 | PG4=0.D0 | |
37210 | IF(IIGLU1.GE.1)THEN | |
37211 | JJG=NC1P | |
37212 | DO 61 IIG=2,2+IIGLU1-1 | |
37213 | KKG=JJG+IIG-1 | |
37214 | IDHKT(IIG) =IDHKK(KKG) | |
37215 | ISTHKT(IIG) =921 | |
37216 | JMOHKT(1,IIG)=KKG | |
37217 | JMOHKT(2,IIG)=0 | |
37218 | JDAHKT(1,IIG)=3+IIGLU1 | |
37219 | JDAHKT(2,IIG)=0 | |
37220 | PHKT(1,IIG)=PHKK(1,KKG) | |
37221 | PG1=PG1+ PHKT(1,IIG) | |
37222 | PHKT(2,IIG)=PHKK(2,KKG) | |
37223 | PG2=PG2+ PHKT(2,IIG) | |
37224 | PHKT(3,IIG)=PHKK(3,KKG) | |
37225 | PG3=PG3+ PHKT(3,IIG) | |
37226 | PHKT(4,IIG)=PHKK(4,KKG) | |
37227 | PG4=PG4+ PHKT(4,IIG) | |
37228 | PHKT(5,IIG)=PHKK(5,KKG) | |
37229 | VHKT(1,IIG) =VHKK(1,KKG) | |
37230 | VHKT(2,IIG) =VHKK(2,KKG) | |
37231 | VHKT(3,IIG) =VHKK(3,KKG) | |
37232 | VHKT(4,IIG) =VHKK(4,KKG) | |
37233 | WHKT(1,IIG) =WHKK(1,KKG) | |
37234 | WHKT(2,IIG) =WHKK(2,KKG) | |
37235 | WHKT(3,IIG) =WHKK(3,KKG) | |
37236 | WHKT(4,IIG) =WHKK(4,KKG) | |
37237 | 61 CONTINUE | |
37238 | ENDIF | |
37239 | IDHKT(2+IIGLU1) =IP21 | |
37240 | ISTHKT(2+IIGLU1) =952 | |
37241 | JMOHKT(1,2+IIGLU1)=NC1T | |
37242 | JMOHKT(2,2+IIGLU1)=0 | |
37243 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
37244 | JDAHKT(2,2+IIGLU1)=0 | |
37245 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37246 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37247 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37248 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37249 | C PHKT(5,2) =PHKK(5,NC1T) | |
37250 | XMIST =(PHKT(4,2+IIGLU1)**2- | |
37251 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37252 | *PHKT(1,2+IIGLU1)**2) | |
37253 | IF(XMIST.GT.0.D0)THEN | |
37254 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
37255 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37256 | *PHKT(1,2+IIGLU1)**2) | |
37257 | ELSE | |
37258 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37259 | PHKT(5,5+IIGLU1)=0.D0 | |
37260 | ENDIF | |
37261 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
37262 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
37263 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
37264 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
37265 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
37266 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
37267 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
37268 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
37269 | IDHKT(3+IIGLU1) =88888 | |
37270 | ISTHKT(3+IIGLU1) =95 | |
37271 | JMOHKT(1,3+IIGLU1)=1 | |
37272 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
37273 | JDAHKT(1,3+IIGLU1)=0 | |
37274 | JDAHKT(2,3+IIGLU1)=0 | |
37275 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
37276 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
37277 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
37278 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
37279 | XMIST | |
37280 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37281 | * -PHKT(3,3+IIGLU1)**2) | |
37282 | IF(XMIST.GT.0.D0)THEN | |
37283 | PHKT(5,3+IIGLU1) | |
37284 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37285 | * -PHKT(3,3+IIGLU1)**2) | |
37286 | ELSE | |
37287 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37288 | PHKT(5,5+IIGLU1)=0.D0 | |
37289 | ENDIF | |
37290 | IF(IPIP.GE.2)THEN | |
37291 | C IF(NUMEV.EQ.-324)THEN | |
37292 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
37293 | C * JDAHKT(1,1), | |
37294 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
37295 | DO 71 IIG=2,2+IIGLU1-1 | |
37296 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
37297 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37298 | C * JDAHKT(1,IIG), | |
37299 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37300 | 71 CONTINUE | |
37301 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
37302 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
37303 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
37304 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
37305 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
37306 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
37307 | ENDIF | |
37308 | CHAMAL=CHAM1 | |
37309 | IF(IPIP.EQ.1)THEN | |
37310 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 | |
37311 | ELSEIF(IPIP.EQ.2)THEN | |
37312 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 | |
37313 | ENDIF | |
37314 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
37315 | C IREJ=1 | |
37316 | IPCO=0 | |
37317 | C RETURN | |
37318 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' | |
37319 | GO TO 3466 | |
37320 | ENDIF | |
37321 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
37322 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
37323 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
37324 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
37325 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
37326 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
37327 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
37328 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
37329 | IF(IPIP.EQ.1)THEN | |
37330 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37331 | ELSEIF(IPIP.EQ.2)THEN | |
37332 | IDHKT(4+IIGLU1) =ISAQ1 | |
37333 | ENDIF | |
37334 | ISTHKT(4+IIGLU1) =951 | |
37335 | JMOHKT(1,4+IIGLU1)=NC1P | |
37336 | JMOHKT(2,4+IIGLU1)=0 | |
37337 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37338 | JDAHKT(2,4+IIGLU1)=0 | |
37339 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37340 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37341 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37342 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37343 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37344 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37345 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
37346 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37347 | *PHKT(1,4+IIGLU1)**2) | |
37348 | IF(XMIST.GT.0.D0)THEN | |
37349 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
37350 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37351 | *PHKT(1,4+IIGLU1)**2) | |
37352 | ELSE | |
37353 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST | |
37354 | PHKT(5,4+IIGLU1)=0.D0 | |
37355 | ENDIF | |
37356 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37357 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37358 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37359 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37360 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37361 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37362 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37363 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37364 | IDHKT(5+IIGLU1) =IP22 | |
37365 | ISTHKT(5+IIGLU1) =952 | |
37366 | JMOHKT(1,5+IIGLU1)=NC1T | |
37367 | JMOHKT(2,5+IIGLU1)=0 | |
37368 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37369 | JDAHKT(2,5+IIGLU1)=0 | |
37370 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37371 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37372 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37373 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37374 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37375 | XMIST =(PHKT(4,5+IIGLU1)**2- | |
37376 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37377 | *PHKT(1,5+IIGLU1)**2) | |
37378 | IF(XMIST.GT.0.D0)THEN | |
37379 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
37380 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37381 | *PHKT(1,5+IIGLU1)**2) | |
37382 | ELSE | |
37383 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37384 | PHKT(5,5+IIGLU1)=0.D0 | |
37385 | ENDIF | |
37386 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37387 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37388 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37389 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37390 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37391 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37392 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37393 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37394 | IDHKT(6+IIGLU1) =88888 | |
37395 | ISTHKT(6+IIGLU1) =95 | |
37396 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37397 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37398 | JDAHKT(1,6+IIGLU1)=0 | |
37399 | JDAHKT(2,6+IIGLU1)=0 | |
37400 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37401 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37402 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37403 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37404 | XMIST | |
37405 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37406 | * -PHKT(3,6+IIGLU1)**2) | |
37407 | IF(XMIST.GT.0.D0)THEN | |
37408 | PHKT(5,6+IIGLU1) | |
37409 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37410 | * -PHKT(3,6+IIGLU1)**2) | |
37411 | ELSE | |
37412 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37413 | PHKT(5,5+IIGLU1)=0.D0 | |
37414 | ENDIF | |
37415 | C IF(IPIP.GE.2)THEN | |
37416 | C IF(NUMEV.EQ.-324)THEN | |
37417 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37418 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37419 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37420 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37421 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37422 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37423 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37424 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37425 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37426 | C ENDIF | |
37427 | CHAMAL=CHAM1 | |
37428 | IF(IPIP.EQ.1)THEN | |
37429 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37430 | ELSEIF(IPIP.EQ.2)THEN | |
37431 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37432 | ENDIF | |
37433 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37434 | C IREJ=1 | |
37435 | IPCO=0 | |
37436 | C RETURN | |
37437 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', | |
37438 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
37439 | GO TO 3466 | |
37440 | ENDIF | |
37441 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37442 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37443 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37444 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
37445 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
37446 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
37447 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
37448 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
37449 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
37450 | IDHKT(7+IIGLU1) =IP1 | |
37451 | ISTHKT(7+IIGLU1) =951 | |
37452 | JMOHKT(1,7+IIGLU1)=NC1P | |
37453 | JMOHKT(2,7+IIGLU1)=0 | |
37454 | **NEW | |
37455 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 | |
37456 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
37457 | ** | |
37458 | JDAHKT(2,7+IIGLU1)=0 | |
37459 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
37460 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
37461 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
37462 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
37463 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
37464 | XMIST =(PHKT(4,7+IIGLU1)**2- | |
37465 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37466 | *PHKT(1,7+IIGLU1)**2) | |
37467 | IF(XMIST.GT.0.D0)THEN | |
37468 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
37469 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37470 | *PHKT(1,7+IIGLU1)**2) | |
37471 | ELSE | |
37472 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST | |
37473 | PHKT(5,7+IIGLU1)=0.D0 | |
37474 | ENDIF | |
37475 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
37476 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
37477 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
37478 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
37479 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
37480 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
37481 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
37482 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
37483 | C Insert here the IIGLU2 gluons | |
37484 | PG1=0.D0 | |
37485 | PG2=0.D0 | |
37486 | PG3=0.D0 | |
37487 | PG4=0.D0 | |
37488 | IF(IIGLU2.GE.1)THEN | |
37489 | JJG=NC2P | |
37490 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37491 | KKG=JJG+IIG-7-IIGLU1 | |
37492 | IDHKT(IIG) =IDHKK(KKG) | |
37493 | ISTHKT(IIG) =921 | |
37494 | JMOHKT(1,IIG)=KKG | |
37495 | JMOHKT(2,IIG)=0 | |
37496 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
37497 | JDAHKT(2,IIG)=0 | |
37498 | PHKT(1,IIG)=PHKK(1,KKG) | |
37499 | PG1=PG1+ PHKT(1,IIG) | |
37500 | PHKT(2,IIG)=PHKK(2,KKG) | |
37501 | PG2=PG2+ PHKT(2,IIG) | |
37502 | PHKT(3,IIG)=PHKK(3,KKG) | |
37503 | PG3=PG3+ PHKT(3,IIG) | |
37504 | PHKT(4,IIG)=PHKK(4,KKG) | |
37505 | PG4=PG4+ PHKT(4,IIG) | |
37506 | PHKT(5,IIG)=PHKK(5,KKG) | |
37507 | VHKT(1,IIG) =VHKK(1,KKG) | |
37508 | VHKT(2,IIG) =VHKK(2,KKG) | |
37509 | VHKT(3,IIG) =VHKK(3,KKG) | |
37510 | VHKT(4,IIG) =VHKK(4,KKG) | |
37511 | WHKT(1,IIG) =WHKK(1,KKG) | |
37512 | WHKT(2,IIG) =WHKK(2,KKG) | |
37513 | WHKT(3,IIG) =WHKK(3,KKG) | |
37514 | WHKT(4,IIG) =WHKK(4,KKG) | |
37515 | 81 CONTINUE | |
37516 | ENDIF | |
37517 | IF(IPIP.EQ.1)THEN | |
37518 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
37519 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
37520 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
37521 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
37522 | ELSEIF(IPIP.EQ.2)THEN | |
37523 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
37524 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
37525 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
37526 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
37527 | ENDIF | |
37528 | ISTHKT(8+IIGLU1+IIGLU2) =952 | |
37529 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
37530 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
37531 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
37532 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
37533 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ | |
37534 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37535 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ | |
37536 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37537 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ | |
37538 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37539 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ | |
37540 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37541 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
37542 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
37543 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
37544 | C IREJ=1 | |
37545 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
37546 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T | |
37547 | IPCO=0 | |
37548 | C RETURN | |
37549 | GO TO 3466 | |
37550 | ENDIF | |
37551 | C PHKT(5,8) =PHKK(5,NC2T) | |
37552 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37553 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37554 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37555 | IF(XMIST.GT.0.D0)THEN | |
37556 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37557 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37558 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37559 | ELSE | |
37560 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37561 | PHKT(5,5+IIGLU1)=0.D0 | |
37562 | ENDIF | |
37563 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
37564 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
37565 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
37566 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
37567 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
37568 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
37569 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
37570 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
37571 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
37572 | ISTHKT(9+IIGLU1+IIGLU2) =95 | |
37573 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
37574 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
37575 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
37576 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
37577 | **NEW | |
37578 | C PHKT(1,9+IIGLU1+IIGLU2) | |
37579 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37580 | C PHKT(2,9+IIGLU1+IIGLU2) | |
37581 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37582 | C PHKT(3,9+IIGLU1+IIGLU2) | |
37583 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37584 | C PHKT(4,9+IIGLU1+IIGLU2) | |
37585 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37586 | PHKT(1,9+IIGLU1+IIGLU2) | |
37587 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37588 | PHKT(2,9+IIGLU1+IIGLU2) | |
37589 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37590 | PHKT(3,9+IIGLU1+IIGLU2) | |
37591 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37592 | PHKT(4,9+IIGLU1+IIGLU2) | |
37593 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37594 | ** | |
37595 | XMIST | |
37596 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37597 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37598 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37599 | IF(XMIST.GT.0.D0)THEN | |
37600 | PHKT(5,9+IIGLU1+IIGLU2) | |
37601 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37602 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37603 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37604 | ELSE | |
37605 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37606 | PHKT(5,5+IIGLU1)=0.D0 | |
37607 | ENDIF | |
37608 | IF(IPIP.GE.2)THEN | |
37609 | C IF(NUMEV.EQ.-324)THEN | |
37610 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
37611 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
37612 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
37613 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37614 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37615 | C * JDAHKT(1,IIG), | |
37616 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37617 | C 91 CONTINUE | |
37618 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
37619 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
37620 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
37621 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
37622 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
37623 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
37624 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
37625 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
37626 | ENDIF | |
37627 | CHAMAL=CHAB1 | |
37628 | IF(IPIP.EQ.1)THEN | |
37629 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
37630 | ELSEIF(IPIP.EQ.2)THEN | |
37631 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
37632 | ENDIF | |
37633 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
37634 | C IREJ=1 | |
37635 | IPCO=0 | |
37636 | C RETURN | |
37637 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', | |
37638 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
37639 | GO TO 3466 | |
37640 | ENDIF | |
37641 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
37642 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
37643 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
37644 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
37645 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
37646 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
37647 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
37648 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
37649 | C | |
37650 | IPCO=0 | |
37651 | IGCOUN=9+IIGLU1+IIGLU2 | |
37652 | RETURN | |
37653 | END | |
37654 | ||
37655 | *$ CREATE MGSQBS2.FOR | |
37656 | *COPY MGSQBS2 | |
37657 | C | |
37658 | C | |
37659 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
37660 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37661 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) | |
37662 | C | |
37663 | C GSQBS-2 diagram (split target diquark) | |
37664 | C | |
37665 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37666 | SAVE | |
37667 | ||
37668 | PARAMETER ( LINP = 10 , | |
37669 | & LOUT = 6 , | |
37670 | & LDAT = 9 ) | |
37671 | * event history | |
37672 | PARAMETER (NMXHKK=200000) | |
37673 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37674 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37675 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37676 | * extended event history | |
37677 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37678 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37679 | & IHIST(2,NMXHKK) | |
37680 | * Lorentz-parameters of the current interaction | |
37681 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37682 | & UMO,PPCM,EPROJ,PPROJ | |
37683 | * diquark-breaking mechanism | |
37684 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37685 | ||
37686 | C | |
37687 | PARAMETER (NTMHKK= 300) | |
37688 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37689 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37690 | +(4,NTMHKK) | |
37691 | ||
37692 | *KEEP,XSEADI. | |
37693 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37694 | +SSMIMQ,VVMTHR | |
37695 | *KEEP,DPRIN. | |
37696 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37697 | C | |
37698 | C GSQBS-2 diagram (split target diquark) | |
37699 | C | |
37700 | C | |
37701 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
37702 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) | |
37703 | C | |
37704 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
37705 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37706 | C | |
37707 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37708 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37709 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37710 | C | |
37711 | C | |
37712 | C | |
37713 | C Put new chains into COMMON /HKKTMP/ | |
37714 | C | |
37715 | IIGLU1=NC1T-NC1P-1 | |
37716 | IIGLU2=NC2T-NC2P-1 | |
37717 | IGCOUN=0 | |
37718 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37719 | CVQ=1.D0 | |
37720 | IREJ=0 | |
37721 | C IF(IPIP.EQ.2)THEN | |
37722 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37723 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', | |
37724 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37725 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN | |
37726 | C ENDIF | |
37727 | C | |
37728 | C | |
37729 | C | |
37730 | C determine x-values of NC1T diquark | |
37731 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37732 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37733 | C | |
37734 | C determine x-values of sea quark pair | |
37735 | C | |
37736 | IPCO=1 | |
37737 | ICOU=0 | |
37738 | 2234 CONTINUE | |
37739 | ICOU=ICOU+1 | |
37740 | IF(ICOU.GE.500)THEN | |
37741 | IREJ=1 | |
37742 | IF(ISQ.EQ.3)IREJ=3 | |
37743 | IF(IPCO.GE.3) | |
37744 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' | |
37745 | IPCO=0 | |
37746 | RETURN | |
37747 | ENDIF | |
37748 | IF(IPCO.GE.3) | |
37749 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37750 | * UMO, XDIQT,XVQP | |
37751 | XSQ=0.D0 | |
37752 | XSAQ=0.D0 | |
37753 | **NEW | |
37754 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37755 | IF (IPIP.EQ.1) THEN | |
37756 | XQMAX = XDIQT/2.0D0 | |
37757 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37758 | ELSE | |
37759 | XQMAX = 2.D0*XVQP/3.0D0 | |
37760 | XAQMAX = XDIQT/2.0D0 | |
37761 | ENDIF | |
37762 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37763 | ISAQ = 6+ISQ | |
37764 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37765 | ** | |
37766 | IF(IPCO.GE.3) | |
37767 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37768 | IF(IREJ.GE.1)THEN | |
37769 | IF(IPCO.GE.3) | |
37770 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37771 | IPCO=0 | |
37772 | RETURN | |
37773 | ENDIF | |
37774 | IF(IPIP.EQ.1)THEN | |
37775 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37776 | ELSEIF(IPIP.EQ.2)THEN | |
37777 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37778 | ENDIF | |
37779 | IF(IPCO.GE.3)THEN | |
37780 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37781 | * XDIQT,XVQP,XSQ,XSAQ | |
37782 | ENDIF | |
37783 | C | |
37784 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37785 | C | |
37786 | C XSQ=0.D0 | |
37787 | IF(IPIP.EQ.1)THEN | |
37788 | XDIQT=XDIQT-XSQ | |
37789 | XVQP =XVQP -XSAQ | |
37790 | ELSEIF(IPIP.EQ.2)THEN | |
37791 | XDIQT=XDIQT-XSAQ | |
37792 | XVQP =XVQP -XSQ | |
37793 | ENDIF | |
37794 | IF(IPCO.GE.3) | |
37795 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37796 | C | |
37797 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37798 | C | |
37799 | XVTHRO=CVQ/UMO | |
37800 | IVTHR=0 | |
37801 | 3466 CONTINUE | |
37802 | IF(IVTHR.EQ.10)THEN | |
37803 | IREJ=1 | |
37804 | IF(ISQ.EQ.3)IREJ=3 | |
37805 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' | |
37806 | IPCO=0 | |
37807 | RETURN | |
37808 | ENDIF | |
37809 | IVTHR=IVTHR+1 | |
37810 | XVTHR=XVTHRO/(201-IVTHR) | |
37811 | UNOPRV=UNON | |
37812 | 380 CONTINUE | |
37813 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37814 | IREJ=1 | |
37815 | IF(ISQ.EQ.3)IREJ=3 | |
37816 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ', | |
37817 | * XVTHR | |
37818 | IPCO=0 | |
37819 | RETURN | |
37820 | ENDIF | |
37821 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37822 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37823 | XVTQII=XDIQT-XVTQI | |
37824 | ELSE | |
37825 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37826 | XVTQI=XDIQT-XVTQII | |
37827 | ENDIF | |
37828 | IF(IPCO.GE.3)THEN | |
37829 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37830 | ENDIF | |
37831 | C | |
37832 | C Prepare 4 momenta of new chains and chain ends | |
37833 | C | |
37834 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37835 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37836 | C +(4,NTMHKK) | |
37837 | C | |
37838 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37839 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37840 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37841 | C | |
37842 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37843 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) | |
37844 | C | |
37845 | IF(IPIP.EQ.1)THEN | |
37846 | XSQ1=XSQ | |
37847 | XSAQ1=XSAQ | |
37848 | ISQ1=ISQ | |
37849 | ISAQ1=ISAQ | |
37850 | ELSEIF(IPIP.EQ.2)THEN | |
37851 | XSQ1=XSAQ | |
37852 | XSAQ1=XSQ | |
37853 | ISQ1=ISAQ | |
37854 | ISAQ1=ISQ | |
37855 | ENDIF | |
37856 | KK11=IP21 | |
37857 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37858 | KK21=IPP11 | |
37859 | KK22=IPP12 | |
37860 | XGIVE=0.D0 | |
37861 | IF(IPIP.EQ.1)THEN | |
37862 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37863 | ELSEIF(IPIP.EQ.2)THEN | |
37864 | IDHKT(4+IIGLU1) =ISAQ1 | |
37865 | ENDIF | |
37866 | ISTHKT(4+IIGLU1) =961 | |
37867 | JMOHKT(1,4+IIGLU1)=NC1P | |
37868 | JMOHKT(2,4+IIGLU1)=0 | |
37869 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37870 | JDAHKT(2,4+IIGLU1)=0 | |
37871 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37872 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37873 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37874 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37875 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37876 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37877 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
37878 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37879 | *PHKT(1,4+IIGLU1)**2) | |
37880 | IF(XXMIST.GT.0.D0)THEN | |
37881 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37882 | ELSE | |
37883 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
37884 | XXMIST=ABS(XXMIST) | |
37885 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37886 | ENDIF | |
37887 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37888 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37889 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37890 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37891 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37892 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37893 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37894 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37895 | IDHKT(5+IIGLU1) =IP22 | |
37896 | ISTHKT(5+IIGLU1) =962 | |
37897 | JMOHKT(1,5+IIGLU1)=NC1T | |
37898 | JMOHKT(2,5+IIGLU1)=0 | |
37899 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37900 | JDAHKT(2,5+IIGLU1)=0 | |
37901 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37902 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37903 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37904 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37905 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37906 | XXMIST=(PHKT(4,5+IIGLU1)**2- | |
37907 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37908 | *PHKT(1,5+IIGLU1)**2) | |
37909 | IF(XXMIST.GT.0.D0)THEN | |
37910 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37911 | ELSE | |
37912 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST | |
37913 | XXMIST=ABS(XXMIST) | |
37914 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37915 | ENDIF | |
37916 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37917 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37918 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37919 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37920 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37921 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37922 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37923 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37924 | IDHKT(6+IIGLU1) =88888 | |
37925 | ISTHKT(6+IIGLU1) =96 | |
37926 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37927 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37928 | JDAHKT(1,6+IIGLU1)=0 | |
37929 | JDAHKT(2,6+IIGLU1)=0 | |
37930 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37931 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37932 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37933 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37934 | PHKT(5,6+IIGLU1) | |
37935 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37936 | * -PHKT(3,6+IIGLU1)**2) | |
37937 | CHAMAL=CHAM1 | |
37938 | IF(IPIP.EQ.1)THEN | |
37939 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37940 | ELSEIF(IPIP.EQ.2)THEN | |
37941 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37942 | ENDIF | |
37943 | C--------------------------------------------------- | |
37944 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37945 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
37946 | C we drop chain 6 and give the energy to chain 3 | |
37947 | IDHKT(6+IIGLU1)=22888 | |
37948 | XGIVE=1.D0 | |
37949 | C WRITE(6,*)' drop chain 6 xgive=1' | |
37950 | GO TO 7788 | |
37951 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN | |
37952 | C we drop chain 6 and give the energy to chain 3 | |
37953 | C and change KK11 to IDHKT(5) | |
37954 | IDHKT(6+IIGLU1)=22888 | |
37955 | XGIVE=1.D0 | |
37956 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' | |
37957 | KK11=IDHKT(5+IIGLU1) | |
37958 | GO TO 7788 | |
37959 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN | |
37960 | C we drop chain 6 and give the energy to chain 3 | |
37961 | C and change KK21 to IDHKT(5+IIGLU1) | |
37962 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37963 | IDHKT(6+IIGLU1)=22888 | |
37964 | XGIVE=1.D0 | |
37965 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' | |
37966 | KK21=IDHKT(5+IIGLU1) | |
37967 | GO TO 7788 | |
37968 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN | |
37969 | C we drop chain 6 and give the energy to chain 3 | |
37970 | C and change KK22 to IDHKT(5) | |
37971 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37972 | IDHKT(6+IIGLU1)=22888 | |
37973 | XGIVE=1.D0 | |
37974 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' | |
37975 | KK22=IDHKT(5+IIGLU1) | |
37976 | GO TO 7788 | |
37977 | ENDIF | |
37978 | C IREJ=1 | |
37979 | IPCO=0 | |
37980 | C RETURN | |
37981 | GO TO 3466 | |
37982 | ENDIF | |
37983 | 7788 CONTINUE | |
37984 | C--------------------------------------------------- | |
37985 | IF(IPIP.GE.3)THEN | |
37986 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37987 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37988 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37989 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37990 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37991 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37992 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37993 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37994 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37995 | ENDIF | |
37996 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37997 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37998 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37999 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38000 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38001 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38002 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38003 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38004 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
38005 | IF(IPIP.EQ.1)THEN | |
38006 | IDHKT(1) =1000*KK21+100*KK22+3 | |
38007 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 | |
38008 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 | |
38009 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 | |
38010 | ELSEIF(IPIP.EQ.2)THEN | |
38011 | IDHKT(1) =1000*KK21+100*KK22-3 | |
38012 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 | |
38013 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 | |
38014 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 | |
38015 | ENDIF | |
38016 | ISTHKT(1) =961 | |
38017 | JMOHKT(1,1)=NC2P | |
38018 | JMOHKT(2,1)=0 | |
38019 | JDAHKT(1,1)=3+IIGLU1 | |
38020 | JDAHKT(2,1)=0 | |
38021 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
38022 | PHKT(1,1) =PHKK(1,NC2P) | |
38023 | *+XGIVE*PHKT(1,4+IIGLU1) | |
38024 | PHKT(2,1) =PHKK(2,NC2P) | |
38025 | *+XGIVE*PHKT(2,4+IIGLU1) | |
38026 | PHKT(3,1) =PHKK(3,NC2P) | |
38027 | *+XGIVE*PHKT(3,4+IIGLU1) | |
38028 | PHKT(4,1) =PHKK(4,NC2P) | |
38029 | *+XGIVE*PHKT(4,4+IIGLU1) | |
38030 | C PHKT(5,1) =PHKK(5,NC2P) | |
38031 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38032 | *PHKT(1,1)**2 | |
38033 | IF(XXMIST.GT.0.D0)THEN | |
38034 | PHKT(5,1) =SQRT(XXMIST) | |
38035 | ELSE | |
38036 | WRITE(LOUT,*)'MGSQBS2',XXMIST | |
38037 | XXMIST=ABS(XXMIST) | |
38038 | PHKT(5,1) =SQRT(XXMIST) | |
38039 | ENDIF | |
38040 | VHKT(1,1) =VHKK(1,NC2P) | |
38041 | VHKT(2,1) =VHKK(2,NC2P) | |
38042 | VHKT(3,1) =VHKK(3,NC2P) | |
38043 | VHKT(4,1) =VHKK(4,NC2P) | |
38044 | WHKT(1,1) =WHKK(1,NC2P) | |
38045 | WHKT(2,1) =WHKK(2,NC2P) | |
38046 | WHKT(3,1) =WHKK(3,NC2P) | |
38047 | WHKT(4,1) =WHKK(4,NC2P) | |
38048 | C Add here IIGLU1 gluons to this chaina | |
38049 | PG1=0.D0 | |
38050 | PG2=0.D0 | |
38051 | PG3=0.D0 | |
38052 | PG4=0.D0 | |
38053 | IF(IIGLU1.GE.1)THEN | |
38054 | JJG=NC1P | |
38055 | DO 61 IIG=2,2+IIGLU1-1 | |
38056 | KKG=JJG+IIG-1 | |
38057 | IDHKT(IIG) =IDHKK(KKG) | |
38058 | ISTHKT(IIG) =921 | |
38059 | JMOHKT(1,IIG)=KKG | |
38060 | JMOHKT(2,IIG)=0 | |
38061 | JDAHKT(1,IIG)=3+IIGLU1 | |
38062 | JDAHKT(2,IIG)=0 | |
38063 | PHKT(1,IIG)=PHKK(1,KKG) | |
38064 | PG1=PG1+ PHKT(1,IIG) | |
38065 | PHKT(2,IIG)=PHKK(2,KKG) | |
38066 | PG2=PG2+ PHKT(2,IIG) | |
38067 | PHKT(3,IIG)=PHKK(3,KKG) | |
38068 | PG3=PG3+ PHKT(3,IIG) | |
38069 | PHKT(4,IIG)=PHKK(4,KKG) | |
38070 | PG4=PG4+ PHKT(4,IIG) | |
38071 | PHKT(5,IIG)=PHKK(5,KKG) | |
38072 | VHKT(1,IIG) =VHKK(1,KKG) | |
38073 | VHKT(2,IIG) =VHKK(2,KKG) | |
38074 | VHKT(3,IIG) =VHKK(3,KKG) | |
38075 | VHKT(4,IIG) =VHKK(4,KKG) | |
38076 | WHKT(1,IIG) =WHKK(1,KKG) | |
38077 | WHKT(2,IIG) =WHKK(2,KKG) | |
38078 | WHKT(3,IIG) =WHKK(3,KKG) | |
38079 | WHKT(4,IIG) =WHKK(4,KKG) | |
38080 | 61 CONTINUE | |
38081 | ENDIF | |
38082 | C IDHKT(2) =IP21 | |
38083 | IDHKT(2+IIGLU1) =KK11 | |
38084 | ISTHKT(2+IIGLU1) =962 | |
38085 | JMOHKT(1,2+IIGLU1)=NC1T | |
38086 | JMOHKT(2,2+IIGLU1)=0 | |
38087 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38088 | JDAHKT(2,2+IIGLU1)=0 | |
38089 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38090 | C * +0.5D0*PHKK(1,NC2T) | |
38091 | *+XGIVE*PHKT(1,5+IIGLU1) | |
38092 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38093 | C *+0.5D0*PHKK(2,NC2T) | |
38094 | *+XGIVE*PHKT(2,5+IIGLU1) | |
38095 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38096 | C *+0.5D0*PHKK(3,NC2T) | |
38097 | *+XGIVE*PHKT(3,5+IIGLU1) | |
38098 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38099 | C *+0.5D0*PHKK(4,NC2T) | |
38100 | *+XGIVE*PHKT(4,5+IIGLU1) | |
38101 | C PHKT(5,2) =PHKK(5,NC1T) | |
38102 | XXMIST=(PHKT(4,2+IIGLU1)**2- | |
38103 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38104 | *PHKT(1,2+IIGLU1)**2) | |
38105 | IF(XXMIST.GT.0.D0)THEN | |
38106 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38107 | ELSE | |
38108 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
38109 | XXMIST=ABS(XXMIST) | |
38110 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38111 | ENDIF | |
38112 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
38113 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
38114 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
38115 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
38116 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
38117 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
38118 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
38119 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
38120 | IDHKT(3+IIGLU1) =88888 | |
38121 | ISTHKT(3+IIGLU1) =96 | |
38122 | JMOHKT(1,3+IIGLU1)=1 | |
38123 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38124 | JDAHKT(1,3+IIGLU1)=0 | |
38125 | JDAHKT(2,3+IIGLU1)=0 | |
38126 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38127 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38128 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38129 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38130 | PHKT(5,3+IIGLU1) | |
38131 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38132 | * -PHKT(3,3+IIGLU1)**2) | |
38133 | IF(IPIP.EQ.3)THEN | |
38134 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
38135 | * JDAHKT(1,1), | |
38136 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38137 | DO 71 IIG=2,2+IIGLU1-1 | |
38138 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38139 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38140 | * JDAHKT(1,IIG), | |
38141 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38142 | 71 CONTINUE | |
38143 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38144 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38145 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38146 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38147 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38148 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38149 | ENDIF | |
38150 | CHAMAL=CHAB1 | |
38151 | IF(IPIP.EQ.1)THEN | |
38152 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 | |
38153 | ELSEIF(IPIP.EQ.2)THEN | |
38154 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 | |
38155 | ENDIF | |
38156 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38157 | C IREJ=1 | |
38158 | IPCO=0 | |
38159 | C RETURN | |
38160 | GO TO 3466 | |
38161 | ENDIF | |
38162 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38163 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38164 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38165 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38166 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38167 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38168 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38169 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38170 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 | |
38171 | IDHKT(7+IIGLU1) =IP1 | |
38172 | ISTHKT(7+IIGLU1) =961 | |
38173 | JMOHKT(1,7+IIGLU1)=NC1P | |
38174 | JMOHKT(2,7+IIGLU1)=0 | |
38175 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38176 | JDAHKT(2,7+IIGLU1)=0 | |
38177 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
38178 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
38179 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
38180 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
38181 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
38182 | XXMIST=(PHKT(4,7+IIGLU1)**2- | |
38183 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38184 | *PHKT(1,7+IIGLU1)**2) | |
38185 | IF(XXMIST.GT.0.D0)THEN | |
38186 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38187 | ELSE | |
38188 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST | |
38189 | XXMIST=ABS(XXMIST) | |
38190 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38191 | ENDIF | |
38192 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
38193 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
38194 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
38195 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
38196 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
38197 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
38198 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
38199 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38200 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
38201 | C Insert here the IIGLU2 gluons | |
38202 | PG1=0.D0 | |
38203 | PG2=0.D0 | |
38204 | PG3=0.D0 | |
38205 | PG4=0.D0 | |
38206 | IF(IIGLU2.GE.1)THEN | |
38207 | JJG=NC2P | |
38208 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38209 | KKG=JJG+IIG-7-IIGLU1 | |
38210 | IDHKT(IIG) =IDHKK(KKG) | |
38211 | ISTHKT(IIG) =921 | |
38212 | JMOHKT(1,IIG)=KKG | |
38213 | JMOHKT(2,IIG)=0 | |
38214 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38215 | JDAHKT(2,IIG)=0 | |
38216 | PHKT(1,IIG)=PHKK(1,KKG) | |
38217 | PG1=PG1+ PHKT(1,IIG) | |
38218 | PHKT(2,IIG)=PHKK(2,KKG) | |
38219 | PG2=PG2+ PHKT(2,IIG) | |
38220 | PHKT(3,IIG)=PHKK(3,KKG) | |
38221 | PG3=PG3+ PHKT(3,IIG) | |
38222 | PHKT(4,IIG)=PHKK(4,KKG) | |
38223 | PG4=PG4+ PHKT(4,IIG) | |
38224 | PHKT(5,IIG)=PHKK(5,KKG) | |
38225 | VHKT(1,IIG) =VHKK(1,KKG) | |
38226 | VHKT(2,IIG) =VHKK(2,KKG) | |
38227 | VHKT(3,IIG) =VHKK(3,KKG) | |
38228 | VHKT(4,IIG) =VHKK(4,KKG) | |
38229 | WHKT(1,IIG) =WHKK(1,KKG) | |
38230 | WHKT(2,IIG) =WHKK(2,KKG) | |
38231 | WHKT(3,IIG) =WHKK(3,KKG) | |
38232 | WHKT(4,IIG) =WHKK(4,KKG) | |
38233 | 81 CONTINUE | |
38234 | ENDIF | |
38235 | IF(IPIP.EQ.1)THEN | |
38236 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
38237 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
38238 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
38239 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
38240 | ELSEIF(IPIP.EQ.2)THEN | |
38241 | **NEW | |
38242 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 | |
38243 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
38244 | ** | |
38245 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
38246 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
38247 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
38248 | ENDIF | |
38249 | ISTHKT(8+IIGLU1+IIGLU2) =962 | |
38250 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
38251 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38252 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38253 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38254 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) | |
38255 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) | |
38256 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) | |
38257 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) | |
38258 | PHKT(1,8+IIGLU1+IIGLU2) = | |
38259 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38260 | PHKT(2,8+IIGLU1+IIGLU2) = | |
38261 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38262 | PHKT(3,8+IIGLU1+IIGLU2) = | |
38263 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38264 | PHKT(4,8+IIGLU1+IIGLU2) = | |
38265 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38266 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
38267 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
38268 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
38269 | C IREJ=1 | |
38270 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
38271 | IPCO=0 | |
38272 | C RETURN | |
38273 | GO TO 3466 | |
38274 | ENDIF | |
38275 | C PHKT(5,8) =PHKK(5,NC2T) | |
38276 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38277 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38278 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38279 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
38280 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
38281 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
38282 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
38283 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
38284 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
38285 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
38286 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
38287 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38288 | ISTHKT(9+IIGLU1+IIGLU2) =96 | |
38289 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38290 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38291 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38292 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38293 | PHKT(1,9+IIGLU1+IIGLU2) | |
38294 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38295 | PHKT(2,9+IIGLU1+IIGLU2) | |
38296 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38297 | PHKT(3,9+IIGLU1+IIGLU2) | |
38298 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38299 | PHKT(4,9+IIGLU1+IIGLU2) | |
38300 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38301 | PHKT(5,9+IIGLU1+IIGLU2) | |
38302 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
38303 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38304 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38305 | IF(IPIP.GE.3)THEN | |
38306 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38307 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38308 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38309 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38310 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38311 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38312 | * JDAHKT(1,IIG), | |
38313 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38314 | 91 CONTINUE | |
38315 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
38316 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
38317 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
38318 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38319 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38320 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38321 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38322 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38323 | ENDIF | |
38324 | CHAMAL=CHAB1 | |
38325 | IF(IPIP.EQ.1)THEN | |
38326 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38327 | ELSEIF(IPIP.EQ.2)THEN | |
38328 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38329 | ENDIF | |
38330 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38331 | C IREJ=1 | |
38332 | IPCO=0 | |
38333 | C RETURN | |
38334 | GO TO 3466 | |
38335 | ENDIF | |
38336 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38337 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38338 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38339 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38340 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38341 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38342 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38343 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38344 | C | |
38345 | IPCO=0 | |
38346 | IGCOUN=9+IIGLU1+IIGLU2 | |
38347 | RETURN | |
38348 | END | |
38349 | ||
38350 | *$ CREATE MUSQBS1.FOR | |
38351 | *COPY MUSQBS1 | |
38352 | C | |
38353 | C | |
38354 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
38355 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38356 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
38357 | C | |
38358 | C USQBS-1 diagram (split projectile diquark) | |
38359 | C | |
38360 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38361 | SAVE | |
38362 | ||
38363 | PARAMETER ( LINP = 10 , | |
38364 | & LOUT = 6 , | |
38365 | & LDAT = 9 ) | |
38366 | * event history | |
38367 | PARAMETER (NMXHKK=200000) | |
38368 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38369 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38370 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38371 | * extended event history | |
38372 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38373 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38374 | & IHIST(2,NMXHKK) | |
38375 | * Lorentz-parameters of the current interaction | |
38376 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
38377 | & UMO,PPCM,EPROJ,PPROJ | |
38378 | * diquark-breaking mechanism | |
38379 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
38380 | ||
38381 | C | |
38382 | PARAMETER (NTMHKK= 300) | |
38383 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38384 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38385 | +(4,NTMHKK) | |
38386 | *KEEP,XSEADI. | |
38387 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
38388 | +SSMIMQ,VVMTHR | |
38389 | *KEEP,DPRIN. | |
38390 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
38391 | COMMON /EVFLAG/ NUMEV | |
38392 | C | |
38393 | C USQBS-1 diagram (split projectile diquark) | |
38394 | C | |
38395 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
38396 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) | |
38397 | C | |
38398 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T | |
38399 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38400 | C | |
38401 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38402 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38403 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38404 | C | |
38405 | C Put new chains into COMMON /HKKTMP/ | |
38406 | C | |
38407 | IIGLU1=NC1T-NC1P-1 | |
38408 | IIGLU2=NC2T-NC2P-1 | |
38409 | IGCOUN=0 | |
38410 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP | |
38411 | CVQ=1.D0 | |
38412 | IREJ=0 | |
38413 | IF(IPIP.EQ.3)THEN | |
38414 | C IF(NUMEV.EQ.-324)THEN | |
38415 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
38416 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', | |
38417 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38418 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN | |
38419 | ENDIF | |
38420 | C | |
38421 | C | |
38422 | C | |
38423 | C determine x-values of NC1P diquark | |
38424 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
38425 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
38426 | C | |
38427 | C determine x-values of sea quark pair | |
38428 | C | |
38429 | IPCO=1 | |
38430 | ICOU=0 | |
38431 | 2234 CONTINUE | |
38432 | ICOU=ICOU+1 | |
38433 | IF(ICOU.GE.500)THEN | |
38434 | IREJ=1 | |
38435 | IF(ISQ.EQ.3)IREJ=3 | |
38436 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' | |
38437 | IPCO=0 | |
38438 | RETURN | |
38439 | ENDIF | |
38440 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
38441 | * UMO, XDIQP,XVQT | |
38442 | XSQ=0.D0 | |
38443 | XSAQ=0.D0 | |
38444 | **NEW | |
38445 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
38446 | IF (IPIP.EQ.1) THEN | |
38447 | XQMAX = XDIQP/2.0D0 | |
38448 | XAQMAX = 2.D0*XVQT/3.0D0 | |
38449 | ELSE | |
38450 | XQMAX = 2.D0*XVQT/3.0D0 | |
38451 | XAQMAX = XDIQP/2.0D0 | |
38452 | ENDIF | |
38453 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
38454 | ISAQ = 6+ISQ | |
38455 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
38456 | ** | |
38457 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38458 | IF(IREJ.GE.1)THEN | |
38459 | IF(IPCO.GE.3) | |
38460 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38461 | IPCO=0 | |
38462 | RETURN | |
38463 | ENDIF | |
38464 | IF(IPIP.EQ.1)THEN | |
38465 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38466 | ELSEIF(IPIP.EQ.2)THEN | |
38467 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38468 | ENDIF | |
38469 | IF(IPCO.GE.3)THEN | |
38470 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
38471 | * XDIQP,XVQT,XSQ,XSAQ | |
38472 | ENDIF | |
38473 | C | |
38474 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
38475 | C | |
38476 | C XSQ=0.D0 | |
38477 | IF(IPIP.EQ.1)THEN | |
38478 | XDIQP=XDIQP-XSQ | |
38479 | XVQT =XVQT -XSAQ | |
38480 | ELSEIF(IPIP.EQ.2)THEN | |
38481 | XDIQP=XDIQP-XSAQ | |
38482 | XVQT =XVQT -XSQ | |
38483 | ENDIF | |
38484 | IF(IPCO.GE.3) | |
38485 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
38486 | C | |
38487 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38488 | C | |
38489 | XVTHRO=CVQ/UMO | |
38490 | IVTHR=0 | |
38491 | 3466 CONTINUE | |
38492 | IF(IVTHR.EQ.10)THEN | |
38493 | IREJ=1 | |
38494 | IF(ISQ.EQ.3)IREJ=3 | |
38495 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' | |
38496 | IPCO=0 | |
38497 | RETURN | |
38498 | ENDIF | |
38499 | IVTHR=IVTHR+1 | |
38500 | XVTHR=XVTHRO/(201-IVTHR) | |
38501 | UNOPRV=UNON | |
38502 | 380 CONTINUE | |
38503 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
38504 | IREJ=1 | |
38505 | IF(ISQ.EQ.3)IREJ=3 | |
38506 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ', | |
38507 | * XVTHR | |
38508 | IPCO=0 | |
38509 | RETURN | |
38510 | ENDIF | |
38511 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
38512 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38513 | XVPQII=XDIQP-XVPQI | |
38514 | ELSE | |
38515 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38516 | XVPQI=XDIQP-XVPQII | |
38517 | ENDIF | |
38518 | IF(IPCO.GE.3)THEN | |
38519 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII | |
38520 | ENDIF | |
38521 | C | |
38522 | C Prepare 4 momenta of new chains and chain ends | |
38523 | C | |
38524 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38525 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38526 | C +(4,NTMHKK) | |
38527 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38528 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38529 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38530 | IF(IPIP.EQ.1)THEN | |
38531 | XSQ1=XSQ | |
38532 | XSAQ1=XSAQ | |
38533 | ISQ1=ISQ | |
38534 | ISAQ1=ISAQ | |
38535 | ELSEIF(IPIP.EQ.2)THEN | |
38536 | XSQ1=XSAQ | |
38537 | XSAQ1=XSQ | |
38538 | ISQ1=ISAQ | |
38539 | ISAQ1=ISQ | |
38540 | ENDIF | |
38541 | IDHKT(1) =IP11 | |
38542 | ISTHKT(1) =931 | |
38543 | JMOHKT(1,1)=NC1P | |
38544 | JMOHKT(2,1)=0 | |
38545 | JDAHKT(1,1)=3+IIGLU1 | |
38546 | JDAHKT(2,1)=0 | |
38547 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38548 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38549 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38550 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38551 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38552 | C PHKT(5,1) =PHKK(5,NC1P) | |
38553 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38554 | *PHKT(1,1)**2) | |
38555 | IF(XMIST.GE.0.D0)THEN | |
38556 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38557 | *PHKT(1,1)**2) | |
38558 | ELSE | |
38559 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38560 | PHKT(5,1)=0.D0 | |
38561 | ENDIF | |
38562 | VHKT(1,1) =VHKK(1,NC1P) | |
38563 | VHKT(2,1) =VHKK(2,NC1P) | |
38564 | VHKT(3,1) =VHKK(3,NC1P) | |
38565 | VHKT(4,1) =VHKK(4,NC1P) | |
38566 | WHKT(1,1) =WHKK(1,NC1P) | |
38567 | WHKT(2,1) =WHKK(2,NC1P) | |
38568 | WHKT(3,1) =WHKK(3,NC1P) | |
38569 | WHKT(4,1) =WHKK(4,NC1P) | |
38570 | C Add here IIGLU1 gluons to this chaina | |
38571 | PG1=0.D0 | |
38572 | PG2=0.D0 | |
38573 | PG3=0.D0 | |
38574 | PG4=0.D0 | |
38575 | IF(IIGLU1.GE.1)THEN | |
38576 | JJG=NC1P | |
38577 | DO 61 IIG=2,2+IIGLU1-1 | |
38578 | KKG=JJG+IIG-1 | |
38579 | IDHKT(IIG) =IDHKK(KKG) | |
38580 | ISTHKT(IIG) =921 | |
38581 | JMOHKT(1,IIG)=KKG | |
38582 | JMOHKT(2,IIG)=0 | |
38583 | JDAHKT(1,IIG)=3+IIGLU1 | |
38584 | JDAHKT(2,IIG)=0 | |
38585 | PHKT(1,IIG)=PHKK(1,KKG) | |
38586 | PG1=PG1+ PHKT(1,IIG) | |
38587 | PHKT(2,IIG)=PHKK(2,KKG) | |
38588 | PG2=PG2+ PHKT(2,IIG) | |
38589 | PHKT(3,IIG)=PHKK(3,KKG) | |
38590 | PG3=PG3+ PHKT(3,IIG) | |
38591 | PHKT(4,IIG)=PHKK(4,KKG) | |
38592 | PG4=PG4+ PHKT(4,IIG) | |
38593 | PHKT(5,IIG)=PHKK(5,KKG) | |
38594 | VHKT(1,IIG) =VHKK(1,KKG) | |
38595 | VHKT(2,IIG) =VHKK(2,KKG) | |
38596 | VHKT(3,IIG) =VHKK(3,KKG) | |
38597 | VHKT(4,IIG) =VHKK(4,KKG) | |
38598 | WHKT(1,IIG) =WHKK(1,KKG) | |
38599 | WHKT(2,IIG) =WHKK(2,KKG) | |
38600 | WHKT(3,IIG) =WHKK(3,KKG) | |
38601 | WHKT(4,IIG) =WHKK(4,KKG) | |
38602 | 61 CONTINUE | |
38603 | ENDIF | |
38604 | IDHKT(2+IIGLU1) =IPP2 | |
38605 | ISTHKT(2+IIGLU1) =932 | |
38606 | JMOHKT(1,2+IIGLU1)=NC2T | |
38607 | JMOHKT(2,2+IIGLU1)=0 | |
38608 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38609 | JDAHKT(2,2+IIGLU1)=0 | |
38610 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
38611 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
38612 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
38613 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
38614 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) | |
38615 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
38616 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38617 | *PHKT(1,2+IIGLU1)**2) | |
38618 | IF(XMIST.GT.0.D0)THEN | |
38619 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
38620 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38621 | *PHKT(1,2+IIGLU1)**2) | |
38622 | ELSE | |
38623 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38624 | PHKT(5,2+IIGLU1)=0.D0 | |
38625 | ENDIF | |
38626 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
38627 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
38628 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
38629 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
38630 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
38631 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
38632 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
38633 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
38634 | IDHKT(3+IIGLU1) =88888 | |
38635 | ISTHKT(3+IIGLU1) =94 | |
38636 | JMOHKT(1,3+IIGLU1)=1 | |
38637 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38638 | JDAHKT(1,3+IIGLU1)=0 | |
38639 | JDAHKT(2,3+IIGLU1)=0 | |
38640 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38641 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38642 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38643 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38644 | XMIST | |
38645 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38646 | * -PHKT(3,3+IIGLU1)**2) | |
38647 | IF(XMIST.GE.0.D0)THEN | |
38648 | PHKT(5,3+IIGLU1) | |
38649 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38650 | * -PHKT(3,3+IIGLU1)**2) | |
38651 | ELSE | |
38652 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38653 | PHKT(5,1)=0.D0 | |
38654 | ENDIF | |
38655 | IF(IPIP.GE.3)THEN | |
38656 | C IF(NUMEV.EQ.-324)THEN | |
38657 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), | |
38658 | * JMOHKT(2,1),JDAHKT(1,1), | |
38659 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38660 | DO 71 IIG=2,2+IIGLU1-1 | |
38661 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38662 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38663 | * JDAHKT(1,IIG), | |
38664 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38665 | 71 CONTINUE | |
38666 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38667 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38668 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38669 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38670 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38671 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38672 | ENDIF | |
38673 | CHAMAL=CHAM1 | |
38674 | IF(IPIP.EQ.1)THEN | |
38675 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 | |
38676 | ELSEIF(IPIP.EQ.2)THEN | |
38677 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 | |
38678 | ENDIF | |
38679 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38680 | C IREJ=1 | |
38681 | IPCO=0 | |
38682 | C RETURN | |
38683 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' | |
38684 | GO TO 3466 | |
38685 | ENDIF | |
38686 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38687 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38688 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38689 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38690 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38691 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38692 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38693 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38694 | IDHKT(4+IIGLU1) =IP12 | |
38695 | ISTHKT(4+IIGLU1) =931 | |
38696 | JMOHKT(1,4+IIGLU1)=NC1P | |
38697 | JMOHKT(2,4+IIGLU1)=0 | |
38698 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
38699 | JDAHKT(2,4+IIGLU1)=0 | |
38700 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38701 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38702 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38703 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38704 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38705 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
38706 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
38707 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38708 | *PHKT(1,4+IIGLU1)**2) | |
38709 | IF(XMIST.GT.0.D0)THEN | |
38710 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
38711 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38712 | *PHKT(1,4+IIGLU1)**2) | |
38713 | ELSE | |
38714 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38715 | PHKT(5,4+IIGLU1)=0.D0 | |
38716 | ENDIF | |
38717 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
38718 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
38719 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
38720 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
38721 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
38722 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
38723 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
38724 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
38725 | IF(IPIP.EQ.1)THEN | |
38726 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
38727 | ELSEIF(IPIP.EQ.2)THEN | |
38728 | IDHKT(5+IIGLU1) =ISAQ1 | |
38729 | ENDIF | |
38730 | ISTHKT(5+IIGLU1) =932 | |
38731 | JMOHKT(1,5+IIGLU1)=NC1T | |
38732 | JMOHKT(2,5+IIGLU1)=0 | |
38733 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
38734 | JDAHKT(2,5+IIGLU1)=0 | |
38735 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38736 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38737 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38738 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38739 | C IF( PHKT(4,5).EQ.0.D0)THEN | |
38740 | C IREJ=1 | |
38741 | CIPCO=0 | |
38742 | CRETURN | |
38743 | C ENDIF | |
38744 | C PHKT(5,5) =PHKK(5,NC1T) | |
38745 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
38746 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38747 | *PHKT(1,5+IIGLU1)**2) | |
38748 | IF(XMIST.GT.0.D0)THEN | |
38749 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
38750 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38751 | *PHKT(1,5+IIGLU1)**2) | |
38752 | ELSE | |
38753 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38754 | PHKT(5,5+IIGLU1)=0.D0 | |
38755 | ENDIF | |
38756 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
38757 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
38758 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
38759 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
38760 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
38761 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
38762 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
38763 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
38764 | IDHKT(6+IIGLU1) =88888 | |
38765 | ISTHKT(6+IIGLU1) =94 | |
38766 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
38767 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
38768 | JDAHKT(1,6+IIGLU1)=0 | |
38769 | JDAHKT(2,6+IIGLU1)=0 | |
38770 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
38771 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
38772 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
38773 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
38774 | XMIST | |
38775 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38776 | * -PHKT(3,6+IIGLU1)**2) | |
38777 | IF(XMIST.GE.0.D0)THEN | |
38778 | PHKT(5,6+IIGLU1) | |
38779 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38780 | * -PHKT(3,6+IIGLU1)**2) | |
38781 | ELSE | |
38782 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38783 | PHKT(5,1)=0.D0 | |
38784 | ENDIF | |
38785 | C IF(IPIP.EQ.3)THEN | |
38786 | CHAMAL=CHAM1 | |
38787 | IF(IPIP.EQ.1)THEN | |
38788 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
38789 | ELSEIF(IPIP.EQ.2)THEN | |
38790 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
38791 | ENDIF | |
38792 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
38793 | C IREJ=1 | |
38794 | IPCO=0 | |
38795 | C RETURN | |
38796 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', | |
38797 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
38798 | GO TO 3466 | |
38799 | ENDIF | |
38800 | IF(IPIP.GE.3)THEN | |
38801 | C IF(NUMEV.EQ.-324)THEN | |
38802 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
38803 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
38804 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
38805 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
38806 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
38807 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
38808 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
38809 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
38810 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
38811 | ENDIF | |
38812 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
38813 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
38814 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
38815 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38816 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38817 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38818 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38819 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38820 | IF(IPIP.EQ.1)THEN | |
38821 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 | |
38822 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
38823 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
38824 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
38825 | ELSEIF(IPIP.EQ.2)THEN | |
38826 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
38827 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
38828 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
38829 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
38830 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 | |
38831 | ENDIF | |
38832 | ISTHKT(7+IIGLU1) =931 | |
38833 | JMOHKT(1,7+IIGLU1)=NC2P | |
38834 | JMOHKT(2,7+IIGLU1)=0 | |
38835 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38836 | JDAHKT(2,7+IIGLU1)=0 | |
38837 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38838 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38839 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38840 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38841 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38842 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
38843 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
38844 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
38845 | C IREJ=1 | |
38846 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' | |
38847 | IPCO=0 | |
38848 | C RETURN | |
38849 | GO TO 3466 | |
38850 | ENDIF | |
38851 | C PHKT(5,7) =PHKK(5,NC2P) | |
38852 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
38853 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38854 | *PHKT(1,7+IIGLU1)**2) | |
38855 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
38856 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
38857 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
38858 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
38859 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
38860 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
38861 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
38862 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38863 | C Insert here the IIGLU2 gluons | |
38864 | PG1=0.D0 | |
38865 | PG2=0.D0 | |
38866 | PG3=0.D0 | |
38867 | PG4=0.D0 | |
38868 | IF(IIGLU2.GE.1)THEN | |
38869 | JJG=NC2P | |
38870 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38871 | KKG=JJG+IIG-7-IIGLU1 | |
38872 | IDHKT(IIG) =IDHKK(KKG) | |
38873 | ISTHKT(IIG) =921 | |
38874 | JMOHKT(1,IIG)=KKG | |
38875 | JMOHKT(2,IIG)=0 | |
38876 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38877 | JDAHKT(2,IIG)=0 | |
38878 | PHKT(1,IIG)=PHKK(1,KKG) | |
38879 | PG1=PG1+ PHKT(1,IIG) | |
38880 | PHKT(2,IIG)=PHKK(2,KKG) | |
38881 | PG2=PG2+ PHKT(2,IIG) | |
38882 | PHKT(3,IIG)=PHKK(3,KKG) | |
38883 | PG3=PG3+ PHKT(3,IIG) | |
38884 | PHKT(4,IIG)=PHKK(4,KKG) | |
38885 | PG4=PG4+ PHKT(4,IIG) | |
38886 | PHKT(5,IIG)=PHKK(5,KKG) | |
38887 | VHKT(1,IIG) =VHKK(1,KKG) | |
38888 | VHKT(2,IIG) =VHKK(2,KKG) | |
38889 | VHKT(3,IIG) =VHKK(3,KKG) | |
38890 | VHKT(4,IIG) =VHKK(4,KKG) | |
38891 | WHKT(1,IIG) =WHKK(1,KKG) | |
38892 | WHKT(2,IIG) =WHKK(2,KKG) | |
38893 | WHKT(3,IIG) =WHKK(3,KKG) | |
38894 | WHKT(4,IIG) =WHKK(4,KKG) | |
38895 | 81 CONTINUE | |
38896 | ENDIF | |
38897 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
38898 | ISTHKT(8+IIGLU1+IIGLU2) =932 | |
38899 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
38900 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38901 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38902 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38903 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
38904 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
38905 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
38906 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
38907 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
38908 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38909 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38910 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38911 | IF(XMIST.GT.0.D0)THEN | |
38912 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38913 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38914 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38915 | ELSE | |
38916 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38917 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
38918 | ENDIF | |
38919 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
38920 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
38921 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
38922 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
38923 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
38924 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
38925 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
38926 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
38927 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38928 | ISTHKT(9+IIGLU1+IIGLU2) =94 | |
38929 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38930 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38931 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38932 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38933 | PHKT(1,9+IIGLU1+IIGLU2) | |
38934 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38935 | PHKT(2,9+IIGLU1+IIGLU2) | |
38936 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38937 | PHKT(3,9+IIGLU1+IIGLU2) | |
38938 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38939 | PHKT(4,9+IIGLU1+IIGLU2) | |
38940 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38941 | XMIST | |
38942 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38943 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38944 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38945 | IF(XMIST.GE.0.D0)THEN | |
38946 | PHKT(5,9+IIGLU1+IIGLU2) | |
38947 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38948 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38949 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38950 | ELSE | |
38951 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38952 | PHKT(5,1)=0.D0 | |
38953 | ENDIF | |
38954 | IF(IPIP.GE.3)THEN | |
38955 | C IF(NUMEV.EQ.-324)THEN | |
38956 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38957 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38958 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38959 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38960 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38961 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38962 | * JDAHKT(1,IIG), | |
38963 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38964 | 91 CONTINUE | |
38965 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, | |
38966 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), | |
38967 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
38968 | *JDAHKT(1,8+IIGLU1+IIGLU2), | |
38969 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38970 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38971 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38972 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38973 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38974 | ENDIF | |
38975 | CHAMAL=CHAB1 | |
38976 | IF(IPIP.EQ.1)THEN | |
38977 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38978 | ELSEIF(IPIP.EQ.2)THEN | |
38979 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38980 | ENDIF | |
38981 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38982 | C IREJ=1 | |
38983 | IPCO=0 | |
38984 | C RETURN | |
38985 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
38986 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
38987 | GO TO 3466 | |
38988 | ENDIF | |
38989 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38990 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38991 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38992 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38993 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38994 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38995 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38996 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38997 | C | |
38998 | IPCO=0 | |
38999 | IGCOUN=9+IIGLU1+IIGLU2 | |
39000 | RETURN | |
39001 | END | |
39002 | ||
39003 | *$ CREATE MGSQBS1.FOR | |
39004 | *COPY MGSQBS1 | |
39005 | C | |
39006 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
39007 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
39008 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) | |
39009 | C | |
39010 | C GSQBS-1 diagram (split projectile diquark) | |
39011 | C | |
39012 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39013 | SAVE | |
39014 | ||
39015 | PARAMETER ( LINP = 10 , | |
39016 | & LOUT = 6 , | |
39017 | & LDAT = 9 ) | |
39018 | * event history | |
39019 | PARAMETER (NMXHKK=200000) | |
39020 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39021 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39022 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39023 | * extended event history | |
39024 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39025 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39026 | & IHIST(2,NMXHKK) | |
39027 | * Lorentz-parameters of the current interaction | |
39028 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
39029 | & UMO,PPCM,EPROJ,PPROJ | |
39030 | * diquark-breaking mechanism | |
39031 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
39032 | ||
39033 | C | |
39034 | PARAMETER (NTMHKK= 300) | |
39035 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39036 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39037 | +(4,NTMHKK) | |
39038 | *KEEP,XSEADI. | |
39039 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
39040 | +SSMIMQ,VVMTHR | |
39041 | *KEEP,DPRIN. | |
39042 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
39043 | C | |
39044 | C GSQBS-1 diagram (split projectile diquark) | |
39045 | C | |
39046 | C | |
39047 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
39048 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) | |
39049 | C | |
39050 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T | |
39051 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39052 | C | |
39053 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39054 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39055 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39056 | C | |
39057 | C Put new chains into COMMON /HKKTMP/ | |
39058 | C | |
39059 | IIGLU1=NC1T-NC1P-1 | |
39060 | IIGLU2=NC2T-NC2P-1 | |
39061 | IGCOUN=0 | |
39062 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
39063 | CVQ=1.D0 | |
39064 | NNNC1=IDHKK(NC1)/1000 | |
39065 | MMMC1=IDHKK(NC1)-NNNC1*1000 | |
39066 | KKKC1=ISTHKK(NC1) | |
39067 | NNNC2=IDHKK(NC2)/1000 | |
39068 | MMMC2=IDHKK(NC2)-NNNC2*1000 | |
39069 | KKKC2=ISTHKK(NC2) | |
39070 | IREJ=0 | |
39071 | IF(IPIP.EQ.3)THEN | |
39072 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
39073 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', | |
39074 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
39075 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN | |
39076 | ENDIF | |
39077 | C | |
39078 | C | |
39079 | C | |
39080 | C determine x-values of NC1P diquark | |
39081 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
39082 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
39083 | C | |
39084 | C determine x-values of sea quark pair | |
39085 | C | |
39086 | IPCO=1 | |
39087 | ICOU=0 | |
39088 | 2234 CONTINUE | |
39089 | ICOU=ICOU+1 | |
39090 | IF(ICOU.GE.500)THEN | |
39091 | IREJ=1 | |
39092 | IF(ISQ.EQ.3)IREJ=3 | |
39093 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' | |
39094 | IPCO=0 | |
39095 | RETURN | |
39096 | ENDIF | |
39097 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
39098 | * UMO, XDIQP,XVQT | |
39099 | XSQ=0.D0 | |
39100 | XSAQ=0.D0 | |
39101 | **NEW | |
39102 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
39103 | IF (IPIP.EQ.1) THEN | |
39104 | XQMAX = XDIQP/2.0D0 | |
39105 | XAQMAX = 2.D0*XVQT/3.0D0 | |
39106 | ELSE | |
39107 | XQMAX = 2.D0*XVQT/3.0D0 | |
39108 | XAQMAX = XDIQP/2.0D0 | |
39109 | ENDIF | |
39110 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
39111 | ISAQ = 6+ISQ | |
39112 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
39113 | ** | |
39114 | IF(IPCO.GE.3) | |
39115 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39116 | IF(IREJ.GE.1)THEN | |
39117 | IF(IPCO.GE.3) | |
39118 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39119 | IPCO=0 | |
39120 | RETURN | |
39121 | ENDIF | |
39122 | IF(IPIP.EQ.1)THEN | |
39123 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39124 | ELSEIF(IPIP.EQ.2)THEN | |
39125 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39126 | ENDIF | |
39127 | IF(IPCO.GE.3)THEN | |
39128 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
39129 | * XDIQP,XVQT,XSQ,XSAQ | |
39130 | ENDIF | |
39131 | C | |
39132 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
39133 | C | |
39134 | C XSQ=0.D0 | |
39135 | IF(IPIP.EQ.1)THEN | |
39136 | XDIQP=XDIQP-XSQ | |
39137 | **NEW | |
39138 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP | |
39139 | ** | |
39140 | XVQT =XVQT -XSAQ | |
39141 | ELSEIF(IPIP.EQ.2)THEN | |
39142 | XDIQP=XDIQP-XSAQ | |
39143 | XVQT =XVQT -XSQ | |
39144 | ENDIF | |
39145 | IF(IPCO.GE.3) | |
39146 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
39147 | C | |
39148 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39149 | C | |
39150 | XVTHRO=CVQ/UMO | |
39151 | IVTHR=0 | |
39152 | 3466 CONTINUE | |
39153 | IF(IVTHR.EQ.10)THEN | |
39154 | IREJ=1 | |
39155 | IF(ISQ.EQ.3)IREJ=3 | |
39156 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' | |
39157 | IPCO=0 | |
39158 | RETURN | |
39159 | ENDIF | |
39160 | IVTHR=IVTHR+1 | |
39161 | XVTHR=XVTHRO/(201-IVTHR) | |
39162 | UNOPRV=UNON | |
39163 | 380 CONTINUE | |
39164 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
39165 | IREJ=1 | |
39166 | IF(ISQ.EQ.3)IREJ=3 | |
39167 | IF(IPCO.GE.3) | |
39168 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ', | |
39169 | * XVTHR | |
39170 | IPCO=0 | |
39171 | RETURN | |
39172 | ENDIF | |
39173 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
39174 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39175 | XVPQII=XDIQP-XVPQI | |
39176 | ELSE | |
39177 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39178 | XVPQI=XDIQP-XVPQII | |
39179 | ENDIF | |
39180 | IF(IPCO.GE.3)THEN | |
39181 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', | |
39182 | * XVTHR,XDIQP,XVPQI,XVPQII | |
39183 | ENDIF | |
39184 | C | |
39185 | C Prepare 4 momenta of new chains and chain ends | |
39186 | C | |
39187 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39188 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39189 | C +(4,NTMHKK) | |
39190 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39191 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39192 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39193 | IF(IPIP.EQ.1)THEN | |
39194 | XSQ1=XSQ | |
39195 | XSAQ1=XSAQ | |
39196 | ISQ1=ISQ | |
39197 | ISAQ1=ISAQ | |
39198 | ELSEIF(IPIP.EQ.2)THEN | |
39199 | XSQ1=XSAQ | |
39200 | XSAQ1=XSQ | |
39201 | ISQ1=ISAQ | |
39202 | ISAQ1=ISQ | |
39203 | ENDIF | |
39204 | KK11=IP11 | |
39205 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39206 | KK21= IPP21 | |
39207 | KK22= IPP22 | |
39208 | XGIVE=0.D0 | |
39209 | IDHKT(4+IIGLU1) =IP12 | |
39210 | ISTHKT(4+IIGLU1) =921 | |
39211 | JMOHKT(1,4+IIGLU1)=NC1P | |
39212 | JMOHKT(2,4+IIGLU1)=0 | |
39213 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
39214 | JDAHKT(2,4+IIGLU1)=0 | |
39215 | **NEW | |
39216 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. | |
39217 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 | |
39218 | ** | |
39219 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39220 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39221 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39222 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39223 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
39224 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
39225 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
39226 | * PHKT(1,4+IIGLU1)**2) | |
39227 | IF(XXMIST.GT.0.D0)THEN | |
39228 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39229 | ELSE | |
39230 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST | |
39231 | XXMIST=ABS(XXMIST) | |
39232 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39233 | ENDIF | |
39234 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
39235 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
39236 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
39237 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
39238 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
39239 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
39240 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
39241 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
39242 | IF(IPIP.EQ.1)THEN | |
39243 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
39244 | ELSEIF(IPIP.EQ.2)THEN | |
39245 | IDHKT(5+IIGLU1) =ISAQ1 | |
39246 | ENDIF | |
39247 | ISTHKT(5+IIGLU1) =922 | |
39248 | JMOHKT(1,5+IIGLU1)=NC1T | |
39249 | JMOHKT(2,5+IIGLU1)=0 | |
39250 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
39251 | JDAHKT(2,5+IIGLU1)=0 | |
39252 | **NEW | |
39253 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) | |
39254 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT | |
39255 | ** | |
39256 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39257 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39258 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39259 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39260 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
39261 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
39262 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39263 | *PHKT(1,5+IIGLU1)**2) | |
39264 | IF(XMIST.GT.0.D0)THEN | |
39265 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
39266 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39267 | *PHKT(1,5+IIGLU1)**2) | |
39268 | ELSE | |
39269 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
39270 | PHKT(5,5+IIGLU1)=0.D0 | |
39271 | ENDIF | |
39272 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
39273 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
39274 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
39275 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
39276 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
39277 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
39278 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
39279 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
39280 | IDHKT(6+IIGLU1) =88888 | |
39281 | C IDHKT(6) =1000*NNNC1+MMMC1 | |
39282 | ISTHKT(6+IIGLU1) =93 | |
39283 | C ISTHKT(6) =KKKC1 | |
39284 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
39285 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
39286 | JDAHKT(1,6+IIGLU1)=0 | |
39287 | JDAHKT(2,6+IIGLU1)=0 | |
39288 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
39289 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
39290 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
39291 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
39292 | PHKT(5,6+IIGLU1) | |
39293 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
39294 | * -PHKT(3,6+IIGLU1)**2) | |
39295 | CHAMAL=CHAM1 | |
39296 | IF(IPIP.EQ.1)THEN | |
39297 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 | |
39298 | ELSEIF(IPIP.EQ.2)THEN | |
39299 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 | |
39300 | ENDIF | |
39301 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
39302 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
39303 | C we drop chain 6 and give the energy to chain 3 | |
39304 | IDHKT(6+IIGLU1)=33888 | |
39305 | XGIVE=1.D0 | |
39306 | C WRITE(6,*)' drop chain 6 xgive=1' | |
39307 | GO TO 7788 | |
39308 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN | |
39309 | C we drop chain 6 and give the energy to chain 3 | |
39310 | C and change KK11 to IDHKT(4) | |
39311 | IDHKT(6+IIGLU1)=33888 | |
39312 | XGIVE=1.D0 | |
39313 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' | |
39314 | KK11=IDHKT(4+IIGLU1) | |
39315 | GO TO 7788 | |
39316 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN | |
39317 | C we drop chain 6 and give the energy to chain 3 | |
39318 | C and change KK21 to IDHKT(4) | |
39319 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39320 | IDHKT(6+IIGLU1)=33888 | |
39321 | XGIVE=1.D0 | |
39322 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' | |
39323 | KK21=IDHKT(4+IIGLU1) | |
39324 | GO TO 7788 | |
39325 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN | |
39326 | C we drop chain 6 and give the energy to chain 3 | |
39327 | C and change KK22 to IDHKT(4) | |
39328 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39329 | IDHKT(6+IIGLU1)=33888 | |
39330 | XGIVE=1.D0 | |
39331 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' | |
39332 | KK22=IDHKT(4+IIGLU1) | |
39333 | GO TO 7788 | |
39334 | ENDIF | |
39335 | C IREJ=1 | |
39336 | IPCO=0 | |
39337 | C RETURN | |
39338 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' | |
39339 | GO TO 3466 | |
39340 | ENDIF | |
39341 | 7788 CONTINUE | |
39342 | IF(IPIP.GE.3)THEN | |
39343 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
39344 | * JMOHKT(1,4+IIGLU1), | |
39345 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
39346 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
39347 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
39348 | * JMOHKT(1,5+IIGLU1), | |
39349 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
39350 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
39351 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
39352 | * JMOHKT(1,6+IIGLU1), | |
39353 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
39354 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
39355 | ENDIF | |
39356 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
39357 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
39358 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
39359 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
39360 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
39361 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
39362 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
39363 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
39364 | C IDHKT(1) =IP11 | |
39365 | IDHKT(1) =KK11 | |
39366 | ISTHKT(1) =921 | |
39367 | JMOHKT(1,1)=NC1P | |
39368 | JMOHKT(2,1)=0 | |
39369 | JDAHKT(1,1)=3+IIGLU1 | |
39370 | JDAHKT(2,1)=0 | |
39371 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39372 | C * +0.5D0*PHKK(1,NC2P) | |
39373 | *+XGIVE*PHKT(1,4+IIGLU1) | |
39374 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39375 | C * +0.5D0*PHKK(2,NC2P) | |
39376 | *+XGIVE*PHKT(2,4+IIGLU1) | |
39377 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39378 | C * +0.5D0*PHKK(3,NC2P) | |
39379 | *+XGIVE*PHKT(3,4+IIGLU1) | |
39380 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39381 | C * +0.5D0*PHKK(4,NC2P) | |
39382 | *+XGIVE*PHKT(4,4+IIGLU1) | |
39383 | C PHKT(5,1) =PHKK(5,NC1P) | |
39384 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39385 | *PHKT(1,1)**2) | |
39386 | IF(XMIST.GE.0.D0)THEN | |
39387 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39388 | *PHKT(1,1)**2) | |
39389 | ELSE | |
39390 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST | |
39391 | PHKT(5,1)=0.D0 | |
39392 | ENDIF | |
39393 | VHKT(1,1) =VHKK(1,NC1P) | |
39394 | VHKT(2,1) =VHKK(2,NC1P) | |
39395 | VHKT(3,1) =VHKK(3,NC1P) | |
39396 | VHKT(4,1) =VHKK(4,NC1P) | |
39397 | WHKT(1,1) =WHKK(1,NC1P) | |
39398 | WHKT(2,1) =WHKK(2,NC1P) | |
39399 | WHKT(3,1) =WHKK(3,NC1P) | |
39400 | WHKT(4,1) =WHKK(4,NC1P) | |
39401 | C Add here IIGLU1 gluons to this chaina | |
39402 | PG1=0.D0 | |
39403 | PG2=0.D0 | |
39404 | PG3=0.D0 | |
39405 | PG4=0.D0 | |
39406 | IF(IIGLU1.GE.1)THEN | |
39407 | JJG=NC1P | |
39408 | DO 61 IIG=2,2+IIGLU1-1 | |
39409 | KKG=JJG+IIG-1 | |
39410 | IDHKT(IIG) =IDHKK(KKG) | |
39411 | ISTHKT(IIG) =921 | |
39412 | JMOHKT(1,IIG)=KKG | |
39413 | JMOHKT(2,IIG)=0 | |
39414 | JDAHKT(1,IIG)=3+IIGLU1 | |
39415 | JDAHKT(2,IIG)=0 | |
39416 | PHKT(1,IIG)=PHKK(1,KKG) | |
39417 | PG1=PG1+ PHKT(1,IIG) | |
39418 | PHKT(2,IIG)=PHKK(2,KKG) | |
39419 | PG2=PG2+ PHKT(2,IIG) | |
39420 | PHKT(3,IIG)=PHKK(3,KKG) | |
39421 | PG3=PG3+ PHKT(3,IIG) | |
39422 | PHKT(4,IIG)=PHKK(4,KKG) | |
39423 | PG4=PG4+ PHKT(4,IIG) | |
39424 | PHKT(5,IIG)=PHKK(5,KKG) | |
39425 | VHKT(1,IIG) =VHKK(1,KKG) | |
39426 | VHKT(2,IIG) =VHKK(2,KKG) | |
39427 | VHKT(3,IIG) =VHKK(3,KKG) | |
39428 | VHKT(4,IIG) =VHKK(4,KKG) | |
39429 | WHKT(1,IIG) =WHKK(1,KKG) | |
39430 | WHKT(2,IIG) =WHKK(2,KKG) | |
39431 | WHKT(3,IIG) =WHKK(3,KKG) | |
39432 | WHKT(4,IIG) =WHKK(4,KKG) | |
39433 | 61 CONTINUE | |
39434 | ENDIF | |
39435 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39436 | IF(IPIP.EQ.1)THEN | |
39437 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 | |
39438 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 | |
39439 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 | |
39440 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 | |
39441 | ELSEIF(IPIP.EQ.2)THEN | |
39442 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 | |
39443 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 | |
39444 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 | |
39445 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 | |
39446 | ENDIF | |
39447 | ISTHKT(2+IIGLU1) =922 | |
39448 | JMOHKT(1,2+IIGLU1)=NC2T | |
39449 | JMOHKT(2,2+IIGLU1)=0 | |
39450 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
39451 | JDAHKT(2,2+IIGLU1)=0 | |
39452 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
39453 | *+XGIVE*PHKT(1,5+IIGLU1) | |
39454 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
39455 | *+XGIVE*PHKT(2,5+IIGLU1) | |
39456 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
39457 | *+XGIVE*PHKT(3,5+IIGLU1) | |
39458 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
39459 | *+XGIVE*PHKT(4,5+IIGLU1) | |
39460 | C PHKT(5,2) =PHKK(5,NC2T) | |
39461 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
39462 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39463 | *PHKT(1,2+IIGLU1)**2) | |
39464 | IF(XMIST.GT.0.D0)THEN | |
39465 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
39466 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39467 | *PHKT(1,2+IIGLU1)**2) | |
39468 | ELSE | |
39469 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39470 | PHKT(5,2+IIGLU1)=0.D0 | |
39471 | ENDIF | |
39472 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
39473 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
39474 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
39475 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
39476 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
39477 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
39478 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
39479 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
39480 | IDHKT(3+IIGLU1) =88888 | |
39481 | C IDHKT(3) =1000*NNNC1+MMMC1+10 | |
39482 | ISTHKT(3+IIGLU1) =93 | |
39483 | C ISTHKT(3) =KKKC1 | |
39484 | JMOHKT(1,3+IIGLU1)=1 | |
39485 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
39486 | JDAHKT(1,3+IIGLU1)=0 | |
39487 | JDAHKT(2,3+IIGLU1)=0 | |
39488 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
39489 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
39490 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
39491 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
39492 | PHKT(5,3+IIGLU1) | |
39493 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
39494 | * -PHKT(3,3+IIGLU1)**2) | |
39495 | IF(IPIP.GE.3)THEN | |
39496 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
39497 | * JDAHKT(1,1), | |
39498 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
39499 | DO 71 IIG=2,2+IIGLU1-1 | |
39500 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39501 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39502 | * JDAHKT(1,IIG), | |
39503 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39504 | 71 CONTINUE | |
39505 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), | |
39506 | & IDHKT(2),JMOHKT(1,2+IIGLU1), | |
39507 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
39508 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
39509 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
39510 | * JMOHKT(1,3+IIGLU1), | |
39511 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
39512 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
39513 | ENDIF | |
39514 | CHAMAL=CHAB1 | |
39515 | **NEW | |
39516 | C IF(IPIP.EQ.1)THEN | |
39517 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 | |
39518 | C ELSEIF(IPIP.EQ.2)THEN | |
39519 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 | |
39520 | C ENDIF | |
39521 | IF(IPIP.EQ.1)THEN | |
39522 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 | |
39523 | ELSEIF(IPIP.EQ.2)THEN | |
39524 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 | |
39525 | ENDIF | |
39526 | ** | |
39527 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
39528 | C IREJ=1 | |
39529 | IPCO=0 | |
39530 | C RETURN | |
39531 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' | |
39532 | GO TO 3466 | |
39533 | ENDIF | |
39534 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
39535 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
39536 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
39537 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
39538 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
39539 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
39540 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
39541 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
39542 | IF(IPIP.EQ.1)THEN | |
39543 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 | |
39544 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
39545 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
39546 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
39547 | ELSEIF(IPIP.EQ.2)THEN | |
39548 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
39549 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
39550 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
39551 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
39552 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 | |
39553 | ENDIF | |
39554 | ISTHKT(7+IIGLU1) =921 | |
39555 | JMOHKT(1,7+IIGLU1)=NC2P | |
39556 | JMOHKT(2,7+IIGLU1)=0 | |
39557 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
39558 | JDAHKT(2,7+IIGLU1)=0 | |
39559 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) | |
39560 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) | |
39561 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) | |
39562 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) | |
39563 | **NEW | |
39564 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) | |
39565 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP | |
39566 | ** | |
39567 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39568 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39569 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39570 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39571 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
39572 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
39573 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
39574 | C IREJ=1 | |
39575 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' | |
39576 | IPCO=0 | |
39577 | C RETURN | |
39578 | GO TO 3466 | |
39579 | ENDIF | |
39580 | C PHKT(5,7) =PHKK(5,NC2P) | |
39581 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
39582 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
39583 | *PHKT(1,7+IIGLU1)**2) | |
39584 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
39585 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
39586 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
39587 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
39588 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
39589 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
39590 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
39591 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
39592 | C Insert here the IIGLU2 gluons | |
39593 | PG1=0.D0 | |
39594 | PG2=0.D0 | |
39595 | PG3=0.D0 | |
39596 | PG4=0.D0 | |
39597 | IF(IIGLU2.GE.1)THEN | |
39598 | JJG=NC2P | |
39599 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39600 | KKG=JJG+IIG-7-IIGLU1 | |
39601 | IDHKT(IIG) =IDHKK(KKG) | |
39602 | ISTHKT(IIG) =921 | |
39603 | JMOHKT(1,IIG)=KKG | |
39604 | JMOHKT(2,IIG)=0 | |
39605 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
39606 | JDAHKT(2,IIG)=0 | |
39607 | PHKT(1,IIG)=PHKK(1,KKG) | |
39608 | PG1=PG1+ PHKT(1,IIG) | |
39609 | PHKT(2,IIG)=PHKK(2,KKG) | |
39610 | PG2=PG2+ PHKT(2,IIG) | |
39611 | PHKT(3,IIG)=PHKK(3,KKG) | |
39612 | PG3=PG3+ PHKT(3,IIG) | |
39613 | PHKT(4,IIG)=PHKK(4,KKG) | |
39614 | PG4=PG4+ PHKT(4,IIG) | |
39615 | PHKT(5,IIG)=PHKK(5,KKG) | |
39616 | VHKT(1,IIG) =VHKK(1,KKG) | |
39617 | VHKT(2,IIG) =VHKK(2,KKG) | |
39618 | VHKT(3,IIG) =VHKK(3,KKG) | |
39619 | VHKT(4,IIG) =VHKK(4,KKG) | |
39620 | WHKT(1,IIG) =WHKK(1,KKG) | |
39621 | WHKT(2,IIG) =WHKK(2,KKG) | |
39622 | WHKT(3,IIG) =WHKK(3,KKG) | |
39623 | WHKT(4,IIG) =WHKK(4,KKG) | |
39624 | 81 CONTINUE | |
39625 | ENDIF | |
39626 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
39627 | ISTHKT(8+IIGLU1+IIGLU2) =922 | |
39628 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
39629 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
39630 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
39631 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
39632 | **NEW | |
39633 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) | |
39634 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 | |
39635 | ** | |
39636 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
39637 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
39638 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
39639 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
39640 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
39641 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39642 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39643 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39644 | IF(XMIST.GT.0.D0)THEN | |
39645 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39646 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39647 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39648 | ELSE | |
39649 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39650 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
39651 | ENDIF | |
39652 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
39653 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
39654 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
39655 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
39656 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
39657 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
39658 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
39659 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
39660 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
39661 | C IDHKT(9) =1000*NNNC2+MMMC2+10 | |
39662 | ISTHKT(9+IIGLU1+IIGLU2) =93 | |
39663 | C ISTHKT(9) =KKKC2 | |
39664 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
39665 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
39666 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
39667 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
39668 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) | |
39669 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
39670 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) | |
39671 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
39672 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) | |
39673 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
39674 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) | |
39675 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
39676 | PHKT(5,9+IIGLU1+IIGLU2) | |
39677 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
39678 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
39679 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
39680 | IF(IPIP.GE.3)THEN | |
39681 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
39682 | * JMOHKT(1,7+IIGLU1), | |
39683 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
39684 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
39685 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39686 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39687 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39688 | * JDAHKT(1,IIG), | |
39689 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39690 | 91 CONTINUE | |
39691 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
39692 | * IDHKT(8+IIGLU1+IIGLU2), | |
39693 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
39694 | * JDAHKT(1,8+IIGLU1+IIGLU2), | |
39695 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
39696 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
39697 | * IDHKT(9+IIGLU1+IIGLU2), | |
39698 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), | |
39699 | * JDAHKT(1,9+IIGLU1+IIGLU2), | |
39700 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
39701 | ENDIF | |
39702 | CHAMAL=CHAB1 | |
39703 | IF(IPIP.EQ.1)THEN | |
39704 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
39705 | ELSEIF(IPIP.EQ.2)THEN | |
39706 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
39707 | ENDIF | |
39708 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
39709 | C IREJ=1 | |
39710 | IPCO=0 | |
39711 | C RETURN | |
39712 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
39713 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
39714 | GO TO 3466 | |
39715 | ENDIF | |
39716 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
39717 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
39718 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
39719 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
39720 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
39721 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
39722 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
39723 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
39724 | C | |
39725 | IGCOUN=9+IIGLU1+IIGLU2 | |
39726 | IPCO=0 | |
39727 | RETURN | |
39728 | END | |
39729 | ||
39730 | *$ CREATE HKKHKT.FOR | |
39731 | *COPY HKKHKT | |
39732 | C | |
39733 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
39734 | C | |
39735 | SUBROUTINE HKKHKT(I,J) | |
39736 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39737 | SAVE | |
39738 | ||
39739 | * event history | |
39740 | PARAMETER (NMXHKK=200000) | |
39741 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39742 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39743 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39744 | * extended event history | |
39745 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39746 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39747 | & IHIST(2,NMXHKK) | |
39748 | ||
39749 | PARAMETER (NTMHKK= 300) | |
39750 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39751 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39752 | +(4,NTMHKK) | |
39753 | C | |
39754 | ISTHKK(I) =ISTHKT(J) | |
39755 | IDHKK(I) =IDHKT(J) | |
39756 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN | |
39757 | IF(IDHKK(I).EQ.88888)THEN | |
39758 | C JMOHKK(1,I)=I-2 | |
39759 | C JMOHKK(2,I)=I-1 | |
39760 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) | |
39761 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) | |
39762 | ELSE | |
39763 | JMOHKK(1,I)=JMOHKT(1,J) | |
39764 | JMOHKK(2,I)=JMOHKT(2,J) | |
39765 | ENDIF | |
39766 | JDAHKK(1,I)=JDAHKT(1,J) | |
39767 | JDAHKK(2,I)=JDAHKT(2,J) | |
39768 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN | |
39769 | C JDAHKK(1,I)=I+2 | |
39770 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN | |
39771 | C JDAHKK(1,I)=I+1 | |
39772 | C ENDIF | |
39773 | IF(JDAHKT(1,J).GT.0)THEN | |
39774 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) | |
39775 | ENDIF | |
39776 | PHKK(1,I) =PHKT(1,J) | |
39777 | PHKK(2,I) =PHKT(2,J) | |
39778 | PHKK(3,I) =PHKT(3,J) | |
39779 | PHKK(4,I) =PHKT(4,J) | |
39780 | PHKK(5,I) =PHKT(5,J) | |
39781 | VHKK(1,I) =VHKT(1,J) | |
39782 | VHKK(2,I) =VHKT(2,J) | |
39783 | VHKK(3,I) =VHKT(3,J) | |
39784 | VHKK(4,I) =VHKT(4,J) | |
39785 | WHKK(1,I) =WHKT(1,J) | |
39786 | WHKK(2,I) =WHKT(2,J) | |
39787 | WHKK(3,I) =WHKT(3,J) | |
39788 | WHKK(4,I) =WHKT(4,J) | |
39789 | RETURN | |
39790 | END | |
39791 | ||
39792 | *$ CREATE DT_DBREAK.FOR | |
39793 | *COPY DT_DBREAK | |
39794 | * | |
39795 | *===dbreak=============================================================* | |
39796 | * | |
39797 | SUBROUTINE DT_DBREAK(MODE) | |
39798 | ||
39799 | ************************************************************************ | |
39800 | * This is the steering subroutine for the different diquark breaking * | |
39801 | * mechanisms. * | |
39802 | * * | |
39803 | * MODE = 1 breaking of projectile diquark in qq-q chain using * | |
39804 | * a sea quark (q-qq chain) of the same projectile * | |
39805 | * = 2 breaking of target diquark in q-qq chain using * | |
39806 | * a sea quark (qq-q chain) of the same target * | |
39807 | * = 3 breaking of projectile diquark in qq-q chain using * | |
39808 | * a sea quark (q-aq chain) of the same projectile * | |
39809 | * = 4 breaking of target diquark in q-qq chain using * | |
39810 | * a sea quark (aq-q chain) of the same target * | |
39811 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39812 | * a sea anti-quark (aq-aqaq chain) of the same projectile * | |
39813 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * | |
39814 | * a sea anti-quark (aqaq-aq chain) of the same target * | |
39815 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39816 | * a sea anti-quark (aq-q chain) of the same projectile * | |
39817 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * | |
39818 | * a sea anti-quark (q-aq chain) of the same target * | |
39819 | * * | |
39820 | * Original version by J. Ranft. * | |
39821 | * This version dated 17.5.00 is written by S. Roesler. * | |
39822 | ************************************************************************ | |
39823 | ||
39824 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39825 | SAVE | |
39826 | PARAMETER ( LINP = 10 , | |
39827 | & LOUT = 6 , | |
39828 | & LDAT = 9 ) | |
39829 | ||
39830 | * event history | |
39831 | PARAMETER (NMXHKK=200000) | |
39832 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39833 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39834 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39835 | * extended event history | |
39836 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39837 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39838 | & IHIST(2,NMXHKK) | |
39839 | * flags for input different options | |
39840 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
39841 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
39842 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
39843 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
39844 | PARAMETER (MAXCHN=10000) | |
39845 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
39846 | * diquark-breaking mechanism | |
39847 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
39848 | * flags for particle decays | |
39849 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
39850 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
39851 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
39852 | ||
39853 | * | |
39854 | * chain identifiers | |
39855 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, | |
39856 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) | |
39857 | DIMENSION IDCHN1(8),IDCHN2(8) | |
39858 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ | |
39859 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ | |
39860 | * | |
39861 | * parton identifiers | |
39862 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), | |
39863 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) | |
39864 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) | |
39865 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, | |
39866 | & 31, 31, 31, 31, 31, 31, 31, 31, | |
39867 | & 41, 41, 41, 41, 51, 51, 51, 51/ | |
39868 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, | |
39869 | & 32, 32, 32, 32, 32, 32, 32, 32, | |
39870 | & 42, 42, 42, 42, 52, 52, 52, 52/ | |
39871 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, | |
39872 | & 51, 31, 41, 41, 31, 31, 31, 31, | |
39873 | & 0, 41, 51, 51, 51, 51, 51, 51/ | |
39874 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, | |
39875 | & 32, 52, 42, 42, 32, 32, 32, 32, | |
39876 | & 42, 0, 52, 52, 52, 52, 52, 52/ | |
39877 | ||
39878 | IF (NCHAIN.LE.0) RETURN | |
39879 | DO 1 I=1,NCHAIN | |
39880 | IDX1 = IDXCHN(1,I) | |
39881 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) | |
39882 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) | |
39883 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) | |
39884 | & .AND. | |
39885 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. | |
39886 | & (IS1P.EQ.ISP1P(MODE,3))) | |
39887 | & .AND. | |
39888 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. | |
39889 | & (IS1T.EQ.ISP1T(MODE,3))) | |
39890 | & ) THEN | |
39891 | DO 2 J=1,NCHAIN | |
39892 | IDX2 = IDXCHN(1,J) | |
39893 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) | |
39894 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) | |
39895 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) | |
39896 | & .AND. | |
39897 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) | |
39898 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) | |
39899 | & .AND. | |
39900 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) | |
39901 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) | |
39902 | & ) THEN | |
39903 | * find mother nucleons of the diquark to be splitted and of the | |
39904 | * sea-quark and reject this combination if it is not the same | |
39905 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. | |
39906 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN | |
39907 | IANCES = 1 | |
39908 | ELSE | |
39909 | IANCES = 2 | |
39910 | ENDIF | |
39911 | IDXMO1 = JMOHKK(IANCES,IDX1) | |
39912 | 4 CONTINUE | |
39913 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. | |
39914 | & (JMOHKK(2,IDXMO1).NE.0)) THEN | |
39915 | IANC = IANCES | |
39916 | ELSE | |
39917 | IANC = 1 | |
39918 | ENDIF | |
39919 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN | |
39920 | IDXMO1 = JMOHKK(IANC,IDXMO1) | |
39921 | GOTO 4 | |
39922 | ENDIF | |
39923 | IDXMO2 = JMOHKK(IANCES,IDX2) | |
39924 | 5 CONTINUE | |
39925 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. | |
39926 | & (JMOHKK(2,IDXMO2).NE.0)) THEN | |
39927 | IANC = IANCES | |
39928 | ELSE | |
39929 | IANC = 1 | |
39930 | ENDIF | |
39931 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN | |
39932 | IDXMO2 = JMOHKK(IANC,IDXMO2) | |
39933 | GOTO 5 | |
39934 | ENDIF | |
39935 | IF (IDXMO1.NE.IDXMO2) GOTO 2 | |
39936 | * quark content of projectile parton | |
39937 | IP1 = IDHKK(JMOHKK(1,IDX1)) | |
39938 | IP11 = IP1/1000 | |
39939 | IP12 = (IP1-1000*IP11)/100 | |
39940 | IP2 = IDHKK(JMOHKK(2,IDX1)) | |
39941 | IP21 = IP2/1000 | |
39942 | IP22 = (IP2-1000*IP21)/100 | |
39943 | * quark content of target parton | |
39944 | IT1 = IDHKK(JMOHKK(1,IDX2)) | |
39945 | IT11 = IT1/1000 | |
39946 | IT12 = (IT1-1000*IT11)/100 | |
39947 | IT2 = IDHKK(JMOHKK(2,IDX2)) | |
39948 | IT21 = IT2/1000 | |
39949 | IT22 = (IT2-1000*IT21)/100 | |
39950 | * split diquark and form new chains | |
39951 | IF (MODE.EQ.1) THEN | |
39952 | IF (IT1.EQ.4) GOTO 2 | |
39953 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39954 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39955 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) | |
39956 | ELSEIF (MODE.EQ.2) THEN | |
39957 | IF (IT2.EQ.4) GOTO 2 | |
39958 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39959 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39960 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) | |
39961 | ELSEIF (MODE.EQ.3) THEN | |
39962 | IF (IT1.EQ.4) GOTO 2 | |
39963 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39964 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39965 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) | |
39966 | ELSEIF (MODE.EQ.4) THEN | |
39967 | IF (IT2.EQ.4) GOTO 2 | |
39968 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39969 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39970 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) | |
39971 | ELSEIF (MODE.EQ.5) THEN | |
39972 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39973 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39974 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) | |
39975 | ELSEIF (MODE.EQ.6) THEN | |
39976 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39977 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39978 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) | |
39979 | ELSEIF (MODE.EQ.7) THEN | |
39980 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39981 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39982 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) | |
39983 | ELSEIF (MODE.EQ.8) THEN | |
39984 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39985 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39986 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) | |
39987 | ENDIF | |
39988 | IF (IREJ.GE.1) THEN | |
39989 | if ((ipq.lt.0).or.(ipq.ge.4)) | |
39990 | & write(LOUT,*) 'ipq !!!',ipq,mode | |
39991 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
39992 | * accept or reject new chains corresponding to PDBSEA | |
39993 | ELSE | |
39994 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN | |
39995 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) | |
39996 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) | |
39997 | ELSEIF (IPQ.EQ.3) THEN | |
39998 | ACC = DBRKA(3,MODE) | |
39999 | REJ = DBRKR(3,MODE) | |
40000 | ELSE | |
40001 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ | |
40002 | STOP | |
40003 | ENDIF | |
40004 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN | |
40005 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 | |
40006 | IACC = 1 | |
40007 | ELSE | |
40008 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
40009 | IACC = 0 | |
40010 | ENDIF | |
40011 | * new chains have been accepted and are now copied into HKKEVT | |
40012 | IF (IACC.EQ.1) THEN | |
40013 | IF (LEMCCK) THEN | |
40014 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), | |
40015 | & PHKK(3,IDX1),PHKK(4,IDX1), | |
40016 | & 1,IDUM1,IDUM2) | |
40017 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), | |
40018 | & PHKK(3,IDX2),PHKK(4,IDX2), | |
40019 | & 2,IDUM1,IDUM2) | |
40020 | ENDIF | |
40021 | IDHKK(IDX1) = 99888 | |
40022 | IDHKK(IDX2) = 99888 | |
40023 | IDXCHN(2,I) = -1 | |
40024 | IDXCHN(2,J) = -1 | |
40025 | DO 3 K=1,IGCOUN | |
40026 | NHKK = NHKK+1 | |
40027 | CALL HKKHKT(NHKK,K) | |
40028 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN | |
40029 | PX = -PHKK(1,NHKK) | |
40030 | PY = -PHKK(2,NHKK) | |
40031 | PZ = -PHKK(3,NHKK) | |
40032 | PE = -PHKK(4,NHKK) | |
40033 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
40034 | ENDIF | |
40035 | 3 CONTINUE | |
40036 | IF (LEMCCK) THEN | |
40037 | CHKLEV = 0.1D0 | |
40038 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, | |
40039 | & IREJ) | |
40040 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) | |
40041 | ENDIF | |
40042 | GOTO 1 | |
40043 | ENDIF | |
40044 | ENDIF | |
40045 | ENDIF | |
40046 | 2 CONTINUE | |
40047 | ENDIF | |
40048 | 1 CONTINUE | |
40049 | RETURN | |
40050 | END | |
40051 | ||
40052 | *$ CREATE DT_CQPAIR.FOR | |
40053 | *COPY DT_CQPAIR | |
40054 | * | |
40055 | *===cqpair=============================================================* | |
40056 | * | |
40057 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) | |
40058 | ||
40059 | ************************************************************************ | |
40060 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * | |
40061 | * * | |
40062 | * XQMAX maxium energy fraction of quark (input) * | |
40063 | * XAQMAX maxium energy fraction of antiquark (input) * | |
40064 | * XQ energy fraction of quark (output) * | |
40065 | * XAQ energy fraction of antiquark (output) * | |
40066 | * IFLV quark flavour (- antiquark flavor) (output) * | |
40067 | * * | |
40068 | * This version dated 14.5.00 is written by S. Roesler. * | |
40069 | ************************************************************************ | |
40070 | ||
40071 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
40072 | SAVE | |
40073 | PARAMETER ( LINP = 10 , | |
40074 | & LOUT = 6 , | |
40075 | & LDAT = 9 ) | |
40076 | ||
40077 | * Lorentz-parameters of the current interaction | |
40078 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
40079 | & UMO,PPCM,EPROJ,PPROJ | |
40080 | ||
40081 | * | |
40082 | IREJ = 0 | |
40083 | XQ = 0.0D0 | |
40084 | XAQ = 0.0D0 | |
40085 | * | |
40086 | * sample quark flavour | |
40087 | * | |
40088 | * set seasq here (the one from DTCHAI should be used in the future) | |
40089 | SEASQ = 0.5D0 | |
40090 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) | |
40091 | * | |
40092 | * sample energy fractions of sea pair | |
40093 | * we first sample the energy fraction of a gluon and then split the gluon | |
40094 | * | |
40095 | * maximum energy fraction of the gluon forced via input | |
40096 | XGMAXI = XQMAX+XAQMAX | |
40097 | * minimum energy fraction of the gluon | |
40098 | XTHR1 = 4.0D0 /UMO**2 | |
40099 | XTHR2 = 0.54D0/UMO**1.5D0 | |
40100 | XGMIN = MAX(XTHR1,XTHR2) | |
40101 | * maximum energy fraction of the gluon | |
40102 | XGMAX = 0.3D0 | |
40103 | XGMAX = MIN(XGMAXI,XGMAX) | |
40104 | IF (XGMIN.GE.XGMAX) THEN | |
40105 | IREJ = 1 | |
40106 | RETURN | |
40107 | ENDIF | |
40108 | * | |
40109 | * sample energy fraction of the gluon | |
40110 | NLOOP = 0 | |
40111 | 1 CONTINUE | |
40112 | NLOOP = NLOOP+1 | |
40113 | IF (NLOOP.GE.50) THEN | |
40114 | IREJ = 1 | |
40115 | RETURN | |
40116 | ENDIF | |
40117 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) | |
40118 | EGLUON = XGLUON*UMO/2.0D0 | |
40119 | * | |
40120 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) | |
40121 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) | |
40122 | ZMAX = 1.0D0-ZMIN | |
40123 | RZ = DT_RNDM(ZMAX) | |
40124 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 | |
40125 | RQ = DT_RNDM(ZMAX) | |
40126 | IF (RQ.LT.0.5D0) THEN | |
40127 | XQ = XGLUON*XHLP | |
40128 | XAQ = XGLUON-XQ | |
40129 | ELSE | |
40130 | XAQ = XGLUON*XHLP | |
40131 | XQ = XGLUON-XAQ | |
40132 | ENDIF | |
40133 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 | |
40134 | ||
40135 | RETURN | |
40136 | END |