]>
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 | |
e3f546f5 | 2206 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
2207 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, | |
2208 | & NCP,NCT | |
9aaba0d6 | 2209 | |
2210 | DIMENSION WHAT(6) | |
2211 | ||
2212 | IREJ = 0 | |
2213 | ILOOP = 0 | |
09b429a4 | 2214 | NSD1 = 0 |
2215 | NSD2 = 0 | |
2216 | NDD = 0 | |
9aaba0d6 | 2217 | 100 CONTINUE |
2218 | IF (ILOOP.EQ.4) THEN | |
2219 | WRITE(LOUT,1000) NEVHKK | |
2220 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') | |
2221 | GOTO 9999 | |
2222 | ENDIF | |
2223 | ILOOP = ILOOP+1 | |
2224 | ||
2225 | * variable energy-runs, recalculate parameters for LT's | |
2226 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN | |
2227 | PDUM = ZERO | |
2228 | CDUM = ZERO | |
2229 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) | |
2230 | ENDIF | |
2231 | IF (EPN.GT.EPROJ) THEN | |
2232 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') | |
2233 | & ' Requested energy (',EPN,'GeV) exceeds', | |
2234 | & ' initialization energy (',EPROJ,'GeV) !' | |
2235 | STOP | |
2236 | ENDIF | |
2237 | ||
2238 | * re-initialize /DTPRTA/ | |
2239 | IP = NPMASS | |
2240 | IPZ = NPCHAR | |
2241 | IT = NTMASS | |
2242 | ITZ = NTCHAR | |
2243 | IJPROJ = IDP | |
2244 | IBPROJ = IIBAR(IJPROJ) | |
2245 | ||
2246 | * calculate nuclear potentials (common /DTNPOT/) | |
2247 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
2248 | ||
2249 | * initialize treatment for residual nuclei | |
2250 | CALL DT_RESNCL(EPN,NLOOP,1) | |
2251 | ||
2252 | * sample hadron/nucleus-nucleus interaction | |
2253 | CALL DT_KKEVNT(KKMAT,IREJ1) | |
2254 | IF (IREJ1.GT.0) THEN | |
2255 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' | |
2256 | GOTO 9999 | |
2257 | ENDIF | |
2258 | ||
2259 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN | |
2260 | ||
2261 | * intranuclear cascade of final state particles for KTAUGE generations | |
2262 | * of secondaries | |
2263 | CALL DT_FOZOCA(LFZC,IREJ1) | |
2264 | IF (IREJ1.GT.0) THEN | |
2265 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' | |
2266 | GOTO 9999 | |
2267 | ENDIF | |
2268 | ||
2269 | * baryons unable to escape the nuclear potential are treated as | |
2270 | * excited nucleons (ISTHKK=15,16) | |
2271 | CALL DT_SCN4BA | |
2272 | ||
2273 | * decay of resonances produced in intranuclear cascade processes | |
2274 | **sr 15-11-95 should be obsolete | |
2275 | C IF (LFZC) CALL DT_DECAY1 | |
2276 | ||
2277 | 101 CONTINUE | |
2278 | * treatment of residual nuclei | |
2279 | CALL DT_RESNCL(EPN,NLOOP,2) | |
2280 | ||
2281 | * evaporation / fission / fragmentation | |
2282 | * (if intranuclear cascade was sampled only) | |
2283 | IF (LFZC) THEN | |
2284 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) | |
2285 | IF (IREJ1.GT.1) GOTO 101 | |
2286 | IF (IREJ1.EQ.1) GOTO 100 | |
2287 | ENDIF | |
2288 | ||
2289 | ENDIF | |
2290 | ||
2291 | * rejection of unphysical configurations | |
2292 | CALL DT_REJUCO(1,IREJ1) | |
2293 | IF (IREJ1.GT.0) THEN | |
2294 | IF (IOULEV(1).GT.0) | |
2295 | & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x' | |
2296 | GOTO 100 | |
2297 | ENDIF | |
2298 | ||
2299 | * transform finale state into Lab. | |
2300 | IFLAG = 2 | |
2301 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) | |
2302 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB | |
2303 | ||
2304 | IF (IPI0.EQ.1) CALL DT_DECPI0 | |
2305 | ||
2306 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) | |
9aaba0d6 | 2307 | RETURN |
e3f546f5 | 2308 | |
9aaba0d6 | 2309 | 9999 CONTINUE |
2310 | IREJ = 1 | |
09b429a4 | 2311 | |
9aaba0d6 | 2312 | RETURN |
2313 | END | |
2314 | ||
2315 | *$ CREATE DT_DEFAUL.FOR | |
2316 | *COPY DT_DEFAUL | |
2317 | * | |
2318 | *===defaul=============================================================* | |
2319 | * | |
2320 | SUBROUTINE DT_DEFAUL(EPN,PPN) | |
2321 | ||
2322 | ************************************************************************ | |
2323 | * Variables are set to default values. * | |
2324 | * This version dated 8.5.95 is written by S. Roesler. * | |
2325 | ************************************************************************ | |
2326 | ||
2327 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2328 | SAVE | |
2329 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
2330 | PARAMETER (TWOPI = 6.283185307179586454D+00) | |
2331 | ||
2332 | * particle properties (BAMJET index convention) | |
2333 | CHARACTER*8 ANAME | |
2334 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2335 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2336 | * nuclear potential | |
2337 | LOGICAL LFERMI | |
2338 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
2339 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
2340 | & ETACOU(2),ICOUL,LFERMI | |
2341 | * interface HADRIN-DPM | |
2342 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
2343 | * central particle production, impact parameter biasing | |
2344 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
2345 | * properties of interacting particles | |
2346 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2347 | * properties of photon/lepton projectiles | |
2348 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2349 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2350 | * emulsion treatment | |
2351 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2352 | & NCOMPO,IEMUL | |
2353 | * parameter for intranuclear cascade | |
2354 | LOGICAL LPAULI | |
2355 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
2356 | * various options for treatment of partons (DTUNUC 1.x) | |
2357 | * (chain recombination, Cronin,..) | |
2358 | LOGICAL LCO2CR,LINTPT | |
2359 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
2360 | & LCO2CR,LINTPT | |
2361 | * threshold values for x-sampling (DTUNUC 1.x) | |
2362 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
2363 | & SSMIMQ,VVMTHR | |
2364 | * flags for input different options | |
2365 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2366 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2367 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2368 | * n-n cross section fluctuations | |
2369 | PARAMETER (NBINS = 1000) | |
2370 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
2371 | * flags for particle decays | |
2372 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2373 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2374 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2375 | * diquark-breaking mechanism | |
2376 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
2377 | * nucleon-nucleon event-generator | |
2378 | CHARACTER*8 CMODEL | |
2379 | LOGICAL LPHOIN | |
2380 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2381 | * flags for diffractive interactions (DTUNUC 1.x) | |
2382 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
2383 | * VDM parameter for photon-nucleus interactions | |
2384 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
2385 | * Glauber formalism: flags and parameters for statistics | |
2386 | LOGICAL LPROD | |
2387 | CHARACTER*8 CGLB | |
2388 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2389 | * kinematical cuts for lepton-nucleus interactions | |
2390 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2391 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2392 | * flags for activated histograms | |
2393 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2394 | * cuts for variable energy runs | |
2395 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2396 | * parameters for hA-diffraction | |
2397 | COMMON /DTDIHA/ DIBETA,DIALPH | |
2398 | * LEPTO | |
2399 | REAL RPPN | |
2400 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
2401 | * steering flags for qel neutrino scattering modules | |
2402 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
2403 | * event flag | |
2404 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2405 | ||
2406 | DATA POTMES /0.002D0/ | |
2407 | ||
2408 | * common /DTNPOT/ | |
2409 | DO 10 I=1,2 | |
2410 | PFERMP(I) = ZERO | |
2411 | PFERMN(I) = ZERO | |
2412 | EBINDP(I) = ZERO | |
2413 | EBINDN(I) = ZERO | |
2414 | DO 11 J=1,210 | |
2415 | EPOT(I,J) = ZERO | |
2416 | 11 CONTINUE | |
2417 | * nucleus independent meson potential | |
2418 | EPOT(I,13) = POTMES | |
2419 | EPOT(I,14) = POTMES | |
2420 | EPOT(I,15) = POTMES | |
2421 | EPOT(I,16) = POTMES | |
2422 | EPOT(I,23) = POTMES | |
2423 | EPOT(I,24) = POTMES | |
2424 | EPOT(I,25) = POTMES | |
2425 | 10 CONTINUE | |
2426 | FERMOD = 0.55D0 | |
2427 | ETACOU(1) = ZERO | |
2428 | ETACOU(2) = ZERO | |
2429 | ICOUL = 1 | |
2430 | LFERMI = .TRUE. | |
2431 | ||
2432 | * common /HNTHRE/ | |
2433 | EHADTH = -99.0D0 | |
2434 | EHADLO = 4.06D0 | |
2435 | EHADHI = 6.0D0 | |
2436 | INTHAD = 1 | |
2437 | IDXTA = 2 | |
2438 | ||
2439 | * common /DTIMPA/ | |
2440 | ICENTR = 0 | |
2441 | BIMIN = ZERO | |
2442 | BIMAX = 1.0D10 | |
2443 | XSFRAC = 1.0D0 | |
2444 | ||
2445 | * common /DTPRTA/ | |
2446 | IP = 1 | |
2447 | IPZ = 1 | |
2448 | IT = 1 | |
2449 | ITZ = 1 | |
2450 | IJPROJ = 1 | |
2451 | IBPROJ = 1 | |
2452 | IJTARG = 1 | |
2453 | IBTARG = 1 | |
2454 | * common /DTGPRO/ | |
2455 | VIRT = ZERO | |
2456 | DO 14 I=1,4 | |
2457 | PGAMM(I) = ZERO | |
2458 | PLEPT0(I) = ZERO | |
2459 | PLEPT1(I) = ZERO | |
2460 | PNUCL(I) = ZERO | |
2461 | 14 CONTINUE | |
2462 | IDIREC = 0 | |
2463 | ||
2464 | * common /DTFOTI/ | |
2465 | **sr 7.4.98: changed after corrected B-sampling | |
2466 | C TAUFOR = 4.4D0 | |
2467 | TAUFOR = 3.5D0 | |
2468 | KTAUGE = 25 | |
2469 | ITAUVE = 1 | |
2470 | INCMOD = 1 | |
2471 | LPAULI = .TRUE. | |
2472 | ||
2473 | * common /DTCHAI/ | |
2474 | SEASQ = ONE | |
2475 | MKCRON = 1 | |
2476 | CRONCO = 0.64D0 | |
2477 | ISICHA = 0 | |
2478 | CUTOF = 100.0D0 | |
2479 | LCO2CR = .FALSE. | |
2480 | IRECOM = 1 | |
2481 | LINTPT = .TRUE. | |
2482 | ||
2483 | * common /DTXCUT/ | |
2484 | * definition of soft quark distributions | |
2485 | XSEACU = 0.05D0 | |
2486 | UNON = 2.0D0 | |
2487 | UNOM = 1.5D0 | |
2488 | UNOSEA = 5.0D0 | |
2489 | * cutoff parameters for x-sampling | |
2490 | CVQ = 1.0D0 | |
2491 | CDQ = 2.0D0 | |
2492 | C CSEA = 0.3D0 | |
2493 | CSEA = 0.1D0 | |
2494 | SSMIMA = 1.2D0 | |
2495 | SSMIMQ = SSMIMA**2 | |
2496 | VVMTHR = 2.0D0 | |
2497 | ||
2498 | * common /DTXSFL/ | |
2499 | IFLUCT = 0 | |
2500 | ||
2501 | * common /DTFRPA/ | |
2502 | PDB = 0.15D0 | |
2503 | PDBSEA(1) = 0.0D0 | |
2504 | PDBSEA(2) = 0.0D0 | |
2505 | PDBSEA(3) = 0.0D0 | |
2506 | ISIG0 = 0 | |
2507 | IPI0 = 0 | |
2508 | NMSTU = 0 | |
2509 | NPARU = 0 | |
2510 | NMSTJ = 0 | |
2511 | NPARJ = 0 | |
2512 | ||
2513 | * common /DTDIQB/ | |
2514 | DO 15 I=1,8 | |
2515 | DBRKR(1,I) = 5.0D0 | |
2516 | DBRKR(2,I) = 5.0D0 | |
2517 | DBRKR(3,I) = 10.0D0 | |
2518 | DBRKA(1,I) = ZERO | |
2519 | DBRKA(2,I) = ZERO | |
2520 | DBRKA(3,I) = ZERO | |
2521 | 15 CONTINUE | |
2522 | CHAM1 = 0.2D0 | |
2523 | CHAM3 = 0.5D0 | |
2524 | CHAB1 = 0.7D0 | |
2525 | CHAB3 = 1.0D0 | |
2526 | ||
2527 | * common /DTFLG3/ | |
2528 | ISINGD = 0 | |
2529 | IDOUBD = 0 | |
2530 | IFLAGD = 0 | |
2531 | IDIFF = 0 | |
2532 | ||
2533 | * common /DTMODL/ | |
2534 | MCGENE = 2 | |
2535 | CMODEL(1) = 'DTUNUC ' | |
2536 | CMODEL(2) = 'PHOJET ' | |
2537 | CMODEL(3) = 'LEPTO ' | |
2538 | CMODEL(4) = 'QNEUTRIN' | |
2539 | LPHOIN = .TRUE. | |
2540 | ELOJET = 5.0D0 | |
2541 | ||
2542 | * common /DTLCUT/ | |
2543 | ECMIN = 3.5D0 | |
2544 | ECMAX = 1.0D10 | |
2545 | XBJMIN = ZERO | |
2546 | ELMIN = ZERO | |
2547 | EGMIN = ZERO | |
2548 | EGMAX = 1.0D10 | |
2549 | YMIN = TINY10 | |
2550 | YMAX = 0.999D0 | |
2551 | Q2MIN = TINY10 | |
2552 | Q2MAX = 10.0D0 | |
2553 | THMIN = ZERO | |
2554 | THMAX = TWOPI | |
2555 | Q2LI = ZERO | |
2556 | Q2HI = 1.0D10 | |
2557 | ECMLI = ZERO | |
2558 | ECMHI = 1.0D10 | |
2559 | ||
2560 | * common /DTVDMP/ | |
2561 | RL2 = 2.0D0 | |
2562 | INTRGE(1) = 1 | |
2563 | INTRGE(2) = 3 | |
2564 | IDPDF = 2212 | |
2565 | MODEGA = 4 | |
2566 | ISHAD(1) = 1 | |
2567 | ISHAD(2) = 1 | |
2568 | ISHAD(3) = 1 | |
2569 | EPSPOL = ZERO | |
2570 | ||
2571 | * common /DTGLGP/ | |
2572 | JSTATB = 1000 | |
2573 | JBINSB = 49 | |
2574 | CGLB = ' ' | |
2575 | IF (ITRSPT.EQ.1) THEN | |
2576 | IOGLB = 100 | |
2577 | ELSE | |
2578 | IOGLB = 0 | |
2579 | ENDIF | |
2580 | LPROD = .TRUE. | |
2581 | ||
2582 | * common /DTHIS3/ | |
2583 | DO 16 I=1,50 | |
2584 | IHISPP(I) = 0 | |
2585 | IHISXS(I) = 0 | |
2586 | 16 CONTINUE | |
2587 | IXSTBL = 0 | |
2588 | ||
2589 | * common /DTVARE/ | |
2590 | VARELO = ZERO | |
2591 | VAREHI = ZERO | |
2592 | VARCLO = ZERO | |
2593 | VARCHI = ZERO | |
2594 | ||
2595 | * common /DTDIHA/ | |
2596 | DIBETA = -1.0D0 | |
2597 | DIALPH = ZERO | |
2598 | ||
2599 | * common /LEPTOI/ | |
2600 | RPPN = 0.0 | |
2601 | LEPIN = 0 | |
2602 | INTER = 0 | |
2603 | ||
2604 | * common /QNEUTO/ | |
2605 | NEUTYP = 1 | |
2606 | NEUDEC = 0 | |
2607 | ||
2608 | * common /DTEVNO/ | |
2609 | NEVENT = 1 | |
2610 | IF (ITRSPT.EQ.1) THEN | |
2611 | ICASCA = 1 | |
2612 | ELSE | |
2613 | ICASCA = 0 | |
2614 | ENDIF | |
2615 | ||
2616 | * default Lab.-energy | |
2617 | EPN = 200.0D0 | |
2618 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) | |
2619 | ||
2620 | RETURN | |
2621 | END | |
2622 | ||
2623 | *$ CREATE DT_AAEVT.FOR | |
2624 | *COPY DT_AAEVT | |
2625 | * | |
2626 | *===aaevt==============================================================* | |
2627 | * | |
2628 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2629 | & IDP,IGLAU) | |
2630 | ||
2631 | ************************************************************************ | |
2632 | * This version dated 22.03.96 is written by S. Roesler. * | |
2633 | ************************************************************************ | |
2634 | ||
2635 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2636 | SAVE | |
2637 | PARAMETER ( LINP = 10 , | |
2638 | & LOUT = 6 , | |
2639 | & LDAT = 9 ) | |
2640 | ||
2641 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2642 | * emulsion treatment | |
2643 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2644 | & NCOMPO,IEMUL | |
2645 | * event flag | |
2646 | COMMON /DTEVNO/ NEVENT,ICASCA | |
9aaba0d6 | 2647 | CHARACTER*8 DATE,HHMMSS |
2648 | DIMENSION IDMNYR(3) | |
09b429a4 | 2649 | NSD1 = 0 |
2650 | NSD2 = 0 | |
2651 | NDD = 0 | |
9aaba0d6 | 2652 | KKMAT = 1 |
2653 | NMSG = MAX(NEVTS/100,1) | |
2654 | ||
2655 | * initialization of run-statistics and histograms | |
2656 | CALL DT_STATIS(1) | |
2657 | CALL PHO_PHIST(1000,DUM) | |
2658 | ||
2659 | * initialization of Glauber-formalism | |
2660 | IF (NCOMPO.LE.0) THEN | |
2661 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2662 | ELSE | |
2663 | DO 1 I=1,NCOMPO | |
2664 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2665 | 1 CONTINUE | |
2666 | ENDIF | |
2667 | CALL DT_SIGEMU | |
2668 | ||
2669 | CALL IDATE(IDMNYR) | |
2670 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2671 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2672 | CALL ITIME(IDMNYR) | |
2673 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2674 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2675 | WRITE(LOUT,1001) DATE,HHMMSS | |
2676 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, | |
2677 | & ' Time: ',A8,' )') | |
2678 | ||
2679 | * generate NEVTS events | |
2680 | DO 2 IEVT=1,NEVTS | |
2681 | ||
2682 | * print run-status message | |
2683 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2684 | CALL IDATE(IDMNYR) | |
2685 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2686 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2687 | CALL ITIME(IDMNYR) | |
2688 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2689 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2690 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS | |
2691 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, | |
2692 | & ' Time: ',A,' )',/) | |
2693 | C WRITE(LOUT,1000) IEVT-1 | |
2694 | C1000 FORMAT(1X,I8,' events sampled') | |
2695 | ENDIF | |
2696 | NEVENT = IEVT | |
2697 | * treat nuclear emulsions | |
2698 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
2699 | * composite targets only | |
2700 | KKMAT = -KKMAT | |
2701 | * sample this event | |
2702 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) | |
2703 | ||
2704 | CALL PHO_PHIST(2000,DUM) | |
09b429a4 | 2705 | |
2706 | write(6,*) "Diffractive collisions", NSD1, NSD2, NDD | |
9aaba0d6 | 2707 | |
2708 | 2 CONTINUE | |
2709 | ||
2710 | * print run-statistics and histograms to output-unit 6 | |
2711 | CALL PHO_PHIST(3000,DUM) | |
2712 | CALL DT_STATIS(2) | |
9aaba0d6 | 2713 | RETURN |
2714 | END | |
2715 | ||
2716 | *$ CREATE DT_LAEVT.FOR | |
2717 | *COPY DT_LAEVT | |
2718 | * | |
2719 | *===laevt==============================================================* | |
2720 | * | |
2721 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2722 | & IDP,IGLAU) | |
2723 | ||
2724 | ************************************************************************ | |
2725 | * Interface to run DPMJET for lepton-nucleus interactions. * | |
2726 | * Kinematics is sampled using the equivalent photon approximation * | |
2727 | * Based on GPHERA-routine by R. Engel. * | |
2728 | * This version dated 23.03.96 is written by S. Roesler. * | |
2729 | ************************************************************************ | |
2730 | ||
2731 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2732 | SAVE | |
2733 | PARAMETER ( LINP = 10 , | |
2734 | & LOUT = 6 , | |
2735 | & LDAT = 9 ) | |
2736 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, | |
2737 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
2738 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
2739 | & PI = TWOPI/TWO, | |
2740 | & ALPHEM = ONE/137.0D0) | |
2741 | ||
2742 | C CHARACTER*72 HEADER | |
2743 | ||
2744 | * particle properties (BAMJET index convention) | |
2745 | CHARACTER*8 ANAME | |
2746 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2747 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2748 | * event history | |
2749 | PARAMETER (NMXHKK=200000) | |
2750 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2751 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2752 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2753 | * extended event history | |
2754 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2755 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2756 | & IHIST(2,NMXHKK) | |
2757 | * kinematical cuts for lepton-nucleus interactions | |
2758 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2759 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2760 | * properties of interacting particles | |
2761 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2762 | * properties of photon/lepton projectiles | |
2763 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2764 | * kinematics at lepton-gamma vertex | |
2765 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) | |
2766 | * flags for activated histograms | |
2767 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2768 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2769 | * emulsion treatment | |
2770 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2771 | & NCOMPO,IEMUL | |
2772 | * Glauber formalism: cross sections | |
2773 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
2774 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
2775 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
2776 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
2777 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
2778 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
2779 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
2780 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
2781 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
2782 | & BSLOPE,NEBINI,NQBINI | |
2783 | * nucleon-nucleon event-generator | |
2784 | CHARACTER*8 CMODEL | |
2785 | LOGICAL LPHOIN | |
2786 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2787 | * flags for input different options | |
2788 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2789 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2790 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2791 | * event flag | |
2792 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2793 | ||
2794 | DIMENSION XDUMB(40),BGTA(4) | |
2795 | ||
2796 | * LEPTO | |
2797 | IF (MCGENE.EQ.3) THEN | |
2798 | STOP ' This version does not contain LEPTO !' | |
2799 | ENDIF | |
2800 | ||
2801 | KKMAT = 1 | |
2802 | NMSG = MAX(NEVTS/10,1) | |
2803 | ||
2804 | * mass of incident lepton | |
2805 | AMLPT = AAM(IDP) | |
2806 | AMLPT2 = AMLPT**2 | |
2807 | IDPPDG = IDT_IPDGHA(IDP) | |
2808 | ||
2809 | * consistency of kinematical limits | |
2810 | Q2MIN = MAX(Q2MIN,TINY10) | |
2811 | Q2MAX = MAX(Q2MAX,TINY10) | |
2812 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) | |
2813 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) | |
2814 | ||
2815 | * total energy of the lepton-nucleon system | |
2816 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 | |
2817 | & +(PLEPT0(3)+PNUCL(3))**2 ) | |
2818 | ETOTLN = PLEPT0(4)+PNUCL(4) | |
2819 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) | |
2820 | ECMAX = MIN(ECMAX,ECMLN) | |
2821 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, | |
2822 | & THMIN,THMAX,ELMIN | |
2823 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, | |
2824 | & '------------------',/,9X,'W (min) =', | |
2825 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', | |
2826 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, | |
2827 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' | |
2828 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', | |
2829 | & F7.4,' for E_lpt >',F7.1,' GeV',/) | |
2830 | ||
2831 | * Lorentz-parameter for transf. into Lab | |
2832 | BGTA(1) = PNUCL(1)/AAM(1) | |
2833 | BGTA(2) = PNUCL(2)/AAM(1) | |
2834 | BGTA(3) = PNUCL(3)/AAM(1) | |
2835 | BGTA(4) = PNUCL(4)/AAM(1) | |
2836 | * LT of incident lepton into Lab and dump it in DTEVT1 | |
2837 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2838 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), | |
2839 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) | |
2840 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2841 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), | |
2842 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) | |
2843 | * maximum energy of photon nucleon system | |
2844 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 | |
2845 | & +(YMAX*PPL0(3)+PPA(3))**2) | |
2846 | ETOTGN = YMAX*PPL0(4)+PPA(4) | |
2847 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2848 | EGNMAX = MIN(EGNMAX,ECMAX) | |
2849 | * minimum energy of photon nucleon system | |
2850 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 | |
2851 | & +(YMIN*PPL0(3)+PPA(3))**2) | |
2852 | ETOTGN = YMIN*PPL0(4)+PPA(4) | |
2853 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2854 | EGNMIN = MAX(EGNMIN,ECMIN) | |
2855 | ||
2856 | * limits for Glauber-initialization | |
2857 | Q2LI = Q2MIN | |
2858 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) | |
2859 | ECMLI = MAX(EGNMIN,THREE) | |
2860 | ECMHI = EGNMAX | |
2861 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI | |
2862 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, | |
2863 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', | |
2864 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, | |
2865 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, | |
2866 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) | |
2867 | * initialization of Glauber-formalism | |
2868 | IF (NCOMPO.LE.0) THEN | |
2869 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2870 | ELSE | |
2871 | DO 9 I=1,NCOMPO | |
2872 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2873 | 9 CONTINUE | |
2874 | ENDIF | |
2875 | CALL DT_SIGEMU | |
2876 | ||
2877 | * initialization of run-statistics and histograms | |
2878 | CALL DT_STATIS(1) | |
2879 | CALL PHO_PHIST(1000,DUM) | |
2880 | ||
2881 | * maximum photon-nucleus cross section | |
2882 | I1 = 1 | |
2883 | I2 = 1 | |
2884 | RAT = ONE | |
2885 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN | |
2886 | I1 = NEBINI | |
2887 | I2 = NEBINI | |
2888 | RAT = ONE | |
2889 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN | |
2890 | DO 5 I=2,NEBINI | |
2891 | IF (EGNMAX.LT.ECMNN(I)) THEN | |
2892 | I1 = I-1 | |
2893 | I2 = I | |
2894 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2895 | GOTO 6 | |
2896 | ENDIF | |
2897 | 5 CONTINUE | |
2898 | 6 CONTINUE | |
2899 | ENDIF | |
2900 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2901 | EGNXX = EGNMAX | |
2902 | I1 = 1 | |
2903 | I2 = 1 | |
2904 | RAT = ONE | |
2905 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN | |
2906 | I1 = NEBINI | |
2907 | I2 = NEBINI | |
2908 | RAT = ONE | |
2909 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN | |
2910 | DO 7 I=2,NEBINI | |
2911 | IF (EGNMIN.LT.ECMNN(I)) THEN | |
2912 | I1 = I-1 | |
2913 | I2 = I | |
2914 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2915 | GOTO 8 | |
2916 | ENDIF | |
2917 | 7 CONTINUE | |
2918 | 8 CONTINUE | |
2919 | ENDIF | |
2920 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2921 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN | |
2922 | SIGMAX = MAX(SIGMAX,SIGXX) | |
2923 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' | |
2924 | ||
2925 | * plot photon flux table | |
2926 | AYMIN = LOG(YMIN) | |
2927 | AYMAX = LOG(YMAX) | |
2928 | AYRGE = AYMAX-AYMIN | |
2929 | MAXTAB = 50 | |
2930 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) | |
2931 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' | |
2932 | DO 1 I=1,MAXTAB | |
2933 | Y = EXP(AYMIN+ADY*DBLE(I-1)) | |
2934 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) | |
2935 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2936 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) | |
2937 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2938 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) | |
2939 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 | |
2940 | 1 CONTINUE | |
2941 | ||
2942 | * maximum residual weight for flux sampling (dy/y) | |
2943 | YY = YMIN | |
2944 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2945 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) | |
2946 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2947 | ||
2948 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) | |
2949 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) | |
2950 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) | |
2951 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) | |
2952 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) | |
2953 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) | |
2954 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) | |
2955 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) | |
2956 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) | |
2957 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) | |
2958 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) | |
2959 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) | |
2960 | XBLOW = 0.001D0 | |
2961 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) | |
2962 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) | |
2963 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) | |
2964 | ||
2965 | ITRY = 0 | |
2966 | ITRW = 0 | |
2967 | NC0 = 0 | |
2968 | NC1 = 0 | |
2969 | ||
2970 | * generate events | |
2971 | DO 2 IEVT=1,NEVTS | |
2972 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2973 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', | |
2974 | C & STATUS='UNKNOWN') | |
2975 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' | |
2976 | C CLOSE(LDAT) | |
2977 | ENDIF | |
2978 | NEVENT = IEVT | |
2979 | ||
2980 | 100 CONTINUE | |
2981 | ITRY = ITRY+1 | |
2982 | ||
2983 | * sample y | |
2984 | 101 CONTINUE | |
2985 | ITRW = ITRW+1 | |
2986 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) | |
2987 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2988 | Q2LOG = LOG(Q2MAX/Q2LOW) | |
2989 | WGH = (ONE+(ONE-YY)**2)*Q2LOG | |
2990 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2991 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH | |
2992 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) | |
2993 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 | |
2994 | ||
2995 | * sample Q2 | |
2996 | YEFF = ONE+(ONE-YY)**2 | |
2997 | 102 CONTINUE | |
2998 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) | |
2999 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF | |
3000 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 | |
3001 | ||
3002 | c NC0 = NC0+1 | |
3003 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) | |
3004 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) | |
3005 | ||
3006 | * kinematics at lepton-photon vertex | |
3007 | * scattered electron | |
3008 | YQ2 = SQRT((ONE-YY)*Q2) | |
3009 | Q2E = Q2/(4.0D0*PLEPT0(4)) | |
3010 | E1Y = (ONE-YY)*PLEPT0(4) | |
3011 | CALL DT_DSFECF(SIF,COF) | |
3012 | PLEPT1(1) = YQ2*COF | |
3013 | PLEPT1(2) = YQ2*SIF | |
3014 | PLEPT1(3) = E1Y-Q2E | |
3015 | PLEPT1(4) = E1Y+Q2E | |
3016 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) | |
3017 | * radiated photon | |
3018 | PGAMM(1) = -PLEPT1(1) | |
3019 | PGAMM(2) = -PLEPT1(2) | |
3020 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) | |
3021 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) | |
3022 | * E_cm cut | |
3023 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 | |
3024 | & +(PGAMM(3)+PNUCL(3))**2 ) | |
3025 | ETOTGN = PGAMM(4)+PNUCL(4) | |
3026 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) | |
3027 | IF (ECMGN.LT.0.1D0) GOTO 101 | |
3028 | ECMGN = SQRT(ECMGN) | |
3029 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 | |
3030 | ||
3031 | * Lorentz-transformation into nucleon-rest system | |
3032 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3033 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), | |
3034 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) | |
3035 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3036 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), | |
3037 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) | |
3038 | * temporary checks.. | |
3039 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) | |
3040 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP | |
3041 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', | |
3042 | & 2F10.4) | |
3043 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) | |
3044 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP | |
3045 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', | |
3046 | & 2F10.2) | |
3047 | YYTMP = PPG(4)/PPL0(4) | |
3048 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP | |
3049 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', | |
3050 | & 2F10.4) | |
3051 | ||
3052 | * lepton tagger (Lab) | |
3053 | THETA = ACOS( PPL1(3)/PLTOT ) | |
3054 | IF (PPL1(4).GT.ELMIN) THEN | |
3055 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 | |
3056 | ENDIF | |
3057 | * photon energy-cut (Lab) | |
3058 | IF (PPG(4).LT.EGMIN) GOTO 101 | |
3059 | IF (PPG(4).GT.EGMAX) GOTO 101 | |
3060 | * x_Bj cut | |
3061 | XBJ = ABS(Q2/(1.876D0*PPG(4))) | |
3062 | IF (XBJ.LT.XBJMIN) GOTO 101 | |
3063 | ||
3064 | NC0 = NC0+1 | |
3065 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) | |
3066 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) | |
3067 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) | |
3068 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) | |
3069 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) | |
3070 | ||
3071 | * rotation angles against z-axis | |
3072 | COD = PPG(3)/PGTOT | |
3073 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3074 | PPT = SQRT(PPG(1)**2+PPG(2)**2) | |
3075 | SID = PPT/PGTOT | |
3076 | COF = ONE | |
3077 | SIF = ZERO | |
3078 | IF (PGTOT*SID.GT.TINY10) THEN | |
3079 | COF = PPG(1)/(SID*PGTOT) | |
3080 | SIF = PPG(2)/(SID*PGTOT) | |
3081 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3082 | COF = COF/ANORF | |
3083 | SIF = SIF/ANORF | |
3084 | ENDIF | |
3085 | ||
3086 | IF (IXSTBL.EQ.0) THEN | |
3087 | * change to photon projectile | |
3088 | IJPROJ = 7 | |
3089 | * set virtuality | |
3090 | VIRT = Q2 | |
3091 | * re-initialize LTs with new kinematics | |
3092 | * !!PGAMM ist set in cms (ECMGN) along z | |
3093 | EPN = ZERO | |
3094 | PPN = ZERO | |
3095 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) | |
3096 | * force Lab-system | |
3097 | IFRAME = 1 | |
3098 | * get emulsion component if requested | |
3099 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
3100 | * convolute with cross section | |
3101 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) | |
3102 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) | |
3103 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') | |
3104 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, | |
3105 | & Q2,ECMGN,STOT | |
3106 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 | |
3107 | NC1 = NC1+1 | |
3108 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) | |
3109 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) | |
3110 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) | |
3111 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) | |
3112 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) | |
3113 | * composite targets only | |
3114 | KKMAT = -KKMAT | |
3115 | * sample this event | |
3116 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, | |
3117 | & IREJ) | |
3118 | * rotate momenta of final state particles back in photon-nucleon syst. | |
3119 | DO 4 I=NPOINT(4),NHKK | |
3120 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3121 | & (ISTHKK(I).EQ.1001)) THEN | |
3122 | PX = PHKK(1,I) | |
3123 | PY = PHKK(2,I) | |
3124 | PZ = PHKK(3,I) | |
3125 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, | |
3126 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) | |
3127 | ENDIF | |
3128 | 4 CONTINUE | |
3129 | ENDIF | |
3130 | ||
3131 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) | |
3132 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) | |
3133 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) | |
3134 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) | |
3135 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) | |
3136 | ||
3137 | * dump this event to histograms | |
3138 | CALL PHO_PHIST(2000,DUM) | |
3139 | ||
3140 | 2 CONTINUE | |
3141 | ||
3142 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) | |
3143 | WGY = WGY*LOG(YMAX/YMIN) | |
3144 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) | |
3145 | ||
3146 | C HEADER = ' LAEVT: Q^2 distribution 0' | |
3147 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3148 | C HEADER = ' LAEVT: Q^2 distribution 1' | |
3149 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3150 | C HEADER = ' LAEVT: Q^2 distribution 2' | |
3151 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3152 | C HEADER = ' LAEVT: y distribution 0' | |
3153 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3154 | C HEADER = ' LAEVT: y distribution 1' | |
3155 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3156 | C HEADER = ' LAEVT: y distribution 2' | |
3157 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3158 | C HEADER = ' LAEVT: x distribution 0' | |
3159 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3160 | C HEADER = ' LAEVT: x distribution 1' | |
3161 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3162 | C HEADER = ' LAEVT: x distribution 2' | |
3163 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3164 | C HEADER = ' LAEVT: E_g distribution 0' | |
3165 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3166 | C HEADER = ' LAEVT: E_g distribution 1' | |
3167 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3168 | C HEADER = ' LAEVT: E_g distribution 2' | |
3169 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3170 | C HEADER = ' LAEVT: E_c distribution 0' | |
3171 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3172 | C HEADER = ' LAEVT: E_c distribution 1' | |
3173 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3174 | C HEADER = ' LAEVT: E_c distribution 2' | |
3175 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3176 | ||
3177 | * print run-statistics and histograms to output-unit 6 | |
3178 | CALL PHO_PHIST(3000,DUM) | |
3179 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) | |
3180 | ||
3181 | RETURN | |
3182 | END | |
3183 | ||
3184 | *$ CREATE DT_DTUINI.FOR | |
3185 | *COPY DT_DTUINI | |
3186 | * | |
3187 | *===dtuini=============================================================* | |
3188 | * | |
3189 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
3190 | & IDP,IEMU) | |
3191 | ||
3192 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3193 | SAVE | |
3194 | ||
3195 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
3196 | * emulsion treatment | |
3197 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
3198 | & NCOMPO,IEMUL | |
3199 | * Glauber formalism: flags and parameters for statistics | |
3200 | LOGICAL LPROD | |
3201 | CHARACTER*8 CGLB | |
3202 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
3203 | ||
3204 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) | |
3205 | CALL DT_STATIS(1) | |
3206 | CALL PHO_PHIST(1000,DUM) | |
3207 | IF (NCOMPO.LE.0) THEN | |
3208 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
3209 | ELSE | |
3210 | DO 1 I=1,NCOMPO | |
3211 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
3212 | 1 CONTINUE | |
3213 | ENDIF | |
3214 | IF (IOGLB.NE.100) CALL DT_SIGEMU | |
3215 | IEMU = IEMUL | |
3216 | ||
3217 | RETURN | |
3218 | END | |
3219 | ||
3220 | *$ CREATE DT_DTUOUT.FOR | |
3221 | *COPY DT_DTUOUT | |
3222 | * | |
3223 | *===dtuout=============================================================* | |
3224 | * | |
3225 | SUBROUTINE DT_DTUOUT | |
3226 | ||
3227 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3228 | SAVE | |
3229 | ||
3230 | CALL PHO_PHIST(3000,DUM) | |
3231 | CALL DT_STATIS(2) | |
3232 | ||
3233 | RETURN | |
3234 | END | |
3235 | ||
3236 | *$ CREATE DT_BEAMPR.FOR | |
3237 | *COPY DT_BEAMPR | |
3238 | * | |
3239 | *===beampr=============================================================* | |
3240 | * | |
3241 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) | |
3242 | ||
3243 | ************************************************************************ | |
3244 | * Initialization of event generation * | |
3245 | * This version dated 7.4.98 is written by S. Roesler. * | |
3246 | ************************************************************************ | |
3247 | ||
3248 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3249 | SAVE | |
3250 | ||
3251 | PARAMETER ( LINP = 10 , | |
3252 | & LOUT = 6 , | |
3253 | & LDAT = 9 ) | |
3254 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3255 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3256 | ||
3257 | LOGICAL LBEAM | |
3258 | ||
3259 | * event history | |
3260 | PARAMETER (NMXHKK=200000) | |
3261 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3262 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3263 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3264 | * extended event history | |
3265 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3266 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3267 | & IHIST(2,NMXHKK) | |
3268 | * properties of interacting particles | |
3269 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3270 | * particle properties (BAMJET index convention) | |
3271 | CHARACTER*8 ANAME | |
3272 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3273 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3274 | * beam momenta | |
3275 | COMMON /DTBEAM/ P1(4),P2(4) | |
3276 | ||
3277 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) | |
3278 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) | |
3279 | ||
3280 | DATA LBEAM /.FALSE./ | |
3281 | ||
3282 | GOTO (1,2) MODE | |
3283 | ||
3284 | 1 CONTINUE | |
3285 | ||
3286 | E1 = WHAT(1) | |
3287 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) | |
3288 | E2 = WHAT(2) | |
3289 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) | |
3290 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) | |
3291 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) | |
3292 | TH = 1.D-6*WHAT(3)/2.D0 | |
3293 | PH = WHAT(4)*BOG | |
3294 | P1(1) = PP1*SIN(TH)*COS(PH) | |
3295 | P1(2) = PP1*SIN(TH)*SIN(PH) | |
3296 | P1(3) = PP1*COS(TH) | |
3297 | P1(4) = E1 | |
3298 | P2(1) = PP2*SIN(TH)*COS(PH) | |
3299 | P2(2) = PP2*SIN(TH)*SIN(PH) | |
3300 | P2(3) = -PP2*COS(TH) | |
3301 | P2(4) = E2 | |
3302 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 | |
3303 | & -(P1(3)+P2(3))**2 ) | |
3304 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) | |
3305 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) | |
3306 | BGX = (P1(1)+P2(1))/ECM | |
3307 | BGY = (P1(2)+P2(2))/ECM | |
3308 | BGZ = (P1(3)+P2(3))/ECM | |
3309 | BGE = (P1(4)+P2(4))/ECM | |
3310 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), | |
3311 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) | |
3312 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), | |
3313 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) | |
3314 | COD = P1CMS(3)/P1TOT | |
3315 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3316 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) | |
3317 | SID = PPT/P1TOT | |
3318 | COF = ONE | |
3319 | SIF = ZERO | |
3320 | IF (P1TOT*SID.GT.TINY10) THEN | |
3321 | COF = P1CMS(1)/(SID*P1TOT) | |
3322 | SIF = P1CMS(2)/(SID*P1TOT) | |
3323 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3324 | COF = COF/ANORF | |
3325 | SIF = SIF/ANORF | |
3326 | ENDIF | |
3327 | **check | |
3328 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3329 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3330 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT | |
3331 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT | |
3332 | C PAX = ZERO | |
3333 | C PAY = ZERO | |
3334 | C PAZ = P1TOT | |
3335 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) | |
3336 | C PBX = ZERO | |
3337 | C PBY = ZERO | |
3338 | C PBZ = -P2TOT | |
3339 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) | |
3340 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE | |
3341 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE | |
3342 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, | |
3343 | C & P1CMS(1),P1CMS(2),P1CMS(3)) | |
3344 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, | |
3345 | C & P2CMS(1),P2CMS(2),P2CMS(3)) | |
3346 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) | |
3347 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) | |
3348 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), | |
3349 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) | |
3350 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), | |
3351 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) | |
3352 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3353 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3354 | C STOP | |
3355 | ** | |
3356 | ||
3357 | LBEAM = .TRUE. | |
3358 | ||
3359 | RETURN | |
3360 | ||
3361 | 2 CONTINUE | |
3362 | ||
3363 | IF (LBEAM) THEN | |
3364 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3365 | DO 20 I=NPOINT(4),NHKK | |
430525dd | 3366 | IF ((ABS(ISTHKK(I)).EQ.1) .OR. |
3367 | & (ABS(ISTHKK(I)).EQ.2) .OR. | |
3368 | & (ISTHKK(I).EQ.1000) .OR. | |
3369 | & (ISTHKK(I).EQ.1001)) THEN | |
3370 | ||
9aaba0d6 | 3371 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), |
3372 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) | |
3373 | PECMS = PHKK(4,I) | |
3374 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, | |
3375 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) | |
3376 | ENDIF | |
3377 | 20 CONTINUE | |
3378 | ELSE | |
3379 | MODE = -1 | |
3380 | ENDIF | |
3381 | ||
3382 | RETURN | |
3383 | END | |
3384 | ||
3385 | *$ CREATE DT_REJUCO.FOR | |
3386 | *COPY DT_REJUCO | |
3387 | * | |
3388 | *===rejuco=============================================================* | |
3389 | * | |
3390 | SUBROUTINE DT_REJUCO(MODE,IREJ) | |
3391 | ||
3392 | ************************************************************************ | |
3393 | * REJection of Unphysical COnfigurations * | |
3394 | * MODE = 1 rejection of particles with unphysically large energy * | |
3395 | * * | |
3396 | * This version dated 27.12.2006 is written by S. Roesler. * | |
3397 | ************************************************************************ | |
3398 | ||
3399 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3400 | SAVE | |
3401 | ||
3402 | PARAMETER ( LINP = 10 , | |
3403 | & LOUT = 6 , | |
3404 | & LDAT = 9 ) | |
3405 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3406 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3407 | ||
3408 | * maximum x_cms of final state particle | |
3409 | PARAMETER (XCMSMX = 1.4D0) | |
3410 | ||
3411 | * event history | |
3412 | PARAMETER (NMXHKK=200000) | |
3413 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3414 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3415 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3416 | * extended event history | |
3417 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3418 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3419 | & IHIST(2,NMXHKK) | |
3420 | * Lorentz-parameters of the current interaction | |
3421 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
3422 | & UMO,PPCM,EPROJ,PPROJ | |
3423 | ||
3424 | IREJ = 0 | |
3425 | ||
3426 | IF (MODE.EQ.1) THEN | |
3427 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3428 | ECMHLF = UMO/2.0D0 | |
3429 | DO 10 I=NPOINT(4),NHKK | |
3430 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN | |
3431 | XCMS = ABS(PHKK(4,I))/ECMHLF | |
3432 | IF (XCMS.GT.XCMSMX) GOTO 9999 | |
3433 | ENDIF | |
3434 | 10 CONTINUE | |
3435 | ENDIF | |
3436 | ||
3437 | RETURN | |
3438 | 9999 CONTINUE | |
3439 | IREJ = 1 | |
3440 | RETURN | |
3441 | END | |
3442 | ||
3443 | *$ CREATE DT_EVENTB.FOR | |
3444 | *COPY DT_EVENTB | |
3445 | * | |
3446 | *===eventb=============================================================* | |
3447 | * | |
3448 | SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
3449 | ||
3450 | ************************************************************************ | |
3451 | * Treatment of nucleon-nucleon interactions with full two-component * | |
3452 | * Dual Parton Model. * | |
3453 | * NCSY number of nucleon-nucleon interactions * | |
3454 | * IREJ rejection flag * | |
3455 | * This version dated 14.01.2000 is written by S. Roesler * | |
3456 | ************************************************************************ | |
3457 | ||
3458 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3459 | SAVE | |
3460 | PARAMETER ( LINP = 10 , | |
3461 | & LOUT = 6 , | |
3462 | & LDAT = 9 ) | |
3463 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
3464 | ||
3465 | * event history | |
3466 | PARAMETER (NMXHKK=200000) | |
3467 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3468 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3469 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3470 | * extended event history | |
3471 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3472 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3473 | & IHIST(2,NMXHKK) | |
3474 | *! uncomment this line for internal phojet-fragmentation | |
3475 | C #include "dtu_dtevtp.inc" | |
3476 | * particle properties (BAMJET index convention) | |
3477 | CHARACTER*8 ANAME | |
3478 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3479 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3480 | * flags for input different options | |
3481 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
3482 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
3483 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
3484 | * rejection counter | |
3485 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
3486 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
3487 | & IREXCI(3),IRDIFF(2),IRINC | |
3488 | * properties of interacting particles | |
3489 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3490 | * properties of photon/lepton projectiles | |
3491 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
3492 | * various options for treatment of partons (DTUNUC 1.x) | |
3493 | * (chain recombination, Cronin,..) | |
3494 | LOGICAL LCO2CR,LINTPT | |
3495 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
3496 | & LCO2CR,LINTPT | |
3497 | * statistics | |
3498 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
3499 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
3500 | & ICEVTG(8,0:30) | |
3501 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
3502 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
3503 | * Glauber formalism: collision properties | |
3504 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 3505 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
3506 | & NCP,NCT | |
9aaba0d6 | 3507 | * flags for diffractive interactions (DTUNUC 1.x) |
3508 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
3509 | * statistics: double-Pomeron exchange | |
3510 | COMMON /DTFLG2/ INTFLG,IPOPO | |
3511 | * flags for particle decays | |
3512 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
3513 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
3514 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
3515 | * nucleon-nucleon event-generator | |
3516 | CHARACTER*8 CMODEL | |
3517 | LOGICAL LPHOIN | |
3518 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
3519 | C nucleon-nucleus / nucleus-nucleus interface to DPMJET | |
3520 | INTEGER IDEQP,IDEQB,IHFLD,IHFLS | |
3521 | DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB | |
3522 | COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, | |
3523 | & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) | |
3524 | C model switches and parameters | |
3525 | CHARACTER*8 MDLNA | |
3526 | INTEGER ISWMDL,IPAMDL | |
3527 | DOUBLE PRECISION PARMDL | |
3528 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
3529 | C initial state parton radiation (internal part) | |
3530 | INTEGER MXISR3,MXISR4 | |
3531 | PARAMETER ( MXISR3 = 50, MXISR4 = 100 ) | |
3532 | INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC | |
3533 | DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT | |
3534 | COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), | |
3535 | & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), | |
3536 | & IFL1(2,MXISR3),IFL2(2,MXISR3), | |
3537 | & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC | |
3538 | C event debugging information | |
3539 | INTEGER NMAXD | |
3540 | PARAMETER (NMAXD=100) | |
3541 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
3542 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3543 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
3544 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3545 | C general process information | |
3546 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
3547 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
3548 | ||
3549 | DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), | |
3550 | & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), | |
3551 | & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), | |
3552 | & KPRON(15),ISINGL(2000) | |
3553 | ||
3554 | * initial values for max. number of phojet scatterings and dtunuc chains | |
3555 | * to be fragmented with one pyexec call | |
3556 | DATA MXPHFR,MXDTFR /10,100/ | |
3557 | ||
3558 | IREJ = 0 | |
3559 | * pointer to first parton of the first chain in dtevt common | |
3560 | NPOINT(3) = NHKK+1 | |
3561 | * special flag for double-Pomeron statistics | |
3562 | IPOPO = 1 | |
3563 | * counter for low-mass (DTUNUC) interactions | |
3564 | NDTUSC = 0 | |
3565 | * counter for interactions treated by PHOJET | |
3566 | NPHOSC = 0 | |
3567 | ||
3568 | * scan interactions for single nucleon-nucleon interactions | |
3569 | * (this has to be checked here because Cronin modifies parton momenta) | |
3570 | NC = NPOINT(2) | |
3571 | IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! ' | |
3572 | DO 8 I=1,NCSY | |
3573 | ISINGL(I) = 0 | |
3574 | MOP = JMOHKK(1,NC) | |
3575 | MOT = JMOHKK(1,NC+1) | |
3576 | DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2)) | |
3577 | DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3)) | |
3578 | IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1 | |
3579 | NC = NC+4 | |
3580 | 8 CONTINUE | |
3581 | ||
3582 | * multiple scattering of chain ends | |
3583 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
3584 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
3585 | ||
3586 | * switch to PHOJET-settings for JETSET parameter | |
3587 | CALL DT_INITJS(1) | |
3588 | ||
3589 | * loop over nucleon-nucleon interaction | |
3590 | NC = NPOINT(2) | |
3591 | DO 2 I=1,NCSY | |
3592 | * | |
3593 | * pick up one nucleon-nucleon interaction from DTEVT1 | |
3594 | * ppnn / ptnn - momenta of the interacting nucleons (cms) | |
3595 | * ptotnn - total momentum of the interacting nucleons (cms) | |
3596 | * pp1,2 / pt1,2 - momenta of the four partons | |
3597 | * pp / pt - total momenta of the proj / targ partons | |
3598 | * ptot - total momentum of the four partons | |
3599 | MOP = JMOHKK(1,NC) | |
3600 | MOT = JMOHKK(1,NC+1) | |
3601 | DO 3 K=1,4 | |
3602 | PPNN(K) = PHKK(K,MOP) | |
3603 | PTNN(K) = PHKK(K,MOT) | |
3604 | PTOTNN(K) = PPNN(K)+PTNN(K) | |
3605 | PP1(K) = PHKK(K,NC) | |
3606 | PT1(K) = PHKK(K,NC+1) | |
3607 | PP2(K) = PHKK(K,NC+2) | |
3608 | PT2(K) = PHKK(K,NC+3) | |
3609 | PP(K) = PP1(K)+PP2(K) | |
3610 | PT(K) = PT1(K)+PT2(K) | |
3611 | PTOT(K) = PP(K)+PT(K) | |
3612 | 3 CONTINUE | |
3613 | * | |
3614 | *----------------------------------------------------------------------- | |
3615 | * this is a complete nucleon-nucleon interaction | |
3616 | * | |
3617 | IF (ISINGL(I).EQ.1) THEN | |
3618 | * | |
3619 | * initialize PHOJET-variables for remnant/valence-partons | |
3620 | IHFLD(1,1) = 0 | |
3621 | IHFLD(1,2) = 0 | |
3622 | IHFLD(2,1) = 0 | |
3623 | IHFLD(2,2) = 0 | |
3624 | IHFLS(1) = 1 | |
3625 | IHFLS(2) = 1 | |
3626 | * save current settings of PHOJET process and min. bias flags | |
3627 | DO 9 K=1,11 | |
3628 | KPRON(K) = IPRON(K,1) | |
3629 | 9 CONTINUE | |
3630 | ISWSAV = ISWMDL(2) | |
3631 | * | |
3632 | * check if forced sampling of diffractive interaction requested | |
3633 | IF (ISINGD.LT.-1) THEN | |
3634 | DO 90 K=1,11 | |
3635 | IPRON(K,1) = 0 | |
3636 | 90 CONTINUE | |
3637 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1 | |
3638 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1 | |
3639 | IF (ISINGD.EQ.-5) IPRON(4,1) = 1 | |
3640 | ENDIF | |
3641 | * | |
3642 | * for photons: a direct/anomalous interaction is not sampled | |
3643 | * in PHOJET but already in Glauber-formalism. Here we check if such | |
3644 | * an interaction is requested | |
3645 | IF (IJPROJ.EQ.7) THEN | |
3646 | * first switch off direct interactions | |
3647 | IPRON(8,1) = 0 | |
3648 | * this is a direct interactions | |
3649 | IF (IDIREC.EQ.1) THEN | |
3650 | DO 12 K=1,11 | |
3651 | IPRON(K,1) = 0 | |
3652 | 12 CONTINUE | |
3653 | IPRON(8,1) = 1 | |
3654 | * this is an anomalous interactions | |
3655 | * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) ) | |
3656 | ELSEIF (IDIREC.EQ.2) THEN | |
3657 | ISWMDL(2) = 0 | |
3658 | ENDIF | |
3659 | ELSE | |
3660 | IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! ' | |
3661 | ENDIF | |
3662 | * | |
3663 | * make sure that total momenta of partons, pp and pt, are on mass | |
3664 | * shell (Cronin may have srewed this up..) | |
3665 | CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1) | |
3666 | IF (IR1.NE.0) THEN | |
3667 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)') | |
3668 | & 'EVENTB: mass shell correction rejected' | |
3669 | GOTO 9999 | |
3670 | ENDIF | |
3671 | * | |
3672 | * initialize the incoming particles in PHOJET | |
3673 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3674 | CALL PHO_SETPAR(1,22,0,VIRT) | |
3675 | ELSE | |
3676 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) | |
3677 | ENDIF | |
3678 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) | |
3679 | * | |
3680 | * initialize rejection loop counter for anomalous processes | |
3681 | IRJANO = 0 | |
3682 | 800 CONTINUE | |
3683 | IRJANO = IRJANO+1 | |
3684 | * | |
3685 | * temporary fix for ifano problem | |
3686 | IFANO(1) = 0 | |
3687 | IFANO(2) = 0 | |
3688 | * | |
3689 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET | |
3690 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) | |
3691 | * | |
3692 | * for photons: special consistency check for anomalous interactions | |
3693 | IF (IJPROJ.EQ.7) THEN | |
3694 | IF (IRJANO.LT.30) THEN | |
3695 | IF (IFANO(1).NE.0) THEN | |
3696 | * here, an anomalous interaction was generated. Check if it | |
3697 | * was also requested. Otherwise reject this event. | |
3698 | IF (IDIREC.EQ.0) GOTO 800 | |
3699 | ELSE | |
3700 | * here, an anomalous interaction was not generated. Check if it | |
3701 | * was requested in which case we need to reject this event. | |
3702 | IF (IDIREC.EQ.2) GOTO 800 | |
3703 | ENDIF | |
3704 | ELSE | |
3705 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', | |
3706 | & IRJANO,IDIREC,NEVHKK | |
3707 | ENDIF | |
3708 | ENDIF | |
3709 | * | |
3710 | * copy back original settings of PHOJET process and min. bias flags | |
3711 | DO 10 K=1,11 | |
3712 | IPRON(K,1) = KPRON(K) | |
3713 | 10 CONTINUE | |
3714 | ISWMDL(2) = ISWSAV | |
3715 | * | |
3716 | * check if PHOJET has rejected this event | |
3717 | IF (IREJ1.NE.0) THEN | |
3718 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3719 | WRITE(LOUT,'(1X,A,I4)') | |
3720 | & 'EVENTB: chain system rejected',IDIREC | |
3721 | CALL PHO_PREVNT(0) | |
3722 | GOTO 9999 | |
3723 | ENDIF | |
3724 | * | |
3725 | * copy partons and strings from PHOJET common back into DTEVT for | |
3726 | * external fragmentation | |
3727 | MO1 = NC | |
3728 | MO2 = NC+3 | |
3729 | *! uncomment this line for internal phojet-fragmentation | |
3730 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) | |
3731 | NPHOSC = NPHOSC+1 | |
3732 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) | |
3733 | IF (IREJ1.NE.0) THEN | |
3734 | IF (IOULEV(1).GT.0) | |
3735 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' | |
3736 | GOTO 9999 | |
3737 | ENDIF | |
3738 | * | |
3739 | * update statistics counter | |
3740 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 | |
3741 | * | |
3742 | *----------------------------------------------------------------------- | |
3743 | * this interaction involves "remnants" | |
3744 | * | |
3745 | ELSE | |
3746 | * | |
3747 | * total mass of this system | |
3748 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) | |
3749 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) | |
3750 | IF (AMTOT2.LT.ZERO) THEN | |
3751 | AMTOT = ZERO | |
3752 | ELSE | |
3753 | AMTOT = SQRT(AMTOT2) | |
3754 | ENDIF | |
3755 | * | |
3756 | * systems with masses larger than elojet are treated with PHOJET | |
3757 | IF (AMTOT.GT.ELOJET) THEN | |
3758 | * | |
3759 | * initialize PHOJET-variables for remnant/valence-partons | |
3760 | * projectile parton flavors and valence flag | |
3761 | IHFLD(1,1) = IDHKK(NC) | |
3762 | IHFLD(1,2) = IDHKK(NC+2) | |
3763 | IHFLS(1) = 0 | |
3764 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) | |
3765 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 | |
3766 | * target parton flavors and valence flag | |
3767 | IHFLD(2,1) = IDHKK(NC+1) | |
3768 | IHFLD(2,2) = IDHKK(NC+3) | |
3769 | IHFLS(2) = 0 | |
3770 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) | |
3771 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 | |
3772 | * flag signalizing PHOJET how to treat the remnant: | |
3773 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld | |
3774 | * iremn > -1 valence remnant: PHOJET assumes flavors according | |
3775 | * to mother particle | |
3776 | IREMN1 = IHFLS(1)-1 | |
3777 | IREMN2 = IHFLS(2)-1 | |
3778 | * | |
3779 | * initialize the incoming particles in PHOJET | |
3780 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3781 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) | |
3782 | ELSE | |
3783 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) | |
3784 | ENDIF | |
3785 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) | |
3786 | * | |
3787 | * calculate Lorentz parameter of the nucleon-nucleon cm-system | |
3788 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) | |
3789 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) | |
3790 | BGX = PTOTNN(1)/AMNN | |
3791 | BGY = PTOTNN(2)/AMNN | |
3792 | BGZ = PTOTNN(3)/AMNN | |
3793 | GAM = PTOTNN(4)/AMNN | |
3794 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3795 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3796 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, | |
3797 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) | |
3798 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3799 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, | |
3800 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) | |
3801 | * transform (total) momenta of the proj and targ partons into | |
3802 | * nucleon-nucleon cm-system | |
3803 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3804 | & PP(1),PP(2),PP(3),PP(4), | |
3805 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) | |
3806 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3807 | & PT(1),PT(2),PT(3),PT(4), | |
3808 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) | |
3809 | * energy fractions of the proj and targ partons | |
3810 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) | |
3811 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) | |
3812 | *** | |
3813 | * testprint | |
3814 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3815 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3816 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3817 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3818 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3819 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3820 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3821 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3822 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3823 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3824 | *** | |
3825 | * | |
3826 | * save current settings of PHOJET process and min. bias flags | |
3827 | DO 7 K=1,11 | |
3828 | KPRON(K) = IPRON(K,1) | |
3829 | 7 CONTINUE | |
3830 | * disallow direct photon int. (does not make sense here anyway) | |
3831 | IPRON(8,1) = 0 | |
3832 | * disallow double pomeron processes (due to technical problems | |
3833 | * in PHOJET, needs to be solved sometime) | |
3834 | IPRON(4,1) = 0 | |
3835 | * disallow diffraction for sea-diquarks | |
3836 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. | |
3837 | & (IABS(IHFLD(1,2)).GT.1100)) THEN | |
3838 | IPRON(3,1) = 0 | |
3839 | IPRON(6,1) = 0 | |
3840 | ENDIF | |
3841 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. | |
3842 | & (IABS(IHFLD(2,2)).GT.1100)) THEN | |
3843 | IPRON(3,1) = 0 | |
3844 | IPRON(5,1) = 0 | |
3845 | ENDIF | |
3846 | * | |
3847 | * we need massless partons: transform them on mass shell | |
3848 | XMP = ZERO | |
3849 | XMT = ZERO | |
3850 | DO 6 K=1,4 | |
3851 | PPTMP(K) = PPSUB(K) | |
3852 | PTTMP(K) = PTSUB(K) | |
3853 | 6 CONTINUE | |
3854 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) | |
3855 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) | |
3856 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) | |
3857 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ | |
3858 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) | |
3859 | * total energy of the subsysten after mass transformation | |
3860 | * (should be the same as before..) | |
3861 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* | |
3862 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) | |
3863 | * | |
3864 | * after mass shell transformation the x_sub - relation has to be | |
3865 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. | |
3866 | * | |
3867 | * The old version was to scale based on the original x_sub and the | |
3868 | * 4-momenta of the subsystem. At very high energy this could lead to | |
3869 | * "pseudo-cm energies" of the parent system considerably exceeding | |
3870 | * the true cm energy. Now we keep the true cm energy and calculate | |
3871 | * new x_sub instead. | |
3872 | C old version PPTCMS(4) = PPSUB(4)/XPSUB | |
3873 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) | |
3874 | XPSUB = PPSUB(4)/PPTCMS(4) | |
3875 | IF (IJPROJ.EQ.7) THEN | |
3876 | AMP2 = PHKK(5,MOT)**2 | |
3877 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) | |
3878 | ELSE | |
3879 | *??????? | |
3880 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) | |
3881 | & *(PPTCMS(4)+PHKK(5,MOP))) | |
3882 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) | |
3883 | C & *(PPTCMS(4)+PHKK(5,MOT))) | |
3884 | ENDIF | |
3885 | C old version PTTCMS(4) = PTSUB(4)/XTSUB | |
3886 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) | |
3887 | XTSUB = PTSUB(4)/PTTCMS(4) | |
3888 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) | |
3889 | & *(PTTCMS(4)+PHKK(5,MOT))) | |
3890 | DO 4 K=1,3 | |
3891 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO | |
3892 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO | |
3893 | 4 CONTINUE | |
3894 | *** | |
3895 | * testprint | |
3896 | * | |
3897 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) | |
3898 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) | |
3899 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) | |
3900 | * pp1,2 / pt1,2 - momenta of the four partons | |
3901 | * | |
3902 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) | |
3903 | * ptot - total momentum of the four partons (cms, negl. Fermi) | |
3904 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) | |
3905 | * | |
3906 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3907 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3908 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3909 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3910 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3911 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3912 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3913 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3914 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3915 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3916 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN | |
3917 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM | |
3918 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU | |
3919 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB | |
3920 | c ENDIF | |
3921 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM | |
3922 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM | |
3923 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM | |
3924 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM | |
3925 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3926 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3927 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, | |
3928 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) | |
3929 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3930 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, | |
3931 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) | |
3932 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3933 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, | |
3934 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) | |
3935 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3936 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, | |
3937 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) | |
3938 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + | |
3939 | c & (PPNEW2+PTNEW2)**2 + | |
3940 | c & (PPNEW3+PTNEW3)**2 ) | |
3941 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * | |
3942 | c & (PPNEW4+PTNEW4+PTSTCM) ) | |
3943 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + | |
3944 | c & (PPSUB2+PTSUB2)**2 + | |
3945 | c & (PPSUB3+PTSUB3)**2 ) | |
3946 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * | |
3947 | c & (PPSUB4+PTSUB4+PTSTSU) ) | |
3948 | C WRITE(*,*) ' mother cmE :' | |
3949 | C WRITE(*,*) ETSTCM,ENEWCM | |
3950 | C WRITE(*,*) ' subsystem cmE :' | |
3951 | C WRITE(*,*) ETSTSU,ENEWSU | |
3952 | C WRITE(*,*) ' projectile mother :' | |
3953 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 | |
3954 | C WRITE(*,*) ' target mother :' | |
3955 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 | |
3956 | C WRITE(*,*) ' projectile subsystem:' | |
3957 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 | |
3958 | C WRITE(*,*) ' target subsystem:' | |
3959 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 | |
3960 | C WRITE(*,*) ' projectile subsystem should be:' | |
3961 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, | |
3962 | C & XPSUB*ETSTCM/2.0D0 | |
3963 | C WRITE(*,*) ' target subsystem should be:' | |
3964 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, | |
3965 | C & XTSUB*ETSTCM/2.0D0 | |
3966 | C WRITE(*,*) ' subsystem cmE should be: ' | |
3967 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB | |
3968 | *** | |
3969 | * | |
3970 | * generate complete remnant - nucleon/remnant event with PHOJET | |
3971 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) | |
3972 | * | |
3973 | * copy back original settings of PHOJET process flags | |
3974 | DO 11 K=1,11 | |
3975 | IPRON(K,1) = KPRON(K) | |
3976 | 11 CONTINUE | |
3977 | * | |
3978 | * check if PHOJET has rejected this event | |
3979 | IF (IREJ1.NE.0) THEN | |
3980 | IF (IOULEV(1).GT.0) | |
3981 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' | |
3982 | WRITE(LOUT,*) | |
3983 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT | |
3984 | CALL PHO_PREVNT(0) | |
3985 | GOTO 9999 | |
3986 | ENDIF | |
3987 | * | |
3988 | * copy partons and strings from PHOJET common back into DTEVT for | |
3989 | * external fragmentation | |
3990 | MO1 = NC | |
3991 | MO2 = NC+3 | |
3992 | *! uncomment this line for internal phojet-fragmentation | |
3993 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) | |
3994 | NPHOSC = NPHOSC+1 | |
3995 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) | |
3996 | IF (IREJ1.NE.0) THEN | |
3997 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3998 | & 'EVENTB: chain system rejected 2' | |
3999 | GOTO 9999 | |
4000 | ENDIF | |
4001 | * | |
4002 | * update statistics counter | |
4003 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 | |
4004 | * | |
4005 | *----------------------------------------------------------------------- | |
4006 | * two-chain approx. for smaller systems | |
4007 | * | |
4008 | ELSE | |
4009 | * | |
4010 | NDTUSC = NDTUSC+1 | |
4011 | * special flag for double-Pomeron statistics | |
4012 | IPOPO = 0 | |
4013 | * | |
4014 | * pick up flavors at the ends of the two chains | |
4015 | IFP1 = IDHKK(NC) | |
4016 | IFT1 = IDHKK(NC+1) | |
4017 | IFP2 = IDHKK(NC+2) | |
4018 | IFT2 = IDHKK(NC+3) | |
4019 | * ..and the indices of the mothers | |
4020 | MOP1 = NC | |
4021 | MOT1 = NC+1 | |
4022 | MOP2 = NC+2 | |
4023 | MOT2 = NC+3 | |
4024 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
4025 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
4026 | * | |
4027 | * check if this chain system was rejected | |
4028 | IF (IREJ1.GT.0) THEN | |
4029 | IF (IOULEV(1).GT.0) THEN | |
4030 | WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4031 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') | |
4032 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT | |
4033 | ENDIF | |
4034 | IRHHA = IRHHA+1 | |
4035 | GOTO 9999 | |
4036 | ENDIF | |
4037 | * the following lines are for sea-sea chains rejected in GETCSY | |
4038 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 | |
4039 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 | |
4040 | ENDIF | |
4041 | * | |
4042 | ENDIF | |
4043 | * | |
4044 | * update statistics counter | |
4045 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 | |
4046 | * | |
4047 | NC = NC+4 | |
4048 | * | |
4049 | 2 CONTINUE | |
4050 | * | |
4051 | *----------------------------------------------------------------------- | |
4052 | * treatment of low-mass chains (if there are any) | |
4053 | * | |
4054 | IF (NDTUSC.GT.0) THEN | |
4055 | * | |
4056 | * correct chains of very low masses for possible resonances | |
4057 | IF (IRESCO.EQ.1) THEN | |
4058 | CALL DT_EVTRES(IREJ1) | |
4059 | IF (IREJ1.GT.0) THEN | |
4060 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' | |
4061 | IRRES(1) = IRRES(1)+1 | |
4062 | GOTO 9999 | |
4063 | ENDIF | |
4064 | ENDIF | |
4065 | * fragmentation of low-mass chains | |
4066 | *! uncomment this line for internal phojet-fragmentation | |
4067 | * (of course it will still be fragmented by DPMJET-routines but it | |
4068 | * has to be done here instead of further below) | |
4069 | C CALL DT_EVTFRA(IREJ1) | |
4070 | C IF (IREJ1.GT.0) THEN | |
4071 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' | |
4072 | C IRFRAG = IRFRAG+1 | |
4073 | C GOTO 9999 | |
4074 | C ENDIF | |
4075 | ELSE | |
4076 | *! uncomment this line for internal phojet-fragmentation | |
4077 | C NPOINT(4) = NHKK+1 | |
4078 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
4079 | ENDIF | |
4080 | * | |
4081 | *----------------------------------------------------------------------- | |
4082 | * new di-quark breaking mechanisms | |
4083 | * | |
4084 | MXLEFT = 2 | |
4085 | CALL DT_CHASTA(0) | |
4086 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
4087 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
4088 | CALL DT_DIQBRK | |
4089 | MXLEFT = 4 | |
4090 | ENDIF | |
4091 | * | |
4092 | *----------------------------------------------------------------------- | |
4093 | * hadronize this event | |
4094 | * | |
4095 | * hadronize PHOJET chain systems | |
4096 | NPYMAX = 0 | |
4097 | NPJE = NPHOSC/MXPHFR | |
4098 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 | |
4099 | IF (NPJE.GT.1) THEN | |
4100 | NLEFT = NPHOSC-NPJE*MXPHFR | |
4101 | DO 20 JFRG=1,NPJE | |
4102 | NFRG = JFRG*MXPHFR | |
4103 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN | |
4104 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4105 | IF (IREJ1.GT.0) GOTO 22 | |
4106 | NLEFT = 0 | |
4107 | ELSE | |
4108 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) | |
4109 | IF (IREJ1.GT.0) GOTO 22 | |
4110 | ENDIF | |
4111 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4112 | 20 CONTINUE | |
4113 | IF (NLEFT.GT.0) THEN | |
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 | ELSE | |
4119 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4120 | IF (IREJ1.GT.0) GOTO 22 | |
4121 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4122 | ENDIF | |
4123 | * | |
4124 | * check max. filling level of jetset common and | |
4125 | * reduce mxphfr if necessary | |
4126 | IF (NPYMAX.GT.3000) THEN | |
4127 | IF (NPYMAX.GT.3500) THEN | |
4128 | MXPHFR = MAX(1,MXPHFR-2) | |
4129 | ELSE | |
4130 | MXPHFR = MAX(1,MXPHFR-1) | |
4131 | ENDIF | |
4132 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR | |
4133 | ENDIF | |
4134 | * | |
4135 | * hadronize DTUNUC chain systems | |
4136 | 23 CONTINUE | |
4137 | IBACK = MXDTFR | |
4138 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) | |
4139 | IF (IREJ2.GT.0) GOTO 22 | |
4140 | * | |
4141 | * check max. filling level of jetset common and | |
4142 | * reduce mxdtfr if necessary | |
4143 | IF (NPYMEM.GT.3000) THEN | |
4144 | IF (NPYMEM.GT.3500) THEN | |
4145 | MXDTFR = MAX(1,MXDTFR-20) | |
4146 | ELSE | |
4147 | MXDTFR = MAX(1,MXDTFR-10) | |
4148 | ENDIF | |
4149 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR | |
4150 | ENDIF | |
4151 | * | |
4152 | IF (IBACK.EQ.-1) GOTO 23 | |
4153 | * | |
4154 | 22 CONTINUE | |
4155 | C CALL DT_EVTFRG(1,IREJ1) | |
4156 | C CALL DT_EVTFRG(2,IREJ2) | |
4157 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN | |
4158 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4159 | IRFRAG = IRFRAG+1 | |
4160 | GOTO 9999 | |
4161 | ENDIF | |
4162 | * | |
4163 | * get final state particles from /DTEVTP/ | |
4164 | *! uncomment this line for internal phojet-fragmentation | |
4165 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) | |
4166 | ||
4167 | IF (IJPROJ.NE.7) | |
4168 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) | |
4169 | C IF (IREJ3.NE.0) GOTO 9999 | |
4170 | ||
4171 | RETURN | |
4172 | ||
4173 | 9999 CONTINUE | |
4174 | IREVT = IREVT+1 | |
4175 | IREJ = 1 | |
4176 | RETURN | |
4177 | END | |
4178 | ||
4179 | *$ CREATE DT_GETPJE.FOR | |
4180 | *COPY DT_GETPJE | |
4181 | * | |
4182 | *===getpje=============================================================* | |
4183 | * | |
4184 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) | |
4185 | ||
4186 | ************************************************************************ | |
4187 | * This subroutine copies PHOJET partons and strings from POEVT1 into * | |
4188 | * DTEVT1. * | |
4189 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * | |
4190 | * PP,PT 4-momenta of projectile/target being handled by * | |
4191 | * PHOJET * | |
4192 | * This version dated 11.12.99 is written by S. Roesler * | |
4193 | ************************************************************************ | |
4194 | ||
4195 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4196 | SAVE | |
4197 | PARAMETER ( LINP = 10 , | |
4198 | & LOUT = 6 , | |
4199 | & LDAT = 9 ) | |
4200 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, | |
4201 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) | |
4202 | ||
4203 | LOGICAL LFLIP | |
4204 | ||
4205 | * event history | |
4206 | PARAMETER (NMXHKK=200000) | |
4207 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4208 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4209 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4210 | * extended event history | |
4211 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4212 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4213 | & IHIST(2,NMXHKK) | |
4214 | * Lorentz-parameters of the current interaction | |
4215 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4216 | & UMO,PPCM,EPROJ,PPROJ | |
4217 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
4218 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
4219 | * flags for input different options | |
4220 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4221 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4222 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4223 | * statistics: double-Pomeron exchange | |
4224 | COMMON /DTFLG2/ INTFLG,IPOPO | |
4225 | * statistics | |
4226 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
4227 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
4228 | & ICEVTG(8,0:30) | |
4229 | * rejection counter | |
4230 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
4231 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
4232 | & IREXCI(3),IRDIFF(2),IRINC | |
4233 | C standard particle data interface | |
4234 | INTEGER NMXHEP | |
4235 | PARAMETER (NMXHEP=4000) | |
4236 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
4237 | DOUBLE PRECISION PHEP,VHEP | |
4238 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
4239 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
09b429a4 | 4240 | & VHEP(4,NMXHEP), NSD1, NSD2, NDD |
9aaba0d6 | 4241 | C extension to standard particle data interface (PHOJET specific) |
4242 | INTEGER IMPART,IPHIST,ICOLOR | |
4243 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
4244 | C color string configurations including collapsed strings and hadrons | |
4245 | INTEGER MSTR | |
4246 | PARAMETER (MSTR=500) | |
4247 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD | |
4248 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), | |
4249 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), | |
4250 | & NNCH(MSTR),IBHAD(MSTR),ISTR | |
4251 | C general process information | |
4252 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4253 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4254 | C model switches and parameters | |
4255 | CHARACTER*8 MDLNA | |
4256 | INTEGER ISWMDL,IPAMDL | |
4257 | DOUBLE PRECISION PARMDL | |
4258 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4259 | C event debugging information | |
4260 | INTEGER NMAXD | |
4261 | PARAMETER (NMAXD=100) | |
4262 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
4263 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4264 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
4265 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4266 | ||
4267 | DIMENSION PP(4),PT(4) | |
4268 | DATA MAXLOP /10000/ | |
4269 | ||
4270 | INHKK = NHKK | |
4271 | LFLIP = .TRUE. | |
4272 | 1 CONTINUE | |
4273 | NPVAL = 0 | |
4274 | NTVAL = 0 | |
4275 | IREJ = 0 | |
4276 | ||
4277 | * store initial momenta for energy-momentum conservation check | |
4278 | IF (LEMCCK) THEN | |
4279 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) | |
4280 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) | |
4281 | ENDIF | |
4282 | * copy partons and strings from POEVT1 into DTEVT1 | |
4283 | DO 11 I=1,ISTR | |
4284 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN | |
4285 | IF (NCODE(I).EQ.-99) THEN | |
4286 | IDXSTG = NPOS(1,I) | |
4287 | IDSTG = IDHEP(IDXSTG) | |
4288 | PX = PHEP(1,IDXSTG) | |
4289 | PY = PHEP(2,IDXSTG) | |
4290 | PZ = PHEP(3,IDXSTG) | |
4291 | PE = PHEP(4,IDXSTG) | |
4292 | IF (MODE.LT.0) THEN | |
4293 | ISTAT = 70000+IPJE | |
4294 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, | |
4295 | & 11,IDSTG,0) | |
4296 | IF (LEMCCK) THEN | |
4297 | PX = -PX | |
4298 | PY = -PY | |
4299 | PZ = -PZ | |
4300 | PE = -PE | |
4301 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4302 | ENDIF | |
4303 | ELSE | |
4304 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4305 | & PPX,PPY,PPZ,PPE) | |
4306 | ISTAT = 70000+IPJE | |
4307 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, | |
4308 | & 11,IDSTG,0) | |
4309 | IF (LEMCCK) THEN | |
4310 | PX = -PPX | |
4311 | PY = -PPY | |
4312 | PZ = -PPZ | |
4313 | PE = -PPE | |
4314 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4315 | ENDIF | |
4316 | ENDIF | |
4317 | NOBAM(NHKK) = 0 | |
4318 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) | |
4319 | IHIST(2,NHKK) = 0 | |
4320 | ELSEIF (NCODE(I).GE.0) THEN | |
4321 | * indices of partons and string in POEVT1 | |
4322 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) | |
4323 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) | |
4324 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN | |
4325 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, | |
4326 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' | |
4327 | STOP ' GETPJE 1' | |
4328 | ENDIF | |
4329 | IDXSTG = NPOS(1,I) | |
4330 | * find "mother" string of the string | |
4331 | IDXMS1 = ABS(JMOHEP(1,IDX1)) | |
4332 | IDXMS2 = ABS(JMOHEP(1,IDX2)) | |
4333 | IF (IDXMS1.NE.IDXMS2) THEN | |
4334 | IDXMS1 = IDXSTG | |
4335 | IDXMS2 = IDXSTG | |
4336 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' | |
4337 | ENDIF | |
4338 | * search POEVT1 for the original hadron of the parton | |
4339 | ILOOP = 0 | |
4340 | IPOM1 = 0 | |
4341 | 14 CONTINUE | |
4342 | ILOOP = ILOOP+1 | |
4343 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 | |
4344 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) | |
4345 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. | |
4346 | & (ILOOP.LT.MAXLOP)) GOTO 14 | |
4347 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' | |
4348 | IPOM2 = 0 | |
4349 | ILOOP = 0 | |
4350 | 15 CONTINUE | |
4351 | ILOOP = ILOOP+1 | |
4352 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 | |
4353 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN | |
4354 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) | |
4355 | ELSE | |
4356 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) | |
4357 | ENDIF | |
4358 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. | |
4359 | & (ILOOP.LT.MAXLOP)) GOTO 15 | |
4360 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' | |
4361 | * parton 1 | |
4362 | IF (IDXMS1.EQ.1) THEN | |
4363 | ISPTN1 = ISTHKK(MO1) | |
4364 | M1PTN1 = MO1 | |
4365 | M2PTN1 = MO1+2 | |
4366 | ELSE | |
4367 | ISPTN1 = ISTHKK(MO2) | |
4368 | M1PTN1 = MO2-2 | |
4369 | M2PTN1 = MO2 | |
4370 | ENDIF | |
4371 | * parton 2 | |
4372 | IF (IDXMS2.EQ.1) THEN | |
4373 | ISPTN2 = ISTHKK(MO1) | |
4374 | M1PTN2 = MO1 | |
4375 | M2PTN2 = MO1+2 | |
4376 | ELSE | |
4377 | ISPTN2 = ISTHKK(MO2) | |
4378 | M1PTN2 = MO2-2 | |
4379 | M2PTN2 = MO2 | |
4380 | ENDIF | |
4381 | * check for mis-identified mothers and switch mother indices if necessary | |
4382 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) | |
4383 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. | |
4384 | & (LFLIP)) THEN | |
4385 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN | |
4386 | ISPTN1 = ISTHKK(MO1) | |
4387 | M1PTN1 = MO1 | |
4388 | M2PTN1 = MO1+2 | |
4389 | ISPTN2 = ISTHKK(MO2) | |
4390 | M1PTN2 = MO2-2 | |
4391 | M2PTN2 = MO2 | |
4392 | ELSE | |
4393 | ISPTN1 = ISTHKK(MO2) | |
4394 | M1PTN1 = MO2-2 | |
4395 | M2PTN1 = MO2 | |
4396 | ISPTN2 = ISTHKK(MO1) | |
4397 | M1PTN2 = MO1 | |
4398 | M2PTN2 = MO1+2 | |
4399 | ENDIF | |
4400 | ENDIF | |
4401 | * register partons in temporary common | |
4402 | * parton at chain end | |
4403 | PX = PHEP(1,IDX1) | |
4404 | PY = PHEP(2,IDX1) | |
4405 | PZ = PHEP(3,IDX1) | |
4406 | PE = PHEP(4,IDX1) | |
4407 | * flag only partons coming from Pomeron with 41/42 | |
4408 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4409 | IF (IPOM1.NE.0) THEN | |
4410 | ISTX = ABS(ISPTN1)/10 | |
4411 | IMO = ABS(ISPTN1)-10*ISTX | |
4412 | ISPTN1 = -(40+IMO) | |
4413 | ELSE | |
4414 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN | |
4415 | ISTX = ABS(ISPTN1)/10 | |
4416 | IMO = ABS(ISPTN1)-10*ISTX | |
4417 | IF ((IDHEP(IDX1).EQ.21).OR. | |
4418 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN | |
4419 | ISPTN1 = -(60+IMO) | |
4420 | ELSE | |
4421 | ISPTN1 = -(50+IMO) | |
4422 | ENDIF | |
4423 | ENDIF | |
4424 | ENDIF | |
4425 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 | |
4426 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 | |
4427 | IF (MODE.LT.0) THEN | |
4428 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, | |
4429 | & PZ,PE,0,0,0) | |
4430 | ELSE | |
4431 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4432 | & PPX,PPY,PPZ,PPE) | |
4433 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, | |
4434 | & PPZ,PPE,0,0,0) | |
4435 | ENDIF | |
4436 | IHIST(1,NHKK) = IPHIST(1,IDX1) | |
4437 | IHIST(2,NHKK) = 0 | |
4438 | DO 19 KK=1,4 | |
4439 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) | |
4440 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) | |
4441 | 19 CONTINUE | |
4442 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB | |
4443 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB | |
4444 | M1STRG = NHKK | |
4445 | * gluon kinks | |
4446 | NGLUON = IDX2-IDX1-1 | |
4447 | IF (NGLUON.GT.0) THEN | |
4448 | DO 17 IGLUON=1,NGLUON | |
4449 | IDX = IDX1+IGLUON | |
4450 | IDXMS = ABS(JMOHEP(1,IDX)) | |
4451 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN | |
4452 | ILOOP = 0 | |
4453 | 16 CONTINUE | |
4454 | ILOOP = ILOOP+1 | |
4455 | IDXMS = ABS(JMOHEP(1,IDXMS)) | |
4456 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. | |
4457 | & (ILOOP.LT.MAXLOP)) GOTO 16 | |
4458 | IF (ILOOP.EQ.MAXLOP) | |
4459 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' | |
4460 | ENDIF | |
4461 | IF (IDXMS.EQ.1) THEN | |
4462 | ISPTN = ISTHKK(MO1) | |
4463 | M1PTN = MO1 | |
4464 | M2PTN = MO1+2 | |
4465 | ELSE | |
4466 | ISPTN = ISTHKK(MO2) | |
4467 | M1PTN = MO2-2 | |
4468 | M2PTN = MO2 | |
4469 | ENDIF | |
4470 | PX = PHEP(1,IDX) | |
4471 | PY = PHEP(2,IDX) | |
4472 | PZ = PHEP(3,IDX) | |
4473 | PE = PHEP(4,IDX) | |
4474 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN | |
4475 | ISTX = ABS(ISPTN)/10 | |
4476 | IMO = ABS(ISPTN)-10*ISTX | |
4477 | IF ((IDHEP(IDX).EQ.21).OR. | |
4478 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN | |
4479 | ISPTN = -(60+IMO) | |
4480 | ELSE | |
4481 | ISPTN = -(50+IMO) | |
4482 | ENDIF | |
4483 | ENDIF | |
4484 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 | |
4485 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 | |
4486 | IF (MODE.LT.0) THEN | |
4487 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4488 | & PX,PY,PZ,PE,0,0,0) | |
4489 | ELSE | |
4490 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4491 | & PPX,PPY,PPZ,PPE) | |
4492 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4493 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4494 | ENDIF | |
4495 | IHIST(1,NHKK) = IPHIST(1,IDX) | |
4496 | IHIST(2,NHKK) = 0 | |
4497 | DO 20 KK=1,4 | |
4498 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) | |
4499 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) | |
4500 | 20 CONTINUE | |
4501 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB | |
4502 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB | |
4503 | 17 CONTINUE | |
4504 | ENDIF | |
4505 | * parton at chain end | |
4506 | PX = PHEP(1,IDX2) | |
4507 | PY = PHEP(2,IDX2) | |
4508 | PZ = PHEP(3,IDX2) | |
4509 | PE = PHEP(4,IDX2) | |
4510 | * flag only partons coming from Pomeron with 41/42 | |
4511 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4512 | IF (IPOM2.NE.0) THEN | |
4513 | ISTX = ABS(ISPTN2)/10 | |
4514 | IMO = ABS(ISPTN2)-10*ISTX | |
4515 | ISPTN2 = -(40+IMO) | |
4516 | ELSE | |
4517 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN | |
4518 | ISTX = ABS(ISPTN2)/10 | |
4519 | IMO = ABS(ISPTN2)-10*ISTX | |
4520 | IF ((IDHEP(IDX2).EQ.21).OR. | |
4521 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN | |
4522 | ISPTN2 = -(60+IMO) | |
4523 | ELSE | |
4524 | ISPTN2 = -(50+IMO) | |
4525 | ENDIF | |
4526 | ENDIF | |
4527 | ENDIF | |
4528 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 | |
4529 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 | |
4530 | IF (MODE.LT.0) THEN | |
4531 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4532 | & PX,PY,PZ,PE,0,0,0) | |
4533 | ELSE | |
4534 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4535 | & PPX,PPY,PPZ,PPE) | |
4536 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4537 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4538 | ENDIF | |
4539 | IHIST(1,NHKK) = IPHIST(1,IDX2) | |
4540 | IHIST(2,NHKK) = 0 | |
4541 | DO 21 KK=1,4 | |
4542 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) | |
4543 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) | |
4544 | 21 CONTINUE | |
4545 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB | |
4546 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB | |
4547 | M2STRG = NHKK | |
4548 | * register string | |
4549 | JSTRG = 100*IPROCE+NCODE(I) | |
4550 | PX = PHEP(1,IDXSTG) | |
4551 | PY = PHEP(2,IDXSTG) | |
4552 | PZ = PHEP(3,IDXSTG) | |
4553 | PE = PHEP(4,IDXSTG) | |
4554 | IF (MODE.LT.0) THEN | |
4555 | ISTAT = 70000+IPJE | |
4556 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4557 | & PX,PY,PZ,PE,0,0,0) | |
4558 | IF (LEMCCK) THEN | |
4559 | PX = -PX | |
4560 | PY = -PY | |
4561 | PZ = -PZ | |
4562 | PE = -PE | |
4563 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4564 | ENDIF | |
4565 | ELSE | |
4566 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4567 | & PPX,PPY,PPZ,PPE) | |
4568 | ISTAT = 70000+IPJE | |
4569 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4570 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4571 | IF (LEMCCK) THEN | |
4572 | PX = -PPX | |
4573 | PY = -PPY | |
4574 | PZ = -PPZ | |
4575 | PE = -PPE | |
4576 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4577 | ENDIF | |
4578 | ENDIF | |
4579 | NOBAM(NHKK) = 0 | |
4580 | IHIST(1,NHKK) = 0 | |
4581 | IHIST(2,NHKK) = 0 | |
4582 | DO 18 KK=1,4 | |
4583 | VHKK(KK,NHKK) = VHKK(KK,MO2) | |
4584 | WHKK(KK,NHKK) = WHKK(KK,MO1) | |
4585 | 18 CONTINUE | |
4586 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
4587 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
4588 | ENDIF | |
4589 | 11 CONTINUE | |
4590 | ||
4591 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN | |
4592 | NHKK = INHKK | |
4593 | LFLIP = .FALSE. | |
4594 | GOTO 1 | |
4595 | ENDIF | |
4596 | ||
4597 | IF (LEMCCK) THEN | |
4598 | IF (UMO.GT.1.0D5) THEN | |
4599 | CHKLEV = 1.0D0 | |
4600 | ELSE | |
4601 | CHKLEV = TINY1 | |
4602 | ENDIF | |
4603 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) | |
4604 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) | |
4605 | ENDIF | |
4606 | ||
4607 | * internal statistics | |
4608 | * dble-Po statistics. | |
4609 | IF (IPROCE.NE.4) IPOPO = 0 | |
4610 | ||
4611 | INTFLG = IPROCE | |
4612 | IDCHSY = IDCH(MO1) | |
4613 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN | |
4614 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 | |
4615 | ELSE | |
4616 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 | |
4617 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, | |
4618 | & ') at evt(chain) ',I6,'(',I2,')') | |
4619 | ENDIF | |
4620 | IF (IPROCE.EQ.5) THEN | |
4621 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN | |
4622 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 | |
4623 | ELSE | |
4624 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4625 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', | |
4626 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') | |
4627 | ENDIF | |
4628 | ELSEIF (IPROCE.EQ.6) THEN | |
4629 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4630 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 | |
4631 | ELSE | |
4632 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4633 | ENDIF | |
4634 | ELSEIF (IPROCE.EQ.7) THEN | |
4635 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. | |
4636 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4637 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) | |
4638 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 | |
4639 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) | |
4640 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 | |
4641 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) | |
4642 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 | |
4643 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) | |
4644 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 | |
4645 | ELSE | |
4646 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4647 | ENDIF | |
4648 | ENDIF | |
4649 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) | |
4650 | & THEN | |
4651 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4652 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4653 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4654 | ENDIF | |
4655 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM | |
4656 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM | |
4657 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG | |
4658 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) | |
4659 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) | |
4660 | ||
4661 | RETURN | |
4662 | ||
4663 | 9999 CONTINUE | |
4664 | IREJ = 1 | |
4665 | RETURN | |
4666 | END | |
4667 | ||
4668 | *$ CREATE DT_PHOINI.FOR | |
4669 | *COPY DT_PHOINI | |
4670 | * | |
4671 | *===phoini=============================================================* | |
4672 | * | |
4673 | SUBROUTINE DT_PHOINI | |
4674 | ||
4675 | ************************************************************************ | |
4676 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * | |
4677 | * This version dated 16.11.95 is written by S. Roesler * | |
4678 | * * | |
4679 | * Last change 27.12.2006 by S. Roesler. * | |
4680 | ************************************************************************ | |
4681 | ||
4682 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4683 | SAVE | |
4684 | PARAMETER ( LINP = 10 , | |
4685 | & LOUT = 6 , | |
4686 | & LDAT = 9 ) | |
4687 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
4688 | ||
4689 | * nucleon-nucleon event-generator | |
4690 | CHARACTER*8 CMODEL | |
4691 | LOGICAL LPHOIN | |
4692 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
4693 | * particle properties (BAMJET index convention) | |
4694 | CHARACTER*8 ANAME | |
4695 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
4696 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
4697 | * Lorentz-parameters of the current interaction | |
4698 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4699 | & UMO,PPCM,EPROJ,PPROJ | |
4700 | * properties of interacting particles | |
4701 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4702 | * properties of photon/lepton projectiles | |
4703 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
4704 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
4705 | * emulsion treatment | |
4706 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
4707 | & NCOMPO,IEMUL | |
4708 | * VDM parameter for photon-nucleus interactions | |
4709 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
4710 | * nuclear potential | |
4711 | LOGICAL LFERMI | |
4712 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4713 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4714 | & ETACOU(2),ICOUL,LFERMI | |
4715 | * Glauber formalism: flags and parameters for statistics | |
4716 | LOGICAL LPROD | |
4717 | CHARACTER*8 CGLB | |
4718 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
4719 | * | |
4720 | * parameters for cascade calculations: | |
4721 | * maximum mumber of PDF's which can be defined in phojet (limited | |
4722 | * by the dimension of ipdfs in pho_setpdf) | |
4723 | PARAMETER (MAXPDF = 20) | |
4724 | * PDF parametrization and number of set for the first 30 hadrons in | |
4725 | * the bamjet-code list | |
4726 | * negative numbers mean that the PDF is set in phojet, | |
4727 | * zero stands for "not a hadron" | |
4728 | DIMENSION IPARPD(30),ISETPD(30) | |
4729 | * PDF parametrization | |
4730 | DATA IPARPD / | |
4731 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, | |
4732 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ | |
4733 | * number of set | |
4734 | DATA ISETPD / | |
4735 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, | |
4736 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ | |
4737 | ||
4738 | **PHOJET105a | |
4739 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4740 | C PARAMETER ( MAXPRO = 16 ) | |
4741 | C PARAMETER ( MAXTAB = 20 ) | |
4742 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), | |
4743 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB | |
4744 | C CHARACTER*8 MDLNA | |
4745 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
4746 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) | |
4747 | **PHOJET110 | |
4748 | C global event kinematics and particle IDs | |
4749 | INTEGER IFPAP,IFPAB | |
4750 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
4751 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4752 | C hard cross sections and MC selection weights | |
4753 | INTEGER Max_pro_2 | |
4754 | PARAMETER ( Max_pro_2 = 16 ) | |
4755 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, | |
4756 | & MH_acc_1,MH_acc_2 | |
4757 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last | |
4758 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), | |
4759 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), | |
4760 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, | |
4761 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), | |
4762 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) | |
4763 | C model switches and parameters | |
4764 | CHARACTER*8 MDLNA | |
4765 | INTEGER ISWMDL,IPAMDL | |
4766 | DOUBLE PRECISION PARMDL | |
4767 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4768 | C general process information | |
4769 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4770 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4771 | ** | |
4772 | DIMENSION PP(4),PT(4) | |
4773 | ||
4774 | LOGICAL LSTART | |
4775 | DATA LSTART /.TRUE./ | |
4776 | ||
4777 | IJP = IJPROJ | |
4778 | IJT = IJTARG | |
4779 | Q2 = VIRT | |
4780 | * lepton-projectiles: initialize real photon instead | |
4781 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
4782 | IJP = 7 | |
4783 | Q2 = ZERO | |
4784 | ENDIF | |
4785 | IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM) | |
4786 | * switch Reggeon off | |
4787 | C IPAMDL(3)= 0 | |
4788 | IF (IP.EQ.1) THEN | |
4789 | IFPAP(1) = IDT_IPDGHA(IJP) | |
4790 | IFPAB(1) = IJP | |
4791 | ELSE | |
4792 | IFPAP(1) = 2212 | |
4793 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) | |
4794 | ENDIF | |
4795 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) | |
4796 | PVIRT(1) = PMASS(1)**2 | |
4797 | IF (IT.EQ.1) THEN | |
4798 | IFPAP(2) = IDT_IPDGHA(IJT) | |
4799 | IFPAB(2) = IJT | |
4800 | ELSE | |
4801 | IFPAP(2) = 2212 | |
4802 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) | |
4803 | ENDIF | |
4804 | PMASS(2) = AAM(IFPAB(2)) | |
4805 | PVIRT(2) = ZERO | |
4806 | DO 1 K=1,4 | |
4807 | PP(K) = ZERO | |
4808 | PT(K) = ZERO | |
4809 | 1 CONTINUE | |
4810 | * get max. possible momenta of incoming particles to be used for PHOJET ini. | |
4811 | PPF = ZERO | |
4812 | PTF = ZERO | |
4813 | SCPF= 1.5D0 | |
4814 | IF (UMO.GE.1.E5) THEN | |
4815 | SCPF= 5.0D0 | |
4816 | ENDIF | |
4817 | IF (NCOMPO.GT.0) THEN | |
4818 | DO 2 I=1,NCOMPO | |
4819 | IF (IT.GT.1) THEN | |
4820 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) | |
4821 | ELSE | |
4822 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) | |
4823 | ENDIF | |
4824 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) | |
4825 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) | |
4826 | IF (PPFTMP.GT.PPF) PPF = PPFTMP | |
4827 | IF (PTFTMP.GT.PTF) PTF = PTFTMP | |
4828 | 2 CONTINUE | |
4829 | ELSE | |
4830 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
4831 | PPF = MAX(PFERMP(1),PFERMN(1)) | |
4832 | PTF = MAX(PFERMP(2),PFERMN(2)) | |
4833 | ENDIF | |
4834 | PTF = -PTF | |
4835 | PPF = SCPF*PPF | |
4836 | PTF = SCPF*PTF | |
4837 | IF (IJP.EQ.7) THEN | |
4838 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4839 | PP(3) = PPCM | |
4840 | PP(4) = SQRT(AMP2+PP(3)**2) | |
4841 | ELSE | |
4842 | EPF = SQRT(PPF**2+PMASS(1)**2) | |
4843 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) | |
4844 | ENDIF | |
4845 | ETF = SQRT(PTF**2+PMASS(2)**2) | |
4846 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) | |
4847 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
4848 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
4849 | IF (LSTART) THEN | |
4850 | WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP | |
4851 | 1001 FORMAT( | |
4852 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', | |
4853 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4854 | IF (NCOMPO.GT.0) THEN | |
4855 | WRITE(LOUT,1002) SCPF,PTF,PT | |
4856 | ELSE | |
4857 | WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT | |
4858 | ENDIF | |
4859 | 1002 FORMAT( | |
4860 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', | |
4861 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4862 | 1003 FORMAT( | |
4863 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', | |
4864 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4865 | WRITE(LOUT,1004) ECMINI | |
4866 | 1004 FORMAT(' E_cm = ',E10.3) | |
4867 | IF (IJP.EQ.8) WRITE(LOUT,1005) | |
4868 | 1005 FORMAT( | |
4869 | & ' DT_PHOINI: warning! proton parameters used for neutron', | |
4870 | & ' projectile') | |
4871 | LSTART = .FALSE. | |
4872 | ENDIF | |
4873 | * switch off new diffractive cross sections at low energies for nuclei | |
4874 | * (temporary solution) | |
4875 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN | |
4876 | WRITE(LOUT,'(1X,A)') | |
4877 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' | |
4878 | CALL PHO_SETMDL(30,0,1) | |
4879 | ENDIF | |
4880 | * | |
4881 | C IF (IJP.EQ.7) THEN | |
4882 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4883 | C PP(3) = PPCM | |
4884 | C PP(4) = SQRT(AMP2+PP(3)**2) | |
4885 | C ELSE | |
4886 | C PFERMX = ZERO | |
4887 | C IF (IP.GT.1) PFERMX = 0.5D0 | |
4888 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) | |
4889 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) | |
4890 | C ENDIF | |
4891 | C PFERMX = ZERO | |
4892 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 | |
4893 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) | |
4894 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) | |
4895 | **sr 26.10.96 | |
4896 | ISAV = IPAMDL(13) | |
4897 | IF ((ISHAD(2).EQ.1).AND. | |
4898 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. | |
4899 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 | |
4900 | ** | |
4901 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) | |
4902 | **sr 26.10.96 | |
4903 | IPAMDL(13) = ISAV | |
4904 | ** | |
4905 | * | |
4906 | * patch for cascade calculations: | |
4907 | * define parton distribution functions for other hadrons, i.e. other | |
4908 | * then defined already in phojet | |
4909 | IF (IOGLB.EQ.100) THEN | |
4910 | WRITE(LOUT,1006) | |
4911 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', | |
4912 | & ' assiged (ID,IPAR,ISET)',/) | |
4913 | NPDF = 0 | |
4914 | DO 3 I=1,30 | |
4915 | IF (IPARPD(I).NE.0) THEN | |
4916 | NPDF = NPDF+1 | |
4917 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' | |
4918 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN | |
4919 | IDPDG = IDT_IPDGHA(I) | |
4920 | IPAR = IPARPD(I) | |
4921 | ISET = ISETPD(I) | |
4922 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET | |
4923 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) | |
4924 | ENDIF | |
4925 | ENDIF | |
4926 | 3 CONTINUE | |
4927 | ENDIF | |
4928 | ||
4929 | C CALL PHO_PHIST(-1,SIGMAX) | |
4930 | IF (IREJ1.NE.0) THEN | |
4931 | WRITE(LOUT,1000) | |
4932 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') | |
4933 | STOP | |
4934 | ENDIF | |
4935 | ||
4936 | RETURN | |
4937 | END | |
4938 | ||
4939 | *$ CREATE DT_EVENTD.FOR | |
4940 | *COPY DT_EVENTD | |
4941 | * | |
4942 | *===eventd=============================================================* | |
4943 | * | |
4944 | SUBROUTINE DT_EVENTD(IREJ) | |
4945 | ||
4946 | ************************************************************************ | |
4947 | * Quasi-elastic neutrino nucleus scattering. * | |
4948 | * This version dated 29.04.00 is written by S. Roesler. * | |
4949 | ************************************************************************ | |
4950 | ||
4951 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4952 | SAVE | |
4953 | PARAMETER ( LINP = 10 , | |
4954 | & LOUT = 6 , | |
4955 | & LDAT = 9 ) | |
4956 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) | |
4957 | PARAMETER (SQTINF=1.0D+15) | |
4958 | ||
4959 | LOGICAL LFIRST | |
4960 | ||
4961 | * event history | |
4962 | PARAMETER (NMXHKK=200000) | |
4963 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4964 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4965 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4966 | * extended event history | |
4967 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4968 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4969 | & IHIST(2,NMXHKK) | |
4970 | * flags for input different options | |
4971 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4972 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4973 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4974 | PARAMETER (MAXLND=4000) | |
4975 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
4976 | * properties of interacting particles | |
4977 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4978 | * Lorentz-parameters of the current interaction | |
4979 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4980 | & UMO,PPCM,EPROJ,PPROJ | |
4981 | * nuclear potential | |
4982 | LOGICAL LFERMI | |
4983 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4984 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4985 | & ETACOU(2),ICOUL,LFERMI | |
4986 | * steering flags for qel neutrino scattering modules | |
4987 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
4988 | COMMON /QNPOL/ POLARX(4),PMODUL | |
4989 | INTEGER PYK | |
4990 | ||
4991 | DATA LFIRST /.TRUE./ | |
4992 | ||
4993 | IREJ = 0 | |
4994 | ||
4995 | IF (LFIRST) THEN | |
4996 | LFIRST = .FALSE. | |
4997 | CALL DT_MASS_INI | |
4998 | ENDIF | |
4999 | ||
5000 | * JETSET parameter | |
5001 | CALL DT_INITJS(0) | |
5002 | ||
5003 | * interacting target nucleon | |
5004 | LTYP = NEUTYP | |
5005 | IF (NEUDEC.LE.9) THEN | |
5006 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN | |
5007 | NUCTYP = 2112 | |
5008 | NUCTOP = 2 | |
5009 | ELSE | |
5010 | NUCTYP = 2212 | |
5011 | NUCTOP = 1 | |
5012 | ENDIF | |
5013 | ELSE | |
5014 | RTYP = DT_RNDM(RTYP) | |
5015 | ZFRAC = DBLE(ITZ)/DBLE(IT) | |
5016 | IF (RTYP.LE.ZFRAC) THEN | |
5017 | NUCTYP = 2212 | |
5018 | NUCTOP = 1 | |
5019 | ELSE | |
5020 | NUCTYP = 2112 | |
5021 | NUCTOP = 2 | |
5022 | ENDIF | |
5023 | ENDIF | |
5024 | ||
5025 | * select first nucleon in list with matching id and reset all other | |
5026 | * nucleons which have been marked as "wounded" by ININUC | |
5027 | IFOUND = 0 | |
5028 | DO 1 I=1,NHKK | |
5029 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN | |
5030 | ISTHKK(I) = 12 | |
5031 | IFOUND = 1 | |
5032 | IDX = I | |
5033 | ELSE | |
5034 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 | |
5035 | ENDIF | |
5036 | 1 CONTINUE | |
5037 | IF (IFOUND.EQ.0) | |
5038 | & STOP ' EVENTD: interacting target nucleon not found! ' | |
5039 | ||
5040 | * correct position of proj. lepton: assume position of target nucleon | |
5041 | DO 3 I=1,4 | |
5042 | VHKK(I,1) = VHKK(I,IDX) | |
5043 | WHKK(I,1) = WHKK(I,IDX) | |
5044 | 3 CONTINUE | |
5045 | ||
5046 | * load initial momenta for conservation check | |
5047 | IF (LEMCCK) THEN | |
5048 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) | |
5049 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), | |
5050 | & 2,IDUM,IDUM) | |
5051 | ENDIF | |
5052 | ||
5053 | * quasi-elastic scattering | |
5054 | IF (NEUDEC.LT.9) THEN | |
5055 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), | |
5056 | & PHKK(4,IDX),PHKK(5,IDX)) | |
5057 | * CC event on p or n | |
5058 | ELSEIF (NEUDEC.EQ.10) THEN | |
5059 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), | |
5060 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5061 | * NC event on p or n | |
5062 | ELSEIF (NEUDEC.EQ.11) THEN | |
5063 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), | |
5064 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5065 | ENDIF | |
5066 | ||
5067 | * get final state particles from Lund-common and write them into HKKEVT | |
5068 | NPOINT(1) = NHKK+1 | |
5069 | NPOINT(4) = NHKK+1 | |
5070 | NLINES = PYK(0,1) | |
5071 | NHKK0 = NHKK+1 | |
5072 | DO 4 I=4,NLINES | |
5073 | IF (K(I,1).EQ.1) THEN | |
5074 | ID = K(I,2) | |
5075 | PX = P(I,1) | |
5076 | PY = P(I,2) | |
5077 | PZ = P(I,3) | |
5078 | PE = P(I,4) | |
5079 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) | |
5080 | IDBJ = IDT_ICIHAD(ID) | |
5081 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) | |
5082 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN | |
5083 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 | |
5084 | ENDIF | |
5085 | VHKK(1,NHKK) = VHKK(1,IDX) | |
5086 | VHKK(2,NHKK) = VHKK(2,IDX) | |
5087 | VHKK(3,NHKK) = VHKK(3,IDX) | |
5088 | VHKK(4,NHKK) = VHKK(4,IDX) | |
5089 | C IF (I.EQ.4) THEN | |
5090 | C WHKK(1,NHKK) = POLARX(1) | |
5091 | C WHKK(2,NHKK) = POLARX(2) | |
5092 | C WHKK(3,NHKK) = POLARX(3) | |
5093 | C WHKK(4,NHKK) = POLARX(4) | |
5094 | C ELSE | |
5095 | WHKK(1,NHKK) = WHKK(1,IDX) | |
5096 | WHKK(2,NHKK) = WHKK(2,IDX) | |
5097 | WHKK(3,NHKK) = WHKK(3,IDX) | |
5098 | WHKK(4,NHKK) = WHKK(4,IDX) | |
5099 | C ENDIF | |
5100 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
5101 | ENDIF | |
5102 | 4 CONTINUE | |
5103 | ||
5104 | IF (LEMCCK) THEN | |
5105 | CHKLEV = TINY5 | |
5106 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) | |
5107 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
5108 | ENDIF | |
5109 | ||
5110 | * transform momenta into cms (as required for inc etc.) | |
5111 | DO 5 I=NHKK0,NHKK | |
5112 | IF (ISTHKK(I).EQ.1) THEN | |
5113 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) | |
5114 | PHKK(3,I) = PZ | |
5115 | PHKK(4,I) = PE | |
5116 | ENDIF | |
5117 | 5 CONTINUE | |
5118 | ||
5119 | RETURN | |
5120 | END | |
5121 | ||
5122 | *$ CREATE DT_KKEVNT.FOR | |
5123 | *COPY DT_KKEVNT | |
5124 | * | |
5125 | *===kkevnt=============================================================* | |
5126 | * | |
5127 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) | |
5128 | ||
5129 | ************************************************************************ | |
5130 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
5131 | * without nuclear effects (one event). * | |
5132 | * This subroutine is an update of the previous version (KKEVT) written * | |
5133 | * by J. Ranft/ H.-J. Moehring. * | |
5134 | * This version dated 20.04.95 is written by S. Roesler * | |
5135 | ************************************************************************ | |
5136 | ||
5137 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5138 | SAVE | |
5139 | PARAMETER ( LINP = 10 , | |
5140 | & LOUT = 6 , | |
5141 | & LDAT = 9 ) | |
5142 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) | |
5143 | ||
5144 | PARAMETER ( MAXNCL = 260, | |
5145 | & MAXVQU = MAXNCL, | |
5146 | & MAXSQU = 20*MAXVQU, | |
5147 | & MAXINT = MAXVQU+MAXSQU) | |
5148 | * event history | |
5149 | PARAMETER (NMXHKK=200000) | |
5150 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5151 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5152 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5153 | * extended event history | |
5154 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5155 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5156 | & IHIST(2,NMXHKK) | |
5157 | * flags for input different options | |
5158 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5159 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5160 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5161 | * rejection counter | |
5162 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
5163 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
5164 | & IREXCI(3),IRDIFF(2),IRINC | |
5165 | * statistics | |
5166 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5167 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5168 | & ICEVTG(8,0:30) | |
5169 | * properties of interacting particles | |
5170 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5171 | * Lorentz-parameters of the current interaction | |
5172 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5173 | & UMO,PPCM,EPROJ,PPROJ | |
5174 | * flags for diffractive interactions (DTUNUC 1.x) | |
5175 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5176 | * interface HADRIN-DPM | |
5177 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5178 | * nucleon-nucleon event-generator | |
5179 | CHARACTER*8 CMODEL | |
5180 | LOGICAL LPHOIN | |
5181 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
5182 | * coordinates of nucleons | |
5183 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
5184 | * interface between Glauber formalism and DPM | |
5185 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
5186 | & INTER1(MAXINT),INTER2(MAXINT) | |
5187 | * Glauber formalism: collision properties | |
5188 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
7cbda79e | 5189 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
5190 | & NCP,NCT | |
9aaba0d6 | 5191 | * central particle production, impact parameter biasing |
5192 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5193 | **temporary | |
5194 | * statistics: Glauber-formalism | |
5195 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5196 | ** | |
5197 | ||
5198 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ | |
5199 | ||
5200 | IREJ = 0 | |
5201 | ICREQU = ICREQU+1 | |
5202 | NC = 0 | |
e3f546f5 | 5203 | |
9aaba0d6 | 5204 | 1 CONTINUE |
5205 | ICSAMP = ICSAMP+1 | |
5206 | NC = NC+1 | |
5207 | IF (MOD(NC,10).EQ.0) THEN | |
5208 | WRITE(LOUT,1000) NEVHKK | |
5209 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') | |
5210 | GOTO 9999 | |
5211 | ENDIF | |
5212 | ||
5213 | * initialize DTEVT1/DTEVT2 | |
5214 | CALL DT_EVTINI | |
5215 | ||
5216 | * We need the following only in order to sample nucleon coordinates. | |
5217 | * However we don't have parameters (cross sections, slope etc.) | |
5218 | * for neutrinos available. Therefore switch projectile to proton | |
5219 | * in this case. | |
5220 | IF (MCGENE.EQ.4) THEN | |
5221 | JJPROJ = 1 | |
5222 | ELSE | |
5223 | JJPROJ = IJPROJ | |
5224 | ENDIF | |
5225 | ||
5226 | 10 CONTINUE | |
5227 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. | |
5228 | * make sure that Glauber-formalism is called each time the interaction | |
5229 | * configuration changed | |
5230 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. | |
5231 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN | |
5232 | * sample number of nucleon-nucleon coll. according to Glauber-form. | |
5233 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) | |
5234 | NWTSAM = NN | |
5235 | NWASAM = NP | |
5236 | NWBSAM = NT | |
5237 | NEVOLD = NEVHKK | |
5238 | IPOLD = IP | |
5239 | ITOLD = IT | |
5240 | JJPOLD = JJPROJ | |
5241 | EPROLD = EPROJ | |
e3f546f5 | 5242 | NCP = 0 |
5243 | NCT = 0 | |
5244 | ||
7cbda79e | 5245 | DO 8 I=1, IP |
5246 | NCP = NCP+JSSH(I) | |
5247 | * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP | |
5248 | 8 CONTINUE | |
e3f546f5 | 5249 | write(6,*) "why this (1)", NCP, NCT |
7cbda79e | 5250 | DO 9 I=1, IT |
e3f546f5 | 5251 | NCT = NCT +JTSH(I) |
5252 | * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT | |
7cbda79e | 5253 | 9 CONTINUE |
e3f546f5 | 5254 | ENDIF |
9aaba0d6 | 5255 | |
5256 | * force diffractive particle production in h-K interactions | |
5257 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. | |
5258 | & (IP.EQ.1).AND.(NN.NE.1)) THEN | |
5259 | NEVOLD = 0 | |
5260 | GOTO 10 | |
5261 | ENDIF | |
5262 | ||
5263 | * check number of involved proj. nucl. (NP) if central prod.is requested | |
5264 | IF (ICENTR.GT.0) THEN | |
5265 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5266 | IF (IBACK.GT.0) GOTO 10 | |
5267 | ENDIF | |
5268 | ||
5269 | * get initial nucleon-configuration in projectile and target | |
5270 | * rest-system (including Fermi-momenta if requested) | |
5271 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) | |
5272 | MODE = 2 | |
5273 | IF (EPROJ.LE.EHADTH) MODE = 3 | |
5274 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) | |
5275 | ||
5276 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN | |
5277 | ||
5278 | * activate HADRIN at low energies (implemented for h-N scattering only) | |
5279 | IF (EPROJ.LE.EHADHI) THEN | |
5280 | IF (EHADTH.LT.ZERO) THEN | |
5281 | * smooth transition btwn. DPM and HADRIN | |
5282 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) | |
5283 | RR = DT_RNDM(FRAC) | |
5284 | IF (RR.GT.FRAC) THEN | |
5285 | IF (IP.EQ.1) THEN | |
5286 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5287 | IF (IREJ1.GT.0) GOTO 1 | |
5288 | RETURN | |
5289 | ELSE | |
5290 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5291 | ENDIF | |
5292 | ENDIF | |
5293 | ELSE | |
5294 | * fixed threshold for onset of production via HADRIN | |
5295 | IF (EPROJ.LE.EHADTH) THEN | |
5296 | IF (IP.EQ.1) THEN | |
5297 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5298 | IF (IREJ1.GT.0) GOTO 1 | |
5299 | RETURN | |
5300 | ELSE | |
5301 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5302 | ENDIF | |
5303 | ENDIF | |
5304 | ENDIF | |
5305 | ENDIF | |
5306 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', | |
5307 | & I3,') with target (m=',I3,')',/,11X, | |
5308 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, | |
5309 | & 'GeV) cannot be handled') | |
5310 | ||
5311 | * sampling of momentum-x fractions & flavors of chain ends | |
5312 | CALL DT_SPLPTN(NN) | |
5313 | ||
5314 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms | |
5315 | CALL DT_NUC2CM | |
5316 | ||
5317 | * collect momenta of chain ends and put them into DTEVT1 | |
5318 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) | |
5319 | IF (IREJ1.NE.0) GOTO 1 | |
5320 | ||
5321 | ENDIF | |
5322 | ||
5323 | * handle chains including fragmentation (two-chain approximation) | |
5324 | IF (MCGENE.EQ.1) THEN | |
5325 | * two-chain approximation | |
5326 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) | |
5327 | IF (IREJ1.NE.0) THEN | |
5328 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' | |
5329 | GOTO 1 | |
5330 | ENDIF | |
5331 | ELSEIF (MCGENE.EQ.2) THEN | |
5332 | * multiple-Po exchange including minijets | |
5333 | CALL DT_EVENTB(NCSY,IREJ1) | |
5334 | IF (IREJ1.NE.0) THEN | |
5335 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' | |
5336 | GOTO 1 | |
5337 | ENDIF | |
5338 | ELSEIF (MCGENE.EQ.3) THEN | |
5339 | STOP ' This version does not contain LEPTO !' | |
5340 | ELSEIF (MCGENE.EQ.4) THEN | |
5341 | * quasi-elastic neutrino scattering | |
5342 | CALL DT_EVENTD(IREJ1) | |
5343 | IF (IREJ1.NE.0) THEN | |
5344 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' | |
5345 | GOTO 1 | |
5346 | ENDIF | |
5347 | ELSE | |
5348 | WRITE(LOUT,1002) MCGENE | |
5349 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, | |
5350 | & ' not available - program stopped') | |
5351 | STOP | |
5352 | ENDIF | |
5353 | ||
5354 | RETURN | |
5355 | ||
5356 | 9999 CONTINUE | |
5357 | IREJ = 1 | |
5358 | RETURN | |
5359 | END | |
5360 | ||
5361 | *$ CREATE DT_CHKCEN.FOR | |
5362 | *COPY DT_CHKCEN | |
5363 | * | |
5364 | *===chkcen=============================================================* | |
5365 | * | |
5366 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5367 | ||
5368 | ************************************************************************ | |
5369 | * Check of number of involved projectile nucleons if central production* | |
5370 | * is requested. * | |
5371 | * Adopted from a part of the old KKEVT routine which was written by * | |
5372 | * J. Ranft/H.-J.Moehring. * | |
5373 | * This version dated 13.01.95 is written by S. Roesler * | |
5374 | ************************************************************************ | |
5375 | ||
5376 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5377 | SAVE | |
5378 | PARAMETER ( LINP = 10 , | |
5379 | & LOUT = 6 , | |
5380 | & LDAT = 9 ) | |
5381 | ||
5382 | * statistics | |
5383 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5384 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5385 | & ICEVTG(8,0:30) | |
5386 | * central particle production, impact parameter biasing | |
5387 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5388 | ||
5389 | IBACK = 0 | |
5390 | ||
5391 | * old version | |
5392 | IF (ICENTR.EQ.2) THEN | |
5393 | IF (IP.LT.IT) THEN | |
5394 | IF (IP.LE.8) THEN | |
5395 | IF (NP.LT.IP-1) IBACK = 1 | |
5396 | ELSEIF (IP.LE.16) THEN | |
5397 | IF (NP.LT.IP-2) IBACK = 1 | |
5398 | ELSEIF (IP.LE.32) THEN | |
5399 | IF (NP.LT.IP-3) IBACK = 1 | |
5400 | ELSEIF (IP.GE.33) THEN | |
5401 | IF (NP.LT.IP-5) IBACK = 1 | |
5402 | ENDIF | |
5403 | ELSEIF (IP.EQ.IT) THEN | |
5404 | IF (IP.EQ.32) THEN | |
5405 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5406 | ELSE | |
5407 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5408 | ENDIF | |
5409 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5410 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5411 | ENDIF | |
5412 | ELSE | |
5413 | * new version (DPMJET, 5.6.99) | |
5414 | IF (IP.LT.IT) THEN | |
5415 | IF (IP.LE.8) THEN | |
5416 | IF (NP.LT.IP-1) IBACK = 1 | |
5417 | ELSEIF (IP.LE.16) THEN | |
5418 | IF (NP.LT.IP-2) IBACK = 1 | |
5419 | ELSEIF (IP.LT.32) THEN | |
5420 | IF (NP.LT.IP-3) IBACK = 1 | |
5421 | ELSEIF (IP.GE.32) THEN | |
5422 | IF (IT.LE.150) THEN | |
5423 | * Example: S-Ag | |
5424 | IF (NP.LT.IP-1) IBACK = 1 | |
5425 | ELSE | |
5426 | * Example: S-Au | |
5427 | IF (NP.LT.IP) IBACK = 1 | |
5428 | ENDIF | |
5429 | ENDIF | |
5430 | ELSEIF (IP.EQ.IT) THEN | |
5431 | * Example: S-S | |
5432 | IF (IP.EQ.32) THEN | |
5433 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5434 | * Example: Pb-Pb | |
5435 | ELSE | |
5436 | IF (NP.LT.IP-IP/4) IBACK = 1 | |
5437 | ENDIF | |
5438 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5439 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5440 | ENDIF | |
5441 | ENDIF | |
5442 | ||
5443 | ICCPRO = ICCPRO+1 | |
5444 | ||
5445 | RETURN | |
5446 | END | |
5447 | ||
5448 | *$ CREATE DT_ININUC.FOR | |
5449 | *COPY DT_ININUC | |
5450 | * | |
5451 | *===ininuc=============================================================* | |
5452 | * | |
5453 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) | |
5454 | ||
5455 | ************************************************************************ | |
5456 | * Samples initial configuration of nucleons in nucleus with mass NMASS * | |
5457 | * including Fermi-momenta (if reqested). * | |
5458 | * ID BAMJET-code for hadrons (instead of nuclei) * | |
5459 | * NMASS mass number of nucleus (number of nucleons) * | |
5460 | * NCH charge of nucleus * | |
5461 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * | |
5462 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * | |
5463 | * IMODE = 1 projectile nucleus * | |
5464 | * = 2 target nucleus * | |
5465 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * | |
5466 | * Adopted from a part of the old KKEVT routine which was written by * | |
5467 | * J. Ranft/H.-J.Moehring. * | |
5468 | * This version dated 13.01.95 is written by S. Roesler * | |
5469 | ************************************************************************ | |
5470 | ||
5471 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5472 | SAVE | |
5473 | PARAMETER ( LINP = 10 , | |
5474 | & LOUT = 6 , | |
5475 | & LDAT = 9 ) | |
5476 | PARAMETER (FM2MM=1.0D-12) | |
5477 | ||
5478 | PARAMETER ( MAXNCL = 260, | |
5479 | & MAXVQU = MAXNCL, | |
5480 | & MAXSQU = 20*MAXVQU, | |
5481 | & MAXINT = MAXVQU+MAXSQU) | |
5482 | * event history | |
5483 | PARAMETER (NMXHKK=200000) | |
5484 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5485 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5486 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5487 | * extended event history | |
5488 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5489 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5490 | & IHIST(2,NMXHKK) | |
5491 | * flags for input different options | |
5492 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5493 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5494 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5495 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5496 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5497 | * nuclear potential | |
5498 | LOGICAL LFERMI | |
5499 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5500 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5501 | & ETACOU(2),ICOUL,LFERMI | |
5502 | * properties of photon/lepton projectiles | |
5503 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5504 | * particle properties (BAMJET index convention) | |
5505 | CHARACTER*8 ANAME | |
5506 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5507 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5508 | * Glauber formalism: collision properties | |
5509 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 5510 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
5511 | & NCP,NCT | |
9aaba0d6 | 5512 | * flavors of partons (DTUNUC 1.x) |
5513 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5514 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5515 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5516 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5517 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5518 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5519 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5520 | * interface HADRIN-DPM | |
5521 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5522 | ||
5523 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) | |
5524 | ||
5525 | * number of neutrons | |
5526 | NNEU = NMASS-NCH | |
5527 | * initializations | |
5528 | NP = 0 | |
5529 | NN = 0 | |
5530 | DO 1 K=1,4 | |
5531 | PFTOT(K) = 0.0D0 | |
5532 | 1 CONTINUE | |
5533 | MODE = IMODE | |
5534 | IF (IMODE.GT.2) MODE = 2 | |
5535 | **sr 29.5. new NPOINT(1)-definition | |
5536 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 | |
5537 | ** | |
5538 | NHADRI = 0 | |
5539 | NC = NHKK | |
5540 | ||
5541 | * get initial configuration | |
5542 | DO 2 I=1,NMASS | |
5543 | NHKK = NHKK+1 | |
5544 | IF (JS(I).GT.0) THEN | |
5545 | ISTHKK(NHKK) = 10+MODE | |
5546 | IF (IMODE.EQ.3) THEN | |
5547 | * additional treatment if HADRIN-generator is requested | |
5548 | NHADRI = NHADRI+1 | |
5549 | IF (NHADRI.EQ.1) IDXTA = NHKK | |
5550 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 | |
5551 | ENDIF | |
5552 | ELSE | |
5553 | ISTHKK(NHKK) = 12+MODE | |
5554 | ENDIF | |
5555 | IF (NMASS.GE.2) THEN | |
5556 | * treatment for nuclei | |
5557 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) | |
5558 | RR = DT_RNDM(FRAC) | |
5559 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN | |
5560 | IDX = 8 | |
5561 | NN = NN+1 | |
5562 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN | |
5563 | IDX = 1 | |
5564 | NP = NP+1 | |
5565 | ELSEIF (NN.LT.NNEU) THEN | |
5566 | IDX = 8 | |
5567 | NN = NN+1 | |
5568 | ELSEIF (NP.LT.NCH) THEN | |
5569 | IDX = 1 | |
5570 | NP = NP+1 | |
5571 | ENDIF | |
5572 | IDHKK(NHKK) = IDT_IPDGHA(IDX) | |
5573 | IDBAM(NHKK) = IDX | |
5574 | IF (MODE.EQ.1) THEN | |
5575 | IPOSP(I) = NHKK | |
5576 | KKPROJ(I) = IDX | |
5577 | ELSE | |
5578 | IPOST(I) = NHKK | |
5579 | KKTARG(I) = IDX | |
5580 | ENDIF | |
5581 | IF (IDX.EQ.1) THEN | |
5582 | PFER = PFERMP(MODE) | |
5583 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) | |
5584 | ELSE | |
5585 | PFER = PFERMN(MODE) | |
5586 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) | |
5587 | ENDIF | |
5588 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) | |
5589 | DO 3 K=1,4 | |
5590 | PFTOT(K) = PFTOT(K)+PF(K) | |
5591 | PHKK(K,NHKK) = PF(K) | |
5592 | 3 CONTINUE | |
5593 | PHKK(5,NHKK) = AAM(IDX) | |
5594 | ELSE | |
5595 | * treatment for hadrons | |
5596 | IDHKK(NHKK) = IDT_IPDGHA(ID) | |
5597 | IDBAM(NHKK) = ID | |
5598 | PHKK(4,NHKK) = AAM(ID) | |
5599 | PHKK(5,NHKK) = AAM(ID) | |
5600 | C* VDM assumption | |
5601 | C IF (IDHKK(NHKK).EQ.22) THEN | |
5602 | C PHKK(4,NHKK) = AAM(33) | |
5603 | C PHKK(5,NHKK) = AAM(33) | |
5604 | C ENDIF | |
5605 | IF (MODE.EQ.1) THEN | |
5606 | IPOSP(I) = NHKK | |
5607 | KKPROJ(I) = ID | |
5608 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) | |
5609 | ELSE | |
5610 | IPOST(I) = NHKK | |
5611 | KKTARG(I) = ID | |
5612 | ENDIF | |
5613 | ENDIF | |
5614 | DO 4 K=1,3 | |
5615 | VHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5616 | WHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5617 | 4 CONTINUE | |
5618 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM | |
5619 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM | |
5620 | VHKK(4,NHKK) = 0.0D0 | |
5621 | WHKK(4,NHKK) = 0.0D0 | |
5622 | 2 CONTINUE | |
5623 | ||
5624 | * balance Fermi-momenta | |
5625 | IF (NMASS.GE.2) THEN | |
5626 | DO 5 I=1,NMASS | |
5627 | NC = NC+1 | |
5628 | DO 6 K=1,3 | |
5629 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) | |
5630 | 6 CONTINUE | |
5631 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ | |
5632 | & PHKK(2,NC)**2+PHKK(3,NC)**2) | |
5633 | 5 CONTINUE | |
5634 | ENDIF | |
5635 | ||
5636 | RETURN | |
5637 | END | |
5638 | ||
5639 | *$ CREATE DT_FER4M.FOR | |
5640 | *COPY DT_FER4M | |
5641 | * | |
5642 | *===fer4m==============================================================* | |
5643 | * | |
5644 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) | |
5645 | ||
5646 | ************************************************************************ | |
5647 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * | |
5648 | * processed by S. Roesler, 17.10.95 * | |
5649 | ************************************************************************ | |
5650 | ||
5651 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5652 | SAVE | |
5653 | PARAMETER ( LINP = 10 , | |
5654 | & LOUT = 6 , | |
5655 | & LDAT = 9 ) | |
5656 | ||
5657 | LOGICAL LSTART | |
5658 | ||
5659 | * particle properties (BAMJET index convention) | |
5660 | CHARACTER*8 ANAME | |
5661 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5662 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5663 | * nuclear potential | |
5664 | LOGICAL LFERMI | |
5665 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5666 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5667 | & ETACOU(2),ICOUL,LFERMI | |
5668 | ||
5669 | DATA LSTART /.TRUE./ | |
5670 | ||
5671 | ILOOP = 0 | |
5672 | IF (LFERMI) THEN | |
5673 | IF (LSTART) THEN | |
5674 | WRITE(LOUT,1000) | |
5675 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') | |
5676 | LSTART = .FALSE. | |
5677 | ENDIF | |
5678 | 1 CONTINUE | |
5679 | CALL DT_DFERMI(PABS) | |
5680 | PABS = PFERM*PABS | |
5681 | C IF (PABS.GE.PBIND) THEN | |
5682 | C ILOOP = ILOOP+1 | |
5683 | C IF (MOD(ILOOP,500).EQ.0) THEN | |
5684 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP | |
5685 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', | |
5686 | C & ' energy ',2E12.3,I6) | |
5687 | C ENDIF | |
5688 | C GOTO 1 | |
5689 | C ENDIF | |
5690 | CALL DT_DPOLI(POLC,POLS) | |
5691 | CALL DT_DSFECF(SFE,CFE) | |
5692 | CXTA = POLS*CFE | |
5693 | CYTA = POLS*SFE | |
5694 | CZTA = POLC | |
5695 | ET = SQRT(PABS*PABS+AAM(KT)**2) | |
5696 | PXT = CXTA*PABS | |
5697 | PYT = CYTA*PABS | |
5698 | PZT = CZTA*PABS | |
5699 | ELSE | |
5700 | ET = AAM(KT) | |
5701 | PXT = 0.0D0 | |
5702 | PYT = 0.0D0 | |
5703 | PZT = 0.0D0 | |
5704 | ENDIF | |
5705 | ||
5706 | RETURN | |
5707 | END | |
5708 | ||
5709 | *$ CREATE DT_NUC2CM.FOR | |
5710 | *COPY DT_NUC2CM | |
5711 | * | |
5712 | *===nuc2cm=============================================================* | |
5713 | * | |
5714 | SUBROUTINE DT_NUC2CM | |
5715 | ||
5716 | ************************************************************************ | |
5717 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * | |
5718 | * nucl. cms. (This subroutine replaces NUCMOM.) * | |
5719 | * This version dated 15.01.95 is written by S. Roesler * | |
5720 | ************************************************************************ | |
5721 | ||
5722 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5723 | SAVE | |
5724 | PARAMETER ( LINP = 10 , | |
5725 | & LOUT = 6 , | |
5726 | & LDAT = 9 ) | |
5727 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
5728 | ||
5729 | * event history | |
5730 | PARAMETER (NMXHKK=200000) | |
5731 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5732 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5733 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5734 | * extended event history | |
5735 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5736 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5737 | & IHIST(2,NMXHKK) | |
5738 | * statistics | |
5739 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5740 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5741 | & ICEVTG(8,0:30) | |
5742 | * properties of photon/lepton projectiles | |
5743 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5744 | * particle properties (BAMJET index convention) | |
5745 | CHARACTER*8 ANAME | |
5746 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5747 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5748 | * Glauber formalism: collision properties | |
5749 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 5750 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
5751 | & NCP,NCT | |
9aaba0d6 | 5752 | **temporary |
5753 | * statistics: Glauber-formalism | |
5754 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5755 | ** | |
5756 | ||
5757 | ICWP = 0 | |
5758 | ICWT = 0 | |
5759 | NWTACC = 0 | |
5760 | NWAACC = 0 | |
5761 | NWBACC = 0 | |
5762 | ||
5763 | NPOINT(1) = NHKK+1 | |
5764 | NEND = NHKK | |
5765 | DO 1 I=1,NEND | |
5766 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN | |
5767 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 | |
5768 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 | |
5769 | MODE = ISTHKK(I)-9 | |
5770 | C IF (IDHKK(I).EQ.22) THEN | |
5771 | C* VDM assumption | |
5772 | C PEIN = AAM(33) | |
5773 | C IDB = 33 | |
5774 | C ELSE | |
5775 | C PEIN = PHKK(4,I) | |
5776 | C IDB = IDBAM(I) | |
5777 | C ENDIF | |
5778 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, | |
5779 | C & PX,PY,PZ,PE,IDB,MODE) | |
5780 | IF (PHKK(5,I).GT.ZERO) THEN | |
5781 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
5782 | & PX,PY,PZ,PE,IDBAM(I),MODE) | |
5783 | ELSE | |
5784 | PX = PGAMM(1) | |
5785 | PY = PGAMM(2) | |
5786 | PZ = PGAMM(3) | |
5787 | PE = PGAMM(4) | |
5788 | ENDIF | |
5789 | IST = ISTHKK(I)-2 | |
5790 | ID = IDHKK(I) | |
5791 | C* VDM assumption | |
5792 | C IF (ID.EQ.22) ID = 113 | |
5793 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) | |
5794 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 | |
5795 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 | |
5796 | ENDIF | |
5797 | 1 CONTINUE | |
5798 | ||
5799 | NWTACC = MAX(NWAACC,NWBACC) | |
5800 | ICDPR = ICDPR+ICWP | |
5801 | ICDTA = ICDTA+ICWT | |
5802 | **temporary | |
5803 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN | |
5804 | CALL DT_EVTOUT(4) | |
5805 | STOP | |
5806 | ENDIF | |
5807 | ||
5808 | RETURN | |
5809 | END | |
5810 | ||
5811 | *$ CREATE DT_SPLPTN.FOR | |
5812 | *COPY DT_SPLPTN | |
5813 | * | |
5814 | *===splptn=============================================================* | |
5815 | * | |
5816 | SUBROUTINE DT_SPLPTN(NN) | |
5817 | ||
5818 | ************************************************************************ | |
5819 | * SamPLing of ParToN momenta and flavors. * | |
5820 | * This version dated 15.01.95 is written by S. Roesler * | |
5821 | ************************************************************************ | |
5822 | ||
5823 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5824 | SAVE | |
5825 | PARAMETER ( LINP = 10 , | |
5826 | & LOUT = 6 , | |
5827 | & LDAT = 9 ) | |
5828 | ||
5829 | * Lorentz-parameters of the current interaction | |
5830 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5831 | & UMO,PPCM,EPROJ,PPROJ | |
5832 | ||
5833 | * sample flavors of sea-quarks | |
5834 | CALL DT_SPLFLA(NN,1) | |
5835 | ||
5836 | * sample x-values of partons at chain ends | |
5837 | ECM = UMO | |
5838 | CALL DT_XKSAMP(NN,ECM) | |
5839 | ||
5840 | * samle flavors | |
5841 | CALL DT_SPLFLA(NN,2) | |
5842 | ||
5843 | RETURN | |
5844 | END | |
5845 | ||
5846 | *$ CREATE DT_SPLFLA.FOR | |
5847 | *COPY DT_SPLFLA | |
5848 | * | |
5849 | *===splfla=============================================================* | |
5850 | * | |
5851 | SUBROUTINE DT_SPLFLA(NN,MODE) | |
5852 | ||
5853 | ************************************************************************ | |
5854 | * SamPLing of FLAvors of partons at chain ends. * | |
5855 | * This subroutine replaces FLKSAA/FLKSAM. * | |
5856 | * NN number of nucleon-nucleon interactions * | |
5857 | * MODE = 1 sea-flavors * | |
5858 | * = 2 valence-flavors * | |
5859 | * Based on the original version written by J. Ranft/H.-J. Moehring. * | |
5860 | * This version dated 16.01.95 is written by S. Roesler * | |
5861 | ************************************************************************ | |
5862 | ||
5863 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5864 | SAVE | |
5865 | PARAMETER ( LINP = 10 , | |
5866 | & LOUT = 6 , | |
5867 | & LDAT = 9 ) | |
5868 | ||
5869 | PARAMETER ( MAXNCL = 260, | |
5870 | & MAXVQU = MAXNCL, | |
5871 | & MAXSQU = 20*MAXVQU, | |
5872 | & MAXINT = MAXVQU+MAXSQU) | |
5873 | * flavors of partons (DTUNUC 1.x) | |
5874 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5875 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5876 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5877 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5878 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5879 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5880 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5881 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5882 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5883 | & IXPV,IXPS,IXTV,IXTS, | |
5884 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5885 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5886 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5887 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5888 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5889 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5890 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5891 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5892 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5893 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
5894 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
5895 | * particle properties (BAMJET index convention) | |
5896 | CHARACTER*8 ANAME | |
5897 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5898 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5899 | * various options for treatment of partons (DTUNUC 1.x) | |
5900 | * (chain recombination, Cronin,..) | |
5901 | LOGICAL LCO2CR,LINTPT | |
5902 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
5903 | & LCO2CR,LINTPT | |
5904 | ||
5905 | IF (MODE.EQ.1) THEN | |
5906 | * sea-flavors | |
5907 | DO 1 I=1,NN | |
5908 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5909 | IPSAQ(I) = -IPSQ(I) | |
5910 | 1 CONTINUE | |
5911 | DO 2 I=1,NN | |
5912 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5913 | ITSAQ(I)= -ITSQ(I) | |
5914 | 2 CONTINUE | |
5915 | ELSEIF (MODE.EQ.2) THEN | |
5916 | * valence flavors | |
5917 | DO 3 I=1,IXPV | |
5918 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) | |
5919 | 3 CONTINUE | |
5920 | DO 4 I=1,IXTV | |
5921 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) | |
5922 | 4 CONTINUE | |
5923 | ENDIF | |
5924 | ||
5925 | RETURN | |
5926 | END | |
5927 | ||
5928 | *$ CREATE DT_GETPTN.FOR | |
5929 | *COPY DT_GETPTN | |
5930 | * | |
5931 | *===getptn=============================================================* | |
5932 | * | |
5933 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) | |
5934 | ||
5935 | ************************************************************************ | |
5936 | * This subroutine collects partons at chain ends from temporary * | |
5937 | * commons and puts them into DTEVT1. * | |
5938 | * This version dated 15.01.95 is written by S. Roesler * | |
5939 | ************************************************************************ | |
5940 | ||
5941 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5942 | SAVE | |
5943 | PARAMETER ( LINP = 10 , | |
5944 | & LOUT = 6 , | |
5945 | & LDAT = 9 ) | |
5946 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) | |
5947 | ||
5948 | LOGICAL LCHK | |
5949 | ||
5950 | PARAMETER ( MAXNCL = 260, | |
5951 | & MAXVQU = MAXNCL, | |
5952 | & MAXSQU = 20*MAXVQU, | |
5953 | & MAXINT = MAXVQU+MAXSQU) | |
5954 | * event history | |
5955 | PARAMETER (NMXHKK=200000) | |
5956 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5957 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5958 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5959 | * extended event history | |
5960 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5961 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5962 | & IHIST(2,NMXHKK) | |
5963 | * flags for input different options | |
5964 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5965 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5966 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5967 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5968 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5969 | * statistics | |
5970 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5971 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5972 | & ICEVTG(8,0:30) | |
5973 | * flags for diffractive interactions (DTUNUC 1.x) | |
5974 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5975 | * x-values of partons (DTUNUC 1.x) | |
5976 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
5977 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
5978 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
5979 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
5980 | * flavors of partons (DTUNUC 1.x) | |
5981 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5982 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5983 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5984 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5985 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5986 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5987 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5988 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5989 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5990 | & IXPV,IXPS,IXTV,IXTS, | |
5991 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5992 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5993 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5994 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5995 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5996 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5997 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5998 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5999 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
6000 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
6001 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
6002 | ||
6003 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) | |
6004 | ||
6005 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ | |
6006 | ||
6007 | IREJ = 0 | |
6008 | NCSY = 0 | |
6009 | NPOINT(2) = NHKK+1 | |
6010 | ||
6011 | * sea-sea chains | |
6012 | DO 10 I=1,NSS | |
6013 | IF (ISKPCH(1,I).EQ.99) GOTO 10 | |
6014 | ICCHAI(1,1) = ICCHAI(1,1)+2 | |
6015 | IDXP = INTSS1(I) | |
6016 | IDXT = INTSS2(I) | |
6017 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6018 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6019 | DO 11 K=1,4 | |
6020 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6021 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6022 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6023 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6024 | 11 CONTINUE | |
6025 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6026 | & +(PP1(3)+PT1(3))**2) | |
6027 | ECH = PP1(4)+PT1(4) | |
6028 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6029 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6030 | & +(PP2(3)+PT2(3))**2) | |
6031 | ECH = PP2(4)+PT2(4) | |
6032 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6033 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6034 | AM1 = SQRT(AM1) | |
6035 | AM2 = SQRT(AM2) | |
6036 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN | |
6037 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6038 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) | |
6039 | ENDIF | |
6040 | ELSE | |
6041 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6042 | ENDIF | |
6043 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6044 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6045 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6046 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6047 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6048 | & 0,0,1) | |
6049 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6050 | & 0,0,1) | |
6051 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6052 | & 0,0,1) | |
6053 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6054 | & 0,0,1) | |
6055 | NCSY = NCSY+1 | |
6056 | 10 CONTINUE | |
6057 | ||
6058 | * disea-sea chains | |
6059 | DO 20 I=1,NDS | |
6060 | IF (ISKPCH(2,I).EQ.99) GOTO 20 | |
6061 | ICCHAI(1,2) = ICCHAI(1,2)+2 | |
6062 | IDXP = INTDS1(I) | |
6063 | IDXT = INTDS2(I) | |
6064 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6065 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6066 | DO 21 K=1,4 | |
6067 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6068 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6069 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6070 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6071 | 21 CONTINUE | |
6072 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6073 | & +(PP1(3)+PT1(3))**2) | |
6074 | ECH = PP1(4)+PT1(4) | |
6075 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6076 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6077 | & +(PP2(3)+PT2(3))**2) | |
6078 | ECH = PP2(4)+PT2(4) | |
6079 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6080 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6081 | AM1 = SQRT(AM1) | |
6082 | AM2 = SQRT(AM2) | |
6083 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6084 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6085 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) | |
6086 | ENDIF | |
6087 | ELSE | |
6088 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6089 | ENDIF | |
6090 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6091 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6092 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6093 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6094 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6095 | & 0,0,2) | |
6096 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6097 | & 0,0,2) | |
6098 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6099 | & 0,0,2) | |
6100 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6101 | & 0,0,2) | |
6102 | NCSY = NCSY+1 | |
6103 | 20 CONTINUE | |
6104 | ||
6105 | * sea-disea chains | |
6106 | DO 30 I=1,NSD | |
6107 | IF (ISKPCH(3,I).EQ.99) GOTO 30 | |
6108 | ICCHAI(1,3) = ICCHAI(1,3)+2 | |
6109 | IDXP = INTSD1(I) | |
6110 | IDXT = INTSD2(I) | |
6111 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6112 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6113 | DO 31 K=1,4 | |
6114 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6115 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6116 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6117 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6118 | 31 CONTINUE | |
6119 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6120 | & +(PP1(3)+PT1(3))**2) | |
6121 | ECH = PP1(4)+PT1(4) | |
6122 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6123 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6124 | & +(PP2(3)+PT2(3))**2) | |
6125 | ECH = PP2(4)+PT2(4) | |
6126 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6127 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6128 | AM1 = SQRT(AM1) | |
6129 | AM2 = SQRT(AM2) | |
6130 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6131 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6132 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) | |
6133 | ENDIF | |
6134 | ELSE | |
6135 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6136 | ENDIF | |
6137 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6138 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6139 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6140 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6141 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6142 | & 0,0,3) | |
6143 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6144 | & 0,0,3) | |
6145 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6146 | & 0,0,3) | |
6147 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6148 | & 0,0,3) | |
6149 | NCSY = NCSY+1 | |
6150 | 30 CONTINUE | |
6151 | ||
6152 | * disea-valence chains | |
6153 | DO 50 I=1,NDV | |
6154 | IF (ISKPCH(5,I).EQ.99) GOTO 50 | |
6155 | ICCHAI(1,5) = ICCHAI(1,5)+2 | |
6156 | IDXP = INTDV1(I) | |
6157 | IDXT = INTDV2(I) | |
6158 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6159 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6160 | DO 51 K=1,4 | |
6161 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6162 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6163 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6164 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6165 | 51 CONTINUE | |
6166 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6167 | & +(PP1(3)+PT1(3))**2) | |
6168 | ECH = PP1(4)+PT1(4) | |
6169 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6170 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6171 | & +(PP2(3)+PT2(3))**2) | |
6172 | ECH = PP2(4)+PT2(4) | |
6173 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6174 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6175 | AM1 = SQRT(AM1) | |
6176 | AM2 = SQRT(AM2) | |
6177 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6178 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6179 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) | |
6180 | ENDIF | |
6181 | ELSE | |
6182 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6183 | ENDIF | |
6184 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6185 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6186 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6187 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6188 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6189 | & 0,0,5) | |
6190 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6191 | & 0,0,5) | |
6192 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6193 | & 0,0,5) | |
6194 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6195 | & 0,0,5) | |
6196 | NCSY = NCSY+1 | |
6197 | 50 CONTINUE | |
6198 | ||
6199 | * valence-sea chains | |
6200 | DO 60 I=1,NVS | |
6201 | IF (ISKPCH(6,I).EQ.99) GOTO 60 | |
6202 | ICCHAI(1,6) = ICCHAI(1,6)+2 | |
6203 | IDXP = INTVS1(I) | |
6204 | IDXT = INTVS2(I) | |
6205 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6206 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6207 | DO 61 K=1,4 | |
6208 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6209 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6210 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6211 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6212 | 61 CONTINUE | |
6213 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6214 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6215 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6216 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6217 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6218 | IF (LCHK) THEN | |
6219 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6220 | & 0,0,6) | |
6221 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6222 | & 0,0,6) | |
6223 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6224 | & 0,0,6) | |
6225 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6226 | & 0,0,6) | |
6227 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6228 | & +(PP1(3)+PT1(3))**2) | |
6229 | ECH = PP1(4)+PT1(4) | |
6230 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6231 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6232 | & +(PP2(3)+PT2(3))**2) | |
6233 | ECH = PP2(4)+PT2(4) | |
6234 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6235 | ELSE | |
6236 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6237 | & 0,0,6) | |
6238 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6239 | & 0,0,6) | |
6240 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6241 | & 0,0,6) | |
6242 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6243 | & 0,0,6) | |
6244 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6245 | & +(PP1(3)+PT2(3))**2) | |
6246 | ECH = PP1(4)+PT2(4) | |
6247 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6248 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6249 | & +(PP2(3)+PT1(3))**2) | |
6250 | ECH = PP2(4)+PT1(4) | |
6251 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6252 | ENDIF | |
6253 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6254 | AM1 = SQRT(AM1) | |
6255 | AM2 = SQRT(AM2) | |
6256 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN | |
6257 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6258 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) | |
6259 | ENDIF | |
6260 | ELSE | |
6261 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6262 | ENDIF | |
6263 | NCSY = NCSY+1 | |
6264 | 60 CONTINUE | |
6265 | ||
6266 | * sea-valence chains | |
6267 | DO 40 I=1,NSV | |
6268 | IF (ISKPCH(4,I).EQ.99) GOTO 40 | |
6269 | ICCHAI(1,4) = ICCHAI(1,4)+2 | |
6270 | IDXP = INTSV1(I) | |
6271 | IDXT = INTSV2(I) | |
6272 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6273 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6274 | DO 41 K=1,4 | |
6275 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6276 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6277 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6278 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6279 | 41 CONTINUE | |
6280 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6281 | & +(PP1(3)+PT1(3))**2) | |
6282 | ECH = PP1(4)+PT1(4) | |
6283 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6284 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6285 | & +(PP2(3)+PT2(3))**2) | |
6286 | ECH = PP2(4)+PT2(4) | |
6287 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6288 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6289 | AM1 = SQRT(AM1) | |
6290 | AM2 = SQRT(AM2) | |
6291 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN | |
6292 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6293 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) | |
6294 | ENDIF | |
6295 | ELSE | |
6296 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6297 | ENDIF | |
6298 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6299 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6300 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6301 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6302 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6303 | & 0,0,4) | |
6304 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6305 | & 0,0,4) | |
6306 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6307 | & 0,0,4) | |
6308 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6309 | & 0,0,4) | |
6310 | NCSY = NCSY+1 | |
6311 | 40 CONTINUE | |
6312 | ||
6313 | * valence-disea chains | |
6314 | DO 70 I=1,NVD | |
6315 | IF (ISKPCH(7,I).EQ.99) GOTO 70 | |
6316 | ICCHAI(1,7) = ICCHAI(1,7)+2 | |
6317 | IDXP = INTVD1(I) | |
6318 | IDXT = INTVD2(I) | |
6319 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6320 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6321 | DO 71 K=1,4 | |
6322 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6323 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6324 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6325 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6326 | 71 CONTINUE | |
6327 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6328 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6329 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6330 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6331 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6332 | IF (LCHK) THEN | |
6333 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6334 | & 0,0,7) | |
6335 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6336 | & 0,0,7) | |
6337 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6338 | & 0,0,7) | |
6339 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6340 | & 0,0,7) | |
6341 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6342 | & +(PP1(3)+PT1(3))**2) | |
6343 | ECH = PP1(4)+PT1(4) | |
6344 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6345 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6346 | & +(PP2(3)+PT2(3))**2) | |
6347 | ECH = PP2(4)+PT2(4) | |
6348 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6349 | ELSE | |
6350 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6351 | & 0,0,7) | |
6352 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6353 | & 0,0,7) | |
6354 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6355 | & 0,0,7) | |
6356 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6357 | & 0,0,7) | |
6358 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6359 | & +(PP1(3)+PT2(3))**2) | |
6360 | ECH = PP1(4)+PT2(4) | |
6361 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6362 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6363 | & +(PP2(3)+PT1(3))**2) | |
6364 | ECH = PP2(4)+PT1(4) | |
6365 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6366 | ENDIF | |
6367 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6368 | AM1 = SQRT(AM1) | |
6369 | AM2 = SQRT(AM2) | |
6370 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6371 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6372 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) | |
6373 | ENDIF | |
6374 | ELSE | |
6375 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6376 | ENDIF | |
6377 | NCSY = NCSY+1 | |
6378 | 70 CONTINUE | |
6379 | ||
6380 | * valence-valence chains | |
6381 | DO 80 I=1,NVV | |
6382 | IF (ISKPCH(8,I).EQ.99) GOTO 80 | |
6383 | ICCHAI(1,8) = ICCHAI(1,8)+2 | |
6384 | IDXP = INTVV1(I) | |
6385 | IDXT = INTVV2(I) | |
6386 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6387 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6388 | DO 81 K=1,4 | |
6389 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) | |
6390 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) | |
6391 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) | |
6392 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) | |
6393 | 81 CONTINUE | |
6394 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6395 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6396 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6397 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6398 | ||
6399 | * check for diffractive event | |
6400 | IDIFF = 0 | |
6401 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. | |
6402 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN | |
6403 | DO 800 K=1,4 | |
6404 | PP(K) = PP1(K)+PP2(K) | |
6405 | PT(K) = PT1(K)+PT2(K) | |
6406 | 800 CONTINUE | |
6407 | ISTCK = NHKK | |
6408 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
6409 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) | |
6410 | C IF (IREJ1.NE.0) GOTO 9999 | |
6411 | IF (IREJ1.NE.0) THEN | |
6412 | IDIFF = 0 | |
6413 | NHKK = ISTCK | |
6414 | ENDIF | |
6415 | ELSE | |
6416 | IDIFF = 0 | |
6417 | ENDIF | |
6418 | ||
6419 | IF (IDIFF.EQ.0) THEN | |
6420 | * valence-valence chain system | |
6421 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6422 | IF (LCHK) THEN | |
6423 | * baryon-baryon | |
6424 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6425 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6426 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6427 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6428 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6429 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6430 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6431 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6432 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6433 | & +(PP1(3)+PT1(3))**2) | |
6434 | ECH = PP1(4)+PT1(4) | |
6435 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6436 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6437 | & +(PP2(3)+PT2(3))**2) | |
6438 | ECH = PP2(4)+PT2(4) | |
6439 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6440 | ELSE | |
6441 | * antibaryon-baryon | |
6442 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6443 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6444 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6445 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6446 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6447 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6448 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6449 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6450 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6451 | & +(PP1(3)+PT2(3))**2) | |
6452 | ECH = PP1(4)+PT2(4) | |
6453 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6454 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6455 | & +(PP2(3)+PT1(3))**2) | |
6456 | ECH = PP2(4)+PT1(4) | |
6457 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6458 | ENDIF | |
6459 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6460 | AM1 = SQRT(AM1) | |
6461 | AM2 = SQRT(AM2) | |
6462 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN | |
6463 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6464 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) | |
6465 | ENDIF | |
6466 | ELSE | |
6467 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6468 | ENDIF | |
6469 | NCSY = NCSY+1 | |
6470 | ENDIF | |
6471 | 80 CONTINUE | |
6472 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 | |
6473 | ||
6474 | * energy-momentum & flavor conservation check | |
6475 | IF (ABS(IDIFF).NE.1) THEN | |
6476 | IF (IDIFF.NE.0) THEN | |
6477 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, | |
6478 | & 1,3,10,IREJ) | |
6479 | ELSE | |
6480 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, | |
6481 | & 1,3,10,IREJ) | |
6482 | ENDIF | |
6483 | IF (IREJ.NE.0) THEN | |
6484 | CALL DT_EVTOUT(4) | |
6485 | STOP | |
6486 | ENDIF | |
6487 | ENDIF | |
6488 | ||
6489 | RETURN | |
6490 | ||
6491 | 9999 CONTINUE | |
6492 | IREJ = 1 | |
6493 | RETURN | |
6494 | END | |
6495 | ||
6496 | *$ CREATE DT_CHKCSY.FOR | |
6497 | *COPY DT_CHKCSY | |
6498 | * | |
6499 | *===chkcsy=============================================================* | |
6500 | * | |
6501 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) | |
6502 | ||
6503 | ************************************************************************ | |
6504 | * CHeCk Chain SYstem for consistency of partons at chain ends. * | |
6505 | * ID1,ID2 PDG-numbers of partons at chain ends * | |
6506 | * LCHK = .true. consistent chain * | |
6507 | * = .false. inconsistent chain * | |
6508 | * This version dated 18.01.95 is written by S. Roesler * | |
6509 | ************************************************************************ | |
6510 | ||
6511 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6512 | SAVE | |
6513 | PARAMETER ( LINP = 10 , | |
6514 | & LOUT = 6 , | |
6515 | & LDAT = 9 ) | |
6516 | ||
6517 | LOGICAL LCHK | |
6518 | ||
6519 | LCHK = .TRUE. | |
6520 | ||
6521 | * q-aq chain | |
6522 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN | |
6523 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6524 | * q-qq, aq-aqaq chain | |
6525 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. | |
6526 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN | |
6527 | IF (ID1*ID2.LT.0) LCHK = .FALSE. | |
6528 | * qq-aqaq chain | |
6529 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN | |
6530 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6531 | ENDIF | |
6532 | ||
6533 | RETURN | |
6534 | END | |
6535 | ||
6536 | *$ CREATE DT_EVENTA.FOR | |
6537 | *COPY DT_EVENTA | |
6538 | * | |
6539 | *===eventa=============================================================* | |
6540 | * | |
6541 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) | |
6542 | ||
6543 | ************************************************************************ | |
6544 | * Treatment of nucleon-nucleon interactions in a two-chain * | |
6545 | * approximation. * | |
6546 | * (input) ID BAMJET-index of projectile hadron (in case of * | |
6547 | * h-K scattering) * | |
6548 | * IP/IT mass number of projectile/target nucleus * | |
6549 | * NCSY number of two chain systems * | |
6550 | * IREJ rejection flag * | |
6551 | * This version dated 15.01.95 is written by S. Roesler * | |
6552 | ************************************************************************ | |
6553 | ||
6554 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6555 | SAVE | |
6556 | PARAMETER ( LINP = 10 , | |
6557 | & LOUT = 6 , | |
6558 | & LDAT = 9 ) | |
6559 | PARAMETER (TINY10=1.0D-10) | |
6560 | ||
6561 | * event history | |
6562 | PARAMETER (NMXHKK=200000) | |
6563 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6564 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6565 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6566 | * extended event history | |
6567 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6568 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6569 | & IHIST(2,NMXHKK) | |
6570 | * rejection counter | |
6571 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6572 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6573 | & IREXCI(3),IRDIFF(2),IRINC | |
6574 | * flags for diffractive interactions (DTUNUC 1.x) | |
6575 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6576 | * particle properties (BAMJET index convention) | |
6577 | CHARACTER*8 ANAME | |
6578 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6579 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6580 | * flags for input different options | |
6581 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6582 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6583 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6584 | * various options for treatment of partons (DTUNUC 1.x) | |
6585 | * (chain recombination, Cronin,..) | |
6586 | LOGICAL LCO2CR,LINTPT | |
6587 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
6588 | & LCO2CR,LINTPT | |
6589 | ||
6590 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
6591 | ||
6592 | IREJ = 0 | |
6593 | NPOINT(3) = NHKK+1 | |
6594 | ||
6595 | * skip following treatment for low-mass diffraction | |
6596 | IF (ABS(IFLAGD).EQ.1) THEN | |
6597 | NPOINT(3) = NPOINT(2) | |
6598 | GOTO 5 | |
6599 | ENDIF | |
6600 | ||
6601 | * multiple scattering of chain ends | |
6602 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
6603 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
6604 | ||
6605 | NC = NPOINT(2) | |
6606 | * get a two-chain system from DTEVT1 | |
6607 | DO 3 I=1,NCSY | |
6608 | IFP1 = IDHKK(NC) | |
6609 | IFT1 = IDHKK(NC+1) | |
6610 | IFP2 = IDHKK(NC+2) | |
6611 | IFT2 = IDHKK(NC+3) | |
6612 | DO 4 K=1,4 | |
6613 | PP1(K) = PHKK(K,NC) | |
6614 | PT1(K) = PHKK(K,NC+1) | |
6615 | PP2(K) = PHKK(K,NC+2) | |
6616 | PT2(K) = PHKK(K,NC+3) | |
6617 | 4 CONTINUE | |
6618 | MOP1 = NC | |
6619 | MOT1 = NC+1 | |
6620 | MOP2 = NC+2 | |
6621 | MOT2 = NC+3 | |
6622 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
6623 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
6624 | IF (IREJ1.GT.0) THEN | |
6625 | IRHHA = IRHHA+1 | |
6626 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' | |
6627 | GOTO 9999 | |
6628 | ENDIF | |
6629 | NC = NC+4 | |
6630 | 3 CONTINUE | |
6631 | ||
6632 | * meson/antibaryon projectile: | |
6633 | * sample single-chain valence-valence systems (Reggeon contrib.) | |
6634 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN | |
6635 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH | |
6636 | ENDIF | |
6637 | ||
6638 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6639 | * check DTEVT1 for remaining resonance mass corrections | |
6640 | CALL DT_EVTRES(IREJ1) | |
6641 | IF (IREJ1.GT.0) THEN | |
6642 | IRRES(1) = IRRES(1)+1 | |
6643 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' | |
6644 | GOTO 9999 | |
6645 | ENDIF | |
6646 | ENDIF | |
6647 | ||
6648 | * assign p_t to two-"chain" systems consisting of two resonances only | |
6649 | * since only entries for chains will be affected, this is obsolete | |
6650 | * in case of JETSET-fragmetation | |
6651 | CALL DT_RESPT | |
6652 | ||
6653 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) | |
6654 | IF (LCO2CR) CALL DT_COM2CR | |
6655 | ||
6656 | 5 CONTINUE | |
6657 | ||
6658 | * fragmentation of the complete event | |
6659 | **uncomment for internal phojet-fragmentation | |
6660 | C CALL DT_EVTFRA(IREJ1) | |
6661 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) | |
6662 | IF (IREJ1.GT.0) THEN | |
6663 | IRFRAG = IRFRAG+1 | |
6664 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' | |
6665 | GOTO 9999 | |
6666 | ENDIF | |
6667 | ||
6668 | * decay of possible resonances (should be obsolete) | |
6669 | CALL DT_DECAY1 | |
6670 | ||
6671 | RETURN | |
6672 | ||
6673 | 9999 CONTINUE | |
6674 | IREVT = IREVT+1 | |
6675 | IREJ = 1 | |
6676 | RETURN | |
6677 | END | |
6678 | ||
6679 | *$ CREATE DT_GETCSY.FOR | |
6680 | *COPY DT_GETCSY | |
6681 | * | |
6682 | *===getcsy=============================================================* | |
6683 | * | |
6684 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, | |
6685 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) | |
6686 | ||
6687 | ************************************************************************ | |
6688 | * This version dated 15.01.95 is written by S. Roesler * | |
6689 | ************************************************************************ | |
6690 | ||
6691 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6692 | SAVE | |
6693 | PARAMETER ( LINP = 10 , | |
6694 | & LOUT = 6 , | |
6695 | & LDAT = 9 ) | |
6696 | PARAMETER (TINY10=1.0D-10) | |
6697 | ||
6698 | * event history | |
6699 | PARAMETER (NMXHKK=200000) | |
6700 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6701 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6702 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6703 | * extended event history | |
6704 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6705 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6706 | & IHIST(2,NMXHKK) | |
6707 | * rejection counter | |
6708 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6709 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6710 | & IREXCI(3),IRDIFF(2),IRINC | |
6711 | * flags for input different options | |
6712 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6713 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6714 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6715 | * flags for diffractive interactions (DTUNUC 1.x) | |
6716 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6717 | ||
6718 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), | |
6719 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) | |
6720 | ||
6721 | IREJ = 0 | |
6722 | ||
6723 | * get quark content of partons | |
6724 | DO 1 I=1,2 | |
6725 | IFP1(I) = 0 | |
6726 | IFP2(I) = 0 | |
6727 | IFT1(I) = 0 | |
6728 | IFT2(I) = 0 | |
6729 | 1 CONTINUE | |
6730 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) | |
6731 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) | |
6732 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) | |
6733 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) | |
6734 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) | |
6735 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) | |
6736 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) | |
6737 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) | |
6738 | ||
6739 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) | |
6740 | IDCH1 = 2 | |
6741 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 | |
6742 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 | |
6743 | IDCH2 = 2 | |
6744 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 | |
6745 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 | |
6746 | ||
6747 | * store initial configuration for energy-momentum cons. check | |
6748 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) | |
6749 | ||
6750 | * sample intrinsic p_t at chain-ends | |
6751 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, | |
6752 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, | |
6753 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) | |
6754 | IF (IREJ1.NE.0) THEN | |
6755 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' | |
6756 | IRPT = IRPT+1 | |
6757 | GOTO 9999 | |
6758 | ENDIF | |
6759 | ||
6760 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6761 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN | |
6762 | C* check second chain for resonance | |
6763 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6764 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6765 | C IF (IREJ1.NE.0) GOTO 9999 | |
6766 | C IF (IDR2.NE.0) THEN | |
6767 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6768 | C & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6769 | C IF (IREJ1.NE.0) GOTO 9999 | |
6770 | C ENDIF | |
6771 | C* check first chain for resonance | |
6772 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6773 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6774 | C IF (IREJ1.NE.0) GOTO 9999 | |
6775 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6776 | C ELSE | |
6777 | C* check first chain for resonance | |
6778 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6779 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6780 | C IF (IREJ1.NE.0) GOTO 9999 | |
6781 | C IF (IDR1.NE.0) THEN | |
6782 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6783 | C & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6784 | C IF (IREJ1.NE.0) GOTO 9999 | |
6785 | C ENDIF | |
6786 | C* check second chain for resonance | |
6787 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6788 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6789 | C IF (IREJ1.NE.0) GOTO 9999 | |
6790 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6791 | C ENDIF | |
6792 | C ENDIF | |
6793 | ||
6794 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6795 | * check chains for resonances | |
6796 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6797 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6798 | IF (IREJ1.NE.0) GOTO 9999 | |
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 | * change kinematics corresponding to resonance-masses | |
6803 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN | |
6804 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6805 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6806 | IF (IREJ1.GT.0) GOTO 9999 | |
6807 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6808 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6809 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6810 | IF (IREJ1.NE.0) GOTO 9999 | |
6811 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6812 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN | |
6813 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6814 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6815 | IF (IREJ1.GT.0) GOTO 9999 | |
6816 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6817 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6818 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6819 | IF (IREJ1.NE.0) GOTO 9999 | |
6820 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6821 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN | |
6822 | AMDIF1 = ABS(AMCH1-AMCH1N) | |
6823 | AMDIF2 = ABS(AMCH2-AMCH2N) | |
6824 | IF (AMDIF2.LT.AMDIF1) THEN | |
6825 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6826 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6827 | IF (IREJ1.GT.0) GOTO 9999 | |
6828 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6829 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), | |
6830 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) | |
6831 | IF (IREJ1.NE.0) GOTO 9999 | |
6832 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6833 | ELSE | |
6834 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6835 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6836 | IF (IREJ1.GT.0) GOTO 9999 | |
6837 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6838 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), | |
6839 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) | |
6840 | IF (IREJ1.NE.0) GOTO 9999 | |
6841 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6842 | ENDIF | |
6843 | ENDIF | |
6844 | ENDIF | |
6845 | ||
6846 | * store final configuration for energy-momentum cons. check | |
6847 | IF (LEMCCK) THEN | |
6848 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) | |
6849 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
6850 | IF (IREJ1.NE.0) GOTO 9999 | |
6851 | ENDIF | |
6852 | ||
6853 | * put partons and chains into DTEVT1 | |
6854 | DO 10 I=1,4 | |
6855 | PCH1(I) = PP1(I)+PT1(I) | |
6856 | PCH2(I) = PP2(I)+PT2(I) | |
6857 | 10 CONTINUE | |
6858 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), | |
6859 | & PP1(3),PP1(4),0,0,0) | |
6860 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), | |
6861 | & PT1(3),PT1(4),0,0,0) | |
6862 | KCH = 100+IDCH(MOP1)*10+1 | |
6863 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6864 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) | |
6865 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), | |
6866 | & PP2(3),PP2(4),0,0,0) | |
6867 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), | |
6868 | & PT2(3),PT2(4),0,0,0) | |
6869 | KCH = KCH+1 | |
6870 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6871 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) | |
6872 | ||
6873 | RETURN | |
6874 | ||
6875 | 9999 CONTINUE | |
6876 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN | |
6877 | * "cancel" sea-sea chains | |
6878 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) | |
6879 | IF (IREJ1.NE.0) GOTO 9998 | |
6880 | **sr 16.5. flag for EVENTB | |
6881 | IREJ = -1 | |
6882 | RETURN | |
6883 | ENDIF | |
6884 | 9998 CONTINUE | |
6885 | IREJ = 1 | |
6886 | RETURN | |
6887 | END | |
6888 | ||
6889 | *$ CREATE DT_CHKINE.FOR | |
6890 | *COPY DT_CHKINE | |
6891 | * | |
6892 | *===chkine=============================================================* | |
6893 | * | |
6894 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, | |
6895 | & AMCH1,AMCH1N,AMCH2,IREJ) | |
6896 | ||
6897 | ************************************************************************ | |
6898 | * This subroutine replaces CORMOM. * | |
6899 | * This version dated 05.01.95 is written by S. Roesler * | |
6900 | ************************************************************************ | |
6901 | ||
6902 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6903 | SAVE | |
6904 | PARAMETER ( LINP = 10 , | |
6905 | & LOUT = 6 , | |
6906 | & LDAT = 9 ) | |
6907 | PARAMETER (TINY10=1.0D-10) | |
6908 | ||
6909 | * flags for input different options | |
6910 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6911 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6912 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6913 | * rejection counter | |
6914 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6915 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6916 | & IREXCI(3),IRDIFF(2),IRINC | |
6917 | ||
6918 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), | |
6919 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) | |
6920 | ||
6921 | IREJ = 0 | |
6922 | JMSHL = IMSHL | |
6923 | ||
6924 | SCALE = AMCH1N/MAX(AMCH1,TINY10) | |
6925 | DO 10 I=1,4 | |
6926 | PP1(I) = PP1I(I) | |
6927 | PP2(I) = PP2I(I) | |
6928 | PT1(I) = PT1I(I) | |
6929 | PT2(I) = PT2I(I) | |
6930 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) | |
6931 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) | |
6932 | PP1(I) = SCALE*PP1(I) | |
6933 | PT1(I) = SCALE*PT1(I) | |
6934 | 10 CONTINUE | |
6935 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. | |
6936 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 | |
6937 | ||
6938 | ECH = PP2(4)+PT2(4) | |
6939 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ | |
6940 | & (PP2(3)+PT2(3))**2 ) | |
6941 | AMCH22 = (ECH-PCH)*(ECH+PCH) | |
6942 | IF (AMCH22.LT.0.0D0) THEN | |
6943 | IF (IOULEV(1).GT.0) | |
6944 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' | |
6945 | GOTO 9997 | |
6946 | ENDIF | |
6947 | ||
6948 | AMCH1 = AMCH1N | |
6949 | AMCH2 = SQRT(AMCH22) | |
6950 | ||
6951 | * put partons again on mass shell | |
6952 | 13 CONTINUE | |
6953 | XM1 = 0.0D0 | |
6954 | XM2 = 0.0D0 | |
6955 | IF (JMSHL.EQ.1) THEN | |
6956 | XM1 = PYMASS(IFP1) | |
6957 | XM2 = PYMASS(IFT1) | |
6958 | ENDIF | |
6959 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
6960 | IF (IREJ1.NE.0) THEN | |
6961 | IF (JMSHL.EQ.0) GOTO 9998 | |
6962 | JMSHL = 0 | |
6963 | GOTO 13 | |
6964 | ENDIF | |
6965 | JMSHL = IMSHL | |
6966 | DO 11 I=1,4 | |
6967 | PP1(I) = P1(I) | |
6968 | PT1(I) = P2(I) | |
6969 | 11 CONTINUE | |
6970 | 14 CONTINUE | |
6971 | XM1 = 0.0D0 | |
6972 | XM2 = 0.0D0 | |
6973 | IF (JMSHL.EQ.1) THEN | |
6974 | XM1 = PYMASS(IFP2) | |
6975 | XM2 = PYMASS(IFT2) | |
6976 | ENDIF | |
6977 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) | |
6978 | IF (IREJ1.NE.0) THEN | |
6979 | IF (JMSHL.EQ.0) GOTO 9998 | |
6980 | JMSHL = 0 | |
6981 | GOTO 14 | |
6982 | ENDIF | |
6983 | DO 12 I=1,4 | |
6984 | PP2(I) = P1(I) | |
6985 | PT2(I) = P2(I) | |
6986 | 12 CONTINUE | |
6987 | DO 15 I=1,4 | |
6988 | PP1I(I) = PP1(I) | |
6989 | PP2I(I) = PP2(I) | |
6990 | PT1I(I) = PT1(I) | |
6991 | PT2I(I) = PT2(I) | |
6992 | 15 CONTINUE | |
6993 | RETURN | |
6994 | ||
6995 | 9997 IRCHKI(1) = IRCHKI(1)+1 | |
6996 | **sr | |
6997 | C GOTO 9999 | |
6998 | IREJ = -1 | |
6999 | RETURN | |
7000 | ** | |
7001 | 9998 IRCHKI(2) = IRCHKI(2)+1 | |
7002 | ||
7003 | 9999 CONTINUE | |
7004 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' | |
7005 | IREJ = 1 | |
7006 | RETURN | |
7007 | END | |
7008 | ||
7009 | *$ CREATE DT_CH2RES.FOR | |
7010 | *COPY DT_CH2RES | |
7011 | * | |
7012 | *===ch2res=============================================================* | |
7013 | * | |
7014 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, | |
7015 | & AM,AMN,IMODE,IREJ) | |
7016 | ||
7017 | ************************************************************************ | |
7018 | * Check chains for resonance production. * | |
7019 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * | |
7020 | * input: * | |
7021 | * IF1,2,3,4 input flavors (q,aq in any order) * | |
7022 | * AM chain mass * | |
7023 | * MODE = 1 check q-aq chain for meson-resonance * | |
7024 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * | |
7025 | * = 3 check qq-aqaq chain for lower mass cut * | |
7026 | * output: * | |
7027 | * IDR = 0 no resonances found * | |
7028 | * = -1 pseudoscalar meson/octet baryon * | |
7029 | * = 1 vector-meson/decuplet baryon * | |
7030 | * IDXR BAMJET-index of corresponding resonance * | |
7031 | * AMN mass of corresponding resonance * | |
7032 | * * | |
7033 | * IREJ rejection flag * | |
7034 | * This version dated 06.01.95 is written by S. Roesler * | |
7035 | ************************************************************************ | |
7036 | ||
7037 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7038 | SAVE | |
7039 | PARAMETER ( LINP = 10 , | |
7040 | & LOUT = 6 , | |
7041 | & LDAT = 9 ) | |
7042 | ||
7043 | * particle properties (BAMJET index convention) | |
7044 | CHARACTER*8 ANAME | |
7045 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7046 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7047 | * quark-content to particle index conversion (DTUNUC 1.x) | |
7048 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
7049 | & IA08(6,21),IA10(6,21) | |
7050 | * rejection counter | |
7051 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7052 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7053 | & IREXCI(3),IRDIFF(2),IRINC | |
7054 | * flags for input different options | |
7055 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7056 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7057 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7058 | ||
7059 | DIMENSION IF(4),JF(4) | |
7060 | ||
7061 | **sr 4.7. test | |
7062 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ | |
7063 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ | |
7064 | ** | |
7065 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ | |
7066 | ||
7067 | MODE = ABS(IMODE) | |
7068 | ||
7069 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN | |
7070 | WRITE(LOUT,1000) MODE | |
7071 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, | |
7072 | & 1X,' program stopped') | |
7073 | STOP | |
7074 | ENDIF | |
7075 | ||
7076 | AMX = AM | |
7077 | IREJ = 0 | |
7078 | IDR = 0 | |
7079 | IDXR = 0 | |
7080 | AMN = AMX | |
7081 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM | |
7082 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB | |
7083 | ||
7084 | IF(1) = IF1 | |
7085 | IF(2) = IF2 | |
7086 | IF(3) = IF3 | |
7087 | IF(4) = IF4 | |
7088 | NF = 0 | |
7089 | DO 100 I=1,4 | |
7090 | IF (IF(I).NE.0) THEN | |
7091 | NF = NF+1 | |
7092 | JF(NF) = IF(I) | |
7093 | ENDIF | |
7094 | 100 CONTINUE | |
7095 | IF (NF.LE.MODE) THEN | |
7096 | WRITE(LOUT,1001) MODE,IF | |
7097 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', | |
7098 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) | |
7099 | GOTO 9999 | |
7100 | ENDIF | |
7101 | ||
7102 | GOTO (1,2,3) MODE | |
7103 | ||
7104 | * check for meson resonance | |
7105 | 1 CONTINUE | |
7106 | IFQ = JF(1) | |
7107 | IFAQ = ABS(JF(2)) | |
7108 | IF (JF(2).GT.0) THEN | |
7109 | IFQ = JF(2) | |
7110 | IFAQ = ABS(JF(1)) | |
7111 | ENDIF | |
7112 | IFPS = IMPS(IFAQ,IFQ) | |
7113 | IFV = IMVE(IFAQ,IFQ) | |
7114 | AMPS = AAM(IFPS) | |
7115 | AMV = AAM(IFV) | |
7116 | AMHI = AMV+0.3D0 | |
7117 | IF (AMX.LT.AMV) THEN | |
7118 | IF (AMX.LT.AMPS) THEN | |
7119 | IF (IMODE.GT.0) THEN | |
7120 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 | |
7121 | ELSE | |
7122 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 | |
7123 | ENDIF | |
7124 | LOMRES = LOMRES+1 | |
7125 | ENDIF | |
7126 | * replace chain by pseudoscalar meson | |
7127 | IDR = -1 | |
7128 | IDXR = IFPS | |
7129 | AMN = AMPS | |
7130 | ELSEIF (AMX.LT.AMHI) THEN | |
7131 | * replace chain by vector-meson | |
7132 | IDR = 1 | |
7133 | IDXR = IFV | |
7134 | AMN = AMV | |
7135 | ENDIF | |
7136 | RETURN | |
7137 | ||
7138 | * check for baryon resonance | |
7139 | 2 CONTINUE | |
7140 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) | |
7141 | AM8 = AAM(JB8) | |
7142 | AM10 = AAM(JB10) | |
7143 | AMHI = AM10+0.3D0 | |
7144 | IF (AMX.LT.AM10) THEN | |
7145 | IF (AMX.LT.AM8) THEN | |
7146 | IF (IMODE.GT.0) THEN | |
7147 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 | |
7148 | ELSE | |
7149 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 | |
7150 | ENDIF | |
7151 | LOBRES = LOBRES+1 | |
7152 | ENDIF | |
7153 | * replace chain by oktet baryon | |
7154 | IDR = -1 | |
7155 | IDXR = JB8 | |
7156 | AMN = AM8 | |
7157 | ELSEIF (AMX.LT.AMHI) THEN | |
7158 | IDR = 1 | |
7159 | IDXR = JB10 | |
7160 | AMN = AM10 | |
7161 | ENDIF | |
7162 | RETURN | |
7163 | ||
7164 | * check qq-aqaq for lower mass cut | |
7165 | 3 CONTINUE | |
7166 | * empirical definition of AMHI to allow for (b-antib)-pair prod. | |
7167 | AMHI = 2.5D0 | |
7168 | IF (AMX.LT.AMHI) GOTO 9999 | |
7169 | RETURN | |
7170 | ||
7171 | 9999 CONTINUE | |
7172 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) | |
7173 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE | |
7174 | IREJ = 1 | |
7175 | IRRES(2) = IRRES(2)+1 | |
7176 | RETURN | |
7177 | END | |
7178 | ||
7179 | *$ CREATE DT_RJSEAC.FOR | |
7180 | *COPY DT_RJSEAC | |
7181 | * | |
7182 | *===rjseac=============================================================* | |
7183 | * | |
7184 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) | |
7185 | ||
7186 | ************************************************************************ | |
7187 | * ReJection of SEA-sea Chains. * | |
7188 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * | |
7189 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * | |
7190 | * This version dated 16.01.95 is written by S. Roesler * | |
7191 | ************************************************************************ | |
7192 | ||
7193 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7194 | SAVE | |
7195 | PARAMETER ( LINP = 10 , | |
7196 | & LOUT = 6 , | |
7197 | & LDAT = 9 ) | |
7198 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
7199 | ||
7200 | * event history | |
7201 | PARAMETER (NMXHKK=200000) | |
7202 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7203 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7204 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7205 | * extended event history | |
7206 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7207 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7208 | & IHIST(2,NMXHKK) | |
7209 | * statistics | |
7210 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7211 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7212 | & ICEVTG(8,0:30) | |
7213 | ||
7214 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) | |
7215 | ||
7216 | IREJ = 0 | |
7217 | ||
7218 | * projectile sea q-aq-pair | |
7219 | * indices of sea-pair | |
7220 | IDXSEA(1,1) = MOP1 | |
7221 | IDXSEA(1,2) = MOP2 | |
7222 | * index of mother-nucleon | |
7223 | IDXNUC(1) = JMOHKK(1,MOP1) | |
7224 | * status of valence quarks to be corrected | |
7225 | ISTVAL(1) = -21 | |
7226 | ||
7227 | * target sea q-aq-pair | |
7228 | * indices of sea-pair | |
7229 | IDXSEA(2,1) = MOT1 | |
7230 | IDXSEA(2,2) = MOT2 | |
7231 | * index of mother-nucleon | |
7232 | IDXNUC(2) = JMOHKK(1,MOT1) | |
7233 | * status of valence quarks to be corrected | |
7234 | ISTVAL(2) = -22 | |
7235 | ||
7236 | DO 1 N=1,2 | |
7237 | IDONE = 0 | |
7238 | DO 2 I=NPOINT(2),NHKK | |
7239 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. | |
7240 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN | |
7241 | * valence parton found | |
7242 | * inrease 4-momentum by sea 4-momentum | |
7243 | DO 3 K=1,4 | |
7244 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ | |
7245 | & PHKK(K,IDXSEA(N,2)) | |
7246 | 3 CONTINUE | |
7247 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
7248 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
7249 | * "cancel" sea-pair | |
7250 | DO 4 J=1,2 | |
7251 | ISTHKK(IDXSEA(N,J)) = 100 | |
7252 | IDHKK(IDXSEA(N,J)) = 0 | |
7253 | JMOHKK(1,IDXSEA(N,J)) = 0 | |
7254 | JMOHKK(2,IDXSEA(N,J)) = 0 | |
7255 | JDAHKK(1,IDXSEA(N,J)) = 0 | |
7256 | JDAHKK(2,IDXSEA(N,J)) = 0 | |
7257 | DO 5 K=1,4 | |
7258 | PHKK(K,IDXSEA(N,J)) = ZERO | |
7259 | VHKK(K,IDXSEA(N,J)) = ZERO | |
7260 | WHKK(K,IDXSEA(N,J)) = ZERO | |
7261 | 5 CONTINUE | |
7262 | PHKK(5,IDXSEA(N,J)) = ZERO | |
7263 | 4 CONTINUE | |
7264 | IDONE = 1 | |
7265 | ENDIF | |
7266 | 2 CONTINUE | |
7267 | IF (IDONE.NE.1) THEN | |
7268 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 | |
7269 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', | |
7270 | & '-record!',/,1X,' sea-quark pairs ', | |
7271 | & 2I5,4X,2I5,' could not be canceled!') | |
7272 | GOTO 9999 | |
7273 | ENDIF | |
7274 | 1 CONTINUE | |
7275 | ICRJSS = ICRJSS+1 | |
7276 | RETURN | |
7277 | ||
7278 | 9999 CONTINUE | |
7279 | IREJ = 1 | |
7280 | RETURN | |
7281 | END | |
7282 | ||
7283 | *$ CREATE DT_VV2SCH.FOR | |
7284 | *COPY DT_VV2SCH | |
7285 | * | |
7286 | *===vv2sch=============================================================* | |
7287 | * | |
7288 | SUBROUTINE DT_VV2SCH | |
7289 | ||
7290 | ************************************************************************ | |
7291 | * Change Valence-Valence chain systems to Single CHain systems for * | |
7292 | * hadron-nucleus collisions with meson or antibaryon projectile. * | |
7293 | * (Reggeon contribution) * | |
7294 | * The single chain system is approximately treated as one chain and a * | |
7295 | * meson at rest. * | |
7296 | * This version dated 18.01.95 is written by S. Roesler * | |
7297 | ************************************************************************ | |
7298 | ||
7299 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7300 | SAVE | |
7301 | PARAMETER ( LINP = 10 , | |
7302 | & LOUT = 6 , | |
7303 | & LDAT = 9 ) | |
7304 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) | |
7305 | ||
7306 | LOGICAL LSTART | |
7307 | ||
7308 | * event history | |
7309 | PARAMETER (NMXHKK=200000) | |
7310 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7311 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7312 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7313 | * extended event history | |
7314 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7315 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7316 | & IHIST(2,NMXHKK) | |
7317 | * flags for input different options | |
7318 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7319 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7320 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7321 | * statistics | |
7322 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7323 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7324 | & ICEVTG(8,0:30) | |
7325 | ||
7326 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), | |
7327 | & PCH2(4) | |
7328 | ||
7329 | DATA LSTART /.TRUE./ | |
7330 | ||
7331 | IFSC = 0 | |
7332 | IF (LSTART) THEN | |
7333 | WRITE(LOUT,1000) | |
7334 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', | |
7335 | & 'valence chains treated') | |
7336 | LSTART = .FALSE. | |
7337 | ENDIF | |
7338 | ||
7339 | NSTOP = NHKK | |
7340 | ||
7341 | * get index of first chain | |
7342 | DO 1 I=NPOINT(3),NHKK | |
7343 | IF (IDHKK(I).EQ.88888) THEN | |
7344 | NC = I | |
7345 | GOTO 2 | |
7346 | ENDIF | |
7347 | 1 CONTINUE | |
7348 | ||
7349 | 2 CONTINUE | |
7350 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) | |
7351 | & .AND.(NC.LT.NSTOP)) THEN | |
7352 | * get valence-valence chains | |
7353 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN | |
7354 | * get "mother"-hadron indices | |
7355 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) | |
7356 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) | |
7357 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) | |
7358 | KTARG = IDT_ICIHAD(IDHKK(MO2)) | |
7359 | * Lab momentum of projectile hadron | |
7360 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) | |
7361 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ | |
7362 | & PHKK(3,MO1)**2) | |
7363 | ||
7364 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) | |
7365 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN | |
7366 | ICVV2S = ICVV2S+1 | |
7367 | * single chain requested | |
7368 | * get flavors of chain-end partons | |
7369 | MO(1) = JMOHKK(1,NC) | |
7370 | MO(2) = JMOHKK(2,NC) | |
7371 | MO(3) = JMOHKK(1,NC+3) | |
7372 | MO(4) = JMOHKK(2,NC+3) | |
7373 | DO 3 I=1,4 | |
7374 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) | |
7375 | IF(I,2) = 0 | |
7376 | IF (ABS(IDHKK(MO(I))).GE.1000) | |
7377 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) | |
7378 | 3 CONTINUE | |
7379 | * which one is the q-aq chain? | |
7380 | * N1,N1+1 - DTEVT1-entries for q-aq system | |
7381 | * N2,N2+1 - DTEVT1-entries for the other chain | |
7382 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN | |
7383 | K1 = 1 | |
7384 | K2 = 3 | |
7385 | N1 = NC-2 | |
7386 | N2 = NC+1 | |
7387 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN | |
7388 | K1 = 3 | |
7389 | K2 = 1 | |
7390 | N1 = NC+1 | |
7391 | N2 = NC-2 | |
7392 | ELSE | |
7393 | GOTO 10 | |
7394 | ENDIF | |
7395 | DO 4 K=1,4 | |
7396 | PP1(K) = PHKK(K,N1) | |
7397 | PT1(K) = PHKK(K,N1+1) | |
7398 | PP2(K) = PHKK(K,N2) | |
7399 | PT2(K) = PHKK(K,N2+1) | |
7400 | 4 CONTINUE | |
7401 | AMCH1 = PHKK(5,N1+2) | |
7402 | AMCH2 = PHKK(5,N2+2) | |
7403 | * get meson-identity corresponding to flavors of q-aq chain | |
7404 | ITMP = IRESRJ | |
7405 | IRESRJ = 0 | |
7406 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, | |
7407 | & ZERO,AMCH1N,1,IDUM) | |
7408 | IRESRJ = ITMP | |
7409 | * change kinematics of chains | |
7410 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), | |
7411 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), | |
7412 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7413 | IF (IREJ1.NE.0) GOTO 10 | |
7414 | * check second chain for resonance | |
7415 | IDCHAI = 2 | |
7416 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 | |
7417 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), | |
7418 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) | |
7419 | IF (IREJ1.NE.0) GOTO 10 | |
7420 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7421 | * add partons and chains to DTEVT1 | |
7422 | DO 5 K=1,4 | |
7423 | PCH1(K) = PP1(K)+PT1(K) | |
7424 | PCH2(K) = PP2(K)+PT2(K) | |
7425 | 5 CONTINUE | |
7426 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), | |
7427 | & PP1(3),PP1(4),0,0,0) | |
7428 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), | |
7429 | & PT1(2),PT1(3),PT1(4),0,0,0) | |
7430 | KCH = ISTHKK(N1+2)+100 | |
7431 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), | |
7432 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) | |
7433 | IDHKK(N1+2) = 22222 | |
7434 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), | |
7435 | & PP2(3),PP2(4),0,0,0) | |
7436 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), | |
7437 | & PT2(2),PT2(3),PT2(4),0,0,0) | |
7438 | KCH = ISTHKK(N2+2)+100 | |
7439 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), | |
7440 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) | |
7441 | IDHKK(N2+2) = 22222 | |
7442 | ENDIF | |
7443 | ENDIF | |
7444 | ELSE | |
7445 | GOTO 11 | |
7446 | ENDIF | |
7447 | 10 CONTINUE | |
7448 | NC = NC+6 | |
7449 | GOTO 2 | |
7450 | ||
7451 | 11 CONTINUE | |
7452 | ||
7453 | RETURN | |
7454 | END | |
7455 | ||
7456 | *$ CREATE DT_PHNSCH.FOR | |
7457 | *COPY DT_PHNSCH | |
7458 | * | |
7459 | *=== phnsch ===========================================================* | |
7460 | * | |
7461 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) | |
7462 | ||
7463 | *----------------------------------------------------------------------* | |
7464 | * * | |
7465 | * Probability for Hadron Nucleon Single CHain interactions: * | |
7466 | * * | |
7467 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * | |
7468 | * Infn - Milan * | |
7469 | * * | |
7470 | * Last change on 04-jan-94 by Alfredo Ferrari * | |
7471 | * * | |
7472 | * modified by J.R.for use in DTUNUC 6.1.94 * | |
7473 | * * | |
7474 | * Input variables: * | |
7475 | * Kp = hadron projectile index (Part numbering * | |
7476 | * scheme) * | |
7477 | * Ktarg = target nucleon index (1=proton, 8=neutron) * | |
7478 | * Plab = projectile laboratory momentum (GeV/c) * | |
7479 | * Output variable: * | |
7480 | * Phnsch = probability per single chain (particle * | |
7481 | * exchange) interactions * | |
7482 | * * | |
7483 | *----------------------------------------------------------------------* | |
7484 | ||
7485 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7486 | SAVE | |
7487 | ||
7488 | PARAMETER ( LUNOUT = 6 ) | |
7489 | PARAMETER ( LUNERR = 6 ) | |
7490 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
7491 | PARAMETER ( ZERZER = 0.D+00 ) | |
7492 | PARAMETER ( ONEONE = 1.D+00 ) | |
7493 | PARAMETER ( TWOTWO = 2.D+00 ) | |
7494 | PARAMETER ( FIVFIV = 5.D+00 ) | |
7495 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
7496 | ||
7497 | PARAMETER ( NALLWP = 39 ) | |
7498 | PARAMETER ( IDMAXP = 210 ) | |
7499 | ||
7500 | DIMENSION ICHRGE(39),AM(39) | |
7501 | ||
7502 | * particle properties (BAMJET index convention) | |
7503 | CHARACTER*8 ANAME | |
7504 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7505 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7506 | ||
7507 | DIMENSION KPTOIP(210) | |
7508 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
7509 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
7510 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
7511 | & IQTCHR(-6:6),MQUARK(3,39) | |
7512 | ||
7513 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) | |
7514 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) | |
454792a9 | 7515 | CPH SAVE SGTCOE, IHLP |
7516 | CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2 | |
9aaba0d6 | 7517 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) |
7518 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) | |
7519 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) | |
7520 | ||
7521 | * Conversion from part to paprop numbering | |
7522 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
7523 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, | |
7524 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ | |
7525 | ||
7526 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: | |
7527 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, | |
7528 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / | |
7529 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / | |
7530 | DATA SGTCO1 / | |
7531 | * 1st reaction: gamma p total | |
7532 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, | |
7533 | * 2nd reaction: gamma d total | |
7534 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, | |
7535 | * 3rd reaction: pi+ p total | |
7536 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , | |
7537 | * 4th reaction: pi- p total | |
7538 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, | |
7539 | * 5th reaction: pi+/- d total | |
7540 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, | |
7541 | * 6th reaction: K+ p total | |
7542 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, | |
7543 | * 7th reaction: K+ n total | |
7544 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, | |
7545 | * 8th reaction: K+ d total | |
7546 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, | |
7547 | * 9th reaction: K- p total | |
7548 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, | |
7549 | * 10th reaction: K- n total | |
7550 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ | |
7551 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / | |
7552 | DATA SGTCO2 / | |
7553 | * 11th reaction: K- d total | |
7554 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, | |
7555 | * 12th reaction: p p total | |
7556 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, | |
7557 | * 13th reaction: p n total | |
7558 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, | |
7559 | * 14th reaction: p d total | |
7560 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, | |
7561 | * 15th reaction: pbar p total | |
7562 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, | |
7563 | * 16th reaction: pbar n total | |
7564 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, | |
7565 | * 17th reaction: pbar d total | |
7566 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, | |
7567 | * 18th reaction: Lamda p total | |
7568 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ | |
7569 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / | |
7570 | DATA SGTCO3 / | |
7571 | * 19th reaction: pi+ p elastic | |
7572 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , | |
7573 | * 20th reaction: pi- p elastic | |
7574 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , | |
7575 | * 21st reaction: K+ p elastic | |
7576 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, | |
7577 | * 22nd reaction: K- p elastic | |
7578 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, | |
7579 | * 23rd reaction: p p elastic | |
7580 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, | |
7581 | * 24th reaction: p d elastic | |
7582 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, | |
7583 | * 25th reaction: pbar p elastic | |
7584 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, | |
7585 | * 26th reaction: pbar p elastic bis | |
7586 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, | |
7587 | * 27th reaction: pbar n elastic | |
7588 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, | |
7589 | * 28th reaction: Lamda p elastic | |
7590 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, | |
7591 | * 29th reaction: K- p ela bis | |
7592 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, | |
7593 | * 30th reaction: pi- p cx | |
7594 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , | |
7595 | * 31st reaction: K- p cx | |
7596 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , | |
7597 | * 32nd reaction: K+ n cx | |
7598 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , | |
7599 | * 33rd reaction: pbar p cx | |
7600 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / | |
7601 | * | |
7602 | * +-------------------------------------------------------------------* | |
7603 | ICHRGE(KTARG)=IICH(KTARG) | |
7604 | AM (KTARG)=AAM (KTARG) | |
7605 | * | Check for pi0 (d-dbar) | |
7606 | IF ( KP .NE. 26 ) THEN | |
7607 | IP = KPTOIP (KP) | |
7608 | IF(IP.EQ.0)IP=1 | |
7609 | ICHRGE(IP)=IICH(KP) | |
7610 | AM (IP)=AAM (KP) | |
7611 | * | | |
7612 | * +-------------------------------------------------------------------* | |
7613 | * | | |
7614 | ELSE | |
7615 | IP = 23 | |
7616 | ICHRGE(IP)=0 | |
7617 | END IF | |
7618 | * | | |
7619 | * +-------------------------------------------------------------------* | |
7620 | * +-------------------------------------------------------------------* | |
7621 | * | No such interactions for baryon-baryon | |
7622 | IF ( IIBAR (KP) .GT. 0 ) THEN | |
7623 | DT_PHNSCH = ZERZER | |
7624 | RETURN | |
7625 | * | | |
7626 | * +-------------------------------------------------------------------* | |
7627 | * | No "annihilation" diagram possible for K+ p/n | |
7628 | ELSE IF ( IP .EQ. 15 ) THEN | |
7629 | DT_PHNSCH = ZERZER | |
7630 | RETURN | |
7631 | * | | |
7632 | * +-------------------------------------------------------------------* | |
7633 | * | No "annihilation" diagram possible for K0 p/n | |
7634 | ELSE IF ( IP .EQ. 24 ) THEN | |
7635 | DT_PHNSCH = ZERZER | |
7636 | RETURN | |
7637 | * | | |
7638 | * +-------------------------------------------------------------------* | |
7639 | * | No "annihilation" diagram possible for Omebar p/n | |
7640 | ELSE IF ( IP .GE. 38 ) THEN | |
7641 | DT_PHNSCH = ZERZER | |
7642 | RETURN | |
7643 | END IF | |
7644 | * | | |
7645 | * +-------------------------------------------------------------------* | |
7646 | * +-------------------------------------------------------------------* | |
7647 | * | If the momentum is larger than 50 GeV/c, compute the single | |
7648 | * | chain probability at 50 GeV/c and extrapolate to the present | |
7649 | * | momentum according to 1/sqrt(s) | |
7650 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch | |
7651 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) | |
7652 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 | |
7653 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) | |
7654 | * | x sqrt(s/s(50)) | |
7655 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
7656 | IF ( PLAB .GT. 50.D+00 ) THEN | |
7657 | PLA = 50.D+00 | |
7658 | AMPSQ = AM (IP)**2 | |
7659 | AMTSQ = AM (KTARG)**2 | |
7660 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7661 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7662 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7663 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7664 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7665 | * | | |
7666 | * +-------------------------------------------------------------------* | |
7667 | * | P < 3 GeV/c | |
7668 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN | |
7669 | PLA = 3.D+00 | |
7670 | AMPSQ = AM (IP)**2 | |
7671 | AMTSQ = AM (KTARG)**2 | |
7672 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7673 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7674 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7675 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7676 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7677 | * | | |
7678 | * +-------------------------------------------------------------------* | |
7679 | * | P < 50 GeV/c | |
7680 | ELSE | |
7681 | PLA = PLAB | |
7682 | UMORAT = ONEONE | |
7683 | END IF | |
7684 | * | | |
7685 | * +-------------------------------------------------------------------* | |
7686 | ALGPLA = LOG (PLA) | |
7687 | * +-------------------------------------------------------------------* | |
7688 | * | Pions: | |
7689 | IF ( IHLP (IP) .EQ. 2 ) THEN | |
7690 | ACOF = SGTCOE (1,3) | |
7691 | BCOF = SGTCOE (2,3) | |
7692 | ENNE = SGTCOE (3,3) | |
7693 | CCOF = SGTCOE (4,3) | |
7694 | DCOF = SGTCOE (5,3) | |
7695 | * | Compute the pi+ p total cross section: | |
7696 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7697 | & + DCOF * ALGPLA | |
7698 | ACOF = SGTCOE (1,19) | |
7699 | BCOF = SGTCOE (2,19) | |
7700 | ENNE = SGTCOE (3,19) | |
7701 | CCOF = SGTCOE (4,19) | |
7702 | DCOF = SGTCOE (5,19) | |
7703 | * | Compute the pi+ p elastic cross section: | |
7704 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7705 | & + DCOF * ALGPLA | |
7706 | * | Compute the pi+ p inelastic cross section: | |
7707 | SPPPIN = SPPPTT - SPPPEL | |
7708 | ACOF = SGTCOE (1,4) | |
7709 | BCOF = SGTCOE (2,4) | |
7710 | ENNE = SGTCOE (3,4) | |
7711 | CCOF = SGTCOE (4,4) | |
7712 | DCOF = SGTCOE (5,4) | |
7713 | * | Compute the pi- p total cross section: | |
7714 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7715 | & + DCOF * ALGPLA | |
7716 | ACOF = SGTCOE (1,20) | |
7717 | BCOF = SGTCOE (2,20) | |
7718 | ENNE = SGTCOE (3,20) | |
7719 | CCOF = SGTCOE (4,20) | |
7720 | DCOF = SGTCOE (5,20) | |
7721 | * | Compute the pi- p elastic cross section: | |
7722 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7723 | & + DCOF * ALGPLA | |
7724 | * | Compute the pi- p inelastic cross section: | |
7725 | SPMPIN = SPMPTT - SPMPEL | |
7726 | SIGDIA = SPMPIN - SPPPIN | |
7727 | * | +----------------------------------------------------------------* | |
7728 | * | | Charged pions: besides isospin consideration it is supposed | |
7729 | * | | that (pi+ n)el is almost equal to (pi- p)el | |
7730 | * | | and (pi+ p)el " " " " (pi- n)el | |
7731 | * | | and all are almost equal among each others | |
7732 | * | | (reasonable above 5 GeV/c) | |
7733 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7734 | KHELP = KTARG / 8 | |
7735 | JREAC = 3 + 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 total cross section: | |
7742 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7743 | & + DCOF * ALGPLA | |
7744 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP | |
7745 | ACOF = SGTCOE (1,JREAC) | |
7746 | BCOF = SGTCOE (2,JREAC) | |
7747 | ENNE = SGTCOE (3,JREAC) | |
7748 | CCOF = SGTCOE (4,JREAC) | |
7749 | DCOF = SGTCOE (5,JREAC) | |
7750 | * | | Compute the elastic cross section: | |
7751 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7752 | & + DCOF * ALGPLA | |
7753 | * | | Compute the inelastic cross section: | |
7754 | SHNCIN = SHNCTT - SHNCEL | |
7755 | * | | Number of diagrams: | |
7756 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP | |
7757 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7758 | IQFSC1 = 1 + IP - 13 | |
7759 | IQFSC2 = 0 | |
7760 | IQBSC1 = 1 + KHELP | |
7761 | IQBSC2 = 1 + IP - 13 | |
7762 | * | | | |
7763 | * | +----------------------------------------------------------------* | |
7764 | * | | pi0: besides isospin consideration it is supposed that the | |
7765 | * | | elastic cross section is not very different from | |
7766 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) | |
7767 | ELSE | |
7768 | KHELP = KTARG / 8 | |
7769 | K2HLP = ( KP - 23 ) / 3 | |
7770 | * | | Number of diagrams: | |
7771 | * | | For u ubar (k2hlp=0): | |
7772 | * NDIAGR = 2 - KHELP | |
7773 | * | | For d dbar (k2hlp=1): | |
7774 | * NDIAGR = 2 + KHELP - K2HLP | |
7775 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP | |
7776 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) | |
7777 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7778 | IQFSC1 = 1 + K2HLP | |
7779 | IQFSC2 = 0 | |
7780 | IQBSC1 = 1 + KHELP | |
7781 | IQBSC2 = 2 - K2HLP | |
7782 | END IF | |
7783 | * | | | |
7784 | * | +----------------------------------------------------------------* | |
7785 | * | end pi's | |
7786 | * +-------------------------------------------------------------------* | |
7787 | * | Kaons: | |
7788 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN | |
7789 | ACOF = SGTCOE (1,6) | |
7790 | BCOF = SGTCOE (2,6) | |
7791 | ENNE = SGTCOE (3,6) | |
7792 | CCOF = SGTCOE (4,6) | |
7793 | DCOF = SGTCOE (5,6) | |
7794 | * | Compute the K+ p total cross section: | |
7795 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7796 | & + DCOF * ALGPLA | |
7797 | ACOF = SGTCOE (1,21) | |
7798 | BCOF = SGTCOE (2,21) | |
7799 | ENNE = SGTCOE (3,21) | |
7800 | CCOF = SGTCOE (4,21) | |
7801 | DCOF = SGTCOE (5,21) | |
7802 | * | Compute the K+ p elastic cross section: | |
7803 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7804 | & + DCOF * ALGPLA | |
7805 | * | Compute the K+ p inelastic cross section: | |
7806 | SKPPIN = SKPPTT - SKPPEL | |
7807 | ACOF = SGTCOE (1,9) | |
7808 | BCOF = SGTCOE (2,9) | |
7809 | ENNE = SGTCOE (3,9) | |
7810 | CCOF = SGTCOE (4,9) | |
7811 | DCOF = SGTCOE (5,9) | |
7812 | * | Compute the K- p total cross section: | |
7813 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7814 | & + DCOF * ALGPLA | |
7815 | ACOF = SGTCOE (1,22) | |
7816 | BCOF = SGTCOE (2,22) | |
7817 | ENNE = SGTCOE (3,22) | |
7818 | CCOF = SGTCOE (4,22) | |
7819 | DCOF = SGTCOE (5,22) | |
7820 | * | Compute the K- p elastic cross section: | |
7821 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7822 | & + DCOF * ALGPLA | |
7823 | * | Compute the K- p inelastic cross section: | |
7824 | SKMPIN = SKMPTT - SKMPEL | |
7825 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) | |
7826 | * | +----------------------------------------------------------------* | |
7827 | * | | Charged Kaons: actually only K- | |
7828 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7829 | KHELP = KTARG / 8 | |
7830 | * | | +-------------------------------------------------------------* | |
7831 | * | | | Proton target: | |
7832 | IF ( KHELP .EQ. 0 ) THEN | |
7833 | SHNCIN = SKMPIN | |
7834 | * | | | Number of diagrams: | |
7835 | NDIAGR = 2 | |
7836 | * | | | | |
7837 | * | | +-------------------------------------------------------------* | |
7838 | * | | | Neutron target: besides isospin consideration it is supposed | |
7839 | * | | | that (K- n)el is almost equal to (K- p)el | |
7840 | * | | | (reasonable above 5 GeV/c) | |
7841 | ELSE | |
7842 | ACOF = SGTCOE (1,10) | |
7843 | BCOF = SGTCOE (2,10) | |
7844 | ENNE = SGTCOE (3,10) | |
7845 | CCOF = SGTCOE (4,10) | |
7846 | DCOF = SGTCOE (5,10) | |
7847 | * | | | Compute the total cross section: | |
7848 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7849 | & + DCOF * ALGPLA | |
7850 | * | | | Compute the elastic cross section: | |
7851 | SHNCEL = SKMPEL | |
7852 | * | | | Compute the inelastic cross section: | |
7853 | SHNCIN = SHNCTT - SHNCEL | |
7854 | * | | | Number of diagrams: | |
7855 | NDIAGR = 1 | |
7856 | END IF | |
7857 | * | | | | |
7858 | * | | +-------------------------------------------------------------* | |
7859 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7860 | IQFSC1 = 3 | |
7861 | IQFSC2 = 0 | |
7862 | IQBSC1 = 1 + KHELP | |
7863 | IQBSC2 = 2 | |
7864 | * | | | |
7865 | * | +----------------------------------------------------------------* | |
7866 | * | | K0's: (actually only K0bar) | |
7867 | ELSE | |
7868 | KHELP = KTARG / 8 | |
7869 | * | | +-------------------------------------------------------------* | |
7870 | * | | | Proton target: (K0bar p)in supposed to be given by | |
7871 | * | | | (K- p)in - Sig_diagr | |
7872 | IF ( KHELP .EQ. 0 ) THEN | |
7873 | SHNCIN = SKMPIN - SIGDIA | |
7874 | * | | | Number of diagrams: | |
7875 | NDIAGR = 1 | |
7876 | * | | | | |
7877 | * | | +-------------------------------------------------------------* | |
7878 | * | | | Neutron target: (K0bar n)in supposed to be given by | |
7879 | * | | | (K- n)in + Sig_diagr | |
7880 | * | | | besides isospin consideration it is supposed | |
7881 | * | | | that (K- n)el is almost equal to (K- p)el | |
7882 | * | | | (reasonable above 5 GeV/c) | |
7883 | ELSE | |
7884 | ACOF = SGTCOE (1,10) | |
7885 | BCOF = SGTCOE (2,10) | |
7886 | ENNE = SGTCOE (3,10) | |
7887 | CCOF = SGTCOE (4,10) | |
7888 | DCOF = SGTCOE (5,10) | |
7889 | * | | | Compute the total cross section: | |
7890 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7891 | & + DCOF * ALGPLA | |
7892 | * | | | Compute the elastic cross section: | |
7893 | SHNCEL = SKMPEL | |
7894 | * | | | Compute the inelastic cross section: | |
7895 | SHNCIN = SHNCTT - SHNCEL + SIGDIA | |
7896 | * | | | Number of diagrams: | |
7897 | NDIAGR = 2 | |
7898 | END IF | |
7899 | * | | | | |
7900 | * | | +-------------------------------------------------------------* | |
7901 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7902 | IQFSC1 = 3 | |
7903 | IQFSC2 = 0 | |
7904 | IQBSC1 = 1 | |
7905 | IQBSC2 = 1 + KHELP | |
7906 | END IF | |
7907 | * | | | |
7908 | * | +----------------------------------------------------------------* | |
7909 | * | end Kaon's | |
7910 | * +-------------------------------------------------------------------* | |
7911 | * | Antinucleons: | |
7912 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN | |
7913 | * | For momenta between 3 and 5 GeV/c the use of tabulated data | |
7914 | * | should be implemented! | |
7915 | ACOF = SGTCOE (1,15) | |
7916 | BCOF = SGTCOE (2,15) | |
7917 | ENNE = SGTCOE (3,15) | |
7918 | CCOF = SGTCOE (4,15) | |
7919 | DCOF = SGTCOE (5,15) | |
7920 | * | Compute the pbar p total cross section: | |
7921 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7922 | & + DCOF * ALGPLA | |
7923 | IF ( PLA .LT. FIVFIV ) THEN | |
7924 | JREAC = 26 | |
7925 | ELSE | |
7926 | JREAC = 25 | |
7927 | END IF | |
7928 | ACOF = SGTCOE (1,JREAC) | |
7929 | BCOF = SGTCOE (2,JREAC) | |
7930 | ENNE = SGTCOE (3,JREAC) | |
7931 | CCOF = SGTCOE (4,JREAC) | |
7932 | DCOF = SGTCOE (5,JREAC) | |
7933 | * | Compute the pbar p elastic cross section: | |
7934 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7935 | & + DCOF * ALGPLA | |
7936 | * | Compute the pbar p inelastic cross section: | |
7937 | SAPPIN = SAPPTT - SAPPEL | |
7938 | ACOF = SGTCOE (1,12) | |
7939 | BCOF = SGTCOE (2,12) | |
7940 | ENNE = SGTCOE (3,12) | |
7941 | CCOF = SGTCOE (4,12) | |
7942 | DCOF = SGTCOE (5,12) | |
7943 | * | Compute the p p total cross section: | |
7944 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7945 | & + DCOF * ALGPLA | |
7946 | ACOF = SGTCOE (1,23) | |
7947 | BCOF = SGTCOE (2,23) | |
7948 | ENNE = SGTCOE (3,23) | |
7949 | CCOF = SGTCOE (4,23) | |
7950 | DCOF = SGTCOE (5,23) | |
7951 | * | Compute the p p elastic cross section: | |
7952 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7953 | & + DCOF * ALGPLA | |
7954 | * | Compute the K- p inelastic cross section: | |
7955 | SPPINE = SPPTOT - SPPELA | |
7956 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV | |
7957 | KHELP = KTARG / 8 | |
7958 | * | +----------------------------------------------------------------* | |
7959 | * | | Pbar: | |
7960 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7961 | NDIAGR = 5 - KHELP | |
7962 | * | | +-------------------------------------------------------------* | |
7963 | * | | | Proton target: | |
7964 | IF ( KHELP .EQ. 0 ) THEN | |
7965 | * | | | Number of diagrams: | |
7966 | SHNCIN = SAPPIN | |
7967 | PUUBAR = 0.8D+00 | |
7968 | * | | | | |
7969 | * | | +-------------------------------------------------------------* | |
7970 | * | | | Neutron target: it is supposed that (ap n)el is almost equal | |
7971 | * | | | to (ap p)el (reasonable above 5 GeV/c) | |
7972 | ELSE | |
7973 | ACOF = SGTCOE (1,16) | |
7974 | BCOF = SGTCOE (2,16) | |
7975 | ENNE = SGTCOE (3,16) | |
7976 | CCOF = SGTCOE (4,16) | |
7977 | DCOF = SGTCOE (5,16) | |
7978 | * | | | Compute the total cross section: | |
7979 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7980 | & + DCOF * ALGPLA | |
7981 | * | | | Compute the elastic cross section: | |
7982 | SHNCEL = SAPPEL | |
7983 | * | | | Compute the inelastic cross section: | |
7984 | SHNCIN = SHNCTT - SHNCEL | |
7985 | PUUBAR = HLFHLF | |
7986 | END IF | |
7987 | * | | | | |
7988 | * | | +-------------------------------------------------------------* | |
7989 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7990 | * | | there are different possibilities, make a random choiche: | |
7991 | IQFSC1 = -1 | |
7992 | RNCHEN = DT_RNDM(PUUBAR) | |
7993 | IF ( RNCHEN .LT. PUUBAR ) THEN | |
7994 | IQFSC2 = -2 | |
7995 | ELSE | |
7996 | IQFSC2 = -1 | |
7997 | END IF | |
7998 | IQBSC1 = -IQFSC1 + KHELP | |
7999 | IQBSC2 = -IQFSC2 | |
8000 | * | | | |
8001 | * | +----------------------------------------------------------------* | |
8002 | * | | nbar: | |
8003 | ELSE | |
8004 | NDIAGR = 4 + KHELP | |
8005 | * | | +-------------------------------------------------------------* | |
8006 | * | | | Proton target: (nbar p)in supposed to be given by | |
8007 | * | | | (pbar p)in - Sig_diagr | |
8008 | IF ( KHELP .EQ. 0 ) THEN | |
8009 | SHNCIN = SAPPIN - SIGDIA | |
8010 | PDDBAR = HLFHLF | |
8011 | * | | | | |
8012 | * | | +-------------------------------------------------------------* | |
8013 | * | | | Neutron target: (nbar n)el is supposed to be equal to | |
8014 | * | | | (pbar p)el (reasonable above 5 GeV/c) | |
8015 | ELSE | |
8016 | * | | | Compute the total cross section: | |
8017 | SHNCTT = SAPPTT | |
8018 | * | | | Compute the elastic cross section: | |
8019 | SHNCEL = SAPPEL | |
8020 | * | | | Compute the inelastic cross section: | |
8021 | SHNCIN = SHNCTT - SHNCEL | |
8022 | PDDBAR = 0.8D+00 | |
8023 | END IF | |
8024 | * | | | | |
8025 | * | | +-------------------------------------------------------------* | |
8026 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8027 | * | | there are different possibilities, make a random choiche: | |
8028 | IQFSC1 = -2 | |
8029 | RNCHEN = DT_RNDM(RNCHEN) | |
8030 | IF ( RNCHEN .LT. PDDBAR ) THEN | |
8031 | IQFSC2 = -1 | |
8032 | ELSE | |
8033 | IQFSC2 = -2 | |
8034 | END IF | |
8035 | IQBSC1 = -IQFSC1 + KHELP - 1 | |
8036 | IQBSC2 = -IQFSC2 | |
8037 | END IF | |
8038 | * | | | |
8039 | * | +----------------------------------------------------------------* | |
8040 | * | | |
8041 | * +-------------------------------------------------------------------* | |
8042 | * | Others: not yet implemented | |
8043 | ELSE | |
8044 | SIGDIA = ZERZER | |
8045 | SHNCIN = ONEONE | |
8046 | NDIAGR = 0 | |
8047 | DT_PHNSCH = ZERZER | |
8048 | RETURN | |
8049 | END IF | |
8050 | * | end others | |
8051 | * +-------------------------------------------------------------------* | |
8052 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN | |
8053 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) | |
8054 | & + IQECHR (IQBSC2) | |
8055 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) | |
8056 | & + IQBCHR (IQBSC2) | |
8057 | IQECHC = IQECHC / 3 | |
8058 | IQBCHC = IQBCHC / 3 | |
8059 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) | |
8060 | & + IQSCHR (IQBSC2) | |
8061 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) | |
8062 | & + IQSCHR (MQUARK(3,IP)) | |
8063 | * +-------------------------------------------------------------------* | |
8064 | * | Consistency check: | |
8065 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN | |
8066 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', | |
8067 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8068 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', | |
8069 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8070 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) | |
8071 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) | |
8072 | END IF | |
8073 | * | | |
8074 | * +-------------------------------------------------------------------* | |
8075 | * +-------------------------------------------------------------------* | |
8076 | * | Consistency check: | |
8077 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) | |
8078 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN | |
8079 | WRITE (LUNOUT,*) | |
8080 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8081 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8082 | WRITE (LUNERR,*) | |
8083 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8084 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8085 | END IF | |
8086 | * | | |
8087 | * +-------------------------------------------------------------------* | |
8088 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
8089 | IF ( UMORAT .GT. ONEPLS ) | |
8090 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH | |
8091 | & - ONEONE ) * UMORAT + ONEONE ) | |
8092 | RETURN | |
8093 | * | |
8094 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) | |
8095 | DT_SCHQUA = ONEONE | |
8096 | JQFSC1 = IQFSC1 | |
8097 | JQFSC2 = IQFSC2 | |
8098 | JQBSC1 = IQBSC1 | |
8099 | JQBSC2 = IQBSC2 | |
8100 | *=== End of function Phnsch ===========================================* | |
8101 | RETURN | |
8102 | END | |
8103 | ||
8104 | *$ CREATE DT_RESPT.FOR | |
8105 | *COPY DT_RESPT | |
8106 | * | |
8107 | *===respt==============================================================* | |
8108 | * | |
8109 | SUBROUTINE DT_RESPT | |
8110 | ||
8111 | ************************************************************************ | |
8112 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * | |
8113 | * This version dated 18.01.95 is written by S. Roesler * | |
8114 | ************************************************************************ | |
8115 | ||
8116 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8117 | SAVE | |
8118 | PARAMETER ( LINP = 10 , | |
8119 | & LOUT = 6 , | |
8120 | & LDAT = 9 ) | |
8121 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8122 | ||
8123 | * event history | |
8124 | PARAMETER (NMXHKK=200000) | |
8125 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8126 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8127 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8128 | * extended event history | |
8129 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8130 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8131 | & IHIST(2,NMXHKK) | |
8132 | ||
8133 | * get index of first chain | |
8134 | DO 1 I=NPOINT(3),NHKK | |
8135 | IF (IDHKK(I).EQ.88888) THEN | |
8136 | NC = I | |
8137 | GOTO 2 | |
8138 | ENDIF | |
8139 | 1 CONTINUE | |
8140 | ||
8141 | 2 CONTINUE | |
8142 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN | |
8143 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) | |
8144 | * skip VV-,SS- systems | |
8145 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. | |
8146 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN | |
8147 | * check if both "chains" are resonances | |
8148 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN | |
8149 | CALL DT_SAPTRE(NC,NC+3) | |
8150 | ENDIF | |
8151 | ENDIF | |
8152 | ELSE | |
8153 | GOTO 3 | |
8154 | ENDIF | |
8155 | NC = NC+6 | |
8156 | GOTO 2 | |
8157 | ||
8158 | 3 CONTINUE | |
8159 | ||
8160 | RETURN | |
8161 | END | |
8162 | ||
8163 | *$ CREATE DT_EVTRES.FOR | |
8164 | *COPY DT_EVTRES | |
8165 | * | |
8166 | *===evtres=============================================================* | |
8167 | * | |
8168 | SUBROUTINE DT_EVTRES(IREJ) | |
8169 | ||
8170 | ************************************************************************ | |
8171 | * This version dated 14.12.94 is written by S. Roesler * | |
8172 | ************************************************************************ | |
8173 | ||
8174 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8175 | SAVE | |
8176 | PARAMETER ( LINP = 10 , | |
8177 | & LOUT = 6 , | |
8178 | & LDAT = 9 ) | |
8179 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) | |
8180 | ||
8181 | * event history | |
8182 | PARAMETER (NMXHKK=200000) | |
8183 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8184 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8185 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8186 | * extended event history | |
8187 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8188 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8189 | & IHIST(2,NMXHKK) | |
8190 | * flags for input different options | |
8191 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8192 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8193 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8194 | * particle properties (BAMJET index convention) | |
8195 | CHARACTER*8 ANAME | |
8196 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
8197 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
8198 | ||
8199 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) | |
8200 | ||
8201 | IREJ = 0 | |
8202 | ||
8203 | DO 1 I=NPOINT(3),NHKK | |
8204 | IF (ABS(IDRES(I)).GE.100) THEN | |
8205 | AMMX = 0.0D0 | |
8206 | DO 2 J=NPOINT(3),NHKK | |
8207 | IF (IDHKK(J).EQ.88888) THEN | |
8208 | IF (PHKK(5,J).GT.AMMX) THEN | |
8209 | AMMX = PHKK(5,J) | |
8210 | IMMX = J | |
8211 | ENDIF | |
8212 | ENDIF | |
8213 | 2 CONTINUE | |
8214 | IF (IDRES(IMMX).NE.0) THEN | |
8215 | IF (IOULEV(3).GT.0) THEN | |
8216 | WRITE(LOUT,'(1X,A)') | |
8217 | & 'EVTRES: no chain for correc. found' | |
8218 | C GOTO 6 | |
8219 | GOTO 9999 | |
8220 | ELSE | |
8221 | GOTO 9999 | |
8222 | ENDIF | |
8223 | ENDIF | |
8224 | IMO11 = JMOHKK(1,I) | |
8225 | IMO12 = JMOHKK(2,I) | |
8226 | IF (PHKK(3,IMO11).LT.0.0D0) THEN | |
8227 | IMO11 = JMOHKK(2,I) | |
8228 | IMO12 = JMOHKK(1,I) | |
8229 | ENDIF | |
8230 | IMO21 = JMOHKK(1,IMMX) | |
8231 | IMO22 = JMOHKK(2,IMMX) | |
8232 | IF (PHKK(3,IMO21).LT.0.0D0) THEN | |
8233 | IMO21 = JMOHKK(2,IMMX) | |
8234 | IMO22 = JMOHKK(1,IMMX) | |
8235 | ENDIF | |
8236 | AMCH1 = PHKK(5,I) | |
8237 | AMCH1N = AAM(IDXRES(I)) | |
8238 | ||
8239 | IFPR1 = IDHKK(IMO11) | |
8240 | IFPR2 = IDHKK(IMO21) | |
8241 | IFTA1 = IDHKK(IMO12) | |
8242 | IFTA2 = IDHKK(IMO22) | |
8243 | DO 4 J=1,4 | |
8244 | PP1(J) = PHKK(J,IMO11) | |
8245 | PP2(J) = PHKK(J,IMO21) | |
8246 | PT1(J) = PHKK(J,IMO12) | |
8247 | PT2(J) = PHKK(J,IMO22) | |
8248 | 4 CONTINUE | |
8249 | * store initial configuration for energy-momentum cons. check | |
8250 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) | |
8251 | * correct kinematics of second chain | |
8252 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
8253 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
8254 | IF (IREJ1.NE.0) GOTO 9999 | |
8255 | * check now this chain for resonance mass | |
8256 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) | |
8257 | IFP(2) = 0 | |
8258 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) | |
8259 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) | |
8260 | IFT(2) = 0 | |
8261 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) | |
8262 | IDCH2 = 2 | |
8263 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 | |
8264 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 | |
8265 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, | |
8266 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
8267 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN | |
8268 | IF (IOULEV(1).GT.0) | |
8269 | & WRITE(LOUT,*) ' correction for resonance not poss.' | |
8270 | **sr test | |
8271 | C GOTO 1 | |
8272 | C GOTO 9999 | |
8273 | ** | |
8274 | ENDIF | |
8275 | * store final configuration for energy-momentum cons. check | |
8276 | IF (LEMCCK) THEN | |
8277 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) | |
8278 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
8279 | IF (IREJ1.NE.0) GOTO 9999 | |
8280 | ENDIF | |
8281 | DO 5 J=1,4 | |
8282 | PHKK(J,IMO11) = PP1(J) | |
8283 | PHKK(J,IMO21) = PP2(J) | |
8284 | PHKK(J,IMO12) = PT1(J) | |
8285 | PHKK(J,IMO22) = PT2(J) | |
8286 | 5 CONTINUE | |
8287 | * correct entries of chains | |
8288 | DO 3 K=1,4 | |
8289 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) | |
8290 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) | |
8291 | 3 CONTINUE | |
8292 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 | |
8293 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- | |
8294 | & PHKK(3,IMMX)**2 | |
8295 | * ?? the following should now be obsolete | |
8296 | **sr test | |
8297 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN | |
8298 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8299 | ** | |
8300 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8301 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 | |
8302 | C GOTO 9999 | |
8303 | GOTO 1 | |
8304 | ENDIF | |
8305 | PHKK(5,I) = SQRT(AM1) | |
8306 | PHKK(5,IMMX) = SQRT(AM2) | |
8307 | IDRES(I) = IDRES(I)/100 | |
8308 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. | |
8309 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN | |
8310 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8311 | & 'EVTRES: inconsistent chain-masses', | |
8312 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 | |
8313 | GOTO 9999 | |
8314 | ENDIF | |
8315 | ENDIF | |
8316 | 1 CONTINUE | |
8317 | 6 CONTINUE | |
8318 | RETURN | |
8319 | ||
8320 | 9999 CONTINUE | |
8321 | IREJ = 1 | |
8322 | RETURN | |
8323 | END | |
8324 | ||
8325 | *$ CREATE DT_GETSPT.FOR | |
8326 | *COPY DT_GETSPT | |
8327 | * | |
8328 | *===getspt=============================================================* | |
8329 | * | |
8330 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, | |
8331 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, | |
8332 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) | |
8333 | ||
8334 | ************************************************************************ | |
8335 | * This version dated 12.12.94 is written by S. Roesler * | |
8336 | ************************************************************************ | |
8337 | ||
8338 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8339 | SAVE | |
8340 | PARAMETER ( LINP = 10 , | |
8341 | & LOUT = 6 , | |
8342 | & LDAT = 9 ) | |
8343 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) | |
8344 | ||
8345 | * various options for treatment of partons (DTUNUC 1.x) | |
8346 | * (chain recombination, Cronin,..) | |
8347 | LOGICAL LCO2CR,LINTPT | |
8348 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8349 | & LCO2CR,LINTPT | |
8350 | * flags for input different options | |
8351 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8352 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8353 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8354 | * flags for diffractive interactions (DTUNUC 1.x) | |
8355 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
8356 | ||
8357 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), | |
8358 | & PT2(4),PT2I(4),P1(4),P2(4), | |
8359 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), | |
8360 | & PTOTI(4),PTOTF(4),DIFF(4) | |
8361 | ||
8362 | IC = 0 | |
8363 | IREJ = 0 | |
8364 | C B33P = 4.0D0 | |
8365 | C B33T = 4.0D0 | |
8366 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 | |
8367 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 | |
8368 | REDU = 1.0D0 | |
8369 | C B33P = 3.5D0 | |
8370 | C B33T = 3.5D0 | |
8371 | B33P = 4.0D0 | |
8372 | B33T = 4.0D0 | |
8373 | IF (IDIFF.NE.0) THEN | |
8374 | B33P = 16.0D0 | |
8375 | B33T = 16.0D0 | |
8376 | ENDIF | |
8377 | ||
8378 | DO 1 I=1,4 | |
8379 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) | |
8380 | PP1(I) = PP1I(I) | |
8381 | PP2(I) = PP2I(I) | |
8382 | PT1(I) = PT1I(I) | |
8383 | PT2(I) = PT2I(I) | |
8384 | 1 CONTINUE | |
8385 | * get initial chain masses | |
8386 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8387 | & +(PP1(3)+PT1(3))**2) | |
8388 | ECH = PP1(4)+PT1(4) | |
8389 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
8390 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8391 | & +(PP2(3)+PT2(3))**2) | |
8392 | ECH = PP2(4)+PT2(4) | |
8393 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
8394 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8395 | IF (IOULEV(1).GT.0) | |
8396 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', | |
8397 | & AM1,AM2 | |
8398 | GOTO 9999 | |
8399 | ENDIF | |
8400 | AM1 = SQRT(AM1) | |
8401 | AM2 = SQRT(AM2) | |
8402 | AM1N = ZERO | |
8403 | AM2N = ZERO | |
8404 | ||
8405 | MODE = 0 | |
8406 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN | |
8407 | C MODE = 0 | |
8408 | C ELSE | |
8409 | C MODE = 1 | |
8410 | C IF (AM1.LT.0.6) THEN | |
8411 | C B33P = 10.0D0 | |
8412 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN | |
8413 | CC B33P = 4.0D0 | |
8414 | C ENDIF | |
8415 | C IF (AM2.LT.0.6) THEN | |
8416 | C B33T = 10.0D0 | |
8417 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN | |
8418 | CC B33T = 4.0D0 | |
8419 | C ENDIF | |
8420 | C ENDIF | |
8421 | ||
8422 | * check chain masses for very low mass chains | |
8423 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8424 | C & AM1,DUM,-IDCH1,IREJ1) | |
8425 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8426 | C & AM2,DUM,-IDCH2,IREJ2) | |
8427 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN | |
8428 | C B33P = 20.0D0 | |
8429 | C B33T = 20.0D0 | |
8430 | C ENDIF | |
8431 | ||
8432 | JMSHL = IMSHL | |
8433 | ||
8434 | 2 CONTINUE | |
8435 | IC = IC+1 | |
8436 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P | |
8437 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T | |
8438 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 | |
8439 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 | |
8440 | IF (MOD(IC,20).EQ.0) GOTO 7 | |
8441 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' | |
8442 | C RETURN | |
8443 | C GOTO 9999 | |
8444 | C ENDIF | |
8445 | ||
8446 | * get transverse momentum | |
8447 | IF (LINTPT) THEN | |
8448 | ES = -2.0D0/(B33P**2) | |
8449 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8450 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8451 | HPSP = HPSP*REDU | |
8452 | ES = -2.0D0/(B33T**2) | |
8453 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8454 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8455 | HPST = HPST*REDU | |
8456 | ELSE | |
8457 | HPSP = ZERO | |
8458 | HPST = ZERO | |
8459 | ENDIF | |
8460 | CALL DT_DSFECF(SFE1,CFE1) | |
8461 | CALL DT_DSFECF(SFE2,CFE2) | |
8462 | IF (MODE.EQ.0) THEN | |
8463 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8464 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8465 | PP2(1) = PP2I(1)-HPSP*CFE1 | |
8466 | PP2(2) = PP2I(2)-HPSP*SFE1 | |
8467 | PT1(1) = PT1I(1)+HPST*CFE2 | |
8468 | PT1(2) = PT1I(2)+HPST*SFE2 | |
8469 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8470 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8471 | ELSE | |
8472 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8473 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8474 | PT1(1) = PT1I(1)-HPSP*CFE1 | |
8475 | PT1(2) = PT1I(2)-HPSP*SFE1 | |
8476 | PP2(1) = PP2I(1)+HPST*CFE2 | |
8477 | PP2(2) = PP2I(2)+HPST*SFE2 | |
8478 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8479 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8480 | ENDIF | |
8481 | ||
8482 | * put partons on mass shell | |
8483 | XMP1 = 0.0D0 | |
8484 | XMT1 = 0.0D0 | |
8485 | IF (JMSHL.EQ.1) THEN | |
8486 | XMP1 = PYMASS(IFPR1) | |
8487 | XMT1 = PYMASS(IFTA1) | |
8488 | ENDIF | |
8489 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) | |
8490 | IF (IREJ1.NE.0) GOTO 2 | |
8491 | DO 3 I=1,4 | |
8492 | PTOTF(I) = P1(I)+P2(I) | |
8493 | PP1(I) = P1(I) | |
8494 | PT1(I) = P2(I) | |
8495 | 3 CONTINUE | |
8496 | XMP2 = 0.0D0 | |
8497 | XMT2 = 0.0D0 | |
8498 | IF (JMSHL.EQ.1) THEN | |
8499 | XMP2 = PYMASS(IFPR2) | |
8500 | XMT2 = PYMASS(IFTA2) | |
8501 | ENDIF | |
8502 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) | |
8503 | IF (IREJ1.NE.0) GOTO 2 | |
8504 | DO 4 I=1,4 | |
8505 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) | |
8506 | PP2(I) = P1(I) | |
8507 | PT2(I) = P2(I) | |
8508 | 4 CONTINUE | |
8509 | ||
8510 | * check consistency | |
8511 | DO 5 I=1,4 | |
8512 | DIFF(I) = PTOTI(I)-PTOTF(I) | |
8513 | 5 CONTINUE | |
8514 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. | |
8515 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN | |
8516 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF | |
8517 | GOTO 9999 | |
8518 | ENDIF | |
8519 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) | |
8520 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) | |
8521 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) | |
8522 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) | |
8523 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) | |
8524 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) | |
8525 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) | |
8526 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) | |
8527 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. | |
8528 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) | |
8529 | & THEN | |
8530 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') | |
8531 | & 'GETSPT: inconsistent masses', | |
8532 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 | |
8533 | * sr 22.11.00: commented. It should only have inconsistent masses for | |
8534 | * ultrahigh energies due to rounding problems | |
8535 | C GOTO 9999 | |
8536 | ENDIF | |
8537 | ||
8538 | * get chain masses | |
8539 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8540 | & +(PP1(3)+PT1(3))**2) | |
8541 | ECH = PP1(4)+PT1(4) | |
8542 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) | |
8543 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8544 | & +(PP2(3)+PT2(3))**2) | |
8545 | ECH = PP2(4)+PT2(4) | |
8546 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) | |
8547 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN | |
8548 | IF (IOULEV(1).GT.0) | |
8549 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', | |
8550 | & AM1N,AM2N | |
8551 | GOTO 2 | |
8552 | ENDIF | |
8553 | AM1N = SQRT(AM1N) | |
8554 | AM2N = SQRT(AM2N) | |
8555 | ||
8556 | * check chain masses for very low mass chains | |
8557 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8558 | & AM1N,DUM,-IDCH1,IREJ1) | |
8559 | IF (IREJ1.NE.0) GOTO 2 | |
8560 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8561 | & AM2N,DUM,-IDCH2,IREJ2) | |
8562 | IF (IREJ2.NE.0) GOTO 2 | |
8563 | ||
8564 | 7 CONTINUE | |
8565 | IF (AM1N.GT.ZERO) THEN | |
8566 | AM1 = AM1N | |
8567 | AM2 = AM2N | |
8568 | ENDIF | |
8569 | DO 6 I=1,4 | |
8570 | PP1I(I) = PP1(I) | |
8571 | PP2I(I) = PP2(I) | |
8572 | PT1I(I) = PT1(I) | |
8573 | PT2I(I) = PT2(I) | |
8574 | 6 CONTINUE | |
8575 | ||
8576 | RETURN | |
8577 | ||
8578 | 9999 CONTINUE | |
8579 | IREJ = 1 | |
8580 | RETURN | |
8581 | END | |
8582 | ||
8583 | *$ CREATE DT_SAPTRE.FOR | |
8584 | *COPY DT_SAPTRE | |
8585 | * | |
8586 | *===saptre=============================================================* | |
8587 | * | |
8588 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) | |
8589 | ||
8590 | ************************************************************************ | |
8591 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * | |
8592 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * | |
8593 | * Adopted from the original SAPTRE written by J. Ranft. * | |
8594 | * This version dated 18.01.95 is written by S. Roesler * | |
8595 | ************************************************************************ | |
8596 | ||
8597 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8598 | SAVE | |
8599 | PARAMETER ( LINP = 10 , | |
8600 | & LOUT = 6 , | |
8601 | & LDAT = 9 ) | |
8602 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8603 | ||
8604 | * event history | |
8605 | PARAMETER (NMXHKK=200000) | |
8606 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8607 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8608 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8609 | * extended event history | |
8610 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8611 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8612 | & IHIST(2,NMXHKK) | |
8613 | * flags for input different options | |
8614 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8615 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8616 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8617 | ||
8618 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
8619 | ||
8620 | DATA B3 /4.0D0/ | |
8621 | ||
8622 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) | |
8623 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) | |
8624 | ESMAX = MIN(ESMAX1,ESMAX2) | |
8625 | IF (ESMAX.LE.0.05D0) RETURN | |
8626 | ||
8627 | HMA = PHKK(5,IDX1) | |
8628 | DO 1 K=1,4 | |
8629 | PA1(K) = PHKK(K,IDX1) | |
8630 | PA2(K) = PHKK(K,IDX2) | |
8631 | 1 CONTINUE | |
8632 | ||
8633 | IF (LEMCCK) THEN | |
8634 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) | |
8635 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) | |
8636 | ENDIF | |
8637 | ||
8638 | EXEB = 0.0D0 | |
8639 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) | |
8640 | BEXP = HMA*(1.0D0-EXEB)/B3 | |
8641 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 | |
8642 | WA = AXEXP/(BEXP+AXEXP) | |
8643 | XAB = DT_RNDM(WA) | |
8644 | 10 CONTINUE | |
8645 | * ES is the transverse kinetic energy | |
8646 | IF (XAB.LT.WA)THEN | |
8647 | X = DT_RNDM(WA) | |
8648 | Y = DT_RNDM(WA) | |
8649 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) | |
8650 | ELSE | |
8651 | X = DT_RNDM(Y) | |
8652 | ES = ABS(-LOG(X+TINY7)/B3) | |
8653 | ENDIF | |
8654 | IF (ES.GT.ESMAX) GOTO 10 | |
8655 | ES = ES+HMA | |
8656 | * transverse momentum | |
8657 | HPS = SQRT((ES-HMA)*(ES+HMA)) | |
8658 | ||
8659 | CALL DT_DSFECF(SFE,CFE) | |
8660 | HPX = HPS*CFE | |
8661 | HPY = HPS*SFE | |
8662 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY | |
8663 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY | |
8664 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN | |
8665 | ||
8666 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) | |
8667 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) | |
8668 | PA1(1) = PA1(1)+HPX | |
8669 | PA1(2) = PA1(2)+HPY | |
8670 | PA2(1) = PA2(1)-HPX | |
8671 | PA2(2) = PA2(2)-HPY | |
8672 | ||
8673 | * put resonances on mass-shell again | |
8674 | XM1 = PHKK(5,IDX1) | |
8675 | XM2 = PHKK(5,IDX2) | |
8676 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) | |
8677 | IF (IREJ1.NE.0) RETURN | |
8678 | ||
8679 | IF (LEMCCK) THEN | |
8680 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) | |
8681 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) | |
8682 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) | |
8683 | IF (IREJ1.NE.0) RETURN | |
8684 | ENDIF | |
8685 | ||
8686 | DO 2 K=1,4 | |
8687 | PHKK(K,IDX1) = P1(K) | |
8688 | PHKK(K,IDX2) = P2(K) | |
8689 | 2 CONTINUE | |
8690 | ||
8691 | RETURN | |
8692 | END | |
8693 | ||
8694 | *$ CREATE DT_CRONIN.FOR | |
8695 | *COPY DT_CRONIN | |
8696 | * | |
8697 | *===cronin=============================================================* | |
8698 | * | |
8699 | SUBROUTINE DT_CRONIN(INCL) | |
8700 | ||
8701 | ************************************************************************ | |
8702 | * Cronin-Effect. Multiple scattering of partons at chain ends. * | |
8703 | * INCL = 1 multiple sc. in projectile * | |
8704 | * = 2 multiple sc. in target * | |
8705 | * This version dated 05.01.96 is written by S. Roesler. * | |
8706 | ************************************************************************ | |
8707 | ||
8708 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8709 | SAVE | |
8710 | PARAMETER ( LINP = 10 , | |
8711 | & LOUT = 6 , | |
8712 | & LDAT = 9 ) | |
8713 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8714 | ||
8715 | * event history | |
8716 | PARAMETER (NMXHKK=200000) | |
8717 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8718 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8719 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8720 | * extended event history | |
8721 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8722 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8723 | & IHIST(2,NMXHKK) | |
8724 | * rejection counter | |
8725 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8726 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8727 | & IREXCI(3),IRDIFF(2),IRINC | |
8728 | * Glauber formalism: collision properties | |
8729 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 8730 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
8731 | & NCP,NCT | |
9aaba0d6 | 8732 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) |
8733 | ||
8734 | DO 1 K=1,4 | |
8735 | DEV(K) = ZERO | |
8736 | 1 CONTINUE | |
8737 | ||
8738 | DO 2 I=NPOINT(2),NHKK | |
8739 | IF (ISTHKK(I).LT.0) THEN | |
8740 | * get z-position of the chain | |
8741 | R(1) = VHKK(1,I)*1.0D12 | |
8742 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC | |
8743 | R(2) = VHKK(2,I)*1.0D12 | |
8744 | IDXNU = JMOHKK(1,I) | |
8745 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) | |
8746 | & IDXNU = JMOHKK(1,I-1) | |
8747 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) | |
8748 | & IDXNU = JMOHKK(1,I+1) | |
8749 | R(3) = VHKK(3,IDXNU)*1.0D12 | |
8750 | * position of target parton the chain is connected to | |
8751 | DO 3 K=1,4 | |
8752 | PIN(K) = PHKK(K,I) | |
8753 | 3 CONTINUE | |
8754 | * multiple scattering of parton with DTEVT1-index I | |
8755 | CALL DT_CROMSC(PIN,R,POUT,INCL) | |
8756 | **testprint | |
8757 | C IF (NEVHKK.EQ.5) THEN | |
8758 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 | |
8759 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 | |
8760 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) | |
8761 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) | |
8762 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU | |
8763 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN | |
8764 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT | |
8765 | C ENDIF | |
8766 | ** | |
8767 | * increase accumulator by energy-momentum difference | |
8768 | DO 4 K=1,4 | |
8769 | DEV(K) = DEV(K)+POUT(K)-PIN(K) | |
8770 | PHKK(K,I) = POUT(K) | |
8771 | 4 CONTINUE | |
8772 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8773 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8774 | ENDIF | |
8775 | 2 CONTINUE | |
8776 | ||
8777 | * dump accumulator to momenta of valence partons | |
8778 | NVAL = 0 | |
8779 | ETOT = 0.0D0 | |
8780 | DO 5 I=NPOINT(2),NHKK | |
8781 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8782 | NVAL = NVAL+1 | |
8783 | ETOT = ETOT+PHKK(4,I) | |
8784 | ENDIF | |
8785 | 5 CONTINUE | |
8786 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) | |
8787 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, | |
8788 | & 9X,4E12.4) | |
8789 | DO 6 I=NPOINT(2),NHKK | |
8790 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8791 | E = PHKK(4,I) | |
8792 | DO 7 K=1,4 | |
8793 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) | |
8794 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT | |
8795 | 7 CONTINUE | |
8796 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8797 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8798 | ENDIF | |
8799 | 6 CONTINUE | |
8800 | ||
8801 | RETURN | |
8802 | END | |
8803 | ||
8804 | *$ CREATE DT_CROMSC.FOR | |
8805 | *COPY DT_CROMSC | |
8806 | * | |
8807 | *===cromsc=============================================================* | |
8808 | * | |
8809 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) | |
8810 | ||
8811 | ************************************************************************ | |
8812 | * Cronin-Effect. Multiple scattering of one parton passing through * | |
8813 | * nuclear matter. * | |
8814 | * PIN(4) input 4-momentum of parton * | |
8815 | * POUT(4) 4-momentum of parton after mult. scatt. * | |
8816 | * R(3) spatial position of parton in target nucleus * | |
8817 | * INCL = 1 multiple sc. in projectile * | |
8818 | * = 2 multiple sc. in target * | |
8819 | * This is a revised version of the original version written by J. Ranft* | |
8820 | * This version dated 17.01.95 is written by S. Roesler. * | |
8821 | ************************************************************************ | |
8822 | ||
8823 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8824 | SAVE | |
8825 | PARAMETER ( LINP = 10 , | |
8826 | & LOUT = 6 , | |
8827 | & LDAT = 9 ) | |
8828 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8829 | ||
8830 | LOGICAL LSTART | |
8831 | ||
8832 | * rejection counter | |
8833 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8834 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8835 | & IREXCI(3),IRDIFF(2),IRINC | |
8836 | * Glauber formalism: collision properties | |
8837 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 8838 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
8839 | & NCP,NCT | |
9aaba0d6 | 8840 | * various options for treatment of partons (DTUNUC 1.x) |
8841 | * (chain recombination, Cronin,..) | |
8842 | LOGICAL LCO2CR,LINTPT | |
8843 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8844 | & LCO2CR,LINTPT | |
8845 | ||
8846 | DIMENSION PIN(4),POUT(4),R(3) | |
8847 | ||
8848 | DATA LSTART /.TRUE./ | |
8849 | ||
8850 | IRCRON(1) = IRCRON(1)+1 | |
8851 | ||
8852 | IF (LSTART) THEN | |
8853 | WRITE(LOUT,1000) CRONCO | |
8854 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', | |
8855 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) | |
8856 | LSTART = .FALSE. | |
8857 | ENDIF | |
8858 | ||
8859 | NCBACK = 0 | |
8860 | RNCL = RPROJ | |
8861 | IF (INCL.EQ.2) RNCL = RTARG | |
8862 | ||
8863 | * Lorentz-transformation into Lab. | |
8864 | MODE = -(INCL+1) | |
8865 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) | |
8866 | ||
8867 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) | |
8868 | IF (PTOT.LE.8.0D0) GOTO 9997 | |
8869 | ||
8870 | * direction cosines of parton before mult. scattering | |
8871 | COSX = PIN(1)/PTOT | |
8872 | COSY = PIN(2)/PTOT | |
8873 | COSZ = PZ/PTOT | |
8874 | ||
8875 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 | |
8876 | IF (RTESQ.GE.-TINY3) GOTO 9999 | |
8877 | ||
8878 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) | |
8879 | * in the direction of particle motion | |
8880 | ||
8881 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) | |
8882 | TMP = A**2-RTESQ | |
8883 | IF (TMP.LT.ZERO) GOTO 9998 | |
8884 | DIST = -A+SQRT(TMP) | |
8885 | ||
8886 | * multiple scattering angle | |
8887 | THETO = CRONCO*SQRT(DIST)/PTOT | |
8888 | IF (THETO.GT.0.1D0) THETO=0.1D0 | |
8889 | ||
8890 | 1 CONTINUE | |
8891 | * Gaussian sampling of spatial angle | |
8892 | CALL DT_RANNOR(R1,R2) | |
8893 | THETA = ABS(R1*THETO) | |
8894 | IF (THETA.GT.0.3D0) GOTO 9997 | |
8895 | CALL DT_DSFECF(SFE,CFE) | |
8896 | COSTH = COS(THETA) | |
8897 | SINTH = SIN(THETA) | |
8898 | ||
8899 | * new direction cosines | |
8900 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, | |
8901 | & COSXN,COSYN,COSZN) | |
8902 | ||
8903 | POUT(1) = COSXN*PTOT | |
8904 | POUT(2) = COSYN*PTOT | |
8905 | PZ = COSZN*PTOT | |
8906 | * Lorentz-transformation into nucl.-nucl. cms | |
8907 | MODE = INCL+1 | |
8908 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) | |
8909 | ||
8910 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN | |
8911 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN | |
8912 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN | |
8913 | THETO = THETO/2.0D0 | |
8914 | NCBACK = NCBACK+1 | |
8915 | IF (MOD(NCBACK,200).EQ.0) THEN | |
8916 | WRITE(LOUT,1001) THETO,PIN,POUT | |
8917 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', | |
8918 | & E12.4,/,1X,' PIN :',4E12.4,/, | |
8919 | & 1X,' POUT:',4E12.4) | |
8920 | GOTO 9997 | |
8921 | ENDIF | |
8922 | GOTO 1 | |
8923 | ENDIF | |
8924 | ||
8925 | RETURN | |
8926 | ||
8927 | 9997 IRCRON(2) = IRCRON(2)+1 | |
8928 | GOTO 9999 | |
8929 | 9998 IRCRON(3) = IRCRON(3)+1 | |
8930 | ||
8931 | 9999 CONTINUE | |
8932 | DO 100 K=1,4 | |
8933 | POUT(K) = PIN(K) | |
8934 | 100 CONTINUE | |
8935 | RETURN | |
8936 | END | |
8937 | ||
8938 | *$ CREATE DT_COM2CR.FOR | |
8939 | *COPY DT_COM2CR | |
8940 | * | |
8941 | *===com2sr=============================================================* | |
8942 | * | |
8943 | SUBROUTINE DT_COM2CR | |
8944 | ||
8945 | ************************************************************************ | |
8946 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * | |
8947 | * CUTOF parameter determining minimum number of not * | |
8948 | * combined q-aq chains * | |
8949 | * This subroutine replaces KKEVCC etc. * | |
8950 | * This version dated 11.01.95 is written by S. Roesler. * | |
8951 | ************************************************************************ | |
8952 | ||
8953 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8954 | SAVE | |
8955 | PARAMETER ( LINP = 10 , | |
8956 | & LOUT = 6 , | |
8957 | & LDAT = 9 ) | |
8958 | ||
8959 | * event history | |
8960 | PARAMETER (NMXHKK=200000) | |
8961 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8962 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8963 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8964 | * extended event history | |
8965 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8966 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8967 | & IHIST(2,NMXHKK) | |
8968 | * statistics | |
8969 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
8970 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
8971 | & ICEVTG(8,0:30) | |
8972 | * various options for treatment of partons (DTUNUC 1.x) | |
8973 | * (chain recombination, Cronin,..) | |
8974 | LOGICAL LCO2CR,LINTPT | |
8975 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8976 | & LCO2CR,LINTPT | |
8977 | ||
8978 | DIMENSION IDXQA(248),IDXAQ(248) | |
8979 | ||
8980 | ICCHAI(1,9) = ICCHAI(1,9)+1 | |
8981 | NQA = 0 | |
8982 | NAQ = 0 | |
8983 | * scan DTEVT1 for q-aq, aq-q chains | |
8984 | DO 10 I=NPOINT(3),NHKK | |
8985 | * skip "chains" which are resonances | |
8986 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN | |
8987 | MO1 = JMOHKK(1,I) | |
8988 | MO2 = JMOHKK(2,I) | |
8989 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN | |
8990 | * q-aq, aq-q chain found, keep index | |
8991 | IF (IDHKK(MO1).GT.0) THEN | |
8992 | NQA = NQA+1 | |
8993 | IDXQA(NQA) = I | |
8994 | ELSE | |
8995 | NAQ = NAQ+1 | |
8996 | IDXAQ(NAQ) = I | |
8997 | ENDIF | |
8998 | ENDIF | |
8999 | ENDIF | |
9000 | 10 CONTINUE | |
9001 | ||
9002 | * minimum number of q-aq chains requested for the same projectile/ | |
9003 | * target | |
9004 | NCHMIN = IDT_NPOISS(CUTOF) | |
9005 | ||
9006 | * combine q-aq chains of the same projectile | |
9007 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) | |
9008 | * combine q-aq chains of the same target | |
9009 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) | |
9010 | * combine aq-q chains of the same projectile | |
9011 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) | |
9012 | * combine aq-q chains of the same target | |
9013 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) | |
9014 | ||
9015 | RETURN | |
9016 | END | |
9017 | ||
9018 | *$ CREATE DT_SCN4CR.FOR | |
9019 | *COPY DT_SCN4CR | |
9020 | * | |
9021 | *===scn4cr=============================================================* | |
9022 | * | |
9023 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) | |
9024 | ||
9025 | ************************************************************************ | |
9026 | * SCan q-aq chains for Color Ropes. * | |
9027 | * This version dated 11.01.95 is written by S. Roesler. * | |
9028 | ************************************************************************ | |
9029 | ||
9030 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9031 | SAVE | |
9032 | PARAMETER ( LINP = 10 , | |
9033 | & LOUT = 6 , | |
9034 | & LDAT = 9 ) | |
9035 | ||
9036 | * event history | |
9037 | PARAMETER (NMXHKK=200000) | |
9038 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9039 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9040 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9041 | * extended event history | |
9042 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9043 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9044 | & IHIST(2,NMXHKK) | |
9045 | ||
9046 | DIMENSION IDXCH(248),IDXJN(248) | |
9047 | ||
9048 | DO 1 I=1,NCH | |
9049 | IF (IDXCH(I).GT.0) THEN | |
9050 | NJOIN = 1 | |
9051 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) | |
9052 | IDXJN(NJOIN) = I | |
9053 | IF (I.LT.NCH) THEN | |
9054 | DO 2 J=I+1,NCH | |
9055 | IF (IDXCH(J).GT.0) THEN | |
9056 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) | |
9057 | IF (IDXMO.EQ.IDXMO1) THEN | |
9058 | NJOIN = NJOIN+1 | |
9059 | IDXJN(NJOIN) = J | |
9060 | ENDIF | |
9061 | ENDIF | |
9062 | 2 CONTINUE | |
9063 | ENDIF | |
9064 | IF (NJOIN.GE.NCHMIN+2) THEN | |
9065 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) | |
9066 | DO 3 J=1,2*NJ,2 | |
9067 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) | |
9068 | IF (IREJ1.NE.0) GOTO 3 | |
9069 | IDXCH(IDXJN(J)) = 0 | |
9070 | IDXCH(IDXJN(J+1)) = 0 | |
9071 | 3 CONTINUE | |
9072 | ENDIF | |
9073 | ENDIF | |
9074 | 1 CONTINUE | |
9075 | ||
9076 | RETURN | |
9077 | END | |
9078 | ||
9079 | *$ CREATE DT_JOIN.FOR | |
9080 | *COPY DT_JOIN | |
9081 | * | |
9082 | *===join===============================================================* | |
9083 | * | |
9084 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) | |
9085 | ||
9086 | ************************************************************************ | |
9087 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * | |
9088 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * | |
9089 | * This version dated 11.01.95 is written by S. Roesler. * | |
9090 | ************************************************************************ | |
9091 | ||
9092 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9093 | SAVE | |
9094 | PARAMETER ( LINP = 10 , | |
9095 | & LOUT = 6 , | |
9096 | & LDAT = 9 ) | |
9097 | ||
9098 | * event history | |
9099 | PARAMETER (NMXHKK=200000) | |
9100 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9101 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9102 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9103 | * extended event history | |
9104 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9105 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9106 | & IHIST(2,NMXHKK) | |
9107 | * flags for input different options | |
9108 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
9109 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
9110 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
9111 | * statistics | |
9112 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
9113 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
9114 | & ICEVTG(8,0:30) | |
9115 | ||
9116 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) | |
9117 | ||
9118 | IREJ = 0 | |
9119 | ||
9120 | IDX(1) = IDX1 | |
9121 | IDX(2) = IDX2 | |
9122 | DO 1 I=1,2 | |
9123 | DO 2 J=1,2 | |
9124 | MO(I,J) = JMOHKK(J,IDX(I)) | |
9125 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) | |
9126 | 2 CONTINUE | |
9127 | 1 CONTINUE | |
9128 | ||
9129 | * check consistency | |
9130 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. | |
9131 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. | |
9132 | & ((ID(1,1)*ID(2,1)).LT.0).OR. | |
9133 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN | |
9134 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), | |
9135 | & MO(2,2) | |
9136 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', | |
9137 | & 2I5,' chain ',I4,':',2I5) | |
9138 | ENDIF | |
9139 | ||
9140 | * join chains | |
9141 | DO 3 K=1,4 | |
9142 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) | |
9143 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) | |
9144 | 3 CONTINUE | |
9145 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) | |
9146 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) | |
9147 | IST1 = ISTHKK(MO(1,1)) | |
9148 | IST2 = ISTHKK(MO(1,2)) | |
9149 | ||
9150 | * put partons again on mass shell | |
9151 | XM1 = 0.0D0 | |
9152 | XM2 = 0.0D0 | |
9153 | IF (IMSHL.EQ.1) THEN | |
9154 | XM1 = PYMASS(IF1) | |
9155 | XM2 = PYMASS(IF2) | |
9156 | ENDIF | |
9157 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) | |
9158 | IF (IREJ1.NE.0) GOTO 9999 | |
9159 | DO 4 I=1,4 | |
9160 | PP(I) = P1(I) | |
9161 | PT(I) = P2(I) | |
9162 | 4 CONTINUE | |
9163 | ||
9164 | * store new partons in DTEVT1 | |
9165 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), | |
9166 | & 0,0,0) | |
9167 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), | |
9168 | & 0,0,0) | |
9169 | DO 5 K=1,4 | |
9170 | PCH(K) = PP(K)+PT(K) | |
9171 | 5 CONTINUE | |
9172 | ||
9173 | * check new chain for lower mass limit | |
9174 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
9175 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) | |
9176 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, | |
9177 | & AMCH,AMCHN,3,IREJ1) | |
9178 | IF (IREJ1.NE.0) THEN | |
9179 | NHKK = NHKK-2 | |
9180 | GOTO 9999 | |
9181 | ENDIF | |
9182 | ENDIF | |
9183 | ||
9184 | ICCHAI(2,9) = ICCHAI(2,9)+1 | |
9185 | * store new chain in DTEVT1 | |
9186 | KCH = 191 | |
9187 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) | |
9188 | IDHKK(IDX(1)) = 22222 | |
9189 | IDHKK(IDX(2)) = 22222 | |
9190 | * special treatment for space-time coordinates | |
9191 | DO 6 K=1,4 | |
9192 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 | |
9193 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 | |
9194 | 6 CONTINUE | |
9195 | RETURN | |
9196 | ||
9197 | 9999 CONTINUE | |
9198 | IREJ = 1 | |
9199 | RETURN | |
9200 | END | |
9201 | ||
9202 | *$ CREATE DT_XSGLAU.FOR | |
9203 | *COPY DT_XSGLAU | |
9204 | * | |
9205 | *===xsglau=============================================================* | |
9206 | * | |
9207 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) | |
9208 | ||
9209 | ************************************************************************ | |
9210 | * Total, elastic, quasi-elastic, inelastic cross sections according to * | |
9211 | * Glauber's approach. * | |
9212 | * NA / NB mass numbers of proj./target nuclei * | |
9213 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * | |
9214 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * | |
9215 | * IE,IQ indices of energy and virtuality (the latter for gamma * | |
9216 | * projectiles only) * | |
9217 | * NIDX index of projectile/target nucleus * | |
9218 | * This version dated 17.3.98 is written by S. Roesler * | |
9219 | ************************************************************************ | |
9220 | ||
9221 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9222 | SAVE | |
9223 | PARAMETER ( LINP = 10 , | |
9224 | & LOUT = 6 , | |
9225 | & LDAT = 9 ) | |
9226 | ||
9227 | COMPLEX*16 CZERO,CONE,CTWO | |
9228 | CHARACTER*12 CFILE | |
9229 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9230 | & ONETHI=ONE/THREE,TINY25=1.0D-25) | |
9231 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
9232 | & PI = TWOPI/TWO, | |
9233 | & GEV2MB = 0.38938D0, | |
9234 | & GEV2FM = 0.1972D0, | |
9235 | & ALPHEM = ONE/137.0D0, | |
9236 | * proton mass | |
9237 | & AMP = 0.938D0, | |
9238 | & AMP2 = AMP**2, | |
9239 | * approx. nucleon radius | |
9240 | & RNUCLE = 1.12D0) | |
9241 | ||
9242 | * particle properties (BAMJET index convention) | |
9243 | CHARACTER*8 ANAME | |
9244 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
9245 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
9246 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9247 | PARAMETER ( MAXNCL = 260, | |
9248 | & MAXVQU = MAXNCL, | |
9249 | & MAXSQU = 20*MAXVQU, | |
9250 | & MAXINT = MAXVQU+MAXSQU) | |
9251 | * Glauber formalism: parameters | |
9252 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9253 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9254 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9255 | & NSITEB,NSTATB | |
9256 | * Glauber formalism: cross sections | |
9257 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
9258 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
9259 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
9260 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
9261 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
9262 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
9263 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
9264 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
9265 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
9266 | & BSLOPE,NEBINI,NQBINI | |
9267 | * Glauber formalism: flags and parameters for statistics | |
9268 | LOGICAL LPROD | |
9269 | CHARACTER*8 CGLB | |
9270 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
9271 | * nucleon-nucleon event-generator | |
9272 | CHARACTER*8 CMODEL | |
9273 | LOGICAL LPHOIN | |
9274 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
9275 | * VDM parameter for photon-nucleus interactions | |
9276 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
9277 | * parameters for hA-diffraction | |
9278 | COMMON /DTDIHA/ DIBETA,DIALPH | |
9279 | ||
9280 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), | |
9281 | & OMPP11,OMPP12,OMPP21,OMPP22, | |
9282 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, | |
9283 | & PPTMP1,PPTMP2 | |
9284 | COMPLEX*16 C,CA,CI | |
9285 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), | |
9286 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), | |
9287 | & BPROD(KSITEB) | |
9288 | ||
9289 | PARAMETER (NPOINT=16) | |
9290 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
9291 | ||
9292 | LOGICAL LFIRST,LOPEN | |
9293 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ | |
9294 | ||
9295 | NTARG = ABS(NIDX) | |
9296 | * for quasi-elastic neutrino scattering set projectile to proton | |
9297 | * it should not have an effect since the whole Glauber-formalism is | |
9298 | * not needed for these interactions.. | |
9299 | IF (MCGENE.EQ.4) THEN | |
9300 | IJPROJ = 1 | |
9301 | ELSE | |
9302 | IJPROJ = JJPROJ | |
9303 | ENDIF | |
9304 | ||
9305 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN | |
9306 | I = INDEX(CGLB,' ') | |
9307 | IF (I.EQ.0) THEN | |
9308 | CFILE = CGLB//'.glb' | |
9309 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') | |
9310 | ELSEIF (I.GT.1) THEN | |
9311 | CFILE = CGLB(1:I-1)//'.glb' | |
9312 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') | |
9313 | ELSE | |
9314 | STOP 'XSGLAU 1' | |
9315 | ENDIF | |
9316 | LOPEN = .TRUE. | |
9317 | ENDIF | |
9318 | ||
9319 | CZERO = DCMPLX(ZERO,ZERO) | |
9320 | CONE = DCMPLX(ONE,ZERO) | |
9321 | CTWO = DCMPLX(TWO,ZERO) | |
9322 | NEBINI = IE | |
9323 | NQBINI = IQ | |
9324 | ||
9325 | * re-define kinematics | |
9326 | S = ECMI**2 | |
9327 | Q2 = Q2I | |
9328 | X = XI | |
9329 | * g(Q2=0)-A, h-A, A-A scattering | |
9330 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9331 | Q2 = 0.0001D0 | |
9332 | X = Q2/(S+Q2-AMP2) | |
9333 | * g(Q2>0)-A scattering | |
9334 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN | |
9335 | X = Q2/(S+Q2-AMP2) | |
9336 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9337 | Q2 = (S-AMP2)*X/(ONE-X) | |
9338 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
9339 | S = Q2*(ONE-X)/X+AMP2 | |
9340 | ELSE | |
9341 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X | |
9342 | STOP | |
9343 | ENDIF | |
9344 | ECMNN(IE) = SQRT(S) | |
9345 | Q2G(IQ) = Q2 | |
9346 | XNU = (S+Q2-AMP2)/(TWO*AMP) | |
9347 | ||
9348 | * parameters determining statistics in evaluating Glauber-xsection | |
9349 | NSTATB = JSTATB | |
9350 | NSITEB = JBINSB | |
9351 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB | |
9352 | ||
9353 | * set up interaction geometry (common /DTGLAM/) | |
9354 | * projectile/target radii | |
9355 | RPRNCL = DT_RNCLUS(NA) | |
9356 | RTANCL = DT_RNCLUS(NB) | |
9357 | IF (IJPROJ.EQ.7) THEN | |
9358 | RASH(1) = ZERO | |
9359 | RBSH(NTARG) = RTANCL | |
9360 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9361 | ELSE | |
9362 | IF (NIDX.LE.-1) THEN | |
9363 | RASH(1) = RPRNCL | |
9364 | RBSH(NTARG) = RTANCL | |
9365 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9366 | ELSE | |
9367 | RASH(NTARG) = RPRNCL | |
9368 | RBSH(1) = RTANCL | |
9369 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) | |
9370 | ENDIF | |
9371 | ENDIF | |
9372 | * maximum impact-parameter | |
9373 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) | |
9374 | ||
9375 | * slope, rho ( Re(f(0))/Im(f(0)) ) | |
9376 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
9377 | IF (MCGENE.EQ.2) THEN | |
9378 | ZERO1 = ZERO | |
9379 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, | |
9380 | & BSLOPE,0) | |
9381 | ELSE | |
9382 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
9383 | ENDIF | |
9384 | IF (ECMNN(IE).LE.3.0D0) THEN | |
9385 | ROSH = -0.43D0 | |
9386 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN | |
9387 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) | |
9388 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN | |
9389 | ROSH = 0.1D0 | |
9390 | ENDIF | |
9391 | ELSEIF (IJPROJ.EQ.7) THEN | |
9392 | ROSH = 0.1D0 | |
9393 | ELSE | |
9394 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
9395 | ROSH = 0.01D0 | |
9396 | ENDIF | |
9397 | ||
9398 | * projectile-nucleon xsection (in fm) | |
9399 | IF (IJPROJ.EQ.7) THEN | |
9400 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 | |
9401 | ELSE | |
9402 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
9403 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
9404 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
9405 | DUMZER = ZERO | |
9406 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
9407 | SIGSH = SIGSH/10.0D0 | |
9408 | ENDIF | |
9409 | ||
9410 | * parameters for projectile diffraction (hA scattering only) | |
9411 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) | |
9412 | & .AND.(DIBETA.GE.ZERO)) THEN | |
9413 | ZERO1 = ZERO | |
9414 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) | |
9415 | C DIBETA = SDIF1/STOT | |
9416 | DIBETA = 0.2D0 | |
9417 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) | |
9418 | IF (DIBETA.LE.ZERO) THEN | |
9419 | ALPGAM = ONE | |
9420 | ELSE | |
9421 | ALPGAM = DIALPH/DIGAMM | |
9422 | ENDIF | |
9423 | FACDI1 = ONE-ALPGAM | |
9424 | FACDI2 = ONE+ALPGAM | |
9425 | FACDI = SQRT(FACDI1*FACDI2) | |
9426 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM | |
9427 | ELSE | |
9428 | DIBETA = -1.0D0 | |
9429 | DIALPH = ZERO | |
9430 | DIGAMM = ZERO | |
9431 | FACDI1 = ZERO | |
9432 | FACDI2 = 2.0D0 | |
9433 | FACDI = ZERO | |
9434 | ENDIF | |
9435 | ||
9436 | * initializations | |
9437 | DO 10 I=1,NSITEB | |
9438 | BSITE( 0,IQ,NTARG,I) = ZERO | |
9439 | BSITE(IE,IQ,NTARG,I) = ZERO | |
9440 | BPROD(I) = ZERO | |
9441 | 10 CONTINUE | |
9442 | STOT = ZERO | |
9443 | STOT2 = ZERO | |
9444 | SELA = ZERO | |
9445 | SELA2 = ZERO | |
9446 | SQEP = ZERO | |
9447 | SQEP2 = ZERO | |
9448 | SQET = ZERO | |
9449 | SQET2 = ZERO | |
9450 | SQE2 = ZERO | |
9451 | SQE22 = ZERO | |
9452 | SPRO = ZERO | |
9453 | SPRO2 = ZERO | |
9454 | SDEL = ZERO | |
9455 | SDEL2 = ZERO | |
9456 | SDQE = ZERO | |
9457 | SDQE2 = ZERO | |
9458 | FACN = ONE/DBLE(NSTATB) | |
9459 | ||
9460 | IPNT = 0 | |
9461 | RPNT = ZERO | |
9462 | ||
9463 | * initialize Gauss-integration for photon-proj. | |
9464 | JPOINT = 1 | |
9465 | IF (IJPROJ.EQ.7) THEN | |
9466 | IF (INTRGE(1).EQ.1) THEN | |
9467 | AMLO2 = (3.0D0*AAM(13))**2 | |
9468 | ELSEIF (INTRGE(1).EQ.2) THEN | |
9469 | AMLO2 = AAM(33)**2 | |
9470 | ELSE | |
9471 | AMLO2 = AAM(96)**2 | |
9472 | ENDIF | |
9473 | IF (INTRGE(2).EQ.1) THEN | |
9474 | AMHI2 = S/TWO | |
9475 | ELSEIF (INTRGE(2).EQ.2) THEN | |
9476 | AMHI2 = S/4.0D0 | |
9477 | ELSE | |
9478 | AMHI2 = S | |
9479 | ENDIF | |
9480 | AMHI20 = (ECMNN(IE)-AMP)**2 | |
9481 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
9482 | XAMLO = LOG( AMLO2+Q2 ) | |
9483 | XAMHI = LOG( AMHI2+Q2 ) | |
9484 | **PHOJET105a | |
9485 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9486 | **PHOJET112 | |
9487 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9488 | ** | |
9489 | JPOINT = NPOINT | |
9490 | * ratio direct/total photon-nucleon xsection | |
9491 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) | |
9492 | ENDIF | |
9493 | ||
9494 | * read pre-initialized profile-function from file | |
9495 | IF (IOGLB.EQ.1) THEN | |
9496 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM | |
9497 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN | |
9498 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, | |
9499 | & NA,NB,NSTATB,NSITEB | |
9500 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, | |
9501 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, | |
9502 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) | |
9503 | STOP | |
9504 | ENDIF | |
9505 | IF (LFIRST) WRITE(LOUT,1001) CFILE | |
9506 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', | |
9507 | & 'file ',A12,/) | |
9508 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), | |
9509 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), | |
9510 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9511 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), | |
9512 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), | |
9513 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9514 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9515 | IF (NLINES.GT.0) THEN | |
9516 | DO 21 I=1,NLINES | |
9517 | ISTART = 7*I-6 | |
9518 | READ(LDAT,'(7E11.4)') | |
9519 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9520 | 21 CONTINUE | |
9521 | ENDIF | |
9522 | ISTART = 7*NLINES+1 | |
9523 | IF (ISTART.LE.NSITEB) THEN | |
9524 | READ(LDAT,'(7E11.4)') | |
9525 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9526 | ENDIF | |
9527 | LFIRST = .FALSE. | |
9528 | GOTO 100 | |
9529 | * variable projectile/target/energy runs: | |
9530 | * read pre-initialized profile-functions from file | |
9531 | ELSEIF (IOGLB.EQ.100) THEN | |
9532 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) | |
9533 | GOTO 100 | |
9534 | ENDIF | |
9535 | ||
9536 | * cross sections averaged over NSTATB nucleon configurations | |
9537 | DO 11 IS=1,NSTATB | |
9538 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS | |
9539 | STOTN = ZERO | |
9540 | SELAN = ZERO | |
9541 | SQEPN = ZERO | |
9542 | SQETN = ZERO | |
9543 | SQE2N = ZERO | |
9544 | SPRON = ZERO | |
9545 | SDELN = ZERO | |
9546 | SDQEN = ZERO | |
9547 | ||
9548 | IF (NIDX.LE.-1) THEN | |
9549 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) | |
9550 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) | |
9551 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9552 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) | |
9553 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) | |
9554 | ENDIF | |
9555 | ELSE | |
9556 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) | |
9557 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) | |
9558 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9559 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) | |
9560 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) | |
9561 | ENDIF | |
9562 | ENDIF | |
9563 | ||
9564 | * integration over impact parameter B | |
9565 | DO 12 IB=1,NSITEB-1 | |
9566 | STOTB = ZERO | |
9567 | SELAB = ZERO | |
9568 | SQEPB = ZERO | |
9569 | SQETB = ZERO | |
9570 | SQE2B = ZERO | |
9571 | SPROB = ZERO | |
9572 | SDIR = ZERO | |
9573 | SDELB = ZERO | |
9574 | SDQEB = ZERO | |
9575 | B = DBLE(IB)*BSTEP(NTARG) | |
9576 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) | |
9577 | ||
9578 | * integration over M_V^2 for photon-proj. | |
9579 | DO 14 IM=1,JPOINT | |
9580 | PP11(1) = CONE | |
9581 | PP12(1) = CONE | |
9582 | PP21(1) = CONE | |
9583 | PP22(1) = CONE | |
9584 | IF (IJPROJ.EQ.7) THEN | |
9585 | DO 13 K=2,NB | |
9586 | PP11(K) = CONE | |
9587 | PP12(K) = CONE | |
9588 | PP21(K) = CONE | |
9589 | PP22(K) = CONE | |
9590 | 13 CONTINUE | |
9591 | ENDIF | |
9592 | SHI = ZERO | |
9593 | FACM = ONE | |
9594 | DCOH = 1.0D10 | |
9595 | ||
9596 | IF (IJPROJ.EQ.7) THEN | |
9597 | AMV2 = EXP(ABSZX(IM))-Q2 | |
9598 | AMV = SQRT(AMV2) | |
9599 | IF (AMV2.LT.16.0D0) THEN | |
9600 | R = TWO | |
9601 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN | |
9602 | R = 10.0D0/3.0D0 | |
9603 | ELSE | |
9604 | R = 11.0D0/3.0D0 | |
9605 | ENDIF | |
9606 | * define M_V dependent properties of nucleon scattering amplitude | |
9607 | * V_M-nucleon xsection | |
9608 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 | |
9609 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) | |
9610 | * slope-parametrisation a la Kaidalov | |
9611 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
9612 | & +0.25D0*LOG(S/(AMV2+Q2))) | |
9613 | * coherence length | |
9614 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM | |
9615 | * integration weight factor | |
9616 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* | |
9617 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) | |
9618 | ENDIF | |
9619 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
9620 | GAM = GSH | |
9621 | IF (IJPROJ.EQ.7) THEN | |
9622 | RCA = GAM*SIGMV/TWOPI | |
9623 | ELSE | |
9624 | RCA = GAM*SIGSH/TWOPI | |
9625 | ENDIF | |
9626 | FCA = -ROSH*RCA | |
9627 | CA = DCMPLX(RCA,FCA) | |
9628 | CI = CONE | |
9629 | ||
9630 | DO 15 INA=1,NA | |
9631 | KK1 = 1 | |
9632 | INT1 = 1 | |
9633 | KK2 = 1 | |
9634 | INT2 = 1 | |
9635 | DO 16 INB=1,NB | |
9636 | * photon-projectile: check for supression by coherence length | |
9637 | IF (IJPROJ.EQ.7) THEN | |
9638 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN | |
9639 | KK1 = INB | |
9640 | INT1 = INT1+1 | |
9641 | ENDIF | |
9642 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN | |
9643 | KK2 = INB | |
9644 | INT2 = INT2+1 | |
9645 | ENDIF | |
9646 | ENDIF | |
9647 | ||
9648 | X11 = B+COOT1(1,INB)-COOP1(1,INA) | |
9649 | Y11 = COOT1(2,INB)-COOP1(2,INA) | |
9650 | XY11 = GAM*(X11*X11+Y11*Y11) | |
9651 | IF (XY11.LE.15.0D0) THEN | |
9652 | C = CONE-CA*EXP(-XY11) | |
9653 | AR = DBLE(PP11(INT1)) | |
9654 | AI = DIMAG(PP11(INT1)) | |
9655 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9656 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9657 | PP11(INT1) = DCMPLX(AR,AI) | |
9658 | PP11(INT1) = PP11(INT1)*C | |
9659 | AR = DBLE(C) | |
9660 | AI = DIMAG(C) | |
9661 | SHI = SHI+LOG(AR*AR+AI*AI) | |
9662 | ENDIF | |
9663 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9664 | X12 = B+COOT2(1,INB)-COOP1(1,INA) | |
9665 | Y12 = COOT2(2,INB)-COOP1(2,INA) | |
9666 | XY12 = GAM*(X12*X12+Y12*Y12) | |
9667 | IF (XY12.LE.15.0D0) THEN | |
9668 | C = CONE-CA*EXP(-XY12) | |
9669 | AR = DBLE(PP12(INT2)) | |
9670 | AI = DIMAG(PP12(INT2)) | |
9671 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9672 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9673 | PP12(INT2) = DCMPLX(AR,AI) | |
9674 | PP12(INT2) = PP12(INT2)*C | |
9675 | ENDIF | |
9676 | X21 = B+COOT1(1,INB)-COOP2(1,INA) | |
9677 | Y21 = COOT1(2,INB)-COOP2(2,INA) | |
9678 | XY21 = GAM*(X21*X21+Y21*Y21) | |
9679 | IF (XY21.LE.15.0D0) THEN | |
9680 | C = CONE-CA*EXP(-XY21) | |
9681 | AR = DBLE(PP21(INT1)) | |
9682 | AI = DIMAG(PP21(INT1)) | |
9683 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9684 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9685 | PP21(INT1) = DCMPLX(AR,AI) | |
9686 | PP21(INT1) = PP21(INT1)*C | |
9687 | ENDIF | |
9688 | X22 = B+COOT2(1,INB)-COOP2(1,INA) | |
9689 | Y22 = COOT2(2,INB)-COOP2(2,INA) | |
9690 | XY22 = GAM*(X22*X22+Y22*Y22) | |
9691 | IF (XY22.LE.15.0D0) THEN | |
9692 | C = CONE-CA*EXP(-XY22) | |
9693 | AR = DBLE(PP22(INT2)) | |
9694 | AI = DIMAG(PP22(INT2)) | |
9695 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9696 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9697 | PP22(INT2) = DCMPLX(AR,AI) | |
9698 | PP22(INT2) = PP22(INT2)*C | |
9699 | ENDIF | |
9700 | ENDIF | |
9701 | 16 CONTINUE | |
9702 | 15 CONTINUE | |
9703 | ||
9704 | OMPP11 = CZERO | |
9705 | OMPP21 = CZERO | |
9706 | DIPP11 = CZERO | |
9707 | DIPP21 = CZERO | |
9708 | DO 17 K=1,INT1 | |
9709 | IF (PP11(K).EQ.CZERO) THEN | |
9710 | PPTMP1 = CZERO | |
9711 | PPTMP2 = CZERO | |
9712 | ELSE | |
9713 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) | |
9714 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) | |
9715 | ENDIF | |
9716 | AVDIPP = 0.5D0* | |
9717 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9718 | OMPP11 = OMPP11+AVDIPP | |
9719 | C OMPP11 = OMPP11+(CONE-PP11(K)) | |
9720 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9721 | DIPP11 = DIPP11+AVDIPP | |
9722 | IF (PP21(K).EQ.CZERO) THEN | |
9723 | PPTMP1 = CZERO | |
9724 | PPTMP2 = CZERO | |
9725 | ELSE | |
9726 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) | |
9727 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) | |
9728 | ENDIF | |
9729 | AVDIPP = 0.5D0* | |
9730 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9731 | OMPP21 = OMPP21+AVDIPP | |
9732 | C OMPP21 = OMPP21+(CONE-PP21(K)) | |
9733 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9734 | DIPP21 = DIPP21+AVDIPP | |
9735 | 17 CONTINUE | |
9736 | OMPP12 = CZERO | |
9737 | OMPP22 = CZERO | |
9738 | DIPP12 = CZERO | |
9739 | DIPP22 = CZERO | |
9740 | DO 18 K=1,INT2 | |
9741 | IF (PP12(K).EQ.CZERO) THEN | |
9742 | PPTMP1 = CZERO | |
9743 | PPTMP2 = CZERO | |
9744 | ELSE | |
9745 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) | |
9746 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) | |
9747 | ENDIF | |
9748 | AVDIPP = 0.5D0* | |
9749 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9750 | OMPP12 = OMPP12+AVDIPP | |
9751 | C OMPP12 = OMPP12+(CONE-PP12(K)) | |
9752 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9753 | DIPP12 = DIPP12+AVDIPP | |
9754 | IF (PP22(K).EQ.CZERO) THEN | |
9755 | PPTMP1 = CZERO | |
9756 | PPTMP2 = CZERO | |
9757 | ELSE | |
9758 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) | |
9759 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) | |
9760 | ENDIF | |
9761 | AVDIPP = 0.5D0* | |
9762 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9763 | OMPP22 = OMPP22+AVDIPP | |
9764 | C OMPP22 = OMPP22+(CONE-PP22(K)) | |
9765 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9766 | DIPP22 = DIPP22+AVDIPP | |
9767 | 18 CONTINUE | |
9768 | ||
9769 | SPROM = ONE-EXP(SHI) | |
9770 | SPROB = SPROB+FACM*SPROM | |
9771 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9772 | STOTM = DBLE(OMPP11+OMPP22) | |
9773 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) | |
9774 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM | |
9775 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM | |
9776 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM | |
9777 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) | |
9778 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM | |
9779 | STOTB = STOTB+FACM*STOTM | |
9780 | SELAB = SELAB+FACM*SELAM | |
9781 | SDELB = SDELB+FACM*SDELM | |
9782 | IF (NB.GT.1) THEN | |
9783 | SQEPB = SQEPB+FACM*SQEPM | |
9784 | SDQEB = SDQEB+FACM*SDQEM | |
9785 | ENDIF | |
9786 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM | |
9787 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M | |
9788 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD | |
9789 | ENDIF | |
9790 | ||
9791 | 14 CONTINUE | |
9792 | ||
9793 | STOTN = STOTN+FACB*STOTB | |
9794 | SELAN = SELAN+FACB*SELAB | |
9795 | SQEPN = SQEPN+FACB*SQEPB | |
9796 | SQETN = SQETN+FACB*SQETB | |
9797 | SQE2N = SQE2N+FACB*SQE2B | |
9798 | SPRON = SPRON+FACB*SPROB | |
9799 | SDELN = SDELN+FACB*SDELB | |
9800 | SDQEN = SDQEN+FACB*SDQEB | |
9801 | ||
9802 | IF (IJPROJ.EQ.7) THEN | |
9803 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) | |
9804 | ELSE | |
9805 | IF (DIBETA.GT.ZERO) THEN | |
9806 | BPROD(IB+1)= BPROD(IB+1) | |
9807 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) | |
9808 | ELSE | |
9809 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB | |
9810 | ENDIF | |
9811 | ENDIF | |
9812 | ||
9813 | 12 CONTINUE | |
9814 | ||
9815 | STOT = STOT +FACN*STOTN | |
9816 | STOT2 = STOT2+FACN*STOTN**2 | |
9817 | SELA = SELA +FACN*SELAN | |
9818 | SELA2 = SELA2+FACN*SELAN**2 | |
9819 | SQEP = SQEP +FACN*SQEPN | |
9820 | SQEP2 = SQEP2+FACN*SQEPN**2 | |
9821 | SQET = SQET +FACN*SQETN | |
9822 | SQET2 = SQET2+FACN*SQETN**2 | |
9823 | SQE2 = SQE2 +FACN*SQE2N | |
9824 | SQE22 = SQE22+FACN*SQE2N**2 | |
9825 | SPRO = SPRO +FACN*SPRON | |
9826 | SPRO2 = SPRO2+FACN*SPRON**2 | |
9827 | SDEL = SDEL +FACN*SDELN | |
9828 | SDEL2 = SDEL2+FACN*SDELN**2 | |
9829 | SDQE = SDQE +FACN*SDQEN | |
9830 | SDQE2 = SDQE2+FACN*SDQEN**2 | |
9831 | ||
9832 | 11 CONTINUE | |
9833 | ||
9834 | * final cross sections | |
9835 | * 1) total | |
9836 | XSTOT(IE,IQ,NTARG) = STOT | |
9837 | IF (IJPROJ.EQ.7) | |
9838 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR | |
9839 | * 2) elastic | |
9840 | XSELA(IE,IQ,NTARG) = SELA | |
9841 | * 3) quasi-el.: A+B-->A+X (excluding 2) | |
9842 | XSQEP(IE,IQ,NTARG) = SQEP | |
9843 | * 4) quasi-el.: A+B-->X+B (excluding 2) | |
9844 | XSQET(IE,IQ,NTARG) = SQET | |
9845 | * 5) quasi-el.: A+B-->X (excluding 2-4) | |
9846 | XSQE2(IE,IQ,NTARG) = SQE2 | |
9847 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) | |
9848 | IF (SDEL.GT.ZERO) THEN | |
9849 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 | |
9850 | ELSE | |
9851 | XSPRO(IE,IQ,NTARG) = SPRO | |
9852 | ENDIF | |
9853 | * 7) projectile diffraction (el. scatt. off target) | |
9854 | XSDEL(IE,IQ,NTARG) = SDEL | |
9855 | * 8) projectile diffraction (quasi-el. scatt. off target) | |
9856 | XSDQE(IE,IQ,NTARG) = SDQE | |
9857 | * stat. errors | |
9858 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) | |
9859 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) | |
9860 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) | |
9861 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) | |
9862 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) | |
9863 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) | |
9864 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) | |
9865 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) | |
9866 | ||
9867 | IF (IJPROJ.EQ.7) THEN | |
9868 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) | |
9869 | & -XSQEP(IE,IQ,NTARG) | |
9870 | ELSE | |
9871 | BNORM = XSPRO(IE,IQ,NTARG) | |
9872 | ENDIF | |
9873 | DO 19 I=2,NSITEB | |
9874 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) | |
9875 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) | |
9876 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) | |
9877 | 19 CONTINUE | |
9878 | ||
9879 | * write profile function data into file | |
9880 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN | |
9881 | WRITE(LDAT,'(5I10,1P,E15.5)') | |
9882 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) | |
9883 | WRITE(LDAT,'(1P,6E12.5)') | |
9884 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), | |
9885 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9886 | WRITE(LDAT,'(1P,6E12.5)') | |
9887 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), | |
9888 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9889 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9890 | IF (NLINES.GT.0) THEN | |
9891 | DO 20 I=1,NLINES | |
9892 | ISTART = 7*I-6 | |
9893 | WRITE(LDAT,'(1P,7E11.4)') | |
9894 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9895 | 20 CONTINUE | |
9896 | ENDIF | |
9897 | ISTART = 7*NLINES+1 | |
9898 | IF (ISTART.LE.NSITEB) THEN | |
9899 | WRITE(LDAT,'(1P,7E11.4)') | |
9900 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9901 | ENDIF | |
9902 | ENDIF | |
9903 | ||
9904 | 100 CONTINUE | |
9905 | ||
9906 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) | |
9907 | ||
9908 | RETURN | |
9909 | END | |
9910 | ||
9911 | *$ CREATE DT_GETBXS.FOR | |
9912 | *COPY DT_GETBXS | |
9913 | * | |
9914 | *===getbxs=============================================================* | |
9915 | * | |
9916 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) | |
9917 | ||
9918 | ************************************************************************ | |
9919 | * Biasing in impact parameter space. * | |
9920 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * | |
9921 | * BHI - maximum impact parameter (input) * | |
9922 | * XSFRAC - fraction of cross section corresponding * | |
9923 | * to impact parameter range (BLO,BHI) * | |
9924 | * (output) * | |
9925 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * | |
9926 | * BHI - maximum impact parameter giving requested * | |
9927 | * fraction of cross section in impact * | |
9928 | * parameter range (0,BMAX) (output) * | |
9929 | * This version dated 17.03.00 is written by S. Roesler * | |
9930 | ************************************************************************ | |
9931 | ||
9932 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9933 | SAVE | |
9934 | PARAMETER ( LINP = 10 , | |
9935 | & LOUT = 6 , | |
9936 | & LDAT = 9 ) | |
9937 | ||
9938 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9939 | * Glauber formalism: parameters | |
9940 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9941 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9942 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9943 | & NSITEB,NSTATB | |
9944 | ||
9945 | NTARG = ABS(NIDX) | |
9946 | IF (XSFRAC.LE.0.0D0) THEN | |
9947 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) | |
9948 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) | |
9949 | IF (ILO.GE.IHI) THEN | |
9950 | XSFRAC = 0.0D0 | |
9951 | RETURN | |
9952 | ENDIF | |
9953 | IF (ILO.EQ.NSITEB-1) THEN | |
9954 | FRCLO = BSITE(0,1,NTARG,NSITEB) | |
9955 | ELSE | |
9956 | FRCLO = BSITE(0,1,NTARG,ILO+1) | |
9957 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) | |
9958 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) | |
9959 | ENDIF | |
9960 | IF (IHI.EQ.NSITEB-1) THEN | |
9961 | FRCHI = BSITE(0,1,NTARG,NSITEB) | |
9962 | ELSE | |
9963 | FRCHI = BSITE(0,1,NTARG,IHI+1) | |
9964 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) | |
9965 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) | |
9966 | ENDIF | |
9967 | XSFRAC = FRCHI-FRCLO | |
9968 | ELSE | |
9969 | BLO = 0.0D0 | |
9970 | BHI = BMAX(NTARG) | |
9971 | DO 1 I=1,NSITEB-1 | |
9972 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN | |
9973 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ | |
9974 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) | |
9975 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC | |
9976 | GOTO 2 | |
9977 | ENDIF | |
9978 | 1 CONTINUE | |
9979 | 2 CONTINUE | |
9980 | ENDIF | |
9981 | ||
9982 | RETURN | |
9983 | END | |
9984 | ||
9985 | *$ CREATE DT_CONUCL.FOR | |
9986 | *COPY DT_CONUCL | |
9987 | * | |
9988 | *===conucl=============================================================* | |
9989 | * | |
9990 | SUBROUTINE DT_CONUCL(X,N,R,MODE) | |
9991 | ||
9992 | ************************************************************************ | |
9993 | * Calculation of coordinates of nucleons within nuclei. * | |
9994 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
9995 | * N / R number of nucleons / radius of nucleus (input) * | |
9996 | * MODE = 0 coordinates not sorted * | |
9997 | * = 1 coordinates sorted with increasing X(3,i) * | |
9998 | * = 2 coordinates sorted with decreasing X(3,i) * | |
9999 | * This version dated 26.10.95 is revised by S. Roesler * | |
10000 | ************************************************************************ | |
10001 | ||
10002 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10003 | SAVE | |
10004 | PARAMETER ( LINP = 10 , | |
10005 | & LOUT = 6 , | |
10006 | & LDAT = 9 ) | |
10007 | ||
10008 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10009 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10010 | ||
10011 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10012 | ||
10013 | PARAMETER (NSRT=10) | |
10014 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10015 | DIMENSION X(3,N),XTMP(3,260) | |
10016 | ||
10017 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) | |
10018 | ||
10019 | IF ((MODE.NE.0).AND.(N.GT.4)) THEN | |
10020 | K = 0 | |
10021 | DO 1 I=1,NSRT | |
10022 | IF (MODE.EQ.2) THEN | |
10023 | ISRT = NSRT+1-I | |
10024 | ELSE | |
10025 | ISRT = I | |
10026 | ENDIF | |
10027 | K1 = K | |
10028 | DO 2 J=1,ICSRT(ISRT) | |
10029 | K = K+1 | |
10030 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) | |
10031 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) | |
10032 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) | |
10033 | 2 CONTINUE | |
10034 | IF (ICSRT(ISRT).GT.1) THEN | |
10035 | I0 = K1+1 | |
10036 | I1 = K | |
10037 | CALL DT_SORT(X,N,I0,I1,MODE) | |
10038 | ENDIF | |
10039 | 1 CONTINUE | |
10040 | ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN | |
10041 | DO 3 I=1,N | |
10042 | X(1,I) = XTMP(1,I) | |
10043 | X(2,I) = XTMP(2,I) | |
10044 | X(3,I) = XTMP(3,I) | |
10045 | 3 CONTINUE | |
10046 | CALL DT_SORT(X,N,1,N,MODE) | |
10047 | ELSE | |
10048 | DO 4 I=1,N | |
10049 | X(1,I) = XTMP(1,I) | |
10050 | X(2,I) = XTMP(2,I) | |
10051 | X(3,I) = XTMP(3,I) | |
10052 | 4 CONTINUE | |
10053 | ENDIF | |
10054 | ||
10055 | RETURN | |
10056 | END | |
10057 | ||
10058 | *$ CREATE DT_COORDI.FOR | |
10059 | *COPY DT_COORDI | |
10060 | * | |
10061 | *===coordi=============================================================* | |
10062 | * | |
10063 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) | |
10064 | ||
10065 | ************************************************************************ | |
10066 | * Calculation of coordinates of nucleons within nuclei. * | |
10067 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
10068 | * N / R number of nucleons / radius of nucleus (input) * | |
10069 | * Based on the original version by Shmakov et al. * | |
10070 | * This version dated 26.10.95 is revised by S. Roesler * | |
10071 | ************************************************************************ | |
10072 | ||
10073 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10074 | SAVE | |
10075 | PARAMETER ( LINP = 10 , | |
10076 | & LOUT = 6 , | |
10077 | & LDAT = 9 ) | |
10078 | ||
10079 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10080 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10081 | ||
10082 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10083 | ||
10084 | LOGICAL LSTART | |
10085 | ||
10086 | PARAMETER (NSRT=10) | |
10087 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10088 | DIMENSION X(3,260),WD(4),RD(3) | |
10089 | ||
10090 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ | |
10091 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ | |
10092 | DATA RD /2.09D0, 0.935D0, 0.697D0/ | |
10093 | ||
10094 | X1SUM = ZERO | |
10095 | X2SUM = ZERO | |
10096 | X3SUM = ZERO | |
10097 | ||
10098 | IF (N.EQ.1) THEN | |
10099 | X(1,1) = ZERO | |
10100 | X(2,1) = ZERO | |
10101 | X(3,1) = ZERO | |
10102 | ELSEIF (N.EQ.2) THEN | |
10103 | EPS = DT_RNDM(RD(1)) | |
10104 | DO 30 I=1,3 | |
10105 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 | |
10106 | 30 CONTINUE | |
10107 | 40 CONTINUE | |
10108 | DO 50 J=1,3 | |
10109 | CALL DT_RANNOR(X1,X2) | |
10110 | X(J,1) = RD(I)*X1 | |
10111 | X(J,2) = -X(J,1) | |
10112 | 50 CONTINUE | |
10113 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN | |
10114 | SIGMA = R/SQRTWO | |
10115 | LSTART = .TRUE. | |
10116 | CALL DT_RANNOR(X3,X4) | |
10117 | DO 100 I=1,N | |
10118 | CALL DT_RANNOR(X1,X2) | |
10119 | X(1,I) = SIGMA*X1 | |
10120 | X(2,I) = SIGMA*X2 | |
10121 | IF (LSTART) GOTO 80 | |
10122 | X(3,I) = SIGMA*X4 | |
10123 | CALL DT_RANNOR(X3,X4) | |
10124 | GOTO 90 | |
10125 | 80 CONTINUE | |
10126 | X(3,I) = SIGMA*X3 | |
10127 | 90 CONTINUE | |
10128 | LSTART = .NOT.LSTART | |
10129 | X1SUM = X1SUM+X(1,I) | |
10130 | X2SUM = X2SUM+X(2,I) | |
10131 | X3SUM = X3SUM+X(3,I) | |
10132 | 100 CONTINUE | |
10133 | X1SUM = X1SUM/DBLE(N) | |
10134 | X2SUM = X2SUM/DBLE(N) | |
10135 | X3SUM = X3SUM/DBLE(N) | |
10136 | DO 101 I=1,N | |
10137 | X(1,I) = X(1,I)-X1SUM | |
10138 | X(2,I) = X(2,I)-X2SUM | |
10139 | X(3,I) = X(3,I)-X3SUM | |
10140 | 101 CONTINUE | |
10141 | ELSE | |
10142 | ||
10143 | * maximum nuclear radius for coordinate sampling | |
10144 | RMAX = R+4.605D0*PDIF | |
10145 | ||
10146 | * initialize pre-sorting | |
10147 | DO 121 I=1,NSRT | |
10148 | ICSRT(I) = 0 | |
10149 | 121 CONTINUE | |
10150 | DR = TWO*RMAX/DBLE(NSRT) | |
10151 | ||
10152 | * sample coordinates for N nucleons | |
10153 | DO 140 I=1,N | |
10154 | 120 CONTINUE | |
10155 | RAD = RMAX*(DT_RNDM(DR))**ONETHI | |
10156 | F = DT_DENSIT(N,RAD,R) | |
10157 | IF (DT_RNDM(RAD).GT.F) GOTO 120 | |
10158 | * theta, phi uniformly distributed | |
10159 | CT = ONE-TWO*DT_RNDM(F) | |
10160 | ST = SQRT((ONE-CT)*(ONE+CT)) | |
10161 | CALL DT_DSFECF(SFE,CFE) | |
10162 | X(1,I) = RAD*ST*CFE | |
10163 | X(2,I) = RAD*ST*SFE | |
10164 | X(3,I) = RAD*CT | |
10165 | * ensure that distance between two nucleons is greater than R2MIN | |
10166 | IF (I.LT.2) GOTO 122 | |
10167 | I1 = I-1 | |
10168 | DO 130 I2=1,I1 | |
10169 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ | |
10170 | & (X(3,I)-X(3,I2))**2 | |
10171 | IF (DIST2.LE.R2MIN) GOTO 120 | |
10172 | 130 CONTINUE | |
10173 | 122 CONTINUE | |
10174 | * save index according to z-bin | |
10175 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 | |
10176 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 | |
10177 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I | |
10178 | X1SUM = X1SUM+X(1,I) | |
10179 | X2SUM = X2SUM+X(2,I) | |
10180 | X3SUM = X3SUM+X(3,I) | |
10181 | 140 CONTINUE | |
10182 | X1SUM = X1SUM/DBLE(N) | |
10183 | X2SUM = X2SUM/DBLE(N) | |
10184 | X3SUM = X3SUM/DBLE(N) | |
10185 | DO 141 I=1,N | |
10186 | X(1,I) = X(1,I)-X1SUM | |
10187 | X(2,I) = X(2,I)-X2SUM | |
10188 | X(3,I) = X(3,I)-X3SUM | |
10189 | 141 CONTINUE | |
10190 | ||
10191 | ENDIF | |
10192 | ||
10193 | RETURN | |
10194 | END | |
10195 | ||
10196 | *$ CREATE DT_DENSIT.FOR | |
10197 | *COPY DT_DENSIT | |
10198 | * | |
10199 | *===densit=============================================================* | |
10200 | * | |
10201 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) | |
10202 | ||
10203 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10204 | SAVE | |
10205 | ||
10206 | PARAMETER ( LINP = 10 , | |
10207 | & LOUT = 6 , | |
10208 | & LDAT = 9 ) | |
10209 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10210 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
10211 | & PI = TWOPI/TWO) | |
10212 | ||
10213 | DIMENSION R0(18),FNORM(18) | |
10214 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, | |
10215 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, | |
10216 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, | |
10217 | & 2.72D0, 2.66D0, 2.79D0/ | |
10218 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10219 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10220 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, | |
10221 | & .1214D+01,.1265D+01,.1318D+01/ | |
10222 | DATA PDIF /0.545D0/ | |
10223 | ||
10224 | DT_DENSIT = ZERO | |
10225 | * shell model | |
10226 | IF (NA.LE.4) THEN | |
10227 | STOP 'DT_DENSIT-0' | |
10228 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN | |
10229 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) | |
10230 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) | |
10231 | & *EXP(-(R/R1)**2)/FNORM(NA) | |
10232 | * Woods-Saxon | |
10233 | ELSEIF (NA.GT.18) THEN | |
10234 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) | |
10235 | ENDIF | |
10236 | ||
10237 | RETURN | |
10238 | END | |
10239 | ||
10240 | *$ CREATE DT_RNCLUS.FOR | |
10241 | *COPY DT_RNCLUS | |
10242 | * | |
10243 | *===rnclus=============================================================* | |
10244 | * | |
10245 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) | |
10246 | ||
10247 | ************************************************************************ | |
10248 | * Nuclear radius for nucleus with mass number N. * | |
10249 | * This version dated 26.9.00 is written by S. Roesler * | |
10250 | ************************************************************************ | |
10251 | ||
10252 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10253 | SAVE | |
10254 | ||
10255 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) | |
10256 | ||
10257 | * nucleon radius | |
10258 | PARAMETER (RNUCLE = 1.12D0) | |
10259 | ||
10260 | * nuclear radii for selected nuclei | |
10261 | DIMENSION RADNUC(18) | |
10262 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, | |
10263 | & 2.58D0,2.71D0,2.66D0,2.71D0/ | |
10264 | ||
10265 | IF (N.LE.18) THEN | |
10266 | IF (RADNUC(N).GT.0.0D0) THEN | |
10267 | DT_RNCLUS = RADNUC(N) | |
10268 | ELSE | |
10269 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10270 | ENDIF | |
10271 | ELSE | |
10272 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10273 | ENDIF | |
10274 | ||
10275 | RETURN | |
10276 | END | |
10277 | ||
10278 | *$ CREATE DT_DENTST.FOR | |
10279 | *COPY DT_DENTST | |
10280 | * | |
10281 | *===dentst=============================================================* | |
10282 | * | |
10283 | C PROGRAM DT_DENTST | |
10284 | SUBROUTINE DT_DENTST | |
10285 | ||
10286 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10287 | SAVE | |
10288 | ||
10289 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') | |
10290 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') | |
10291 | ||
10292 | RMIN = 0.0D0 | |
10293 | RMAX = 8.0D0 | |
10294 | NBINS = 500.0D0 | |
10295 | DR = (RMAX-RMIN)/DBLE(NBINS) | |
10296 | DO 1 IA=5,18 | |
10297 | FMAX = 0.0D0 | |
10298 | DO 2 IR=1,NBINS+1 | |
10299 | R = RMIN+DBLE(IR-1)*DR | |
10300 | F = DT_DENSIT(IA,R,R) | |
10301 | IF (F.GT.FMAX) FMAX = F | |
10302 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F | |
10303 | 2 CONTINUE | |
10304 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX | |
10305 | 1 CONTINUE | |
10306 | ||
10307 | CLOSE(40) | |
10308 | CLOSE(41) | |
10309 | ||
10310 | END | |
10311 | ||
10312 | *$ CREATE DT_SHMAKI.FOR | |
10313 | *COPY DT_SHMAKI | |
10314 | * | |
10315 | *===shmaki=============================================================* | |
10316 | * | |
10317 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) | |
10318 | ||
10319 | ************************************************************************ | |
10320 | * Initialisation of Glauber formalism. This subroutine has to be * | |
10321 | * called once (in case of target emulsions as often as many different * | |
10322 | * target nuclei are considered) before events are sampled. * | |
10323 | * NA / NCA mass number/charge of projectile nucleus * | |
10324 | * NB / NCB mass number/charge of target nucleus * | |
10325 | * IJP identity of projectile (hadrons/leptons/photons) * | |
10326 | * PPN projectile momentum (for projectile nuclei: * | |
10327 | * momentum per nucleon) in target rest system * | |
10328 | * MODE = 0 Glauber formalism invoked * | |
10329 | * = 1 fitted results are loaded from data-file * | |
10330 | * = 99 NTARG is forced to be 1 * | |
10331 | * (used in connection with GLAUBERI-card only) * | |
10332 | * This version dated 22.03.96 is based on the original SHMAKI-routine * | |
10333 | * and revised by S. Roesler. * | |
10334 | ************************************************************************ | |
10335 | ||
10336 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10337 | SAVE | |
10338 | PARAMETER ( LINP = 10 , | |
10339 | & LOUT = 6 , | |
10340 | & LDAT = 9 ) | |
10341 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
10342 | & THREE=3.0D0) | |
10343 | ||
10344 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10345 | * Glauber formalism: parameters | |
10346 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10347 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10348 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10349 | & NSITEB,NSTATB | |
10350 | * Lorentz-parameters of the current interaction | |
10351 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10352 | & UMO,PPCM,EPROJ,PPROJ | |
10353 | * properties of photon/lepton projectiles | |
10354 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10355 | * kinematical cuts for lepton-nucleus interactions | |
10356 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
10357 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
10358 | * Glauber formalism: cross sections | |
10359 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10360 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10361 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10362 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10363 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10364 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10365 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10366 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10367 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10368 | & BSLOPE,NEBINI,NQBINI | |
10369 | * cuts for variable energy runs | |
10370 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
10371 | * nucleon-nucleon event-generator | |
10372 | CHARACTER*8 CMODEL | |
10373 | LOGICAL LPHOIN | |
10374 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10375 | * Glauber formalism: flags and parameters for statistics | |
10376 | LOGICAL LPROD | |
10377 | CHARACTER*8 CGLB | |
10378 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10379 | ||
10380 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ | |
10381 | ||
10382 | C CALL DT_HISHAD | |
10383 | C STOP | |
10384 | ||
10385 | NTARG = NTARG+1 | |
10386 | IF (MODE.EQ.99) NTARG = 1 | |
10387 | NIDX = -NTARG | |
10388 | IF (MODE.EQ.-1) NIDX = NTARG | |
10389 | ||
10390 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 | |
10391 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) | |
10392 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', | |
10393 | & ' initialization',/,12X,'--------------------------', | |
10394 | & '-------------------------',/) | |
10395 | ||
10396 | IF (MODE.EQ.2) THEN | |
10397 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10398 | CALL DT_SHFAST(MODE,PPN,IBACK) | |
10399 | STOP ' Glauber pre-initialization done' | |
10400 | ENDIF | |
10401 | IF (MODE.EQ.1) THEN | |
10402 | CALL DT_PROFBI(NA,NB,PPN,NTARG) | |
10403 | ELSE | |
10404 | IBACK = 1 | |
10405 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) | |
10406 | IF (IBACK.EQ.1) THEN | |
10407 | * lepton-nucleus (variable energy runs) | |
10408 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. | |
10409 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
10410 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10411 | & WRITE(LOUT,1002) NB,NCB | |
10412 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', | |
10413 | & ' target A/Z: ',I3,' /',I3,/,/,8X, | |
10414 | & 'E_cm (GeV) Q^2 (GeV^2)', | |
10415 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, | |
10416 | & '--------------------------------', | |
10417 | & '------------------------------') | |
10418 | AECMLO = LOG10(MIN(UMO,ECMLI)) | |
10419 | AECMHI = LOG10(MIN(UMO,ECMHI)) | |
10420 | IESTEP = NEB-1 | |
10421 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10422 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10423 | DO 1 I=1,IESTEP+1 | |
10424 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10425 | IF (Q2HI.GT.0.1D0) THEN | |
10426 | IF (Q2LI.LT.0.01D0) THEN | |
10427 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10428 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10429 | & WRITE(LOUT,1003) | |
10430 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10431 | Q2LI = 0.01D0 | |
10432 | IBIN = 2 | |
10433 | ELSE | |
10434 | IBIN = 1 | |
10435 | ENDIF | |
10436 | IQSTEP = NQB-IBIN | |
10437 | AQ2LO = LOG10(Q2LI) | |
10438 | AQ2HI = LOG10(Q2HI) | |
10439 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) | |
10440 | DO 2 J=IBIN,IQSTEP+IBIN | |
10441 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) | |
10442 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) | |
10443 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10444 | & WRITE(LOUT,1003) ECMNN(I), | |
10445 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) | |
10446 | 2 CONTINUE | |
10447 | ELSE | |
10448 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10449 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10450 | & WRITE(LOUT,1003) | |
10451 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10452 | ENDIF | |
10453 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) | |
10454 | 1 CONTINUE | |
10455 | IVEOUT = 1 | |
10456 | ELSE | |
10457 | * hadron/photon/nucleus-nucleus | |
10458 | IF ((ABS(VAREHI).GT.ZERO).AND. | |
10459 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN | |
10460 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN | |
10461 | WRITE(LOUT,1004) NA,NB,NCB | |
10462 | 1004 FORMAT(1X,'variable energy run: projectile-id:', | |
10463 | & I3,' target A/Z: ',I3,' /',I3,/) | |
10464 | WRITE(LOUT,1005) | |
10465 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' | |
10466 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, | |
10467 | & ' -------------------------------------', | |
10468 | & '--------------------------------------') | |
10469 | ENDIF | |
10470 | AECMLO = LOG10(VARCLO) | |
10471 | AECMHI = LOG10(VARCHI) | |
10472 | IESTEP = NEB-1 | |
10473 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10474 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10475 | DO 3 I=1,IESTEP+1 | |
10476 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10477 | AMP = 0.938D0 | |
10478 | AMT = 0.938D0 | |
10479 | AMP2 = AMP**2 | |
10480 | AMT2 = AMT**2 | |
10481 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
10482 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) | |
10483 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) | |
10484 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10485 | & WRITE(LOUT,1006) | |
10486 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10487 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) | |
10488 | 3 CONTINUE | |
10489 | IVEOUT = 1 | |
10490 | ELSE | |
10491 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10492 | ENDIF | |
10493 | ENDIF | |
10494 | ENDIF | |
10495 | ENDIF | |
10496 | ||
10497 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. | |
10498 | & (IOGLB.NE.100)) THEN | |
10499 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, | |
10500 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) | |
10501 | 1001 FORMAT(38X,'projectile', | |
10502 | & ' target',/,1X,'Mass number / charge', | |
10503 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, | |
10504 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, | |
10505 | & 'Parameters of elastic scattering amplitude:',/,5X, | |
10506 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', | |
10507 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, | |
10508 | & 'statistics at each b-step',4X,I5,/,/,1X, | |
10509 | & 'Prod. cross section ',5X,F10.4,' mb',/) | |
10510 | ENDIF | |
10511 | ||
10512 | RETURN | |
10513 | END | |
10514 | ||
10515 | *$ CREATE DT_PROFBI.FOR | |
10516 | *COPY DT_PROFBI | |
10517 | * | |
10518 | *===profbi=============================================================* | |
10519 | * | |
10520 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) | |
10521 | ||
10522 | ************************************************************************ | |
10523 | * Integral over profile function (to be used for impact-parameter * | |
10524 | * sampling during event generation). * | |
10525 | * Fitted results are used. * | |
10526 | * NA / NB mass numbers of proj./target nuclei * | |
10527 | * PPN projectile momentum (for projectile nuclei: * | |
10528 | * momentum per nucleon) in target rest system * | |
10529 | * NTARG index of target material (i.e. kind of nucleus) * | |
10530 | * This version dated 31.05.95 is revised by S. Roesler * | |
10531 | ************************************************************************ | |
10532 | ||
10533 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10534 | SAVE | |
10535 | PARAMETER ( LINP = 10 , | |
10536 | & LOUT = 6 , | |
10537 | & LDAT = 9 ) | |
454792a9 | 10538 | CPH SAVE |
9aaba0d6 | 10539 | |
10540 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
10541 | ||
10542 | LOGICAL LSTART | |
10543 | CHARACTER CNAME*80 | |
10544 | ||
10545 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10546 | * Glauber formalism: parameters | |
10547 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10548 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10549 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10550 | & NSITEB,NSTATB | |
10551 | * Glauber formalism: cross sections | |
10552 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10553 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10554 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10555 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10556 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10557 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10558 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10559 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10560 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10561 | & BSLOPE,NEBINI,NQBINI | |
10562 | ||
10563 | PARAMETER (NGLMAX=8000) | |
10564 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), | |
10565 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) | |
10566 | ||
10567 | DATA LSTART /.TRUE./ | |
10568 | ||
10569 | IF (LSTART) THEN | |
10570 | * read fit-parameters from file | |
10571 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') | |
10572 | I = 0 | |
10573 | 1 CONTINUE | |
10574 | READ(47,'(A80)') CNAME | |
10575 | IF (CNAME.EQ.'STOP') GOTO 2 | |
10576 | I = I+1 | |
10577 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), | |
10578 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), | |
10579 | & GLAFIT(4,I),GLAFIT(5,I) | |
10580 | IF (I+1.GT.NGLMAX) THEN | |
10581 | WRITE(LOUT,1000) | |
10582 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', | |
10583 | & 'program stopped') | |
10584 | STOP | |
10585 | ENDIF | |
10586 | GOTO 1 | |
10587 | 2 CONTINUE | |
10588 | NGLPAR = I | |
10589 | LSTART = .FALSE. | |
10590 | ENDIF | |
10591 | ||
10592 | NNA = NA | |
10593 | NNB = NB | |
10594 | IF (NA.GT.NB) THEN | |
10595 | NNA = NB | |
10596 | NNB = NA | |
10597 | ENDIF | |
10598 | IDXGLA = 0 | |
10599 | DO 3 J=1,NGLPAR | |
10600 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN | |
10601 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) | |
10602 | DO 4 K=1,J-1 | |
10603 | IPOINT = J-K | |
10604 | IF (J.EQ.NGLPAR) IPOINT = J+1-K | |
10605 | IF ((NNA.GT.NGLIP(IPOINT)).OR. | |
10606 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN | |
10607 | IF (IPOINT.EQ.1) IPOINT = 0 | |
10608 | NATMP = NGLIP(IPOINT+1) | |
10609 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN | |
10610 | IDXGLA = IPOINT+1 | |
10611 | GOTO 6 | |
10612 | ELSE | |
10613 | J1BEG = IPOINT+1 | |
10614 | J1END = J | |
10615 | C IF (J.EQ.NGLPAR) THEN | |
10616 | C J1BEG = IPOINT | |
10617 | C J1END = J | |
10618 | C ENDIF | |
10619 | DO 5 J1=J1BEG,J1END | |
10620 | IF (NGLIP(J1).EQ.NATMP) THEN | |
10621 | IF (PPN.LT.GLAPPN(J1)) THEN | |
10622 | IDXGLA = J1 | |
10623 | GOTO 6 | |
10624 | ENDIF | |
10625 | ELSE | |
10626 | IDXGLA = J1-1 | |
10627 | GOTO 6 | |
10628 | ENDIF | |
10629 | 5 CONTINUE | |
10630 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) | |
10631 | & IDXGLA = NGLPAR | |
10632 | ENDIF | |
10633 | ENDIF | |
10634 | 4 CONTINUE | |
10635 | ENDIF | |
10636 | 3 CONTINUE | |
10637 | ||
10638 | 6 CONTINUE | |
10639 | IF (IDXGLA.EQ.0) THEN | |
10640 | WRITE(LOUT,1001) NNA,NNB,PPN | |
10641 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', | |
10642 | & 2I4,F6.0,') not found ') | |
10643 | STOP | |
10644 | ENDIF | |
10645 | ||
10646 | * no interpolation yet available | |
10647 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) | |
10648 | ||
10649 | BSITE(1,1,NTARG,1) = ZERO | |
10650 | DO 10 I=2,NSITEB | |
10651 | XX = DBLE(I) | |
10652 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ | |
10653 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ | |
10654 | & GLAFIT(5,IDXGLA)*XX**4 | |
10655 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) | |
10656 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) | |
10657 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO | |
10658 | 10 CONTINUE | |
10659 | ||
10660 | RETURN | |
10661 | END | |
10662 | ||
10663 | *$ CREATE DT_GLAUBE.FOR | |
10664 | *COPY DT_GLAUBE | |
10665 | * | |
10666 | *===glaube=============================================================* | |
10667 | * | |
10668 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) | |
10669 | ||
10670 | ************************************************************************ | |
10671 | * Calculation of configuartion of interacting nucleons for one event. * | |
10672 | * NB / NB mass numbers of proj./target nuclei (input) * | |
10673 | * B impact parameter (output) * | |
10674 | * INTT total number of wounded nucleons " * | |
10675 | * INTA / INTB number of wounded nucleons in proj. / target " * | |
10676 | * JS / JT(i) number of collisions proj. / target nucleon i is * | |
10677 | * involved (output) * | |
10678 | * NIDX index of projectile/target material (input) * | |
10679 | * = -2 call within FLUKA transport calculation * | |
10680 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * | |
10681 | * This version dated 22.03.96 is revised by S. Roesler * | |
10682 | * * | |
10683 | * Last change 27.12.2006 by S. Roesler. * | |
10684 | ************************************************************************ | |
10685 | ||
10686 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10687 | SAVE | |
10688 | PARAMETER ( LINP = 10 , | |
10689 | & LOUT = 6 , | |
10690 | & LDAT = 9 ) | |
10691 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
10692 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
10693 | ||
10694 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10695 | PARAMETER ( MAXNCL = 260, | |
10696 | & MAXVQU = MAXNCL, | |
10697 | & MAXSQU = 20*MAXVQU, | |
10698 | & MAXINT = MAXVQU+MAXSQU) | |
10699 | * Glauber formalism: parameters | |
10700 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10701 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10702 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10703 | & NSITEB,NSTATB | |
10704 | * Glauber formalism: cross sections | |
10705 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10706 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10707 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10708 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10709 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10710 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10711 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10712 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10713 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10714 | & BSLOPE,NEBINI,NQBINI | |
10715 | * Lorentz-parameters of the current interaction | |
10716 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10717 | & UMO,PPCM,EPROJ,PPROJ | |
10718 | * properties of photon/lepton projectiles | |
10719 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10720 | * Glauber formalism: collision properties | |
10721 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 10722 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
10723 | & NCP,NCT | |
9aaba0d6 | 10724 | * Glauber formalism: flags and parameters for statistics |
10725 | LOGICAL LPROD | |
10726 | CHARACTER*8 CGLB | |
10727 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10728 | ||
10729 | DIMENSION JS(MAXNCL),JT(MAXNCL) | |
10730 | ||
10731 | NTARG = ABS(NIDX) | |
10732 | ||
10733 | * get actual energy from /DTLTRA/ | |
10734 | ECMNOW = UMO | |
10735 | Q2 = VIRT | |
10736 | * | |
10737 | * new patch for pre-initialized variable projectile/target/energy runs, | |
10738 | * bypassed for use within FLUKA (Nidx=-2) | |
10739 | IF (IOGLB.EQ.100) THEN | |
10740 | IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) | |
10741 | * | |
10742 | * variable energy run, interpolate profile function | |
10743 | ELSE | |
10744 | I1 = 1 | |
10745 | I2 = 1 | |
10746 | RATE = ONE | |
10747 | IF (NEBINI.GT.1) THEN | |
10748 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN | |
10749 | I1 = NEBINI | |
10750 | I2 = NEBINI | |
10751 | RATE = ONE | |
10752 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN | |
10753 | DO 1 I=2,NEBINI | |
10754 | IF (ECMNOW.LT.ECMNN(I)) THEN | |
10755 | I1 = I-1 | |
10756 | I2 = I | |
10757 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
10758 | GOTO 2 | |
10759 | ENDIF | |
10760 | 1 CONTINUE | |
10761 | 2 CONTINUE | |
10762 | ENDIF | |
10763 | ENDIF | |
10764 | J1 = 1 | |
10765 | J2 = 1 | |
10766 | RATQ = ONE | |
10767 | IF (NQBINI.GT.1) THEN | |
10768 | IF (Q2.GE.Q2G(NQBINI)) THEN | |
10769 | J1 = NQBINI | |
10770 | J2 = NQBINI | |
10771 | RATQ = ONE | |
10772 | ELSEIF (Q2.GT.Q2G(1)) THEN | |
10773 | DO 3 I=2,NQBINI | |
10774 | IF (Q2.LT.Q2G(I)) THEN | |
10775 | J1 = I-1 | |
10776 | J2 = I | |
10777 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ | |
10778 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
10779 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
10780 | GOTO 4 | |
10781 | ENDIF | |
10782 | 3 CONTINUE | |
10783 | 4 CONTINUE | |
10784 | ENDIF | |
10785 | ENDIF | |
10786 | ||
10787 | DO 5 I=1,KSITEB | |
10788 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ | |
10789 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10790 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10791 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ | |
10792 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) | |
10793 | 5 CONTINUE | |
10794 | ENDIF | |
10795 | ||
10796 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) | |
10797 | IF (NIDX.LE.-1) THEN | |
10798 | RPROJ = RASH(1) | |
10799 | RTARG = RBSH(NTARG) | |
10800 | ELSE | |
10801 | RPROJ = RASH(NTARG) | |
10802 | RTARG = RBSH(1) | |
10803 | ENDIF | |
10804 | ||
10805 | RETURN | |
10806 | END | |
10807 | ||
10808 | *$ CREATE DT_DIAGR.FOR | |
10809 | *COPY DT_DIAGR | |
10810 | * | |
10811 | *===diagr==============================================================* | |
10812 | * | |
10813 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, | |
10814 | & NIDX) | |
10815 | ||
10816 | ************************************************************************ | |
10817 | * Based on the original version by Shmakov et al. * | |
10818 | * This version dated 21.04.95 is revised by S. Roesler * | |
10819 | ************************************************************************ | |
10820 | ||
10821 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10822 | SAVE | |
10823 | PARAMETER ( LINP = 10 , | |
10824 | & LOUT = 6 , | |
10825 | & LDAT = 9 ) | |
10826 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10827 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
10828 | & PI = TWOPI/TWO, | |
10829 | & GEV2MB = 0.38938D0, | |
10830 | & GEV2FM = 0.1972D0, | |
10831 | & ALPHEM = ONE/137.0D0, | |
10832 | * proton mass | |
10833 | & AMP = 0.938D0, | |
10834 | & AMP2 = AMP**2, | |
10835 | * rho0 mass | |
10836 | & AMRHO0 = 0.77D0) | |
10837 | ||
10838 | COMPLEX*16 C,CA,CI | |
10839 | PARAMETER ( MAXNCL = 260, | |
10840 | & MAXVQU = MAXNCL, | |
10841 | & MAXSQU = 20*MAXVQU, | |
10842 | & MAXINT = MAXVQU+MAXSQU) | |
10843 | * particle properties (BAMJET index convention) | |
10844 | CHARACTER*8 ANAME | |
10845 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
10846 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
10847 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10848 | * emulsion treatment | |
10849 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
10850 | & NCOMPO,IEMUL | |
10851 | * Glauber formalism: parameters | |
10852 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10853 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10854 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10855 | & NSITEB,NSTATB | |
10856 | * Glauber formalism: cross sections | |
10857 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10858 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10859 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10860 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10861 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10862 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10863 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10864 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10865 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10866 | & BSLOPE,NEBINI,NQBINI | |
10867 | * VDM parameter for photon-nucleus interactions | |
10868 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
10869 | * nucleon-nucleon event-generator | |
10870 | CHARACTER*8 CMODEL | |
10871 | LOGICAL LPHOIN | |
10872 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10873 | **PHOJET105a | |
10874 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10875 | **PHOJET112 | |
10876 | C obsolete cut-off information | |
10877 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN | |
10878 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10879 | ** | |
10880 | * coordinates of nucleons | |
10881 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
10882 | * interface between Glauber formalism and DPM | |
10883 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
10884 | & INTER1(MAXINT),INTER2(MAXINT) | |
10885 | * statistics: Glauber-formalism | |
10886 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
10887 | * n-n cross section fluctuations | |
10888 | PARAMETER (NBINS = 1000) | |
10889 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
10890 | ||
10891 | DIMENSION JS(MAXNCL),JT(MAXNCL), | |
10892 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), | |
10893 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) | |
10894 | DIMENSION NWA(0:210),NWB(0:210) | |
10895 | ||
10896 | LOGICAL LFIRST | |
10897 | DATA LFIRST /.TRUE./ | |
10898 | ||
10899 | DATA NTARGO,ICNT /0,0/ | |
10900 | ||
10901 | NTARG = ABS(NIDX) | |
10902 | ||
10903 | IF (LFIRST) THEN | |
10904 | LFIRST = .FALSE. | |
10905 | IF (NCOMPO.EQ.0) THEN | |
10906 | NCALL = 0 | |
10907 | NWAMAX = NA | |
10908 | NWBMAX = NB | |
10909 | DO 17 I=0,210 | |
10910 | NWA(I) = 0 | |
10911 | NWB(I) = 0 | |
10912 | 17 CONTINUE | |
10913 | ENDIF | |
10914 | ENDIF | |
10915 | IF (NTARG.EQ.-1) THEN | |
10916 | IF (NCOMPO.EQ.0) THEN | |
10917 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' | |
10918 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', | |
10919 | & NCALL,NWAMAX,NWBMAX | |
10920 | DO 18 I=1,MAX(NWAMAX,NWBMAX) | |
10921 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') | |
10922 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), | |
10923 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) | |
10924 | 18 CONTINUE | |
10925 | ENDIF | |
10926 | RETURN | |
10927 | ENDIF | |
10928 | ||
10929 | DCOH = 1.0D10 | |
10930 | IPNT = 0 | |
10931 | ||
10932 | SQ2 = Q2 | |
10933 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 | |
10934 | S = ECMNOW**2 | |
10935 | X = SQ2/(S+SQ2-AMP2) | |
10936 | XNU = (S+SQ2-AMP2)/(TWO*AMP) | |
10937 | * photon projectiles: recalculate photon-nucleon amplitude | |
10938 | IF (IJPROJ.EQ.7) THEN | |
10939 | 15 CONTINUE | |
10940 | * VDM assumption: mass of V-meson | |
10941 | AMV2 = DT_SAM2(SQ2,ECMNOW) | |
10942 | AMV = SQRT(AMV2) | |
10943 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 | |
10944 | * check for pointlike interaction | |
10945 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) | |
10946 | **sr 27.10. | |
10947 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10948 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10949 | ** | |
10950 | ROSH = 0.1D0 | |
10951 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) | |
10952 | & +0.25D0*LOG(S/(AMV2+SQ2))) | |
10953 | * coherence length | |
10954 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM | |
10955 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
10956 | IF (MCGENE.EQ.2) THEN | |
10957 | ZERO1 = ZERO | |
10958 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, | |
10959 | & BSLOPE,0) | |
10960 | ELSE | |
10961 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
10962 | ENDIF | |
10963 | IF (ECMNOW.LE.3.0D0) THEN | |
10964 | ROSH = -0.43D0 | |
10965 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN | |
10966 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) | |
10967 | ELSEIF (ECMNOW.GT.50.0D0) THEN | |
10968 | ROSH = 0.1D0 | |
10969 | ENDIF | |
10970 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10971 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10972 | IF (MCGENE.EQ.2) THEN | |
10973 | ZERO1 = ZERO | |
10974 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, | |
10975 | & BDUM,0) | |
10976 | SIGSH = SIGSH/10.0D0 | |
10977 | ELSE | |
10978 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10979 | DUMZER = ZERO | |
10980 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10981 | SIGSH = SIGSH/10.0D0 | |
10982 | ENDIF | |
10983 | ELSE | |
10984 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
10985 | ROSH = 0.01D0 | |
10986 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10987 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10988 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10989 | DUMZER = ZERO | |
10990 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10991 | SIGSH = SIGSH/10.0D0 | |
10992 | ENDIF | |
10993 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
10994 | GAM = GSH | |
10995 | RCA = GAM*SIGSH/TWOPI | |
10996 | FCA = -ROSH*RCA | |
10997 | CA = DCMPLX(RCA,FCA) | |
10998 | CI = DCMPLX(ONE,ZERO) | |
10999 | ||
11000 | 16 CONTINUE | |
11001 | * impact parameter | |
11002 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) | |
11003 | ||
11004 | NTRY = 0 | |
11005 | 3 CONTINUE | |
11006 | NTRY = NTRY+1 | |
11007 | * initializations | |
11008 | JNT = 0 | |
11009 | DO 1 I=1,NA | |
11010 | JS(I) = 0 | |
11011 | 1 CONTINUE | |
11012 | DO 2 I=1,NB | |
11013 | JT(I) = 0 | |
11014 | 2 CONTINUE | |
11015 | IF (IJPROJ.EQ.7) THEN | |
11016 | DO 8 I=1,MAXNCL | |
11017 | JS0(I) = 0 | |
11018 | JNT0(I)= 0 | |
11019 | DO 9 J=1,NB | |
11020 | JT0(I,J) = 0 | |
11021 | 9 CONTINUE | |
11022 | 8 CONTINUE | |
11023 | ENDIF | |
11024 | ||
11025 | * nucleon configuration | |
11026 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN | |
11027 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN | |
11028 | C CALL DT_CONUCL(PKOO,NA,RASH,2) | |
11029 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) | |
11030 | IF (NIDX.LE.-1) THEN | |
11031 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) | |
11032 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) | |
11033 | ELSE | |
11034 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) | |
11035 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) | |
11036 | ENDIF | |
11037 | NTARGO = NTARG | |
11038 | ENDIF | |
11039 | ICNT = ICNT+1 | |
11040 | ||
11041 | * LEPTO: pick out one struck nucleon | |
11042 | IF (MCGENE.EQ.3) THEN | |
11043 | JNT = 1 | |
11044 | JS(1) = 1 | |
11045 | IDX = INT(DT_RNDM(X)*NB)+1 | |
11046 | JT(IDX) = 1 | |
11047 | B = ZERO | |
11048 | GOTO 19 | |
11049 | ENDIF | |
11050 | ||
11051 | DO 4 INA=1,NA | |
11052 | * cross section fluctuations | |
11053 | AFLUC = ONE | |
11054 | IF (IFLUCT.EQ.1) THEN | |
11055 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) | |
11056 | AFLUC = FLUIXX(IFLUK) | |
11057 | ENDIF | |
11058 | KK1 = 1 | |
11059 | KINT = 1 | |
11060 | DO 5 INB=1,NB | |
11061 | * photon-projectile: check for supression by coherence length | |
11062 | IF (IJPROJ.EQ.7) THEN | |
11063 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN | |
11064 | KK1 = INB | |
11065 | KINT = KINT+1 | |
11066 | ENDIF | |
11067 | ENDIF | |
11068 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) | |
11069 | QQ2 = TKOO(2,INB)-PKOO(2,INA) | |
11070 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) | |
11071 | IF (XY.LE.15.0D0) THEN | |
11072 | C = CI-CA*AFLUC*EXP(-XY) | |
11073 | AR = DBLE(C) | |
11074 | AI = DIMAG(C) | |
11075 | P = AR*AR+AI*AI | |
11076 | IF (DT_RNDM(XY).GE.P) THEN | |
11077 | JNT = JNT+1 | |
11078 | IF (IJPROJ.EQ.7) THEN | |
11079 | JNT0(KINT) = JNT0(KINT)+1 | |
11080 | IF (JNT0(KINT).GT.MAXNCL) THEN | |
11081 | WRITE(LOUT,1001) MAXNCL | |
11082 | 1001 FORMAT(1X, | |
11083 | & 'DIAGR: no. of requested interactions', | |
11084 | & ' exceeds array dimensions ',I4) | |
11085 | STOP | |
11086 | ENDIF | |
11087 | JS0(KINT) = JS0(KINT)+1 | |
11088 | JT0(KINT,INB) = JT0(KINT,INB)+1 | |
11089 | JI1(KINT,JNT0(KINT)) = INA | |
11090 | JI2(KINT,JNT0(KINT)) = INB | |
11091 | ELSE | |
11092 | IF (JNT.GT.MAXINT) THEN | |
11093 | WRITE(LOUT,1000) JNT, MAXINT | |
11094 | 1000 FORMAT(1X, | |
11095 | & 'DIAGR: no. of requested interactions (' | |
11096 | & ,I4,') exceeds array dimensions (',I4,')') | |
11097 | STOP | |
11098 | ENDIF | |
11099 | JS(INA) = JS(INA)+1 | |
11100 | JT(INB) = JT(INB)+1 | |
11101 | INTER1(JNT) = INA | |
11102 | INTER2(JNT) = INB | |
11103 | ENDIF | |
11104 | ENDIF | |
11105 | ENDIF | |
11106 | 5 CONTINUE | |
11107 | 4 CONTINUE | |
11108 | ||
11109 | IF (JNT.EQ.0) THEN | |
11110 | IF (NTRY.LT.500) THEN | |
11111 | GOTO 3 | |
11112 | ELSE | |
11113 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' | |
11114 | GOTO 16 | |
11115 | ENDIF | |
11116 | ENDIF | |
11117 | ||
11118 | IDIREC = 0 | |
11119 | IF (IJPROJ.EQ.7) THEN | |
11120 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) | |
11121 | 10 CONTINUE | |
11122 | IF (JNT0(K).EQ.0) THEN | |
11123 | K = K+1 | |
11124 | IF (K.GT.KINT) K = 1 | |
11125 | GOTO 10 | |
11126 | ENDIF | |
11127 | * supress Glauber-cascade by direct photon processes | |
11128 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) | |
11129 | IF (IPNT.GT.0) THEN | |
11130 | JNT = 1 | |
11131 | JS(1) = 1 | |
11132 | DO 11 INB=1,NB | |
11133 | JT(INB) = JT0(K,INB) | |
11134 | IF (JT(INB).GT.0) GOTO 12 | |
11135 | 11 CONTINUE | |
11136 | 12 CONTINUE | |
11137 | INTER1(1) = 1 | |
11138 | INTER2(1) = INB | |
11139 | IDIREC = IPNT | |
11140 | ELSE | |
11141 | JNT = JNT0(K) | |
11142 | JS(1) = JS0(K) | |
11143 | DO 13 INB=1,NB | |
11144 | JT(INB) = JT0(K,INB) | |
11145 | 13 CONTINUE | |
11146 | DO 14 I=1,JNT | |
11147 | INTER1(I) = JI1(K,I) | |
11148 | INTER2(I) = JI2(K,I) | |
11149 | 14 CONTINUE | |
11150 | ENDIF | |
11151 | ENDIF | |
11152 | ||
11153 | 19 CONTINUE | |
11154 | INTA = 0 | |
11155 | INTB = 0 | |
11156 | DO 6 I=1,NA | |
11157 | IF (JS(I).NE.0) INTA=INTA+1 | |
11158 | 6 CONTINUE | |
11159 | DO 7 I=1,NB | |
11160 | IF (JT(I).NE.0) INTB=INTB+1 | |
11161 | 7 CONTINUE | |
11162 | ICWPG = INTA | |
11163 | ICWTG = INTB | |
11164 | ICIG = JNT | |
11165 | IPGLB = IPGLB+INTA | |
11166 | ITGLB = ITGLB+INTB | |
11167 | NGLB = NGLB+1 | |
11168 | ||
11169 | IF (NCOMPO.EQ.0) THEN | |
11170 | NCALL = NCALL+1 | |
11171 | NWA(INTA) = NWA(INTA)+1 | |
11172 | NWB(INTB) = NWB(INTB)+1 | |
11173 | ENDIF | |
11174 | ||
11175 | RETURN | |
11176 | END | |
11177 | ||
11178 | *$ CREATE DT_MODB.FOR | |
11179 | *COPY DT_MODB | |
11180 | * | |
11181 | *===modb===============================================================* | |
11182 | * | |
11183 | SUBROUTINE DT_MODB(B,NIDX) | |
11184 | ||
11185 | ************************************************************************ | |
11186 | * Sampling of impact parameter of collision. * | |
11187 | * B impact parameter (output) * | |
11188 | * NIDX index of projectile/target material (input)* | |
11189 | * Based on the original version by Shmakov et al. * | |
11190 | * This version dated 21.04.95 is revised by S. Roesler * | |
11191 | * * | |
11192 | * Last change 27.12.2006 by S. Roesler. * | |
11193 | ************************************************************************ | |
11194 | ||
11195 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11196 | SAVE | |
11197 | PARAMETER ( LINP = 10 , | |
11198 | & LOUT = 6 , | |
11199 | & LDAT = 9 ) | |
11200 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) | |
11201 | ||
11202 | LOGICAL LEFT,LFIRST | |
11203 | ||
11204 | * central particle production, impact parameter biasing | |
11205 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
11206 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11207 | * Glauber formalism: parameters | |
11208 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11209 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11210 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11211 | & NSITEB,NSTATB | |
11212 | * Glauber formalism: cross sections | |
11213 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11214 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11215 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11216 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11217 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11218 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11219 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11220 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11221 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11222 | & BSLOPE,NEBINI,NQBINI | |
11223 | ||
11224 | DATA LFIRST /.TRUE./ | |
11225 | ||
11226 | NTARG = ABS(NIDX) | |
11227 | IF (NIDX.LE.-1) THEN | |
11228 | RA = RASH(1) | |
11229 | RB = RBSH(NTARG) | |
11230 | ELSE | |
11231 | RA = RASH(NTARG) | |
11232 | RB = RBSH(1) | |
11233 | ENDIF | |
11234 | ||
11235 | IF (ICENTR.EQ.2) THEN | |
11236 | IF (RA.EQ.RB) THEN | |
11237 | BB = DT_RNDM(B)*(0.3D0*RA)**2 | |
11238 | B = SQRT(BB) | |
11239 | ELSEIF(RA.LT.RB)THEN | |
11240 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 | |
11241 | B = SQRT(BB) | |
11242 | ELSEIF(RA.GT.RB)THEN | |
11243 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 | |
11244 | B = SQRT(BB) | |
11245 | ENDIF | |
11246 | ELSE | |
11247 | 9 CONTINUE | |
11248 | Y = DT_RNDM(BB) | |
11249 | I0 = 1 | |
11250 | I2 = NSITEB | |
11251 | 10 CONTINUE | |
11252 | I1 = (I0+I2)/2 | |
11253 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) | |
11254 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO | |
11255 | IF (LEFT) GOTO 20 | |
11256 | I0 = I1 | |
11257 | GOTO 30 | |
11258 | 20 CONTINUE | |
11259 | I2 = I1 | |
11260 | 30 CONTINUE | |
11261 | IF (I2-I0-2) 40,50,60 | |
11262 | 40 CONTINUE | |
11263 | I1 = I2+1 | |
11264 | IF (I1.GT.NSITEB) I1 = I0-1 | |
11265 | GOTO 70 | |
11266 | 50 CONTINUE | |
11267 | I1 = I0+1 | |
11268 | GOTO 70 | |
11269 | 60 CONTINUE | |
11270 | GOTO 10 | |
11271 | 70 CONTINUE | |
11272 | X0 = DBLE(I0-1)*BSTEP(NTARG) | |
11273 | X1 = DBLE(I1-1)*BSTEP(NTARG) | |
11274 | X2 = DBLE(I2-1)*BSTEP(NTARG) | |
11275 | Y0 = BSITE(0,1,NTARG,I0) | |
11276 | Y1 = BSITE(0,1,NTARG,I1) | |
11277 | Y2 = BSITE(0,1,NTARG,I2) | |
11278 | 80 CONTINUE | |
11279 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ | |
11280 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ | |
11281 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) | |
11282 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD | |
11283 | B = B+0.5D0*BSTEP(NTARG) | |
11284 | IF (B.LT.ZERO) B = X1 | |
11285 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) | |
11286 | IF (ICENTR.LT.0) THEN | |
11287 | IF (LFIRST) THEN | |
11288 | LFIRST = .FALSE. | |
11289 | IF (ICENTR.LE.-100) THEN | |
11290 | BIMIN = 0.0D0 | |
11291 | ELSE | |
11292 | XSFRAC = 0.0D0 | |
11293 | ENDIF | |
11294 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) | |
11295 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), | |
11296 | & BIMIN,BIMAX,XSFRAC*100.0D0, | |
11297 | & XSFRAC*XSPRO(1,1,NTARG) | |
11298 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', | |
11299 | & /,15X,'---------------------------'/,/,4X, | |
11300 | & 'average radii of proj / targ :',F10.3,' fm /', | |
11301 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', | |
11302 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', | |
11303 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', | |
11304 | & ' cross section :',F10.3,' %',/,5X, | |
11305 | & 'corresponding cross section :',F10.3,' mb',/) | |
11306 | ENDIF | |
11307 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN | |
11308 | B = BIMIN | |
11309 | ELSE | |
11310 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 | |
11311 | ENDIF | |
11312 | ENDIF | |
11313 | ENDIF | |
11314 | ||
11315 | RETURN | |
11316 | END | |
11317 | ||
11318 | *$ CREATE DT_SHFAST.FOR | |
11319 | *COPY DT_SHFAST | |
11320 | * | |
11321 | *===shfast=============================================================* | |
11322 | * | |
11323 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) | |
11324 | ||
11325 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11326 | SAVE | |
11327 | PARAMETER ( LINP = 10 , | |
11328 | & LOUT = 6 , | |
11329 | & LDAT = 9 ) | |
11330 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, | |
11331 | & ONE=1.0D0,TWO=2.0D0) | |
11332 | ||
11333 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11334 | * Glauber formalism: parameters | |
11335 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11336 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11337 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11338 | & NSITEB,NSTATB | |
11339 | * properties of interacting particles | |
11340 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11341 | * Glauber formalism: cross sections | |
11342 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11343 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11344 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11345 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11346 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11347 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11348 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11349 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11350 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11351 | & BSLOPE,NEBINI,NQBINI | |
11352 | ||
11353 | IBACK = 0 | |
11354 | ||
11355 | IF (MODE.EQ.2) THEN | |
11356 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11357 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN | |
11358 | 1000 FORMAT(1X,8I5,E15.5) | |
11359 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11360 | 1001 FORMAT(1X,4E15.5) | |
11361 | WRITE(47,1002) SIGSH,ROSH,GSH | |
11362 | 1002 FORMAT(1X,3E15.5) | |
11363 | DO 10 I=1,100 | |
11364 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11365 | 10 CONTINUE | |
11366 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11367 | 1003 FORMAT(1X,2I10,3E15.5) | |
11368 | CLOSE(47) | |
11369 | ELSE | |
11370 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11371 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP | |
11372 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. | |
11373 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) | |
11374 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. | |
11375 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN | |
11376 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11377 | READ(47,1002) SIGSH,ROSH,GSH | |
11378 | DO 11 I=1,100 | |
11379 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11380 | 11 CONTINUE | |
11381 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11382 | ELSE | |
11383 | IBACK = 1 | |
11384 | ENDIF | |
11385 | CLOSE(47) | |
11386 | ENDIF | |
11387 | ||
11388 | RETURN | |
11389 | END | |
11390 | ||
11391 | *$ CREATE DT_POILIK.FOR | |
11392 | *COPY DT_POILIK | |
11393 | * | |
11394 | *===poilik=============================================================* | |
11395 | * | |
11396 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) | |
11397 | ||
11398 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
11399 | SAVE | |
11400 | ||
11401 | PARAMETER ( LINP = 10 , | |
11402 | & LOUT = 6 , | |
11403 | & LDAT = 9 ) | |
11404 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) | |
11405 | PARAMETER (NE = 8) | |
11406 | ||
11407 | **PHOJET105a | |
11408 | C CHARACTER*8 MDLNA | |
11409 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
11410 | C PARAMETER (IEETAB=10) | |
11411 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
11412 | **PHOJET110 | |
11413 | C model switches and parameters | |
11414 | CHARACTER*8 MDLNA | |
11415 | INTEGER ISWMDL,IPAMDL | |
11416 | DOUBLE PRECISION PARMDL | |
11417 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
11418 | C energy-interpolation table | |
11419 | INTEGER IEETA2 | |
11420 | PARAMETER ( IEETA2 = 20 ) | |
11421 | INTEGER ISIMAX | |
11422 | DOUBLE PRECISION SIGTAB,SIGECM | |
11423 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
11424 | ** | |
11425 | * VDM parameter for photon-nucleus interactions | |
11426 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
11427 | **sr 22.7.97 | |
11428 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11429 | * Glauber formalism: cross sections | |
11430 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11431 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11432 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11433 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11434 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11435 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11436 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11437 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11438 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11439 | & BSLOPE,NEBINI,NQBINI | |
11440 | ** | |
11441 | ||
11442 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ | |
11443 | ||
11444 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 | |
11445 | ||
11446 | * load cross sections from interpolation table | |
11447 | IP = 1 | |
11448 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
11449 | I1 = 1 | |
11450 | I2 = 1 | |
11451 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
11452 | DO 50 I=2,ISIMAX | |
11453 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 | |
11454 | 50 CONTINUE | |
11455 | 200 CONTINUE | |
11456 | I1 = I-1 | |
11457 | I2 = I | |
11458 | ELSE | |
11459 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
11460 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
11461 | I1 = ISIMAX | |
11462 | I2 = ISIMAX | |
11463 | ENDIF | |
11464 | FAC2 = ZERO | |
11465 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) | |
11466 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
11467 | FAC1 = ONE-FAC2 | |
11468 | ||
11469 | SIGANO = DT_SANO(ECM) | |
11470 | ||
11471 | * cross section dependence on photon virtuality | |
11472 | FSUP1 = ZERO | |
11473 | DO 150 I=1,3 | |
11474 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) | |
11475 | & /(ONE+VIRT/PARMDL(30+I))**2 | |
11476 | 150 CONTINUE | |
11477 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) | |
11478 | FAC1 = FAC1*FSUP1 | |
11479 | FAC2 = FAC2*FSUP1 | |
11480 | FSUP2 = ONE | |
11481 | ||
11482 | ECMOLD = ECM | |
11483 | Q2OLD = VIRT | |
11484 | ||
11485 | 3 CONTINUE | |
11486 | ||
11487 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
11488 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) | |
11489 | IF (ISHAD(1).EQ.1) THEN | |
11490 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
11491 | ELSE | |
11492 | SIGDIR = ZERO | |
11493 | ENDIF | |
11494 | SIGANO = FSUP1*FSUP2*SIGANO | |
11495 | SIGTOT = SIGTOT-SIGDIR-SIGANO | |
11496 | SIGDIR = SIGDIR/(FSUP1*FSUP2) | |
11497 | SIGANO = SIGANO/(FSUP1*FSUP2) | |
11498 | SIGTOT = SIGTOT+SIGDIR+SIGANO | |
11499 | ||
11500 | RR = DT_RNDM(SIGTOT) | |
11501 | IF (RR.LT.SIGDIR/SIGTOT) THEN | |
11502 | IPNT = 1 | |
11503 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. | |
11504 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN | |
11505 | IPNT = 2 | |
11506 | ELSE | |
11507 | IPNT = 0 | |
11508 | ENDIF | |
11509 | RPNT = (SIGDIR+SIGANO)/SIGTOT | |
11510 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 | |
11511 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO | |
11512 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM | |
11513 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT | |
11514 | IF (MODE.EQ.1) RETURN | |
11515 | ||
11516 | **sr 22.7.97 | |
11517 | K1 = 1 | |
11518 | K2 = 1 | |
11519 | RATE = ZERO | |
11520 | IF (ECM.GE.ECMNN(NEBINI)) THEN | |
11521 | K1 = NEBINI | |
11522 | K2 = NEBINI | |
11523 | RATE = ONE | |
11524 | ELSEIF (ECM.GT.ECMNN(1)) THEN | |
11525 | DO 10 I=2,NEBINI | |
11526 | IF (ECM.LT.ECMNN(I)) THEN | |
11527 | K1 = I-1 | |
11528 | K2 = I | |
11529 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) | |
11530 | GOTO 11 | |
11531 | ENDIF | |
11532 | 10 CONTINUE | |
11533 | 11 CONTINUE | |
11534 | ENDIF | |
11535 | J1 = 1 | |
11536 | J2 = 1 | |
11537 | RATQ = ZERO | |
11538 | IF (NQBINI.GT.1) THEN | |
11539 | IF (VIRT.GE.Q2G(NQBINI)) THEN | |
11540 | J1 = NQBINI | |
11541 | J2 = NQBINI | |
11542 | RATQ = ONE | |
11543 | ELSEIF (VIRT.GT.Q2G(1)) THEN | |
11544 | DO 12 I=2,NQBINI | |
11545 | IF (VIRT.LT.Q2G(I)) THEN | |
11546 | J1 = I-1 | |
11547 | J2 = I | |
11548 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ | |
11549 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
11550 | GOTO 13 | |
11551 | ENDIF | |
11552 | 12 CONTINUE | |
11553 | 13 CONTINUE | |
11554 | ENDIF | |
11555 | ENDIF | |
11556 | SGA = XSPRO(K1,J1,NTARG)+ | |
11557 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11558 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11559 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ | |
11560 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) | |
11561 | SDI = DBLE(NB)*SIGDIR | |
11562 | SAN = DBLE(NB)*SIGANO | |
11563 | SPL = SDI+SAN | |
11564 | RR = DT_RNDM(SPL) | |
11565 | IF (RR.LT.SDI/SGA) THEN | |
11566 | IPNT = 1 | |
11567 | ELSEIF ((RR.GE.SDI/SGA).AND. | |
11568 | & (RR.LT.SPL/SGA)) THEN | |
11569 | IPNT = 2 | |
11570 | ELSE | |
11571 | IPNT = 0 | |
11572 | ENDIF | |
11573 | RPNT = SPL/SGA | |
11574 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM | |
11575 | ** | |
11576 | ||
11577 | RETURN | |
11578 | END | |
11579 | ||
11580 | *$ CREATE DT_GLBINI.FOR | |
11581 | *COPY DT_GLBINI | |
11582 | * | |
11583 | *===glbini=============================================================* | |
11584 | * | |
11585 | SUBROUTINE DT_GLBINI(WHAT) | |
11586 | ||
11587 | ************************************************************************ | |
11588 | * Pre-initialization of profile function * | |
11589 | * This version dated 28.11.00 is written by S. Roesler. * | |
11590 | * * | |
11591 | * Last change 27.12.2006 by S. Roesler. * | |
11592 | ************************************************************************ | |
11593 | ||
11594 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11595 | SAVE | |
11596 | ||
11597 | PARAMETER ( LINP = 10 , | |
11598 | & LOUT = 6 , | |
11599 | & LDAT = 9 ) | |
11600 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) | |
11601 | ||
11602 | LOGICAL LCMS | |
11603 | ||
11604 | * particle properties (BAMJET index convention) | |
11605 | CHARACTER*8 ANAME | |
11606 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11607 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11608 | * properties of interacting particles | |
11609 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11610 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11611 | * emulsion treatment | |
11612 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11613 | & NCOMPO,IEMUL | |
11614 | * Glauber formalism: flags and parameters for statistics | |
11615 | LOGICAL LPROD | |
11616 | CHARACTER*8 CGLB | |
11617 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11618 | * number of data sets other than protons and nuclei | |
11619 | * at the moment = 2 (pions and kaons) | |
11620 | PARAMETER (MAXOFF=2) | |
11621 | DIMENSION IJPINI(5),IOFFST(25) | |
11622 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11623 | * Glauber data-set to be used for hadron projectiles | |
11624 | * (0=proton, 1=pion, 2=kaon) | |
11625 | DATA (IOFFST(K),K=1,25) / | |
11626 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11627 | & 0, 0, 1, 2, 2/ | |
11628 | * Acceptance interval for target nucleus mass | |
11629 | PARAMETER (KBACC = 6) | |
11630 | * flags for input different options | |
11631 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
11632 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
11633 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
11634 | ||
11635 | PARAMETER (MAXMSS = 100) | |
11636 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) | |
11637 | DIMENSION WHAT(6) | |
11638 | ||
11639 | DATA JPEACH,JPSTEP / 18, 5 / | |
11640 | ||
11641 | * temporary patch until fix has been implemented in phojet: | |
11642 | * maximum energy for pion projectile | |
11643 | DATA ECMXPI / 100000.0D0 / | |
11644 | * | |
11645 | *-------------------------------------------------------------------------- | |
11646 | * general initializations | |
11647 | * | |
11648 | * steps in projectile mass number for initialization | |
11649 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) | |
11650 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) | |
11651 | * | |
11652 | * energy range and binning | |
11653 | ELO = ABS(WHAT(1)) | |
11654 | EHI = ABS(WHAT(2)) | |
11655 | IF (ELO.GT.EHI) ELO = EHI | |
11656 | NEBIN = MAX(INT(WHAT(3)),1) | |
11657 | IF (ELO.EQ.EHI) NEBIN = 0 | |
11658 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) | |
11659 | IF (LCMS) THEN | |
11660 | ECMINI = EHI | |
11661 | ELSE | |
11662 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 | |
11663 | & +2.0D0*AAM(IJTARG)*EHI) | |
11664 | ENDIF | |
11665 | * | |
11666 | * default arguments for Glauber-routine | |
11667 | XI = ZERO | |
11668 | Q2I = ZERO | |
11669 | * | |
11670 | * initialize nuclear parameters, etc. | |
11671 | CALL DT_BERTTP | |
11672 | CALL DT_INCINI | |
11673 | * | |
11674 | * open Glauber-data output file | |
11675 | IDX = INDEX(CGLB,' ') | |
11676 | K = 12 | |
11677 | IF (IDX.GT.1) K = IDX-1 | |
11678 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11679 | * | |
11680 | *-------------------------------------------------------------------------- | |
11681 | * Glauber-initialization for proton and nuclei projectiles | |
11682 | * | |
11683 | * initialize phojet for proton-proton interactions | |
11684 | ELAB = ZERO | |
11685 | PLAB = ZERO | |
11686 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11687 | CALL DT_PHOINI | |
11688 | * | |
11689 | * record projectile masses | |
11690 | NASAV = 0 | |
11691 | NPROJ = MIN(IP,JPEACH) | |
11692 | DO 10 KPROJ=1,NPROJ | |
11693 | NASAV = NASAV+1 | |
11694 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11695 | IASAV(NASAV) = KPROJ | |
11696 | 10 CONTINUE | |
11697 | IF (IP.GT.JPEACH) THEN | |
11698 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) | |
11699 | IF (NPROJ.EQ.0) THEN | |
11700 | NASAV = NASAV+1 | |
11701 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11702 | IASAV(NASAV) = IP | |
11703 | ELSE | |
11704 | DO 11 IPROJ=1,NPROJ | |
11705 | KPROJ = JPEACH+IPROJ*JPSTEP | |
11706 | NASAV = NASAV+1 | |
11707 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11708 | IASAV(NASAV) = KPROJ | |
11709 | 11 CONTINUE | |
11710 | IF (KPROJ.LT.IP) THEN | |
11711 | NASAV = NASAV+1 | |
11712 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11713 | IASAV(NASAV) = IP | |
11714 | ENDIF | |
11715 | ENDIF | |
11716 | ENDIF | |
11717 | * | |
11718 | * record target masses | |
11719 | NBSAV = 0 | |
11720 | NTARG = 1 | |
11721 | IF (NCOMPO.GT.0) NTARG = NCOMPO | |
11722 | DO 12 ITARG=1,NTARG | |
11723 | NBSAV = NBSAV+1 | |
11724 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' | |
11725 | IF (NCOMPO.GT.0) THEN | |
11726 | IBSAV(NBSAV) = IEMUMA(ITARG) | |
11727 | ELSE | |
11728 | IBSAV(NBSAV) = IT | |
11729 | ENDIF | |
11730 | 12 CONTINUE | |
11731 | * | |
11732 | * print masses | |
11733 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) | |
11734 | 1000 FORMAT(I4,A,1P,2E13.5) | |
11735 | NLINES = DBLE(NASAV)/18.0D0 | |
11736 | IF (NLINES.GT.0) THEN | |
11737 | DO 13 I=1,NLINES | |
11738 | IF (I.EQ.1) THEN | |
11739 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) | |
11740 | ELSE | |
11741 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) | |
11742 | ENDIF | |
11743 | 13 CONTINUE | |
11744 | ENDIF | |
11745 | I0 = 18*NLINES+1 | |
11746 | IF (I0.LE.NASAV) THEN | |
11747 | IF (I0.EQ.1) THEN | |
11748 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) | |
11749 | ELSE | |
11750 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) | |
11751 | ENDIF | |
11752 | ENDIF | |
11753 | NLINES = DBLE(NBSAV)/18.0D0 | |
11754 | IF (NLINES.GT.0) THEN | |
11755 | DO 14 I=1,NLINES | |
11756 | IF (I.EQ.1) THEN | |
11757 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) | |
11758 | ELSE | |
11759 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) | |
11760 | ENDIF | |
11761 | 14 CONTINUE | |
11762 | ENDIF | |
11763 | I0 = 18*NLINES+1 | |
11764 | IF (I0.LE.NBSAV) THEN | |
11765 | IF (I0.EQ.1) THEN | |
11766 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) | |
11767 | ELSE | |
11768 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) | |
11769 | ENDIF | |
11770 | ENDIF | |
11771 | * | |
11772 | * calculate Glauber-data for each energy and mass combination | |
11773 | * | |
11774 | * loop over energy bins | |
11775 | ELO = LOG10(ELO) | |
11776 | EHI = LOG10(EHI) | |
11777 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) | |
11778 | DO 1 IE=1,NEBIN+1 | |
11779 | E = ELO+DBLE(IE-1)*DEBIN | |
11780 | E = 10**E | |
11781 | IF (LCMS) THEN | |
11782 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) | |
11783 | ECM = E | |
11784 | ELSE | |
11785 | PLAB = ZERO | |
11786 | ECM = ZERO | |
11787 | E = MAX(AAM(IJPROJ)+0.1D0,E) | |
11788 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11789 | ENDIF | |
11790 | * | |
11791 | * loop over projectile and target masses | |
11792 | DO 2 ITARG=1,NBSAV | |
11793 | DO 3 IPROJ=1,NASAV | |
11794 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, | |
11795 | & XI,Q2I,ECM,1,1,-1) | |
11796 | 3 CONTINUE | |
11797 | 2 CONTINUE | |
11798 | * | |
11799 | 1 CONTINUE | |
11800 | * | |
11801 | *-------------------------------------------------------------------------- | |
11802 | * Glauber-initialization for pion, kaon, ... projectiles | |
11803 | * | |
11804 | DO 6 IJ=1,MAXOFF | |
11805 | * | |
11806 | * initialize phojet for this interaction | |
11807 | ELAB = ZERO | |
11808 | PLAB = ZERO | |
11809 | IJPROJ = IJPINI(IJ) | |
11810 | IP = 1 | |
11811 | IPZ = 1 | |
11812 | * | |
11813 | * temporary patch until fix has been implemented in phojet: | |
11814 | IF (ECMINI.GT.ECMXPI) THEN | |
11815 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) | |
11816 | ELSE | |
11817 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11818 | ENDIF | |
11819 | CALL DT_PHOINI | |
11820 | * | |
11821 | * calculate Glauber-data for each energy and mass combination | |
11822 | * | |
11823 | * loop over energy bins | |
11824 | DO 4 IE=1,NEBIN+1 | |
11825 | E = ELO+DBLE(IE-1)*DEBIN | |
11826 | E = 10**E | |
11827 | IF (LCMS) THEN | |
11828 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) | |
11829 | ECM = E | |
11830 | ELSE | |
11831 | PLAB = ZERO | |
11832 | ECM = ZERO | |
11833 | E = MAX(AAM(IJPROJ)+TINY14,E) | |
11834 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11835 | ENDIF | |
11836 | * | |
11837 | * loop over projectile and target masses | |
11838 | DO 5 ITARG=1,NBSAV | |
11839 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) | |
11840 | 5 CONTINUE | |
11841 | * | |
11842 | 4 CONTINUE | |
11843 | * | |
11844 | 6 CONTINUE | |
11845 | ||
11846 | *-------------------------------------------------------------------------- | |
11847 | * close output unit(s), etc. | |
11848 | * | |
11849 | CLOSE(LDAT) | |
11850 | ||
11851 | RETURN | |
11852 | END | |
11853 | ||
11854 | *$ CREATE DT_GLBSET.FOR | |
11855 | *COPY DT_GLBSET | |
11856 | * | |
11857 | *===glbset=============================================================* | |
11858 | * | |
11859 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) | |
11860 | ************************************************************************ | |
11861 | * Interpolation of pre-initialized profile functions * | |
11862 | * This version dated 28.11.00 is written by S. Roesler. * | |
11863 | ************************************************************************ | |
11864 | ||
11865 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11866 | SAVE | |
11867 | ||
11868 | PARAMETER ( LINP = 10 , | |
11869 | & LOUT = 6 , | |
11870 | & LDAT = 9 ) | |
11871 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
11872 | ||
11873 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 | |
11874 | ||
11875 | * particle properties (BAMJET index convention) | |
11876 | CHARACTER*8 ANAME | |
11877 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11878 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11879 | * Glauber formalism: flags and parameters for statistics | |
11880 | LOGICAL LPROD | |
11881 | CHARACTER*8 CGLB | |
11882 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11883 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11884 | * Glauber formalism: parameters | |
11885 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11886 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11887 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11888 | & NSITEB,NSTATB | |
11889 | * Glauber formalism: cross sections | |
11890 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11891 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11892 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11893 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11894 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11895 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11896 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11897 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11898 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11899 | & BSLOPE,NEBINI,NQBINI | |
11900 | * number of data sets other than protons and nuclei | |
11901 | * at the moment = 2 (pions and kaons) | |
11902 | PARAMETER (MAXOFF=2) | |
11903 | DIMENSION IJPINI(5),IOFFST(25) | |
11904 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11905 | * Glauber data-set to be used for hadron projectiles | |
11906 | * (0=proton, 1=pion, 2=kaon) | |
11907 | DATA (IOFFST(K),K=1,25) / | |
11908 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11909 | & 0, 0, 1, 2, 2/ | |
11910 | * Acceptance interval for target nucleus mass | |
11911 | PARAMETER (KBACC = 6) | |
11912 | * emulsion treatment | |
11913 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11914 | & NCOMPO,IEMUL | |
11915 | ||
11916 | PARAMETER (MAXSET=5000, | |
11917 | & MAXBIN=100) | |
11918 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) | |
11919 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), | |
11920 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), | |
11921 | & IAIDX(10) | |
11922 | ||
11923 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ | |
11924 | * | |
11925 | * read data from file | |
11926 | * | |
11927 | IF (MODE.EQ.0) THEN | |
11928 | ||
11929 | IF (LREAD) RETURN | |
11930 | ||
11931 | DO 1 I=1,MAXSET | |
11932 | DO 2 J=1,6 | |
11933 | XSIG(I,J) = ZERO | |
11934 | XERR(I,J) = ZERO | |
11935 | 2 CONTINUE | |
11936 | DO 3 J=1,KSITEB | |
11937 | BPROFL(I,J) = ZERO | |
11938 | 3 CONTINUE | |
11939 | 1 CONTINUE | |
11940 | DO 4 I=1,MAXBIN | |
11941 | IABIN(I) = 0 | |
11942 | IBBIN(I) = 0 | |
11943 | 4 CONTINUE | |
11944 | DO 5 I=1,KSITEB | |
11945 | BPRO0(I) = ZERO | |
11946 | BPRO1(I) = ZERO | |
11947 | BPRO(I) = ZERO | |
11948 | 5 CONTINUE | |
11949 | ||
11950 | IDX = INDEX(CGLB,' ') | |
11951 | K = 12 | |
11952 | IF (IDX.GT.1) K = IDX-1 | |
11953 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11954 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' | |
11955 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', | |
11956 | & 'file ',A12,/) | |
11957 | * | |
11958 | * read binning information | |
11959 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI | |
11960 | * return lower energy threshold to Fluka-interface | |
11961 | ELAB = ELO | |
11962 | LCMS = ELO.LT.ZERO | |
11963 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' | |
11964 | IF (LCMS) THEN | |
11965 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN | |
11966 | ELSE | |
11967 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN | |
11968 | ENDIF | |
11969 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, | |
11970 | & 'No. of bins:',I5,/) | |
11971 | ELO = LOG10(ABS(ELO)) | |
11972 | EHI = LOG10(ABS(EHI)) | |
11973 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) | |
11974 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' | |
11975 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) | |
11976 | IF (NABIN.LT.18) THEN | |
11977 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) | |
11978 | ELSE | |
11979 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) | |
11980 | ENDIF | |
11981 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' | |
11982 | IF (NABIN.GT.18) THEN | |
11983 | NLINES = DBLE(NABIN-18)/18.0D0 | |
11984 | IF (NLINES.GT.0) THEN | |
11985 | DO 7 I=1,NLINES | |
11986 | I0 = 18*(I+1)-17 | |
11987 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11988 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11989 | 7 CONTINUE | |
11990 | ENDIF | |
11991 | I0 = 18*(NLINES+1)+1 | |
11992 | IF (I0.LE.NABIN) THEN | |
11993 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11994 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11995 | ENDIF | |
11996 | ENDIF | |
11997 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' | |
11998 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) | |
11999 | IF (NBBIN.LT.18) THEN | |
12000 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) | |
12001 | ELSE | |
12002 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) | |
12003 | ENDIF | |
12004 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' | |
12005 | IF (NBBIN.GT.18) THEN | |
12006 | NLINES = DBLE(NBBIN-18)/18.0D0 | |
12007 | IF (NLINES.GT.0) THEN | |
12008 | DO 8 I=1,NLINES | |
12009 | I0 = 18*(I+1)-17 | |
12010 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12011 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12012 | 8 CONTINUE | |
12013 | ENDIF | |
12014 | I0 = 18*(NLINES+1)+1 | |
12015 | IF (I0.LE.NBBIN) THEN | |
12016 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12017 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12018 | ENDIF | |
12019 | ENDIF | |
12020 | * number of data sets to follow in the Glauber data file | |
12021 | * this variable is used for checks of consistency of projectile | |
12022 | * and target mass configurations given in header of Glauber data | |
12023 | * file and the data-sets which follow in this file | |
12024 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN | |
12025 | * | |
12026 | * read profile function data | |
12027 | NSET = 0 | |
12028 | NAIDX = 0 | |
12029 | IPOLD = 0 | |
12030 | 10 CONTINUE | |
12031 | NSET = NSET+1 | |
12032 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' | |
12033 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM | |
12034 | 1002 FORMAT(5I10,E15.5) | |
12035 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN | |
12036 | NAIDX = NAIDX+1 | |
12037 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' | |
12038 | IAIDX(NAIDX) = IP | |
12039 | IPOLD = IP | |
12040 | ENDIF | |
12041 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) | |
12042 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) | |
12043 | NLINES = INT(DBLE(ISITEB)/7.0D0) | |
12044 | IF (NLINES.GT.0) THEN | |
12045 | DO 11 I=1,NLINES | |
12046 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) | |
12047 | 11 CONTINUE | |
12048 | ENDIF | |
12049 | I0 = 7*NLINES+1 | |
12050 | IF (I0.LE.ISITEB) | |
12051 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) | |
12052 | GOTO 10 | |
12053 | 100 CONTINUE | |
12054 | NSET = NSET-1 | |
12055 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' | |
12056 | WRITE(LOUT,'(/,1X,A)') | |
12057 | & ' projectiles other than protons and nuclei: (particle index)' | |
12058 | IF (NAIDX.GT.0) THEN | |
12059 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) | |
12060 | ELSE | |
12061 | WRITE(LOUT,'(6X,A)') 'none' | |
12062 | ENDIF | |
12063 | * | |
12064 | CLOSE(LDAT) | |
12065 | WRITE(LOUT,*) | |
12066 | LREAD = .TRUE. | |
12067 | ||
12068 | IF (NCOMPO.EQ.0) THEN | |
12069 | DO 12 J=1,NBBIN | |
12070 | NCOMPO = NCOMPO+1 | |
12071 | IEMUMA(NCOMPO) = IBBIN(J) | |
12072 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 | |
12073 | EMUFRA(NCOMPO) = 1.0D0 | |
12074 | 12 CONTINUE | |
12075 | IEMUL = 1 | |
12076 | ENDIF | |
12077 | * | |
12078 | * calculate profile function for certain set of parameters | |
12079 | * | |
12080 | ELSE | |
12081 | ||
12082 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE | |
12083 | * | |
12084 | * check for type of projectile and set index-offset to entry in | |
12085 | * Glauber data array correspondingly | |
12086 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' | |
12087 | IF (IOFFST(IDPROJ).EQ.-1) THEN | |
12088 | STOP ' GLBSET: no data for this projectile !' | |
12089 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN | |
12090 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN | |
12091 | ELSE | |
12092 | IDXOFF = 0 | |
12093 | ENDIF | |
12094 | * | |
12095 | * get energy bin and interpolation factor | |
12096 | IF (LCMS) THEN | |
12097 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) | |
12098 | ELSE | |
12099 | E = ELAB | |
12100 | ENDIF | |
12101 | E = LOG10(E) | |
12102 | IF (E.LT.ELO) THEN | |
12103 | IF (LFRST1) THEN | |
12104 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E | |
12105 | LFRST1 = .FALSE. | |
12106 | ENDIF | |
12107 | E = ELO | |
12108 | ENDIF | |
12109 | IF (E.GT.EHI) THEN | |
12110 | IF (LFRST2) THEN | |
12111 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E | |
12112 | LFRST2 = .FALSE. | |
12113 | ENDIF | |
12114 | E = EHI | |
12115 | ENDIF | |
12116 | IE0 = (E-ELO)/DEBIN+1 | |
12117 | IE1 = IE0+1 | |
12118 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN | |
12119 | * | |
12120 | * get target nucleus index | |
12121 | KB = 0 | |
12122 | NBACC = KBACC | |
12123 | DO 20 I=1,NBBIN | |
12124 | NBDIFF = ABS(NB-IBBIN(I)) | |
12125 | IF (NB.EQ.IBBIN(I)) THEN | |
12126 | KB = I | |
12127 | GOTO 21 | |
12128 | ELSEIF (NBDIFF.LE.NBACC) THEN | |
12129 | KB = I | |
12130 | NBACC = NBDIFF | |
12131 | ENDIF | |
12132 | 20 CONTINUE | |
12133 | IF (KB.NE.0) GOTO 21 | |
12134 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB | |
12135 | STOP | |
12136 | 21 CONTINUE | |
12137 | * | |
12138 | * get projectile nucleus bin and interpolation factor | |
12139 | KA0 = 0 | |
12140 | KA1 = 0 | |
12141 | FACNA = 0 | |
12142 | IF (IDXOFF.GT.0) THEN | |
12143 | KA0 = 1 | |
12144 | KA1 = 1 | |
12145 | KABIN = 1 | |
12146 | ELSE | |
12147 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' | |
12148 | DO 22 I=1,NABIN | |
12149 | IF (NA.EQ.IABIN(I)) THEN | |
12150 | KA0 = I | |
12151 | KA1 = I | |
12152 | GOTO 23 | |
12153 | ELSEIF (NA.LT.IABIN(I)) THEN | |
12154 | KA0 = I-1 | |
12155 | KA1 = I | |
12156 | GOTO 23 | |
12157 | ENDIF | |
12158 | 22 CONTINUE | |
12159 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA | |
12160 | STOP | |
12161 | 23 CONTINUE | |
12162 | IF (KA0.NE.KA1) | |
12163 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) | |
12164 | KABIN = NABIN | |
12165 | ENDIF | |
12166 | * | |
12167 | * interpolate profile functions for interactions ka0-kb and ka1-kb | |
12168 | * for energy E separately | |
12169 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12170 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12171 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12172 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12173 | DO 30 I=1,ISITEB | |
12174 | BPRO0(I) = BPROFL(IDX0,I) | |
12175 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) | |
12176 | BPRO1(I) = BPROFL(IDY0,I) | |
12177 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) | |
12178 | 30 CONTINUE | |
12179 | RADB = DT_RNCLUS(NB) | |
12180 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) | |
12181 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) | |
12182 | * | |
12183 | * interpolate cross sections for energy E and projectile mass | |
12184 | DO 31 I=1,6 | |
12185 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) | |
12186 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) | |
12187 | XS(I) = XS0+FACNA*(XS1-XS0) | |
12188 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) | |
12189 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) | |
12190 | XE(I) = XE0+FACNA*(XE1-XE0) | |
12191 | 31 CONTINUE | |
12192 | * | |
12193 | * interpolate between ka0 and ka1 | |
12194 | RADA = DT_RNCLUS(NA) | |
12195 | BMX = 2.0D0*(RADA+RADB) | |
12196 | BSTP = BMX/DBLE(ISITEB-1) | |
12197 | BPRO(1) = ZERO | |
12198 | DO 32 I=1,ISITEB-1 | |
12199 | B = DBLE(I)*BSTP | |
12200 | * | |
12201 | * calculate values of profile functions at B | |
12202 | IDX0 = B/BSTP0+1 | |
12203 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12204 | IDX1 = MIN(IDX0+1,ISITEB) | |
12205 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 | |
12206 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) | |
12207 | IDX0 = B/BSTP1+1 | |
12208 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12209 | IDX1 = MIN(IDX0+1,ISITEB) | |
12210 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 | |
12211 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) | |
12212 | * | |
12213 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) | |
12214 | 32 CONTINUE | |
12215 | * | |
12216 | * fill common dtglam | |
12217 | NSITEB = ISITEB | |
12218 | RASH(1) = RADA | |
12219 | RBSH(1) = RADB | |
12220 | BMAX(1) = BMX | |
12221 | BSTEP(1) = BSTP | |
12222 | DO 33 I=1,KSITEB | |
12223 | BSITE(0,1,1,I) = BPRO(I) | |
12224 | 33 CONTINUE | |
12225 | * | |
12226 | * fill common dtglxs | |
12227 | XSTOT(1,1,1) = XS(1) | |
12228 | XSELA(1,1,1) = XS(2) | |
12229 | XSQEP(1,1,1) = XS(3) | |
12230 | XSQET(1,1,1) = XS(4) | |
12231 | XSQE2(1,1,1) = XS(5) | |
12232 | XSPRO(1,1,1) = XS(6) | |
12233 | XETOT(1,1,1) = XE(1) | |
12234 | XEELA(1,1,1) = XE(2) | |
12235 | XEQEP(1,1,1) = XE(3) | |
12236 | XEQET(1,1,1) = XE(4) | |
12237 | XEQE2(1,1,1) = XE(5) | |
12238 | XEPRO(1,1,1) = XE(6) | |
12239 | ||
12240 | ENDIF | |
12241 | ||
12242 | RETURN | |
12243 | END | |
12244 | ||
12245 | *$ CREATE DT_XKSAMP.FOR | |
12246 | *COPY DT_XKSAMP | |
12247 | * | |
12248 | *===xksamp=============================================================* | |
12249 | * | |
12250 | SUBROUTINE DT_XKSAMP(NN,ECM) | |
12251 | ||
12252 | ************************************************************************ | |
12253 | * Sampling of parton x-values and chain system for one interaction. * | |
12254 | * processed by S. Roesler, 9.8.95 * | |
12255 | ************************************************************************ | |
12256 | ||
12257 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12258 | SAVE | |
12259 | PARAMETER ( LINP = 10 , | |
12260 | & LOUT = 6 , | |
12261 | & LDAT = 9 ) | |
12262 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
454792a9 | 12263 | CPH SAVE |
9aaba0d6 | 12264 | |
12265 | PARAMETER ( | |
12266 | * lower cuts for (valence-sea/sea-valence) chain masses | |
12267 | * antiquark-quark (u/d-sea quark) (s-sea quark) | |
12268 | & AMIU = 0.5D0, AMIS = 0.8D0, | |
12269 | * quark-diquark (u/d-sea quark) (s-sea quark) | |
12270 | & AMAU = 2.6D0, AMAS = 2.6D0, | |
12271 | * maximum lower valence-x threshold | |
12272 | & XVMAX = 0.98D0, | |
12273 | * fraction of sea-diquarks sampled out of sea-partons | |
12274 | **test | |
12275 | C & FRCDIQ = 0.9D0, | |
12276 | ** | |
12277 | * | |
12278 | & SQMA = 0.7D0, | |
12279 | * | |
12280 | * maximum number of trials to generate x's for the required number | |
12281 | * of sea quark pairs for a given hadron | |
12282 | & NSEATY = 12 | |
12283 | C & NSEATY = 3 | |
12284 | & ) | |
12285 | ||
12286 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO | |
12287 | ||
12288 | PARAMETER ( MAXNCL = 260, | |
12289 | & MAXVQU = MAXNCL, | |
12290 | & MAXSQU = 20*MAXVQU, | |
12291 | & MAXINT = MAXVQU+MAXSQU) | |
12292 | * event history | |
12293 | PARAMETER (NMXHKK=200000) | |
12294 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
12295 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
12296 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
12297 | * particle properties (BAMJET index convention) | |
12298 | CHARACTER*8 ANAME | |
12299 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12300 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12301 | * interface between Glauber formalism and DPM | |
12302 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
12303 | & INTER1(MAXINT),INTER2(MAXINT) | |
12304 | * properties of interacting particles | |
12305 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
12306 | * threshold values for x-sampling (DTUNUC 1.x) | |
12307 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
12308 | & SSMIMQ,VVMTHR | |
12309 | * x-values of partons (DTUNUC 1.x) | |
12310 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
12311 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
12312 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
12313 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
12314 | * flavors of partons (DTUNUC 1.x) | |
12315 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
12316 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
12317 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
12318 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
12319 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
12320 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
12321 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
12322 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12323 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
12324 | & IXPV,IXPS,IXTV,IXTS, | |
12325 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
12326 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
12327 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
12328 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
12329 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
12330 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
12331 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
12332 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
12333 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12334 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
12335 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
12336 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
12337 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
12338 | * flags for input different options | |
12339 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
12340 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
12341 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
12342 | * various options for treatment of partons (DTUNUC 1.x) | |
12343 | * (chain recombination, Cronin,..) | |
12344 | LOGICAL LCO2CR,LINTPT | |
12345 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
12346 | & LCO2CR,LINTPT | |
12347 | ||
12348 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), | |
12349 | & INTLO(MAXINT) | |
12350 | ||
12351 | * (1) initializations | |
12352 | *----------------------------------------------------------------------- | |
12353 | ||
12354 | **test | |
12355 | IF (ECM.LT.4.5D0) THEN | |
12356 | C FRCDIQ = 0.6D0 | |
12357 | FRCDIQ = 0.4D0 | |
12358 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN | |
12359 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12360 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12361 | ELSE | |
12362 | C FRCDIQ = 0.9D0 | |
12363 | FRCDIQ = 0.7D0 | |
12364 | ENDIF | |
12365 | ** | |
12366 | DO 30 I=1,MAXSQU | |
12367 | ZUOSP(I) = .FALSE. | |
12368 | ZUOST(I) = .FALSE. | |
12369 | IF (I.LE.MAXVQU) THEN | |
12370 | ZUOVP(I) = .FALSE. | |
12371 | ZUOVT(I) = .FALSE. | |
12372 | ENDIF | |
12373 | 30 CONTINUE | |
12374 | ||
12375 | * lower thresholds for x-selection | |
12376 | * sea-quarks (default: CSEA=0.2) | |
12377 | IF (ECM.LT.10.0D0) THEN | |
12378 | **!!test | |
12379 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM | |
12380 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 | |
12381 | NSEA = NSEATY | |
12382 | C XSTHR = ONE/ECM**2 | |
12383 | ELSE | |
12384 | **sr 30.3.98 | |
12385 | C XSTHR = CSEA/ECM | |
12386 | XSTHR = CSEA/ECM**2 | |
12387 | C XSTHR = ONE/ECM**2 | |
12388 | ** | |
12389 | IF ((IP.GE.150).AND.(IT.GE.150)) | |
12390 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) | |
12391 | NSEA = NSEATY | |
12392 | ENDIF | |
12393 | * (default: SSMIMA=0.14) used for sea-diquarks (?) | |
12394 | XSSTHR = SSMIMA/ECM | |
12395 | BSQMA = SQMA/ECM | |
12396 | * valence-quarks (default: CVQ=1.0) | |
12397 | XVTHR = CVQ/ECM | |
12398 | * valence-diquarks (default: CDQ=2.0) | |
12399 | XDTHR = CDQ/ECM | |
12400 | ||
12401 | * maximum-x for sea-quarks | |
12402 | XVCUT = XVTHR+XDTHR | |
12403 | IF (XVCUT.GT.XVMAX) THEN | |
12404 | XVCUT = XVMAX | |
12405 | XVTHR = XVCUT/3.0D0 | |
12406 | XDTHR = XVCUT-XVTHR | |
12407 | ENDIF | |
12408 | XXSEAM = ONE-XVCUT | |
12409 | **sr 18.4. test: DPMJET | |
12410 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) | |
12411 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) | |
12412 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) | |
12413 | ** | |
12414 | * maximum number of sea-pairs allowed kinematically | |
12415 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12416 | RNSMAX = OHALF*XXSEAM/XSTHR | |
12417 | IF (RNSMAX.GT.10000.0D0) THEN | |
12418 | NSMAX = 10000 | |
12419 | ELSE | |
12420 | NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12421 | ENDIF | |
12422 | * check kinematical limit for valence-x thresholds | |
12423 | * (should be obsolete now) | |
12424 | IF (XVCUT.GT.XVMAX) THEN | |
12425 | WRITE(LOUT,1000) XVCUT,ECM | |
12426 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', | |
12427 | & ' thresholds not allowed (',2E9.3,')') | |
12428 | C XVTHR = XVMAX-XDTHR | |
12429 | C IF (XVTHR.LT.ZERO) STOP | |
12430 | STOP | |
12431 | ENDIF | |
12432 | ||
12433 | * set eta for valence-x sampling (BETREJ) | |
12434 | * (UNON per default, UNOM used for projectile mesons only) | |
12435 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN | |
12436 | UNOPRV = UNOM | |
12437 | ELSE | |
12438 | UNOPRV = UNON | |
12439 | ENDIF | |
12440 | ||
12441 | * (2) select parton x-values of interacting projectile nucleons | |
12442 | *----------------------------------------------------------------------- | |
12443 | ||
12444 | IXPV = 0 | |
12445 | IXPS = 0 | |
12446 | ||
12447 | DO 100 IPP=1,IP | |
12448 | * get interacting projectile nucleon as sampled by Glauber | |
12449 | IF (JSSH(IPP).NE.0) THEN | |
12450 | IXSTMP = IXPS | |
12451 | IXVTMP = IXPV | |
12452 | 99 CONTINUE | |
12453 | IXPS = IXSTMP | |
12454 | IXPV = IXVTMP | |
12455 | * JIPP is the actual number of sea-pairs sampled for this nucleon | |
12456 | JIPP = MIN(JSSH(IPP)-1,NSMAX) | |
12457 | 41 CONTINUE | |
12458 | XXSEA = ZERO | |
12459 | IF (JIPP.GT.0) THEN | |
12460 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR | |
12461 | *??? | |
12462 | IF (XSTHR.GE.XSMAX) THEN | |
12463 | JIPP = JIPP-1 | |
12464 | GOTO 41 | |
12465 | ENDIF | |
12466 | ||
12467 | *>>>get x-values of sea-quark pairs | |
12468 | NSCOUN = 0 | |
12469 | PLW = 0.5D0 | |
12470 | 40 CONTINUE | |
12471 | * accumulator for sea x-values | |
12472 | XXSEA = ZERO | |
12473 | NSCOUN = NSCOUN+1 | |
12474 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12475 | IF (NSCOUN.GT.NSEA) THEN | |
12476 | * decrease the number of interactions after NSEA trials | |
12477 | JIPP = JIPP-1 | |
12478 | NSCOUN = 0 | |
12479 | ENDIF | |
12480 | DO 70 ISQ=1,JIPP | |
12481 | * sea-quarks | |
12482 | IF (IPSQ(IXPS+1).LE.2) THEN | |
12483 | **sr 8.4.98 (1/sqrt(x)) | |
12484 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12485 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12486 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12487 | ** | |
12488 | ELSE | |
12489 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12490 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12491 | ELSE | |
12492 | **sr 8.4.98 (1/sqrt(x)) | |
12493 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12494 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12495 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12496 | ** | |
12497 | ENDIF | |
12498 | ENDIF | |
12499 | * sea-antiquarks | |
12500 | IF (IPSAQ(IXPS+1).GE.-2) THEN | |
12501 | **sr 8.4.98 (1/sqrt(x)) | |
12502 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12503 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12504 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12505 | ** | |
12506 | ELSE | |
12507 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12508 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12509 | ELSE | |
12510 | **sr 8.4.98 (1/sqrt(x)) | |
12511 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12512 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12513 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12514 | ** | |
12515 | ENDIF | |
12516 | ENDIF | |
12517 | XXSEA = XXSEA+XPSQI+XPSAQI | |
12518 | * check for maximum allowed sea x-value | |
12519 | IF (XXSEA.GE.XXSEAM) THEN | |
12520 | IXPS = IXPS-ISQ+1 | |
12521 | GOTO 40 | |
12522 | ENDIF | |
12523 | * accept this sea-quark pair | |
12524 | IXPS = IXPS+1 | |
12525 | XPSQ(IXPS) = XPSQI | |
12526 | XPSAQ(IXPS) = XPSAQI | |
12527 | IFROSP(IXPS) = IPP | |
12528 | ZUOSP(IXPS) = .TRUE. | |
12529 | 70 CONTINUE | |
12530 | ENDIF | |
12531 | ||
12532 | *>>>get x-values of valence partons | |
12533 | * valence quark | |
12534 | IF (XVTHR.GT.0.05D0) THEN | |
12535 | XVHI = ONE-XXSEA-XDTHR | |
12536 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) | |
12537 | ELSE | |
12538 | 90 CONTINUE | |
12539 | XPVQI = DT_DBETAR(OHALF,UNOPRV) | |
12540 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) | |
12541 | & GOTO 90 | |
12542 | ENDIF | |
12543 | * valence diquark | |
12544 | XPVDI = ONE-XPVQI-XXSEA | |
12545 | * reject according to x**1.5 | |
12546 | XDTMP = XPVDI**1.5D0 | |
12547 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 | |
12548 | * accept these valence partons | |
12549 | IXPV = IXPV+1 | |
12550 | XPVQ(IXPV) = XPVQI | |
12551 | XPVD(IXPV) = XPVDI | |
12552 | IFROVP(IXPV) = IPP | |
12553 | ITOVP(IPP) = IXPV | |
12554 | ZUOVP(IXPV) = .TRUE. | |
12555 | ||
12556 | ENDIF | |
12557 | 100 CONTINUE | |
12558 | ||
12559 | * (3) select parton x-values of interacting target nucleons | |
12560 | *----------------------------------------------------------------------- | |
12561 | ||
12562 | IXTV = 0 | |
12563 | IXTS = 0 | |
12564 | ||
12565 | DO 170 ITT=1,IT | |
12566 | * get interacting target nucleon as sampled by Glauber | |
12567 | IF (JTSH(ITT).NE.0) THEN | |
12568 | IXSTMP = IXTS | |
12569 | IXVTMP = IXTV | |
12570 | 169 CONTINUE | |
12571 | IXTS = IXSTMP | |
12572 | IXTV = IXVTMP | |
12573 | * JITT is the actual number of sea-pairs sampled for this nucleon | |
12574 | JITT = MIN(JTSH(ITT)-1,NSMAX) | |
12575 | 111 CONTINUE | |
12576 | XXSEA = ZERO | |
12577 | IF (JITT.GT.0) THEN | |
12578 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR | |
12579 | *??? | |
12580 | IF (XSTHR.GE.XSMAX) THEN | |
12581 | JITT = JITT-1 | |
12582 | GOTO 111 | |
12583 | ENDIF | |
12584 | ||
12585 | *>>>get x-values of sea-quark pairs | |
12586 | NSCOUN = 0 | |
12587 | PLW = 0.5D0 | |
12588 | 110 CONTINUE | |
12589 | * accumulator for sea x-values | |
12590 | XXSEA = ZERO | |
12591 | NSCOUN = NSCOUN+1 | |
12592 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12593 | IF (NSCOUN.GT.NSEA)THEN | |
12594 | * decrease the number of interactions after NSEA trials | |
12595 | JITT = JITT-1 | |
12596 | NSCOUN = 0 | |
12597 | ENDIF | |
12598 | DO 140 ISQ=1,JITT | |
12599 | * sea-quarks | |
12600 | IF (ITSQ(IXTS+1).LE.2) THEN | |
12601 | **sr 8.4.98 (1/sqrt(x)) | |
12602 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12603 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12604 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12605 | ** | |
12606 | ELSE | |
12607 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12608 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12609 | ELSE | |
12610 | **sr 8.4.98 (1/sqrt(x)) | |
12611 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12612 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12613 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12614 | ** | |
12615 | ENDIF | |
12616 | ENDIF | |
12617 | * sea-antiquarks | |
12618 | IF (ITSAQ(IXTS+1).GE.-2) THEN | |
12619 | **sr 8.4.98 (1/sqrt(x)) | |
12620 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12621 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12622 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12623 | ** | |
12624 | ELSE | |
12625 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12626 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12627 | ELSE | |
12628 | **sr 8.4.98 (1/sqrt(x)) | |
12629 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12630 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12631 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12632 | ** | |
12633 | ENDIF | |
12634 | ENDIF | |
12635 | XXSEA = XXSEA+XTSQI+XTSAQI | |
12636 | * check for maximum allowed sea x-value | |
12637 | IF (XXSEA.GE.XXSEAM) THEN | |
12638 | IXTS = IXTS-ISQ+1 | |
12639 | GOTO 110 | |
12640 | ENDIF | |
12641 | * accept this sea-quark pair | |
12642 | IXTS = IXTS+1 | |
12643 | XTSQ(IXTS) = XTSQI | |
12644 | XTSAQ(IXTS) = XTSAQI | |
12645 | IFROST(IXTS) = ITT | |
12646 | ZUOST(IXTS) = .TRUE. | |
12647 | 140 CONTINUE | |
12648 | ENDIF | |
12649 | ||
12650 | *>>>get x-values of valence partons | |
12651 | * valence quark | |
12652 | IF (XVTHR.GT.0.05D0) THEN | |
12653 | XVHI = ONE-XXSEA-XDTHR | |
12654 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) | |
12655 | ELSE | |
12656 | 160 CONTINUE | |
12657 | XTVQI = DT_DBETAR(OHALF,UNON) | |
12658 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) | |
12659 | & GOTO 160 | |
12660 | ENDIF | |
12661 | * valence diquark | |
12662 | XTVDI = ONE-XTVQI-XXSEA | |
12663 | * reject according to x**1.5 | |
12664 | XDTMP = XTVDI**1.5D0 | |
12665 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 | |
12666 | * accept these valence partons | |
12667 | IXTV = IXTV+1 | |
12668 | XTVQ(IXTV) = XTVQI | |
12669 | XTVD(IXTV) = XTVDI | |
12670 | IFROVT(IXTV) = ITT | |
12671 | ITOVT(ITT) = IXTV | |
12672 | ZUOVT(IXTV) = .TRUE. | |
12673 | ||
12674 | ENDIF | |
12675 | 170 CONTINUE | |
12676 | ||
12677 | * (4) get valence-valence chains | |
12678 | *----------------------------------------------------------------------- | |
12679 | ||
12680 | NVV = 0 | |
12681 | DO 240 I=1,NN | |
12682 | INTLO(I) = .TRUE. | |
12683 | IPVAL = ITOVP(INTER1(I)) | |
12684 | ITVAL = ITOVT(INTER2(I)) | |
12685 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN | |
12686 | INTLO(I) = .FALSE. | |
12687 | ZUOVP(IPVAL) = .FALSE. | |
12688 | ZUOVT(ITVAL) = .FALSE. | |
12689 | NVV = NVV+1 | |
12690 | ISKPCH(8,NVV) = 0 | |
12691 | INTVV1(NVV) = IPVAL | |
12692 | INTVV2(NVV) = ITVAL | |
12693 | ENDIF | |
12694 | 240 CONTINUE | |
12695 | ||
12696 | * (5) get sea-valence chains | |
12697 | *----------------------------------------------------------------------- | |
12698 | ||
12699 | NSV = 0 | |
12700 | NDV = 0 | |
12701 | PLW = 0.5D0 | |
12702 | DO 270 I=1,NN | |
12703 | IF (INTLO(I)) THEN | |
12704 | IPVAL = ITOVP(INTER1(I)) | |
12705 | ITVAL = ITOVT(INTER2(I)) | |
12706 | DO 250 J=1,IXPS | |
12707 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. | |
12708 | & ZUOVT(ITVAL)) THEN | |
12709 | ZUOSP(J) = .FALSE. | |
12710 | ZUOVT(ITVAL) = .FALSE. | |
12711 | INTLO(I) = .FALSE. | |
12712 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN | |
12713 | * sample sea-diquark pair | |
12714 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) | |
12715 | IF (IREJ1.EQ.0) GOTO 260 | |
12716 | ENDIF | |
12717 | NSV = NSV+1 | |
12718 | ISKPCH(4,NSV) = 0 | |
12719 | INTSV1(NSV) = J | |
12720 | INTSV2(NSV) = ITVAL | |
12721 | ||
12722 | *>>>correct chain kinematics according to minimum chain masses | |
12723 | * the actual chain masses | |
12724 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 | |
12725 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 | |
12726 | * get lower mass cuts | |
12727 | IF (IPSQ(J).EQ.3) THEN | |
12728 | * q being s-quark | |
12729 | AMCHK1 = AMAS | |
12730 | AMCHK2 = AMIS | |
12731 | ELSE | |
12732 | * q being u/d-quark | |
12733 | AMCHK1 = AMAU | |
12734 | AMCHK2 = AMIU | |
12735 | ENDIF | |
12736 | * q-qq chain | |
12737 | * chain mass above minimum - resampling of sea-q x-value | |
12738 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12739 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12740 | **sr 8.4.98 (1/sqrt(x)) | |
12741 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) | |
12742 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) | |
12743 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) | |
12744 | ** | |
12745 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX | |
12746 | XPSQ(J) = XPSQXX | |
12747 | * chain mass below minimum - reset sea-q x-value and correct | |
12748 | * diquark-x of the same nucleon | |
12749 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12750 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12751 | DXPSQ = XPSQW-XPSQ(J) | |
12752 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12753 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12754 | XPSQ(J) = XPSQW | |
12755 | ENDIF | |
12756 | ENDIF | |
12757 | * aq-q chain | |
12758 | * chain mass below minimum - reset sea-aq x-value and correct | |
12759 | * diquark-x of the same nucleon | |
12760 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12761 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) | |
12762 | DXPSQ = XPSQW-XPSAQ(J) | |
12763 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12764 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12765 | XPSAQ(J) = XPSQW | |
12766 | ENDIF | |
12767 | ENDIF | |
12768 | *>>>end of chain mass correction | |
12769 | ||
12770 | GOTO 260 | |
12771 | ENDIF | |
12772 | 250 CONTINUE | |
12773 | ENDIF | |
12774 | 260 CONTINUE | |
12775 | 270 CONTINUE | |
12776 | ||
12777 | * (6) get valence-sea chains | |
12778 | *----------------------------------------------------------------------- | |
12779 | ||
12780 | NVS = 0 | |
12781 | NVD = 0 | |
12782 | DO 300 I=1,NN | |
12783 | IF (INTLO(I)) THEN | |
12784 | IPVAL = ITOVP(INTER1(I)) | |
12785 | ITVAL = ITOVT(INTER2(I)) | |
12786 | DO 280 J=1,IXTS | |
12787 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. | |
12788 | & (IFROST(J).EQ.INTER2(I))) THEN | |
12789 | ZUOST(J) = .FALSE. | |
12790 | ZUOVP(IPVAL) = .FALSE. | |
12791 | INTLO(I) = .FALSE. | |
12792 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
12793 | * sample sea-diquark pair | |
12794 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) | |
12795 | IF (IREJ1.EQ.0) GOTO 290 | |
12796 | ENDIF | |
12797 | NVS = NVS + 1 | |
12798 | ISKPCH(6,NVS) = 0 | |
12799 | INTVS1(NVS) = IPVAL | |
12800 | INTVS2(NVS) = J | |
12801 | ||
12802 | *>>>correct chain kinematics according to minimum chain masses | |
12803 | * the actual chain masses | |
12804 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 | |
12805 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 | |
12806 | * get lower mass cuts | |
12807 | IF (ITSQ(J).EQ.3) THEN | |
12808 | * q being s-quark | |
12809 | AMCHK1 = AMIS | |
12810 | AMCHK2 = AMAS | |
12811 | ELSE | |
12812 | * q being u/d-quark | |
12813 | AMCHK1 = AMIU | |
12814 | AMCHK2 = AMAU | |
12815 | ENDIF | |
12816 | * q-aq chain | |
12817 | * chain mass below minimum - reset sea-aq x-value and correct | |
12818 | * diquark-x of the same nucleon | |
12819 | IF (AMVSQ1.LT.AMCHK1) THEN | |
12820 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) | |
12821 | DXTSQ = XTSQW-XTSAQ(J) | |
12822 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12823 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12824 | XTSAQ(J) = XTSQW | |
12825 | ENDIF | |
12826 | ENDIF | |
12827 | * qq-q chain | |
12828 | * chain mass above minimum - resampling of sea-q x-value | |
12829 | IF (AMVSQ2.GT.AMCHK2) THEN | |
12830 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12831 | **sr 8.4.98 (1/sqrt(x)) | |
12832 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) | |
12833 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) | |
12834 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
12835 | ** | |
12836 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
12837 | XTSQ(J) = XTSQXX | |
12838 | * chain mass below minimum - reset sea-q x-value and correct | |
12839 | * diquark-x of the same nucleon | |
12840 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
12841 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12842 | DXTSQ = XTSQW-XTSQ(J) | |
12843 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12844 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12845 | XTSQ(J) = XTSQW | |
12846 | ENDIF | |
12847 | ENDIF | |
12848 | *>>>end of chain mass correction | |
12849 | ||
12850 | GOTO 290 | |
12851 | ENDIF | |
12852 | 280 CONTINUE | |
12853 | ENDIF | |
12854 | 290 CONTINUE | |
12855 | 300 CONTINUE | |
12856 | ||
12857 | * (7) get sea-sea chains | |
12858 | *----------------------------------------------------------------------- | |
12859 | ||
12860 | NSS = 0 | |
12861 | NDS = 0 | |
12862 | NSD = 0 | |
12863 | DO 420 I=1,NN | |
12864 | IF (INTLO(I)) THEN | |
12865 | IPVAL = ITOVP(INTER1(I)) | |
12866 | ITVAL = ITOVT(INTER2(I)) | |
12867 | * loop over target partons not yet matched | |
12868 | DO 400 J=1,IXTS | |
12869 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN | |
12870 | * loop over projectile partons not yet matched | |
12871 | DO 390 JJ=1,IXPS | |
12872 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN | |
12873 | ZUOSP(JJ) = .FALSE. | |
12874 | ZUOST(J) = .FALSE. | |
12875 | INTLO(I) = .FALSE. | |
12876 | NSS = NSS+1 | |
12877 | ISKPCH(1,NSS) = 0 | |
12878 | INTSS1(NSS) = JJ | |
12879 | INTSS2(NSS) = J | |
12880 | ||
12881 | *---->chain recombination option | |
12882 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) | |
12883 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) | |
12884 | & THEN | |
12885 | * sea-sea chains may recombine with valence-valence chains | |
12886 | * only if they have the same projectile or target nucleon | |
12887 | DO 4201 IVV=1,NVV | |
12888 | IF (ISKPCH(8,IVV).NE.99) THEN | |
12889 | IXVPR = INTVV1(IVV) | |
12890 | IXVTA = INTVV2(IVV) | |
12891 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. | |
12892 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN | |
12893 | * recombination possible, drop old v-v and s-s chains | |
12894 | ISKPCH(1,NSS) = 99 | |
12895 | ISKPCH(8,IVV) = 99 | |
12896 | ||
12897 | * (a) assign new s-v chains | |
12898 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12899 | IF (LSEADI.AND. | |
12900 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) | |
12901 | & THEN | |
12902 | * sample sea-diquark pair | |
12903 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, | |
12904 | & IREJ1) | |
12905 | IF (IREJ1.EQ.0) GOTO 4202 | |
12906 | ENDIF | |
12907 | NSV = NSV+1 | |
12908 | ISKPCH(4,NSV) = 0 | |
12909 | INTSV1(NSV) = JJ | |
12910 | INTSV2(NSV) = IXVTA | |
12911 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12912 | * the actual chain masses | |
12913 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) | |
12914 | & *ECM**2 | |
12915 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) | |
12916 | & *ECM**2 | |
12917 | * get lower mass cuts | |
12918 | IF (IPSQ(JJ).EQ.3) THEN | |
12919 | * q being s-quark | |
12920 | AMCHK1 = AMAS | |
12921 | AMCHK2 = AMIS | |
12922 | ELSE | |
12923 | * q being u/d-quark | |
12924 | AMCHK1 = AMAU | |
12925 | AMCHK2 = AMIU | |
12926 | ENDIF | |
12927 | * q-qq chain | |
12928 | * chain mass above minimum - resampling of sea-q x-value | |
12929 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12930 | XPSQTH = | |
12931 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12932 | **sr 8.4.98 (1/sqrt(x)) | |
12933 | XPSQXX = | |
12934 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) | |
12935 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) | |
12936 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) | |
12937 | ** | |
12938 | XPVD(IPVAL) = | |
12939 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX | |
12940 | XPSQ(JJ) = XPSQXX | |
12941 | * chain mass below minimum - reset sea-q x-value and correct | |
12942 | * diquark-x of the same nucleon | |
12943 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12944 | XPSQW = | |
12945 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12946 | DXPSQ = XPSQW-XPSQ(JJ) | |
12947 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12948 | & THEN | |
12949 | XPVD(IPVAL) = | |
12950 | & XPVD(IPVAL)-DXPSQ | |
12951 | XPSQ(JJ) = XPSQW | |
12952 | ENDIF | |
12953 | ENDIF | |
12954 | * aq-q chain | |
12955 | * chain mass below minimum - reset sea-aq x-value and correct | |
12956 | * diquark-x of the same nucleon | |
12957 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12958 | XPSQW = | |
12959 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) | |
12960 | DXPSQ = XPSQW-XPSAQ(JJ) | |
12961 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12962 | & THEN | |
12963 | XPVD(IPVAL) = | |
12964 | & XPVD(IPVAL)-DXPSQ | |
12965 | XPSAQ(JJ) = XPSQW | |
12966 | ENDIF | |
12967 | ENDIF | |
12968 | *>>>>>>>>>>>end of chain mass correction | |
12969 | 4202 CONTINUE | |
12970 | ||
12971 | * (b) assign new v-s chains | |
12972 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12973 | IF (LSEADI.AND.( | |
12974 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) | |
12975 | & THEN | |
12976 | * sample sea-diquark pair | |
12977 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, | |
12978 | & IREJ1) | |
12979 | IF (IREJ1.EQ.0) GOTO 4203 | |
12980 | ENDIF | |
12981 | NVS = NVS+1 | |
12982 | ISKPCH(6,NVS) = 0 | |
12983 | INTVS1(NVS) = IXVPR | |
12984 | INTVS2(NVS) = J | |
12985 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12986 | * the actual chain masses | |
12987 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 | |
12988 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 | |
12989 | * get lower mass cuts | |
12990 | IF (ITSQ(J).EQ.3) THEN | |
12991 | * q being s-quark | |
12992 | AMCHK1 = AMIS | |
12993 | AMCHK2 = AMAS | |
12994 | ELSE | |
12995 | * q being u/d-quark | |
12996 | AMCHK1 = AMIU | |
12997 | AMCHK2 = AMAU | |
12998 | ENDIF | |
12999 | * q-aq chain | |
13000 | * chain mass below minimum - reset sea-aq x-value and correct | |
13001 | * diquark-x of the same nucleon | |
13002 | IF (AMVSQ1.LT.AMCHK1) THEN | |
13003 | XTSQW = | |
13004 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) | |
13005 | DXTSQ = XTSQW-XTSAQ(J) | |
13006 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
13007 | & THEN | |
13008 | XTVD(ITVAL) = | |
13009 | & XTVD(ITVAL)-DXTSQ | |
13010 | XTSAQ(J) = XTSQW | |
13011 | ENDIF | |
13012 | ENDIF | |
13013 | IF (AMVSQ2.GT.AMCHK2) THEN | |
13014 | XTSQTH = | |
13015 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13016 | **sr 8.4.98 (1/sqrt(x)) | |
13017 | XTSQXX = | |
13018 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
13019 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) | |
13020 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) | |
13021 | ** | |
13022 | XTVD(ITVAL) = | |
13023 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
13024 | XTSQ(J) = XTSQXX | |
13025 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
13026 | XTSQW = | |
13027 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13028 | DXTSQ = XTSQW-XTSQ(J) | |
13029 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
13030 | & THEN | |
13031 | XTVD(ITVAL) = | |
13032 | & XTVD(ITVAL)-DXTSQ | |
13033 | XTSQ(J) = XTSQW | |
13034 | ENDIF | |
13035 | ENDIF | |
13036 | *>>>>>>>>>end of chain mass correction | |
13037 | 4203 CONTINUE | |
13038 | * jump out of s-s chain loop | |
13039 | GOTO 420 | |
13040 | ENDIF | |
13041 | ENDIF | |
13042 | 4201 CONTINUE | |
13043 | ENDIF | |
13044 | *---->end of chain recombination option | |
13045 | ||
13046 | * sample sea-diquark pair (projectile) | |
13047 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN | |
13048 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) | |
13049 | IF (IREJ1.EQ.0) THEN | |
13050 | ISKPCH(1,NSS) = 99 | |
13051 | GOTO 410 | |
13052 | ENDIF | |
13053 | ENDIF | |
13054 | * sample sea-diquark pair (target) | |
13055 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
13056 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) | |
13057 | IF (IREJ1.EQ.0) THEN | |
13058 | ISKPCH(1,NSS) = 99 | |
13059 | GOTO 410 | |
13060 | ENDIF | |
13061 | ENDIF | |
13062 | *>>>>>correct chain kinematics according to minimum chain masses | |
13063 | * the actual chain masses | |
13064 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 | |
13065 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 | |
13066 | * check for lower mass cuts | |
13067 | IF ((SSMA1Q.LT.SSMIMQ).OR. | |
13068 | & (SSMA2Q.LT.SSMIMQ)) THEN | |
13069 | IPVAL = ITOVP(INTER1(I)) | |
13070 | ITVAL = ITOVT(INTER2(I)) | |
13071 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. | |
13072 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN | |
13073 | * maximum allowed x values for sea quarks | |
13074 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- | |
13075 | & 1.2D0*XSSTHR | |
13076 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- | |
13077 | & 1.2D0*XSSTHR | |
13078 | * resampling of x values not possible - skip sea-sea chains | |
13079 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. | |
13080 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 | |
13081 | * resampling of x for projectile sea quark pair | |
13082 | ICOUS = 0 | |
13083 | 310 CONTINUE | |
13084 | ICOUS = ICOUS+1 | |
13085 | IF (XSSTHR.GT.0.05D0) THEN | |
13086 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13087 | & XSPMAX) | |
13088 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13089 | & XSPMAX) | |
13090 | ELSE | |
13091 | 320 CONTINUE | |
13092 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13093 | IF ((XPSQI.LT.XSSTHR).OR. | |
13094 | & (XPSQI.GT.XSPMAX)) GOTO 320 | |
13095 | 330 CONTINUE | |
13096 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13097 | IF ((XPSAQI.LT.XSSTHR).OR. | |
13098 | & (XPSAQI.GT.XSPMAX)) GOTO 330 | |
13099 | ENDIF | |
13100 | * final test of remaining x for projectile diquark | |
13101 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI | |
13102 | & +XPSQ(JJ)+XPSAQ(JJ) | |
13103 | IF (XPVDCO.LE.XDTHR) THEN | |
13104 | *!!! | |
13105 | C IF (ICOUS.LT.5) GOTO 310 | |
13106 | IF (ICOUS.LT.0.5D0) GOTO 310 | |
13107 | GOTO 380 | |
13108 | ENDIF | |
13109 | * resampling of x for target sea quark pair | |
13110 | ICOUS = 0 | |
13111 | 350 CONTINUE | |
13112 | ICOUS = ICOUS+1 | |
13113 | IF (XSSTHR.GT.0.05D0) THEN | |
13114 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13115 | & XSTMAX) | |
13116 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13117 | & XSTMAX) | |
13118 | ELSE | |
13119 | 360 CONTINUE | |
13120 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13121 | IF ((XTSQI.LT.XSSTHR).OR. | |
13122 | & (XTSQI.GT.XSTMAX)) GOTO 360 | |
13123 | 370 CONTINUE | |
13124 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13125 | IF ((XTSAQI.LT.XSSTHR).OR. | |
13126 | & (XTSAQI.GT.XSTMAX)) GOTO 370 | |
13127 | ENDIF | |
13128 | * final test of remaining x for target diquark | |
13129 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI | |
13130 | & +XTSQ(J)+XTSAQ(J) | |
13131 | IF (XTVDCO.LT.XDTHR) THEN | |
13132 | IF (ICOUS.LT.5) GOTO 350 | |
13133 | GOTO 380 | |
13134 | ENDIF | |
13135 | XPVD(IPVAL) = XPVDCO | |
13136 | XTVD(ITVAL) = XTVDCO | |
13137 | XPSQ(JJ) = XPSQI | |
13138 | XPSAQ(JJ) = XPSAQI | |
13139 | XTSQ(J) = XTSQI | |
13140 | XTSAQ(J) = XTSAQI | |
13141 | *>>>>>end of chain mass correction | |
13142 | GOTO 410 | |
13143 | ENDIF | |
13144 | * come here to discard s-s interaction | |
13145 | * resampling of x values not allowed or unsuccessful | |
13146 | 380 CONTINUE | |
13147 | INTLO(I) = .FALSE. | |
13148 | ZUOST(J) = .TRUE. | |
13149 | ZUOSP(JJ) = .TRUE. | |
13150 | NSS = NSS-1 | |
13151 | ENDIF | |
13152 | * consider next s-s interaction | |
13153 | GOTO 410 | |
13154 | ENDIF | |
13155 | 390 CONTINUE | |
13156 | ENDIF | |
13157 | 400 CONTINUE | |
13158 | ENDIF | |
13159 | 410 CONTINUE | |
13160 | 420 CONTINUE | |
13161 | ||
13162 | * correct x-values of valence quarks for non-matching sea quarks | |
13163 | DO 430 I=1,IXPS | |
13164 | IF (ZUOSP(I)) THEN | |
13165 | IPVAL = ITOVP(IFROSP(I)) | |
13166 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) | |
13167 | XPSQ(I) = ZERO | |
13168 | XPSAQ(I) = ZERO | |
13169 | ZUOSP(I) = .FALSE. | |
13170 | ENDIF | |
13171 | 430 CONTINUE | |
13172 | DO 440 I=1,IXTS | |
13173 | IF (ZUOST(I)) THEN | |
13174 | ITVAL = ITOVT(IFROST(I)) | |
13175 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) | |
13176 | XTSQ(I) = ZERO | |
13177 | XTSAQ(I) = ZERO | |
13178 | ZUOST(I) = .FALSE. | |
13179 | ENDIF | |
13180 | 440 CONTINUE | |
13181 | DO 450 I=1,IXPV | |
13182 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 | |
13183 | 450 CONTINUE | |
13184 | DO 460 I=1,IXTV | |
13185 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 | |
13186 | 460 CONTINUE | |
13187 | ||
13188 | RETURN | |
13189 | END | |
13190 | ||
13191 | *$ CREATE DT_SAMSDQ.FOR | |
13192 | *COPY DT_SAMSDQ | |
13193 | * | |
13194 | *===samsdq=============================================================* | |
13195 | * | |
13196 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) | |
13197 | ||
13198 | ************************************************************************ | |
13199 | * SAMpling of Sea-DiQuarks * | |
13200 | * ECM cm-energy of the nucleon-nucleon system * | |
13201 | * IDX1,2 indices of x-values of the participating * | |
13202 | * partons (IDX2 is always the sea-q-pair to be * | |
13203 | * changed to sea-qq-pair) * | |
13204 | * MODE = 1 valence-q - sea-diq * | |
13205 | * = 2 sea-diq - valence-q * | |
13206 | * = 3 sea-q - sea-diq * | |
13207 | * = 4 sea-diq - sea-q * | |
13208 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * | |
13209 | * This version dated 17.10.95 is written by S. Roesler * | |
13210 | ************************************************************************ | |
13211 | ||
13212 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13213 | SAVE | |
13214 | ||
13215 | PARAMETER (ZERO=0.0D0) | |
13216 | ||
13217 | * threshold values for x-sampling (DTUNUC 1.x) | |
13218 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
13219 | & SSMIMQ,VVMTHR | |
13220 | * various options for treatment of partons (DTUNUC 1.x) | |
13221 | * (chain recombination, Cronin,..) | |
13222 | LOGICAL LCO2CR,LINTPT | |
13223 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
13224 | & LCO2CR,LINTPT | |
13225 | PARAMETER ( MAXNCL = 260, | |
13226 | & MAXVQU = MAXNCL, | |
13227 | & MAXSQU = 20*MAXVQU, | |
13228 | & MAXINT = MAXVQU+MAXSQU) | |
13229 | * x-values of partons (DTUNUC 1.x) | |
13230 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
13231 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
13232 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
13233 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
13234 | * flavors of partons (DTUNUC 1.x) | |
13235 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
13236 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
13237 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
13238 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
13239 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
13240 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
13241 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
13242 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13243 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
13244 | & IXPV,IXPS,IXTV,IXTS, | |
13245 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
13246 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
13247 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
13248 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
13249 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
13250 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
13251 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
13252 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
13253 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13254 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
13255 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
13256 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
13257 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
13258 | ||
13259 | IREJ = 0 | |
13260 | * threshold-x for valence diquarks | |
13261 | XDTHR = CDQ/ECM | |
13262 | ||
13263 | GOTO (1,2,3,4) MODE | |
13264 | ||
13265 | *--------------------------------------------------------------------- | |
13266 | * proj. valence partons - targ. sea partons | |
13267 | * get x-values and flavors for target sea-diquark pair | |
13268 | ||
13269 | 1 CONTINUE | |
13270 | IDXVP = IDX1 | |
13271 | IDXST = IDX2 | |
13272 | ||
13273 | * index of corr. val-diquark-x in target nucleon | |
13274 | IDXVT = ITOVT(IFROST(IDXST)) | |
13275 | * available x above diquark thresholds for valence- and sea-diquarks | |
13276 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13277 | ||
13278 | IF (XXD.GE.ZERO) THEN | |
13279 | * x-values for the three diquarks of the target nucleon | |
13280 | RR1 = DT_RNDM(XXD) | |
13281 | RR2 = DT_RNDM(RR1) | |
13282 | RR3 = DT_RNDM(RR2) | |
13283 | SR123 = RR1+RR2+RR3 | |
13284 | XXTV = XDTHR+RR1*XXD/SR123 | |
13285 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13286 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13287 | ELSE | |
13288 | XXTV = XTVD(IDXVT) | |
13289 | XXTSQ = XTSQ(IDXST) | |
13290 | XXTSAQ = XTSAQ(IDXST) | |
13291 | ENDIF | |
13292 | * flavor of the second quarks in the sea-diquark pair | |
13293 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13294 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13295 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains | |
13296 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 | |
13297 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 | |
13298 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13299 | * ss-asas pair | |
13300 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13301 | IREJ = 1 | |
13302 | RETURN | |
13303 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13304 | * at least one strange quark | |
13305 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13306 | IREJ = 1 | |
13307 | RETURN | |
13308 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13309 | IREJ = 1 | |
13310 | RETURN | |
13311 | ENDIF | |
13312 | * accept the new sea-diquark | |
13313 | XTVD(IDXVT) = XXTV | |
13314 | XTSQ(IDXST) = XXTSQ | |
13315 | XTSAQ(IDXST) = XXTSAQ | |
13316 | NVD = NVD+1 | |
13317 | INTVD1(NVD) = IDXVP | |
13318 | INTVD2(NVD) = IDXST | |
13319 | ISKPCH(7,NVD) = 0 | |
13320 | RETURN | |
13321 | ||
13322 | *--------------------------------------------------------------------- | |
13323 | * proj. sea partons - targ. valence partons | |
13324 | * get x-values and flavors for projectile sea-diquark pair | |
13325 | ||
13326 | 2 CONTINUE | |
13327 | IDXSP = IDX2 | |
13328 | IDXVT = IDX1 | |
13329 | ||
13330 | * index of corr. val-diquark-x in projectile nucleon | |
13331 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13332 | * available x above diquark thresholds for valence- and sea-diquarks | |
13333 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13334 | ||
13335 | IF (XXD.GE.ZERO) THEN | |
13336 | * x-values for the three diquarks of the projectile nucleon | |
13337 | RR1 = DT_RNDM(XXD) | |
13338 | RR2 = DT_RNDM(RR1) | |
13339 | RR3 = DT_RNDM(RR2) | |
13340 | SR123 = RR1+RR2+RR3 | |
13341 | XXPV = XDTHR+RR1*XXD/SR123 | |
13342 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13343 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13344 | ELSE | |
13345 | XXPV = XPVD(IDXVP) | |
13346 | XXPSQ = XPSQ(IDXSP) | |
13347 | XXPSAQ = XPSAQ(IDXSP) | |
13348 | ENDIF | |
13349 | * flavor of the second quarks in the sea-diquark pair | |
13350 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13351 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13352 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains | |
13353 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 | |
13354 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 | |
13355 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13356 | * ss-asas pair | |
13357 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13358 | IREJ = 1 | |
13359 | RETURN | |
13360 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13361 | * at least one strange quark | |
13362 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13363 | IREJ = 1 | |
13364 | RETURN | |
13365 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13366 | IREJ = 1 | |
13367 | RETURN | |
13368 | ENDIF | |
13369 | * accept the new sea-diquark | |
13370 | XPVD(IDXVP) = XXPV | |
13371 | XPSQ(IDXSP) = XXPSQ | |
13372 | XPSAQ(IDXSP) = XXPSAQ | |
13373 | NDV = NDV+1 | |
13374 | INTDV1(NDV) = IDXSP | |
13375 | INTDV2(NDV) = IDXVT | |
13376 | ISKPCH(5,NDV) = 0 | |
13377 | RETURN | |
13378 | ||
13379 | *--------------------------------------------------------------------- | |
13380 | * proj. sea partons - targ. sea partons | |
13381 | * get x-values and flavors for target sea-diquark pair | |
13382 | ||
13383 | 3 CONTINUE | |
13384 | IDXSP = IDX1 | |
13385 | IDXST = IDX2 | |
13386 | ||
13387 | * index of corr. val-diquark-x in target nucleon | |
13388 | IDXVT = ITOVT(IFROST(IDXST)) | |
13389 | * available x above diquark thresholds for valence- and sea-diquarks | |
13390 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13391 | ||
13392 | IF (XXD.GE.ZERO) THEN | |
13393 | * x-values for the three diquarks of the target nucleon | |
13394 | RR1 = DT_RNDM(XXD) | |
13395 | RR2 = DT_RNDM(RR1) | |
13396 | RR3 = DT_RNDM(RR2) | |
13397 | SR123 = RR1+RR2+RR3 | |
13398 | XXTV = XDTHR+RR1*XXD/SR123 | |
13399 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13400 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13401 | ELSE | |
13402 | XXTV = XTVD(IDXVT) | |
13403 | XXTSQ = XTSQ(IDXST) | |
13404 | XXTSAQ = XTSAQ(IDXST) | |
13405 | ENDIF | |
13406 | * flavor of the second quarks in the sea-diquark pair | |
13407 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13408 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13409 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains | |
13410 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 | |
13411 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 | |
13412 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13413 | * ss-asas pair | |
13414 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13415 | IREJ = 1 | |
13416 | RETURN | |
13417 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13418 | * at least one strange quark | |
13419 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13420 | IREJ = 1 | |
13421 | RETURN | |
13422 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13423 | IREJ = 1 | |
13424 | RETURN | |
13425 | ENDIF | |
13426 | * accept the new sea-diquark | |
13427 | XTVD(IDXVT) = XXTV | |
13428 | XTSQ(IDXST) = XXTSQ | |
13429 | XTSAQ(IDXST) = XXTSAQ | |
13430 | NSD = NSD+1 | |
13431 | INTSD1(NSD) = IDXSP | |
13432 | INTSD2(NSD) = IDXST | |
13433 | ISKPCH(3,NSD) = 0 | |
13434 | RETURN | |
13435 | ||
13436 | *--------------------------------------------------------------------- | |
13437 | * proj. sea partons - targ. sea partons | |
13438 | * get x-values and flavors for projectile sea-diquark pair | |
13439 | ||
13440 | 4 CONTINUE | |
13441 | IDXSP = IDX2 | |
13442 | IDXST = IDX1 | |
13443 | ||
13444 | * index of corr. val-diquark-x in projectile nucleon | |
13445 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13446 | * available x above diquark thresholds for valence- and sea-diquarks | |
13447 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13448 | ||
13449 | IF (XXD.GE.ZERO) THEN | |
13450 | * x-values for the three diquarks of the projectile nucleon | |
13451 | RR1 = DT_RNDM(XXD) | |
13452 | RR2 = DT_RNDM(RR1) | |
13453 | RR3 = DT_RNDM(RR2) | |
13454 | SR123 = RR1+RR2+RR3 | |
13455 | XXPV = XDTHR+RR1*XXD/SR123 | |
13456 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13457 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13458 | ELSE | |
13459 | XXPV = XPVD(IDXVP) | |
13460 | XXPSQ = XPSQ(IDXSP) | |
13461 | XXPSAQ = XPSAQ(IDXSP) | |
13462 | ENDIF | |
13463 | * flavor of the second quarks in the sea-diquark pair | |
13464 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13465 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13466 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains | |
13467 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 | |
13468 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 | |
13469 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13470 | * ss-asas pair | |
13471 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13472 | IREJ = 1 | |
13473 | RETURN | |
13474 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13475 | * at least one strange quark | |
13476 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13477 | IREJ = 1 | |
13478 | RETURN | |
13479 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13480 | IREJ = 1 | |
13481 | RETURN | |
13482 | ENDIF | |
13483 | * accept the new sea-diquark | |
13484 | XPVD(IDXVP) = XXPV | |
13485 | XPSQ(IDXSP) = XXPSQ | |
13486 | XPSAQ(IDXSP) = XXPSAQ | |
13487 | NDS = NDS+1 | |
13488 | INTDS1(NDS) = IDXSP | |
13489 | INTDS2(NDS) = IDXST | |
13490 | ISKPCH(2,NDS) = 0 | |
13491 | RETURN | |
13492 | END | |
13493 | ||
13494 | *$ CREATE DT_DIFEVT.FOR | |
13495 | *COPY DT_DIFEVT | |
13496 | * | |
13497 | *===difevt=============================================================* | |
13498 | * | |
13499 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
13500 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) | |
13501 | ||
13502 | ************************************************************************ | |
13503 | * Interface to treatment of diffractive interactions. * | |
13504 | * (input) IFP1/2 PDG-indizes of projectile partons * | |
13505 | * (baryon: IFP2 - adiquark) * | |
13506 | * PP(4) projectile 4-momentum * | |
13507 | * IFT1/2 PDG-indizes of target partons * | |
13508 | * (baryon: IFT1 - adiquark) * | |
13509 | * PT(4) target 4-momentum * | |
13510 | * (output) JDIFF = 0 no diffraction * | |
13511 | * = 1/-1 LMSD/LMDD * | |
13512 | * = 2/-2 HMSD/HMDD * | |
13513 | * NCSY counter for two-chain systems * | |
13514 | * dumped to DTEVT1 * | |
13515 | * This version dated 14.02.95 is written by S. Roesler * | |
13516 | ************************************************************************ | |
13517 | ||
13518 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13519 | SAVE | |
13520 | PARAMETER ( LINP = 10 , | |
13521 | & LOUT = 6 , | |
13522 | & LDAT = 9 ) | |
13523 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, | |
13524 | & OHALF=0.5D0) | |
13525 | ||
13526 | * event history | |
13527 | PARAMETER (NMXHKK=200000) | |
13528 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
13529 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
13530 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
13531 | * extended event history | |
13532 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
13533 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
13534 | & IHIST(2,NMXHKK) | |
13535 | * flags for diffractive interactions (DTUNUC 1.x) | |
13536 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
13537 | ||
13538 | DIMENSION PP(4),PT(4) | |
13539 | ||
13540 | LOGICAL LFIRST | |
13541 | DATA LFIRST /.TRUE./ | |
13542 | ||
13543 | IREJ = 0 | |
13544 | JDIFF = 0 | |
13545 | IFLAGD = JDIFF | |
13546 | ||
13547 | * cm. energy | |
13548 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
13549 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
13550 | * identities of projectile hadron / target nucleon | |
13551 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) | |
13552 | KTARG = IDT_ICIHAD(IDHKK(MOT)) | |
13553 | ||
13554 | * single diffractive xsections | |
13555 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) | |
13556 | * double diffractive xsections | |
13557 | **!! no double diff yet | |
13558 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) | |
13559 | DDTOT = 0.0D0 | |
13560 | DDHM = 0.0D0 | |
13561 | **!! | |
13562 | * total inelastic xsection | |
13563 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) | |
13564 | DUMZER = ZERO | |
13565 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) | |
13566 | SIGIN = MAX(SIGTO-SIGEL,ZERO) | |
13567 | ||
13568 | * fraction of diffractive processes | |
13569 | FRADIF = (SDTOT+DDTOT)/SIGIN | |
13570 | ||
13571 | IF (LFIRST) THEN | |
13572 | WRITE(LOUT,1000) XM,SDTOT,SIGIN | |
13573 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', | |
13574 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', | |
13575 | & F5.1,' mb',/) | |
13576 | LFIRST = .FALSE. | |
13577 | ENDIF | |
13578 | ||
13579 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. | |
13580 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN | |
13581 | * diffractive interaction requested by x-section or by user | |
13582 | FRASD = SDTOT/(SDTOT+DDTOT) | |
13583 | FRASDH = SDHM/SDTOT | |
13584 | **sr needs to be specified!! | |
13585 | C FRADDH = DDHM/DDTOT | |
13586 | FRADDH = 1.0D0 | |
13587 | ** | |
13588 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN | |
13589 | * single diffraction | |
13590 | KDIFF = 1 | |
13591 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN | |
13592 | KP = 2 | |
13593 | KT = 0 | |
13594 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. | |
13595 | & ISINGD.NE.3) THEN | |
13596 | KP = 0 | |
13597 | KT = 2 | |
13598 | ENDIF | |
13599 | ELSE | |
13600 | KP = 1 | |
13601 | KT = 0 | |
13602 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. | |
13603 | & ISINGD.NE.3) THEN | |
13604 | KP = 0 | |
13605 | KT = 1 | |
13606 | ENDIF | |
13607 | ENDIF | |
13608 | ELSE | |
13609 | * double diffraction | |
13610 | KDIFF = -1 | |
13611 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN | |
13612 | KP = 2 | |
13613 | KT = 2 | |
13614 | ELSE | |
13615 | KP = 1 | |
13616 | KT = 1 | |
13617 | ENDIF | |
13618 | ENDIF | |
13619 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13620 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13621 | IF (IREJ1.EQ.0) THEN | |
13622 | IFLAGD = 2*KDIFF | |
13623 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF | |
13624 | ELSE | |
13625 | GOTO 9999 | |
13626 | ENDIF | |
13627 | ENDIF | |
13628 | JDIFF = IFLAGD | |
13629 | ||
13630 | RETURN | |
13631 | ||
13632 | 9999 CONTINUE | |
13633 | IREJ = 1 | |
13634 | RETURN | |
13635 | END | |
13636 | ||
13637 | *$ CREATE DT_DIFFKI.FOR | |
13638 | *COPY DT_DIFFKI | |
13639 | * | |
13640 | *===difkin=============================================================* | |
13641 | * | |
13642 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13643 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) | |
13644 | ||
13645 | ************************************************************************ | |
13646 | * Kinematics of diffractive nucleon-nucleon interaction. * | |
13647 | * IFP1/2 PDG-indizes of projectile partons * | |
13648 | * (baryon: IFP2 - adiquark) * | |
13649 | * PP(4) projectile 4-momentum * | |
13650 | * IFT1/2 PDG-indizes of target partons * | |
13651 | * (baryon: IFT1 - adiquark) * | |
13652 | * PT(4) target 4-momentum * | |
13653 | * KP = 0 projectile quasi-elastically scattered * | |
13654 | * = 1 excited to low-mass diff. state * | |
13655 | * = 2 excited to high-mass diff. state * | |
13656 | * KT = 0 target quasi-elastically scattered * | |
13657 | * = 1 excited to low-mass diff. state * | |
13658 | * = 2 excited to high-mass diff. state * | |
13659 | * This version dated 12.02.95 is written by S. Roesler * | |
13660 | ************************************************************************ | |
13661 | ||
13662 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13663 | SAVE | |
13664 | PARAMETER ( LINP = 10 , | |
13665 | & LOUT = 6 , | |
13666 | & LDAT = 9 ) | |
13667 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) | |
13668 | ||
13669 | LOGICAL LSTART | |
13670 | ||
13671 | * particle properties (BAMJET index convention) | |
13672 | CHARACTER*8 ANAME | |
13673 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
13674 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
13675 | * flags for input different options | |
13676 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
13677 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
13678 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
13679 | * rejection counter | |
13680 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
13681 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
13682 | & IREXCI(3),IRDIFF(2),IRINC | |
13683 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13684 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13685 | & PPF(4),PTF(4), | |
13686 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13687 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13688 | ||
13689 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), | |
13690 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) | |
13691 | ||
13692 | DATA LSTART /.TRUE./ | |
13693 | ||
13694 | IF (LSTART) THEN | |
13695 | WRITE(LOUT,2000) | |
13696 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') | |
13697 | LSTART = .FALSE. | |
13698 | ENDIF | |
13699 | ||
13700 | IREJ = 0 | |
13701 | ||
13702 | * initialize common /DTDIKI/ | |
13703 | CALL DT_DIFINI | |
13704 | * store momenta of initial incoming particles for emc-check | |
13705 | IF (LEMCCK) THEN | |
13706 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) | |
13707 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) | |
13708 | ENDIF | |
13709 | ||
13710 | * masses of initial particles | |
13711 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 | |
13712 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 | |
13713 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 | |
13714 | XMP = SQRT(XMP2) | |
13715 | XMT = SQRT(XMT2) | |
13716 | * check quark-input (used to adjust coherence cond. for M-selection) | |
13717 | IBP = 0 | |
13718 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 | |
13719 | IBT = 0 | |
13720 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 | |
13721 | ||
13722 | * parameter for Lorentz-transformation into nucleon-nucleon cms | |
13723 | DO 3 K=1,4 | |
13724 | PITOT(K) = PP(K)+PT(K) | |
13725 | 3 CONTINUE | |
13726 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 | |
13727 | IF (XMTOT2.LE.ZERO) THEN | |
13728 | WRITE(LOUT,1000) XMTOT2 | |
13729 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', | |
13730 | & 'XMTOT2 = ',E12.3) | |
13731 | GOTO 9999 | |
13732 | ENDIF | |
13733 | XMTOT = SQRT(XMTOT2) | |
13734 | DO 4 K=1,4 | |
13735 | BGTOT(K) = PITOT(K)/XMTOT | |
13736 | 4 CONTINUE | |
13737 | * transformation of nucleons into cms | |
13738 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), | |
13739 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) | |
13740 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), | |
13741 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) | |
13742 | * rotation angles | |
13743 | COD = PP1(3)/PPTOT | |
13744 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
13745 | PPT = SQRT(PP1(1)**2+PP1(2)**2) | |
13746 | SID = PPT/PPTOT | |
13747 | COF = ONE | |
13748 | SIF = ZERO | |
13749 | IF(PPTOT*SID.GT.TINY10) THEN | |
13750 | COF = PP1(1)/(SID*PPTOT) | |
13751 | SIF = PP1(2)/(SID*PPTOT) | |
13752 | ANORF = SQRT(COF*COF+SIF*SIF) | |
13753 | COF = COF/ANORF | |
13754 | SIF = SIF/ANORF | |
13755 | ENDIF | |
13756 | * check consistency | |
13757 | DO 5 K=1,4 | |
13758 | DEV1(K) = ABS(PP1(K)+PT1(K)) | |
13759 | 5 CONTINUE | |
13760 | DEV1(4) = ABS(DEV1(4)-XMTOT) | |
13761 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. | |
13762 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN | |
13763 | WRITE(LOUT,1001) DEV1 | |
13764 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', | |
13765 | & /,8X,4E12.3) | |
13766 | GOTO 9999 | |
13767 | ENDIF | |
13768 | ||
13769 | * select x-fractions in high-mass diff. interactions | |
13770 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) | |
13771 | ||
13772 | * select diffractive masses | |
13773 | * - projectile | |
13774 | IF (KP.EQ.1) THEN | |
13775 | XMPF = DT_XMLMD(XMTOT) | |
13776 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) | |
13777 | IF (IREJ1.GT.0) GOTO 9999 | |
13778 | ELSEIF (KP.EQ.2) THEN | |
13779 | XMPF = DT_XMHMD(XMTOT,IBP,1) | |
13780 | ELSE | |
13781 | XMPF = XMP | |
13782 | ENDIF | |
13783 | * - target | |
13784 | IF (KT.EQ.1) THEN | |
13785 | XMTF = DT_XMLMD(XMTOT) | |
13786 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) | |
13787 | IF (IREJ1.GT.0) GOTO 9999 | |
13788 | ELSEIF (KT.EQ.2) THEN | |
13789 | XMTF = DT_XMHMD(XMTOT,IBT,2) | |
13790 | ELSE | |
13791 | XMTF = XMT | |
13792 | ENDIF | |
13793 | ||
13794 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) | |
13795 | XMPF2 = XMPF**2 | |
13796 | XMTF2 = XMTF**2 | |
13797 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) | |
13798 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) | |
13799 | ||
13800 | * select momentum transfer (all t-values used here are <0) | |
13801 | * minimum absolute value to produce diffractive masses | |
13802 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) | |
13803 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) | |
13804 | IF (IREJ1.GT.0) GOTO 9999 | |
13805 | ||
13806 | * longitudinal momentum of excited/elastically scattered projectile | |
13807 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) | |
13808 | * total transverse momentum due to t-selection | |
13809 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 | |
13810 | IF (PPBLT2.LT.ZERO) THEN | |
13811 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT | |
13812 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', | |
13813 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) | |
13814 | GOTO 9999 | |
13815 | ENDIF | |
13816 | CALL DT_DSFECF(SINPHI,COSPHI) | |
13817 | PPBLT = SQRT(PPBLT2) | |
13818 | PPBLOB(1) = COSPHI*PPBLT | |
13819 | PPBLOB(2) = SINPHI*PPBLT | |
13820 | ||
13821 | * rotate excited/elastically scattered projectile into n-n cms. | |
13822 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, | |
13823 | & XX,YY,ZZ) | |
13824 | PPBLOB(1) = XX | |
13825 | PPBLOB(2) = YY | |
13826 | PPBLOB(3) = ZZ | |
13827 | ||
13828 | * 4-momentum of excited/elastically scattered target and of exchanged | |
13829 | * Pomeron | |
13830 | DO 6 K=1,4 | |
13831 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) | |
13832 | PPOM1(K) = PP1(K)-PPBLOB(K) | |
13833 | 6 CONTINUE | |
13834 | PTBLOB(4) = XMTOT-PPBLOB(4) | |
13835 | ||
13836 | * Lorentz-transformation back into system of initial diff. collision | |
13837 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13838 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), | |
13839 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) | |
13840 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13841 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), | |
13842 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) | |
13843 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13844 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), | |
13845 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) | |
13846 | ||
13847 | * store 4-momentum of elastically scattered particle (in single diff. | |
13848 | * events) | |
13849 | IF (KP.EQ.0) THEN | |
13850 | DO 7 K=1,4 | |
13851 | PSC(K) = PPF(K) | |
13852 | 7 CONTINUE | |
13853 | ELSEIF (KT.EQ.0) THEN | |
13854 | DO 8 K=1,4 | |
13855 | PSC(K) = PTF(K) | |
13856 | 8 CONTINUE | |
13857 | ENDIF | |
13858 | ||
13859 | * check consistency of kinematical treatment so far | |
13860 | IF (LEMCCK) THEN | |
13861 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) | |
13862 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) | |
13863 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) | |
13864 | IF (IREJ1.NE.0) GOTO 9999 | |
13865 | ENDIF | |
13866 | DO 9 K=1,4 | |
13867 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) | |
13868 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) | |
13869 | 9 CONTINUE | |
13870 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. | |
13871 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. | |
13872 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. | |
13873 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN | |
13874 | WRITE(LOUT,1003) DEV1,DEV2 | |
13875 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', | |
13876 | & 2(/,8X,4E12.3)) | |
13877 | GOTO 9999 | |
13878 | ENDIF | |
13879 | ||
13880 | * kinematical treatment for low-mass diffraction | |
13881 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) | |
13882 | IF (IREJ1.NE.0) GOTO 9999 | |
13883 | ||
13884 | * dump diffractive chains into DTEVT1 | |
13885 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13886 | IF (IREJ1.NE.0) GOTO 9999 | |
13887 | ||
13888 | RETURN | |
13889 | ||
13890 | 9999 CONTINUE | |
13891 | IRDIFF(1) = IRDIFF(1)+1 | |
13892 | IREJ = 1 | |
13893 | RETURN | |
13894 | END | |
13895 | ||
13896 | *$ CREATE DT_XMHMD.FOR | |
13897 | *COPY DT_XMHMD | |
13898 | * | |
13899 | *===xmhmd==============================================================* | |
13900 | * | |
13901 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) | |
13902 | ||
13903 | ************************************************************************ | |
13904 | * Diffractive mass in high mass single/double diffractive events. * | |
13905 | * This version dated 11.02.95 is written by S. Roesler * | |
13906 | ************************************************************************ | |
13907 | ||
13908 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13909 | SAVE | |
13910 | PARAMETER ( LINP = 10 , | |
13911 | & LOUT = 6 , | |
13912 | & LDAT = 9 ) | |
13913 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) | |
13914 | ||
13915 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13916 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13917 | & PPF(4),PTF(4), | |
13918 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13919 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13920 | ||
13921 | C DATA XCOLOW /0.05D0/ | |
13922 | DATA XCOLOW /0.15D0/ | |
13923 | ||
13924 | DT_XMHMD = ZERO | |
13925 | XH = XPH(2) | |
13926 | IF (MODE.EQ.2) XH = XTH(2) | |
13927 | ||
13928 | * minimum Pomeron-x for high-mass diffraction | |
13929 | * (adjusted to get a smooth transition between HM and LM component) | |
13930 | R = DT_RNDM(XH) | |
13931 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) | |
13932 | IF (ECM.LE.300.0D0) THEN | |
13933 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) | |
13934 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) | |
13935 | ENDIF | |
13936 | * maximum Pomeron-x for high-mass diffraction | |
13937 | * (coherence condition, adjusted to fit to experimental data) | |
13938 | IF (IB.NE.0) THEN | |
13939 | * baryon-diffraction | |
13940 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) | |
13941 | ELSE | |
13942 | * meson-diffraction | |
13943 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) | |
13944 | ENDIF | |
13945 | * check boundaries | |
13946 | IF (XDIMIN.GE.XDIMAX) THEN | |
13947 | XDIMIN = OHALF*XDIMAX | |
13948 | ENDIF | |
13949 | ||
13950 | KLOOP = 0 | |
13951 | 1 CONTINUE | |
13952 | KLOOP = KLOOP+1 | |
13953 | IF (KLOOP.GT.20) RETURN | |
13954 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) | |
13955 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) | |
13956 | * corr. diffr. mass | |
13957 | DT_XMHMD = ECM*SQRT(XDIFF) | |
13958 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 | |
13959 | ||
13960 | RETURN | |
13961 | END | |
13962 | ||
13963 | *$ CREATE DT_XMLMD.FOR | |
13964 | *COPY DT_XMLMD | |
13965 | * | |
13966 | *===xmlmd==============================================================* | |
13967 | * | |
13968 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) | |
13969 | ||
13970 | ************************************************************************ | |
13971 | * Diffractive mass in high mass single/double diffractive events. * | |
13972 | * This version dated 11.02.95 is written by S. Roesler * | |
13973 | ************************************************************************ | |
13974 | ||
13975 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13976 | SAVE | |
13977 | PARAMETER ( LINP = 10 , | |
13978 | & LOUT = 6 , | |
13979 | & LDAT = 9 ) | |
13980 | ||
13981 | * minimum Pomeron-x for low-mass diffraction | |
13982 | C AMO = 1.5D0 | |
13983 | AMO = 2.0D0 | |
13984 | * maximum Pomeron-x for low-mass diffraction | |
13985 | * (adjusted to get a smooth transition between HM and LM component) | |
13986 | R = DT_RNDM(AMO) | |
13987 | SAM = 1.0D0 | |
13988 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) | |
13989 | R = DT_RNDM(AMO)*SAM | |
13990 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) | |
13991 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX | |
13992 | ||
13993 | * selection of diffractive mass | |
13994 | * (adjusted to get a smooth transition between HM and LM component) | |
13995 | R = DT_RNDM(AMU) | |
13996 | IF (ECM.LE.50.0D0) THEN | |
13997 | DT_XMLMD = AMO*(AMU/AMO)**R | |
13998 | ELSE | |
13999 | A = 0.7D0 | |
14000 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) | |
14001 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) | |
14002 | ENDIF | |
14003 | ||
14004 | RETURN | |
14005 | END | |
14006 | ||
14007 | *$ CREATE DT_TDIFF.FOR | |
14008 | *COPY DT_TDIFF | |
14009 | * | |
14010 | *===tdiff==============================================================* | |
14011 | * | |
14012 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) | |
14013 | ||
14014 | ************************************************************************ | |
14015 | * t-selection for single/double diffractive interactions. * | |
14016 | * ECM cm. energy * | |
14017 | * TMIN minimum momentum transfer to produce diff. masses * | |
14018 | * XM1/XM2 diffractively produced masses * | |
14019 | * (for single diffraction XM2 is obsolete) * | |
14020 | * K1/K2= 0 not excited * | |
14021 | * = 1 low-mass excitation * | |
14022 | * = 2 high-mass excitation * | |
14023 | * This version dated 11.02.95 is written by S. Roesler * | |
14024 | ************************************************************************ | |
14025 | ||
14026 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14027 | SAVE | |
14028 | PARAMETER ( LINP = 10 , | |
14029 | & LOUT = 6 , | |
14030 | & LDAT = 9 ) | |
14031 | PARAMETER (ZERO=0.0D0) | |
14032 | ||
14033 | PARAMETER ( BTP0 = 3.7D0, | |
14034 | & ALPHAP = 0.24D0 ) | |
14035 | ||
14036 | IREJ = 0 | |
14037 | NCLOOP = 0 | |
14038 | DT_TDIFF = ZERO | |
14039 | ||
14040 | IF (K1.GT.0) THEN | |
14041 | XM1 = XM1I | |
14042 | XM2 = XM2I | |
14043 | ELSE | |
14044 | XM1 = XM2I | |
14045 | ENDIF | |
14046 | XDI = (XM1/ECM)**2 | |
14047 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN | |
14048 | * slope for single diffraction | |
14049 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) | |
14050 | ELSE | |
14051 | * slope for double diffraction | |
14052 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) | |
14053 | ENDIF | |
14054 | ||
14055 | 1 CONTINUE | |
14056 | NCLOOP = NCLOOP+1 | |
14057 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 | |
14058 | Y = DT_RNDM(XDI) | |
14059 | T = -LOG(1.0D0-Y)/SLOPE | |
14060 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 | |
14061 | DT_TDIFF = -ABS(T) | |
14062 | ||
14063 | RETURN | |
14064 | ||
14065 | 9999 CONTINUE | |
14066 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 | |
14067 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, | |
14068 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', | |
14069 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) | |
14070 | IREJ = 1 | |
14071 | RETURN | |
14072 | END | |
14073 | ||
14074 | *$ CREATE DT_XVALHM.FOR | |
14075 | *COPY DT_XVALHM | |
14076 | * | |
14077 | *===xvalhm=============================================================* | |
14078 | * | |
14079 | SUBROUTINE DT_XVALHM(KP,KT) | |
14080 | ||
14081 | ************************************************************************ | |
14082 | * Sampling of parton x-values in high-mass diffractive interactions. * | |
14083 | * This version dated 12.02.95 is written by S. Roesler * | |
14084 | ************************************************************************ | |
14085 | ||
14086 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14087 | SAVE | |
14088 | PARAMETER ( LINP = 10 , | |
14089 | & LOUT = 6 , | |
14090 | & LDAT = 9 ) | |
14091 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) | |
14092 | ||
14093 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14094 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14095 | & PPF(4),PTF(4), | |
14096 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14097 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14098 | * various options for treatment of partons (DTUNUC 1.x) | |
14099 | * (chain recombination, Cronin,..) | |
14100 | LOGICAL LCO2CR,LINTPT | |
14101 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
14102 | & LCO2CR,LINTPT | |
14103 | ||
14104 | DATA UNON,XVQTHR /2.0D0,0.8D0/ | |
14105 | ||
14106 | IF (KP.EQ.2) THEN | |
14107 | * x-fractions of projectile valence partons | |
14108 | 1 CONTINUE | |
14109 | XPH(1) = DT_DBETAR(OHALF,UNON) | |
14110 | IF (XPH(1).GE.XVQTHR) GOTO 1 | |
14111 | XPH(2) = ONE-XPH(1) | |
14112 | * x-fractions of Pomeron q-aq-pair | |
14113 | XPOLO = TINY2 | |
14114 | XPOHI = ONE-TINY2 | |
14115 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14116 | XPPO(2) = ONE-XPPO(1) | |
14117 | * flavors of Pomeron q-aq-pair | |
14118 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) | |
14119 | IFPPO(1) = IFLAV | |
14120 | IFPPO(2) = -IFLAV | |
14121 | IF (DT_RNDM(UNON).GT.OHALF) THEN | |
14122 | IFPPO(1) = -IFLAV | |
14123 | IFPPO(2) = IFLAV | |
14124 | ENDIF | |
14125 | ENDIF | |
14126 | ||
14127 | IF (KT.EQ.2) THEN | |
14128 | * x-fractions of projectile target partons | |
14129 | 2 CONTINUE | |
14130 | XTH(1) = DT_DBETAR(OHALF,UNON) | |
14131 | IF (XTH(1).GE.XVQTHR) GOTO 2 | |
14132 | XTH(2) = ONE-XTH(1) | |
14133 | * x-fractions of Pomeron q-aq-pair | |
14134 | XPOLO = TINY2 | |
14135 | XPOHI = ONE-TINY2 | |
14136 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14137 | XTPO(2) = ONE-XTPO(1) | |
14138 | * flavors of Pomeron q-aq-pair | |
14139 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) | |
14140 | IFTPO(1) = IFLAV | |
14141 | IFTPO(2) = -IFLAV | |
14142 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN | |
14143 | IFTPO(1) = -IFLAV | |
14144 | IFTPO(2) = IFLAV | |
14145 | ENDIF | |
14146 | ENDIF | |
14147 | ||
14148 | RETURN | |
14149 | END | |
14150 | ||
14151 | *$ CREATE DT_LM2RES.FOR | |
14152 | *COPY DT_LM2RES | |
14153 | * | |
14154 | *===lm2res=============================================================* | |
14155 | * | |
14156 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) | |
14157 | ||
14158 | ************************************************************************ | |
14159 | * Check low-mass diffractive excitation for resonance mass. * | |
14160 | * (input) IF1/2 PDG-indizes of valence partons * | |
14161 | * (in/out) XM diffractive mass requested/corrected * | |
14162 | * (output) IDR/IDXR id./BAMJET-index of resonance * | |
14163 | * This version dated 12.02.95 is written by S. Roesler * | |
14164 | ************************************************************************ | |
14165 | ||
14166 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14167 | SAVE | |
14168 | PARAMETER ( LINP = 10 , | |
14169 | & LOUT = 6 , | |
14170 | & LDAT = 9 ) | |
14171 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14172 | ||
14173 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14174 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14175 | & PPF(4),PTF(4), | |
14176 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14177 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14178 | ||
14179 | IREJ = 0 | |
14180 | IF1B = 0 | |
14181 | IF2B = 0 | |
14182 | XMI = XM | |
14183 | ||
14184 | * BAMJET indices of partons | |
14185 | IF1A = IDT_IPDG2B(IF1,1,2) | |
14186 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) | |
14187 | IF2A = IDT_IPDG2B(IF2,1,2) | |
14188 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) | |
14189 | ||
14190 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) | |
14191 | IDCH = 2 | |
14192 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 | |
14193 | ||
14194 | * check for resonance mass | |
14195 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) | |
14196 | IF (IREJ1.NE.0) GOTO 9999 | |
14197 | ||
14198 | XM = XMN | |
14199 | RETURN | |
14200 | ||
14201 | 9999 CONTINUE | |
14202 | IREJ = 1 | |
14203 | RETURN | |
14204 | END | |
14205 | ||
14206 | *$ CREATE DT_LMKINE.FOR | |
14207 | *COPY DT_LMKINE | |
14208 | * | |
14209 | *===lmkine=============================================================* | |
14210 | * | |
14211 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) | |
14212 | ||
14213 | ************************************************************************ | |
14214 | * Kinematical treatment of low-mass excitations. * | |
14215 | * This version dated 12.02.95 is written by S. Roesler * | |
14216 | ************************************************************************ | |
14217 | ||
14218 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14219 | SAVE | |
14220 | PARAMETER ( LINP = 10 , | |
14221 | & LOUT = 6 , | |
14222 | & LDAT = 9 ) | |
14223 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14224 | ||
14225 | * flags for input different options | |
14226 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14227 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14228 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14229 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14230 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14231 | & PPF(4),PTF(4), | |
14232 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14233 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14234 | ||
14235 | DIMENSION P1(4),P2(4) | |
14236 | ||
14237 | IREJ = 0 | |
14238 | ||
14239 | IF (KP.EQ.1) THEN | |
14240 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) | |
14241 | POE = PPF(4)/PABS | |
14242 | FAC1 = OHALF*(POE+ONE) | |
14243 | FAC2 = -OHALF*(POE-ONE) | |
14244 | DO 1 K=1,3 | |
14245 | PPLM1(K) = FAC1*PPF(K) | |
14246 | PPLM2(K) = FAC2*PPF(K) | |
14247 | 1 CONTINUE | |
14248 | PPLM1(4) = FAC1*PABS | |
14249 | PPLM2(4) = -FAC2*PABS | |
14250 | IF (IMSHL.EQ.1) THEN | |
14251 | XM1 = PYMASS(IFP1) | |
14252 | XM2 = PYMASS(IFP2) | |
14253 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) | |
14254 | IF (IREJ1.NE.0) GOTO 9999 | |
14255 | DO 2 K=1,4 | |
14256 | PPLM1(K) = P1(K) | |
14257 | PPLM2(K) = P2(K) | |
14258 | 2 CONTINUE | |
14259 | ENDIF | |
14260 | ENDIF | |
14261 | ||
14262 | IF (KT.EQ.1) THEN | |
14263 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) | |
14264 | POE = PTF(4)/PABS | |
14265 | FAC1 = OHALF*(POE+ONE) | |
14266 | FAC2 = -OHALF*(POE-ONE) | |
14267 | DO 3 K=1,3 | |
14268 | PTLM2(K) = FAC1*PTF(K) | |
14269 | PTLM1(K) = FAC2*PTF(K) | |
14270 | 3 CONTINUE | |
14271 | PTLM2(4) = FAC1*PABS | |
14272 | PTLM1(4) = -FAC2*PABS | |
14273 | IF (IMSHL.EQ.1) THEN | |
14274 | XM1 = PYMASS(IFT1) | |
14275 | XM2 = PYMASS(IFT2) | |
14276 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) | |
14277 | IF (IREJ1.NE.0) GOTO 9999 | |
14278 | DO 4 K=1,4 | |
14279 | PTLM1(K) = P1(K) | |
14280 | PTLM2(K) = P2(K) | |
14281 | 4 CONTINUE | |
14282 | ENDIF | |
14283 | ENDIF | |
14284 | ||
14285 | RETURN | |
14286 | ||
14287 | 9999 CONTINUE | |
14288 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' | |
14289 | IREJ = 1 | |
14290 | RETURN | |
14291 | END | |
14292 | ||
14293 | *$ CREATE DT_DIFINI.FOR | |
14294 | *COPY DT_DIFINI | |
14295 | * | |
14296 | *===difini=============================================================* | |
14297 | * | |
14298 | SUBROUTINE DT_DIFINI | |
14299 | ||
14300 | ************************************************************************ | |
14301 | * Initialization of common /DTDIKI/ * | |
14302 | * This version dated 12.02.95 is written by S. Roesler * | |
14303 | ************************************************************************ | |
14304 | ||
14305 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14306 | SAVE | |
14307 | PARAMETER ( LINP = 10 , | |
14308 | & LOUT = 6 , | |
14309 | & LDAT = 9 ) | |
14310 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14311 | ||
14312 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14313 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14314 | & PPF(4),PTF(4), | |
14315 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14316 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14317 | ||
14318 | DO 1 K=1,4 | |
14319 | PPOM(K) = ZERO | |
14320 | PSC(K) = ZERO | |
14321 | PPF(K) = ZERO | |
14322 | PTF(K) = ZERO | |
14323 | PPLM1(K) = ZERO | |
14324 | PPLM2(K) = ZERO | |
14325 | PTLM1(K) = ZERO | |
14326 | PTLM2(K) = ZERO | |
14327 | 1 CONTINUE | |
14328 | DO 2 K=1,2 | |
14329 | XPH(K) = ZERO | |
14330 | XPPO(K) = ZERO | |
14331 | XTH(K) = ZERO | |
14332 | XTPO(K) = ZERO | |
14333 | IFPPO(K) = 0 | |
14334 | IFTPO(K) = 0 | |
14335 | 2 CONTINUE | |
14336 | IDPR = 0 | |
14337 | IDXPR = 0 | |
14338 | IDTR = 0 | |
14339 | IDXTR = 0 | |
14340 | ||
14341 | RETURN | |
14342 | END | |
14343 | ||
14344 | *$ CREATE DT_DIFPUT.FOR | |
14345 | *COPY DT_DIFPUT | |
14346 | * | |
14347 | *===difput=============================================================* | |
14348 | * | |
14349 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, | |
14350 | & IREJ) | |
14351 | ||
14352 | ************************************************************************ | |
14353 | * Dump diffractive chains into DTEVT1 * | |
14354 | * This version dated 12.02.95 is written by S. Roesler * | |
14355 | ************************************************************************ | |
14356 | ||
14357 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14358 | SAVE | |
14359 | PARAMETER ( LINP = 10 , | |
14360 | & LOUT = 6 , | |
14361 | & LDAT = 9 ) | |
14362 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14363 | ||
14364 | LOGICAL LCHK | |
14365 | ||
14366 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14367 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14368 | & PPF(4),PTF(4), | |
14369 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14370 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14371 | * event history | |
14372 | PARAMETER (NMXHKK=200000) | |
14373 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14374 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14375 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14376 | * extended event history | |
14377 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14378 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14379 | & IHIST(2,NMXHKK) | |
14380 | * rejection counter | |
14381 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
14382 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
14383 | & IREXCI(3),IRDIFF(2),IRINC | |
14384 | ||
14385 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), | |
14386 | & P1(4),P2(4),P3(4),P4(4) | |
14387 | ||
14388 | IREJ = 0 | |
14389 | ||
14390 | IF (KP.EQ.1) THEN | |
14391 | DO 1 K=1,4 | |
14392 | PCH(K) = PPLM1(K)+PPLM2(K) | |
14393 | 1 CONTINUE | |
14394 | ID1 = IFP1 | |
14395 | ID2 = IFP2 | |
14396 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14397 | ID1 = IFP2 | |
14398 | ID2 = IFP1 | |
14399 | ENDIF | |
14400 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), | |
14401 | & PPLM1(4),0,0,0) | |
14402 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), | |
14403 | & PPLM2(4),0,0,0) | |
14404 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14405 | & IDPR,IDXPR,8) | |
14406 | ELSEIF (KP.EQ.2) THEN | |
14407 | DO 2 K=1,4 | |
14408 | PP1(K) = XPH(1)*PP(K) | |
14409 | PP2(K) = XPH(2)*PP(K) | |
14410 | PT1(K) = -XPPO(1)*PPOM(K) | |
14411 | PT2(K) = -XPPO(2)*PPOM(K) | |
14412 | 2 CONTINUE | |
14413 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) | |
14414 | XM1 = ZERO | |
14415 | XM2 = ZERO | |
14416 | IF (LCHK) THEN | |
14417 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14418 | IF (IREJ1.NE.0) GOTO 9999 | |
14419 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14420 | IF (IREJ1.NE.0) GOTO 9999 | |
14421 | DO 3 K=1,4 | |
14422 | PP1(K) = P1(K) | |
14423 | PT1(K) = P2(K) | |
14424 | PP2(K) = P3(K) | |
14425 | PT2(K) = P4(K) | |
14426 | 3 CONTINUE | |
14427 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14428 | & 0,0,8) | |
14429 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14430 | & PT1(4),0,0,8) | |
14431 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14432 | & 0,0,8) | |
14433 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14434 | & PT2(4),0,0,8) | |
14435 | ELSE | |
14436 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14437 | IF (IREJ1.NE.0) GOTO 9999 | |
14438 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14439 | IF (IREJ1.NE.0) GOTO 9999 | |
14440 | DO 4 K=1,4 | |
14441 | PP1(K) = P1(K) | |
14442 | PT2(K) = P2(K) | |
14443 | PP2(K) = P3(K) | |
14444 | PT1(K) = P4(K) | |
14445 | 4 CONTINUE | |
14446 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14447 | & 0,0,8) | |
14448 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14449 | & PT2(4),0,0,8) | |
14450 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14451 | & 0,0,8) | |
14452 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14453 | & PT1(4),0,0,8) | |
14454 | ENDIF | |
14455 | NCSY = NCSY+1 | |
14456 | ELSE | |
14457 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14458 | & 0,0,0) | |
14459 | ENDIF | |
14460 | ||
14461 | IF (KT.EQ.1) THEN | |
14462 | DO 5 K=1,4 | |
14463 | PCH(K) = PTLM1(K)+PTLM2(K) | |
14464 | 5 CONTINUE | |
14465 | ID1 = IFT1 | |
14466 | ID2 = IFT2 | |
14467 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14468 | ID1 = IFT2 | |
14469 | ID2 = IFT1 | |
14470 | ENDIF | |
14471 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), | |
14472 | & PTLM1(4),0,0,0) | |
14473 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), | |
14474 | & PTLM2(4),0,0,0) | |
14475 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14476 | & IDTR,IDXTR,8) | |
14477 | ELSEIF (KT.EQ.2) THEN | |
14478 | DO 6 K=1,4 | |
14479 | PP1(K) = XTPO(1)*PPOM(K) | |
14480 | PP2(K) = XTPO(2)*PPOM(K) | |
14481 | PT1(K) = XTH(2)*PT(K) | |
14482 | PT2(K) = XTH(1)*PT(K) | |
14483 | 6 CONTINUE | |
14484 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) | |
14485 | XM1 = ZERO | |
14486 | XM2 = ZERO | |
14487 | IF (LCHK) THEN | |
14488 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14489 | IF (IREJ1.NE.0) GOTO 9999 | |
14490 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14491 | IF (IREJ1.NE.0) GOTO 9999 | |
14492 | DO 7 K=1,4 | |
14493 | PP1(K) = P1(K) | |
14494 | PT1(K) = P2(K) | |
14495 | PP2(K) = P3(K) | |
14496 | PT2(K) = P4(K) | |
14497 | 7 CONTINUE | |
14498 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14499 | & PP1(4),0,0,8) | |
14500 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14501 | & 0,0,8) | |
14502 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14503 | & PP2(4),0,0,8) | |
14504 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14505 | & 0,0,8) | |
14506 | ELSE | |
14507 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14508 | IF (IREJ1.NE.0) GOTO 9999 | |
14509 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14510 | IF (IREJ1.NE.0) GOTO 9999 | |
14511 | DO 8 K=1,4 | |
14512 | PP1(K) = P1(K) | |
14513 | PT2(K) = P2(K) | |
14514 | PP2(K) = P3(K) | |
14515 | PT1(K) = P4(K) | |
14516 | 8 CONTINUE | |
14517 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14518 | & PP1(4),0,0,8) | |
14519 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14520 | & 0,0,8) | |
14521 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14522 | & PP2(4),0,0,8) | |
14523 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14524 | & 0,0,8) | |
14525 | ENDIF | |
14526 | NCSY = NCSY+1 | |
14527 | ELSE | |
14528 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14529 | & 0,0,0) | |
14530 | ENDIF | |
14531 | ||
14532 | RETURN | |
14533 | ||
14534 | 9999 CONTINUE | |
14535 | IRDIFF(2) = IRDIFF(2)+1 | |
14536 | IREJ = 1 | |
14537 | RETURN | |
14538 | END | |
14539 | ||
14540 | *$ CREATE DT_EVTFRG.FOR | |
14541 | *COPY DT_EVTFRG | |
14542 | * | |
14543 | *===evtfrg=============================================================* | |
14544 | * | |
14545 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) | |
14546 | ||
14547 | ************************************************************************ | |
14548 | * Hadronization of chains in DTEVT1. * | |
14549 | * * | |
14550 | * Input: * | |
14551 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * | |
14552 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * | |
14553 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * | |
14554 | * hadronized with one PYEXEC call * | |
14555 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * | |
14556 | * with one PYEXEC call * | |
14557 | * Output: * | |
14558 | * NPYMEM number of entries in JETSET-common after hadronization * | |
14559 | * IREJ rejection flag * | |
14560 | * * | |
14561 | * This version dated 17.09.00 is written by S. Roesler * | |
14562 | ************************************************************************ | |
14563 | ||
14564 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14565 | SAVE | |
14566 | PARAMETER ( LINP = 10 , | |
14567 | & LOUT = 6 , | |
14568 | & LDAT = 9 ) | |
14569 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) | |
14570 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) | |
14571 | ||
14572 | LOGICAL LACCEP | |
14573 | ||
14574 | PARAMETER (MXJOIN=200) | |
14575 | ||
14576 | * event history | |
14577 | PARAMETER (NMXHKK=200000) | |
14578 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14579 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14580 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14581 | * extended event history | |
14582 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14583 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14584 | & IHIST(2,NMXHKK) | |
14585 | * flags for input different options | |
14586 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14587 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14588 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14589 | * statistics | |
14590 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
14591 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
14592 | & ICEVTG(8,0:30) | |
14593 | * flags for diffractive interactions (DTUNUC 1.x) | |
14594 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
14595 | * nucleon-nucleon event-generator | |
14596 | CHARACTER*8 CMODEL | |
14597 | LOGICAL LPHOIN | |
14598 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
14599 | * phojet | |
14600 | C model switches and parameters | |
14601 | CHARACTER*8 MDLNA | |
14602 | INTEGER ISWMDL,IPAMDL | |
14603 | DOUBLE PRECISION PARMDL | |
14604 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
14605 | * jetset | |
14606 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
1ddc441c | 14607 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 14608 | PARAMETER (MAXLND=4000) |
14609 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
14610 | INTEGER PYK | |
14611 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) | |
1ddc441c | 14612 | INTEGER PYCOMP |
9aaba0d6 | 14613 | MODE = KMODE |
14614 | ISTSTG = 7 | |
14615 | IF (MODE.NE.1) ISTSTG = 8 | |
14616 | IREJ = 0 | |
14617 | ||
14618 | IP = 0 | |
14619 | ISH = 0 | |
14620 | INIEMC = 1 | |
14621 | NEND = NHKK | |
14622 | NACCEP = 0 | |
14623 | IFRG = 0 | |
14624 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
14625 | DO 10 I=NPOINT(3),NEND | |
14626 | * sr 14.02.00: seems to be not necessary anymore, commented | |
14627 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. | |
14628 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) | |
14629 | LACCEP = .TRUE. | |
14630 | * pick up chains from dtevt1 | |
14631 | IDCHK = IDHKK(I)/10000 | |
14632 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN | |
14633 | IF (IDCHK.EQ.7) THEN | |
14634 | IPJE = IDHKK(I)-IDCHK*10000 | |
14635 | IF (IPJE.NE.IFRG) THEN | |
14636 | IFRG = IPJE | |
14637 | IF (IFRG.GT.NFRG) GOTO 16 | |
14638 | ENDIF | |
14639 | ELSE | |
14640 | IPJE = 1 | |
14641 | IFRG = IFRG+1 | |
14642 | IF (IFRG.GT.NFRG) THEN | |
14643 | NFRG = -1 | |
14644 | GOTO 16 | |
14645 | ENDIF | |
14646 | ENDIF | |
14647 | * statistics counter | |
14648 | c IF (IDCH(I).LE.8) | |
14649 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 | |
14650 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 | |
14651 | * special treatment for small chains already corrected to hadrons | |
14652 | IF (IDRES(I).NE.0) THEN | |
14653 | IF (IDRES(I).EQ.11) THEN | |
14654 | ID = IDXRES(I) | |
14655 | ELSE | |
14656 | ID = IDT_IPDGHA(IDXRES(I)) | |
14657 | ENDIF | |
14658 | IF (LEMCCK) THEN | |
14659 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
14660 | & PHKK(4,I),INIEMC,IDUM,IDUM) | |
14661 | INIEMC = 2 | |
14662 | ENDIF | |
14663 | IP = IP+1 | |
14664 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' | |
14665 | P(IP,1) = PHKK(1,I) | |
14666 | P(IP,2) = PHKK(2,I) | |
14667 | P(IP,3) = PHKK(3,I) | |
14668 | P(IP,4) = PHKK(4,I) | |
14669 | P(IP,5) = PHKK(5,I) | |
14670 | K(IP,1) = 1 | |
14671 | K(IP,2) = ID | |
14672 | K(IP,3) = 0 | |
14673 | K(IP,4) = 0 | |
14674 | K(IP,5) = 0 | |
14675 | IHIST(2,I) = 10000*IPJE+IP | |
14676 | IF (IHIST(1,I).LE.-100) THEN | |
14677 | ISH = ISH+1 | |
14678 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14679 | ISJOIN(ISH) = I | |
14680 | ENDIF | |
14681 | N = IP | |
14682 | IHISMO(IP) = I | |
14683 | ELSE | |
14684 | IJ = 0 | |
14685 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) | |
14686 | IF (LEMCCK) THEN | |
14687 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), | |
14688 | & PHKK(4,KK),INIEMC,IDUM,IDUM) | |
14689 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) | |
14690 | INIEMC = 2 | |
14691 | ENDIF | |
14692 | ID = IDHKK(KK) | |
14693 | IF (ID.EQ.0) ID = 21 | |
14694 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) | |
14695 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) | |
14696 | c AMRQ = PYMASS(ID) | |
14697 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
14698 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. | |
14699 | c & (ABS(IDIFF).EQ.0)) THEN | |
14700 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ | |
14701 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) | |
14702 | c PHKK(4,KK) = PHKK(4,KK)+DELTA | |
14703 | c PTOT1 = PTOT-DELTA | |
14704 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT | |
14705 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT | |
14706 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT | |
14707 | c PHKK(5,KK) = AMRQ | |
14708 | c ENDIF | |
14709 | IP = IP+1 | |
14710 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' | |
14711 | P(IP,1) = PHKK(1,KK) | |
14712 | P(IP,2) = PHKK(2,KK) | |
14713 | P(IP,3) = PHKK(3,KK) | |
14714 | P(IP,4) = PHKK(4,KK) | |
14715 | P(IP,5) = PHKK(5,KK) | |
14716 | K(IP,1) = 1 | |
14717 | K(IP,2) = ID | |
14718 | K(IP,3) = 0 | |
14719 | K(IP,4) = 0 | |
14720 | K(IP,5) = 0 | |
14721 | IHIST(2,KK) = 10000*IPJE+IP | |
14722 | IF (IHIST(1,KK).LE.-100) THEN | |
14723 | ISH = ISH+1 | |
14724 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14725 | ISJOIN(ISH) = KK | |
14726 | ENDIF | |
14727 | IJ = IJ+1 | |
14728 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' | |
14729 | IJOIN(IJ) = IP | |
14730 | IHISMO(IP) = I | |
14731 | 11 CONTINUE | |
14732 | N = IP | |
14733 | * join the two-parton system | |
14734 | CALL PYJOIN(IJ,IJOIN) | |
14735 | ENDIF | |
14736 | IDHKK(I) = 99999 | |
14737 | ENDIF | |
14738 | 10 CONTINUE | |
14739 | 16 CONTINUE | |
14740 | N = IP | |
14741 | ||
14742 | IF (IP.GT.0) THEN | |
14743 | ||
14744 | * final state parton shower | |
14745 | DO 136 NPJE=1,IPJE | |
14746 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN | |
14747 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN | |
14748 | DO 130 K1=1,ISH | |
14749 | IF (ISJOIN(K1).EQ.0) GOTO 130 | |
14750 | I = ISJOIN(K1) | |
14751 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) | |
14752 | & GOTO 130 | |
14753 | IH1 = IHIST(2,I)/10000 | |
14754 | IF (IH1.NE.NPJE) GOTO 130 | |
14755 | IH1 = IHIST(2,I)-IH1*10000 | |
14756 | DO 135 K2=K1+1,ISH | |
14757 | IF (ISJOIN(K2).EQ.0) GOTO 135 | |
14758 | II = ISJOIN(K2) | |
14759 | IH2 = IHIST(2,II)/10000 | |
14760 | IF (IH2.NE.NPJE) GOTO 135 | |
14761 | IH2 = IHIST(2,II)-IH2*10000 | |
14762 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN | |
14763 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) | |
14764 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) | |
14765 | RQLUN = MIN(PT1,PT2) | |
14766 | CALL PYSHOW(IH1,IH2,RQLUN) | |
14767 | ||
14768 | ISJOIN(K1) = 0 | |
14769 | ISJOIN(K2) = 0 | |
14770 | GOTO 130 | |
14771 | ENDIF | |
14772 | 135 CONTINUE | |
14773 | 130 CONTINUE | |
14774 | ENDIF | |
14775 | ENDIF | |
14776 | 136 CONTINUE | |
14777 | ||
14778 | CALL DT_INITJS(MODE) | |
14779 | * hadronization | |
14780 | ||
14781 | CALL PYEXEC | |
14782 | ||
14783 | IF (MSTU(24).NE.0) THEN | |
14784 | WRITE(LOUT,*) ' JETSET-reject at event', | |
14785 | & NEVHKK,MSTU(24),KMODE | |
14786 | C CALL DT_EVTOUT(4) | |
14787 | ||
14788 | C CALL PYLIST(2) | |
14789 | ||
14790 | GOTO 9999 | |
14791 | ENDIF | |
14792 | ||
14793 | * number of entries in LUJETS | |
14794 | ||
14795 | NLINES = PYK(0,1) | |
14796 | ||
14797 | NPYMEM = NLINES | |
14798 | ||
14799 | DO 12 I=1,NLINES | |
14800 | IFLG(I) = 0 | |
14801 | 12 CONTINUE | |
14802 | ||
14803 | DO 13 II=1,NLINES | |
14804 | ||
14805 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN | |
14806 | ||
14807 | * pick up mother resonance if possible and put it together with | |
14808 | * their decay-products into the common | |
14809 | IDXMOR = K(II,3) | |
14810 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN | |
14811 | KFMOR = K(IDXMOR,2) | |
14812 | ISMOR = K(IDXMOR,1) | |
14813 | ELSE | |
14814 | KFMOR = 91 | |
14815 | ISMOR = 1 | |
14816 | ENDIF | |
14817 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. | |
14818 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN | |
14819 | ID = K(IDXMOR,2) | |
14820 | MO = IHISMO(PYK(IDXMOR,15)) | |
14821 | PX = PYP(IDXMOR,1) | |
14822 | PY = PYP(IDXMOR,2) | |
14823 | PZ = PYP(IDXMOR,3) | |
14824 | PE = PYP(IDXMOR,4) | |
14825 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14826 | IFLG(IDXMOR) = 1 | |
14827 | MO = NHKK | |
14828 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) | |
14829 | IF (PYK(JDAUG,7).EQ.1) THEN | |
14830 | ID = PYK(JDAUG,8) | |
14831 | PX = PYP(JDAUG,1) | |
14832 | PY = PYP(JDAUG,2) | |
14833 | PZ = PYP(JDAUG,3) | |
14834 | PE = PYP(JDAUG,4) | |
14835 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14836 | IF (LEMCCK) THEN | |
14837 | PX = -PYP(JDAUG,1) | |
14838 | PY = -PYP(JDAUG,2) | |
14839 | PZ = -PYP(JDAUG,3) | |
14840 | PE = -PYP(JDAUG,4) | |
14841 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14842 | ENDIF | |
14843 | IFLG(JDAUG) = 1 | |
14844 | ENDIF | |
14845 | 15 CONTINUE | |
14846 | ELSE | |
14847 | * there was no mother resonance | |
14848 | MO = IHISMO(PYK(II,15)) | |
14849 | ID = PYK(II,8) | |
14850 | PX = PYP(II,1) | |
14851 | PY = PYP(II,2) | |
14852 | PZ = PYP(II,3) | |
14853 | PE = PYP(II,4) | |
14854 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14855 | IF (LEMCCK) THEN | |
14856 | PX = -PYP(II,1) | |
14857 | PY = -PYP(II,2) | |
14858 | PZ = -PYP(II,3) | |
14859 | PE = -PYP(II,4) | |
14860 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14861 | ENDIF | |
14862 | ENDIF | |
14863 | ENDIF | |
14864 | 13 CONTINUE | |
14865 | IF (LEMCCK) THEN | |
14866 | CHKLEV = TINY1 | |
14867 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) | |
14868 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
14869 | ENDIF | |
14870 | ||
14871 | * global energy-momentum & flavor conservation check | |
14872 | **sr 16.5. this check is skipped in case of phojet-treatment | |
14873 | IF (MCGENE.EQ.1) | |
14874 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) | |
14875 | ||
14876 | * update statistics-counter for diffraction | |
14877 | c IF (IFLAGD.NE.0) THEN | |
14878 | c ICDIFF(1) = ICDIFF(1)+1 | |
14879 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 | |
14880 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 | |
14881 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 | |
14882 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 | |
14883 | c ENDIF | |
14884 | ||
14885 | ENDIF | |
14886 | ||
14887 | RETURN | |
14888 | ||
14889 | 9999 CONTINUE | |
14890 | IREJ = 1 | |
14891 | RETURN | |
14892 | END | |
14893 | ||
14894 | *$ CREATE DT_DECAYS.FOR | |
14895 | *COPY DT_DECAYS | |
14896 | * | |
14897 | *===decay==============================================================* | |
14898 | * | |
14899 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
14900 | ||
14901 | ************************************************************************ | |
14902 | * Resonance-decay. * | |
14903 | * This subroutine replaces DDECAY/DECHKK. * | |
14904 | * PIN(4) 4-momentum of resonance (input) * | |
14905 | * IDXIN BAMJET-index of resonance (input) * | |
14906 | * POUT(20,4) 4-momenta of decay-products (output) * | |
14907 | * IDXOUT(20) BAMJET-indices of decay-products (output) * | |
14908 | * NSEC number of secondaries (output) * | |
14909 | * Adopted from the original version DECHKK. * | |
14910 | * This version dated 09.01.95 is written by S. Roesler * | |
14911 | ************************************************************************ | |
14912 | ||
14913 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14914 | SAVE | |
14915 | PARAMETER ( LINP = 10 , | |
14916 | & LOUT = 6 , | |
14917 | & LDAT = 9 ) | |
14918 | PARAMETER (TINY17=1.0D-17) | |
14919 | ||
14920 | * HADRIN: decay channel information | |
14921 | PARAMETER (IDMAX9=602) | |
14922 | CHARACTER*8 ZKNAME | |
14923 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
14924 | * particle properties (BAMJET index convention) | |
14925 | CHARACTER*8 ANAME | |
14926 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
14927 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
14928 | * flags for input different options | |
14929 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14930 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14931 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14932 | ||
14933 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), | |
14934 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), | |
14935 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) | |
14936 | ||
14937 | * ISTAB = 1 strong and weak decays | |
14938 | * = 2 strong decays only | |
14939 | * = 3 strong decays, weak decays for charmed particles and tau | |
14940 | * leptons only | |
14941 | DATA ISTAB /2/ | |
14942 | ||
14943 | IREJ = 0 | |
14944 | NSEC = 0 | |
14945 | * put initial resonance to stack | |
14946 | NSTK = 1 | |
14947 | IDXSTK(NSTK) = IDXIN | |
14948 | DO 5 I=1,4 | |
14949 | PI(NSTK,I) = PIN(I) | |
14950 | 5 CONTINUE | |
14951 | ||
14952 | * store initial configuration for energy-momentum cons. check | |
14953 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), | |
14954 | & PI(NSTK,4),1,IDUM,IDUM) | |
14955 | ||
14956 | 100 CONTINUE | |
14957 | * get particle from stack | |
14958 | IDXI = IDXSTK(NSTK) | |
14959 | * skip stable particles | |
14960 | IF (ISTAB.EQ.1) THEN | |
14961 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 | |
14962 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 | |
14963 | ELSEIF (ISTAB.EQ.2) THEN | |
14964 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 | |
14965 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14966 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 | |
14967 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 | |
14968 | IF ( IDXI.EQ.109) GOTO 10 | |
14969 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 | |
14970 | ELSEIF (ISTAB.EQ.3) THEN | |
14971 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 | |
14972 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14973 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 | |
14974 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 | |
14975 | ENDIF | |
14976 | ||
14977 | * calculate direction cosines and Lorentz-parameter of decaying part. | |
14978 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) | |
14979 | PTOT = MAX(PTOT,TINY17) | |
14980 | DO 1 I=1,3 | |
14981 | DCOS(I) = PI(NSTK,I)/PTOT | |
14982 | 1 CONTINUE | |
14983 | GAM = PI(NSTK,4)/AAM(IDXI) | |
14984 | BGAM = PTOT/AAM(IDXI) | |
14985 | ||
14986 | * get decay-channel | |
14987 | KCHAN = K1(IDXI)-1 | |
14988 | 2 CONTINUE | |
14989 | KCHAN = KCHAN+1 | |
14990 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 | |
14991 | ||
14992 | * identities of secondaries | |
14993 | IDX(1) = NZK(KCHAN,1) | |
14994 | IDX(2) = NZK(KCHAN,2) | |
14995 | IF (IDX(2).LT.1) GOTO 9999 | |
14996 | IDX(3) = NZK(KCHAN,3) | |
14997 | ||
14998 | * handle decay in rest system of decaying particle | |
14999 | IF (IDX(3).EQ.0) THEN | |
15000 | * two-particle decay | |
15001 | NDEC = 2 | |
15002 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), | |
15003 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
15004 | & AAM(IDX(1)),AAM(IDX(2))) | |
15005 | ELSE | |
15006 | * three-particle decay | |
15007 | NDEC = 3 | |
15008 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), | |
15009 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
15010 | & CODF(3),COFF(3),SIFF(3), | |
15011 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) | |
15012 | ENDIF | |
15013 | NSTK = NSTK-1 | |
15014 | ||
15015 | * transform decay products back | |
15016 | DO 3 I=1,NDEC | |
15017 | NSTK = NSTK+1 | |
15018 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), | |
15019 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), | |
15020 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) | |
15021 | * add particle to stack | |
15022 | IDXSTK(NSTK) = IDX(I) | |
15023 | DO 4 J=1,3 | |
15024 | PI(NSTK,J) = DCOSF(J)*PFF(I) | |
15025 | 4 CONTINUE | |
15026 | 3 CONTINUE | |
15027 | GOTO 100 | |
15028 | ||
15029 | 10 CONTINUE | |
15030 | * stable particle, put to output-arrays | |
15031 | NSEC = NSEC+1 | |
15032 | DO 6 I=1,4 | |
15033 | POUT(NSEC,I) = PI(NSTK,I) | |
15034 | 6 CONTINUE | |
15035 | IDXOUT(NSEC) = IDXSTK(NSTK) | |
15036 | * store secondaries for energy-momentum conservation check | |
15037 | IF (LEMCCK) | |
15038 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), | |
15039 | & -POUT(NSEC,4),2,IDUM,IDUM) | |
15040 | NSTK = NSTK-1 | |
15041 | IF (NSTK.GT.0) GOTO 100 | |
15042 | ||
15043 | * check energy-momentum conservation | |
15044 | IF (LEMCCK) THEN | |
15045 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) | |
15046 | IF (IREJ1.NE.0) GOTO 9999 | |
15047 | ENDIF | |
15048 | ||
15049 | RETURN | |
15050 | ||
15051 | 9999 CONTINUE | |
15052 | IREJ = 1 | |
15053 | RETURN | |
15054 | END | |
15055 | ||
15056 | *$ CREATE DT_DECAY1.FOR | |
15057 | *COPY DT_DECAY1 | |
15058 | * | |
15059 | *===decay1=============================================================* | |
15060 | * | |
15061 | SUBROUTINE DT_DECAY1 | |
15062 | ||
15063 | ************************************************************************ | |
15064 | * Decay of resonances stored in DTEVT1. * | |
15065 | * This version dated 20.01.95 is written by S. Roesler * | |
15066 | ************************************************************************ | |
15067 | ||
15068 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15069 | SAVE | |
15070 | PARAMETER ( LINP = 10 , | |
15071 | & LOUT = 6 , | |
15072 | & LDAT = 9 ) | |
15073 | ||
15074 | * event history | |
15075 | PARAMETER (NMXHKK=200000) | |
15076 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15077 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15078 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15079 | * extended event history | |
15080 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15081 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15082 | & IHIST(2,NMXHKK) | |
15083 | ||
15084 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) | |
15085 | ||
15086 | NEND = NHKK | |
15087 | C DO 1 I=NPOINT(5),NEND | |
15088 | DO 1 I=NPOINT(4),NEND | |
15089 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
15090 | DO 2 K=1,4 | |
15091 | PIN(K) = PHKK(K,I) | |
15092 | 2 CONTINUE | |
15093 | IDXIN = IDBAM(I) | |
15094 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
15095 | IF (NSEC.GT.1) THEN | |
15096 | DO 3 N=1,NSEC | |
15097 | IDHAD = IDT_IPDGHA(IDXOUT(N)) | |
15098 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), | |
15099 | & POUT(N,3),POUT(N,4),0,0,0) | |
15100 | 3 CONTINUE | |
15101 | ENDIF | |
15102 | ENDIF | |
15103 | 1 CONTINUE | |
15104 | ||
15105 | RETURN | |
15106 | END | |
15107 | ||
15108 | *$ CREATE DT_DECPI0.FOR | |
15109 | *COPY DT_DECPI0 | |
15110 | * | |
15111 | *===decpi0=============================================================* | |
15112 | * | |
15113 | SUBROUTINE DT_DECPI0 | |
15114 | ||
15115 | ************************************************************************ | |
15116 | * Decay of pi0 handled with JETSET. * | |
15117 | * This version dated 18.02.96 is written by S. Roesler * | |
15118 | ************************************************************************ | |
15119 | ||
15120 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15121 | SAVE | |
15122 | PARAMETER ( LINP = 10 , | |
15123 | & LOUT = 6 , | |
15124 | & LDAT = 9 ) | |
15125 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) | |
15126 | ||
15127 | * event history | |
15128 | PARAMETER (NMXHKK=200000) | |
15129 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15130 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15131 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15132 | * extended event history | |
15133 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15134 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15135 | & IHIST(2,NMXHKK) | |
bd378884 | 15136 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 15137 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
15138 | PARAMETER (MAXLND=4000) | |
15139 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
15140 | * flags for input different options | |
15141 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15142 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15143 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15144 | ||
15145 | INTEGER PYCOMP,PYK | |
15146 | ||
15147 | DIMENSION IHISMO(NMXHKK),P1(4) | |
15148 | ||
15149 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) | |
15150 | ||
15151 | CALL DT_INITJS(2) | |
15152 | * allow pi0 decay | |
15153 | KC = PYCOMP(111) | |
15154 | MDCY(KC,1) = 1 | |
15155 | ||
15156 | NN = 0 | |
15157 | INI = 0 | |
15158 | DO 1 I=1,NHKK | |
15159 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN | |
15160 | IF (INI.EQ.0) THEN | |
15161 | INI = 1 | |
15162 | ELSE | |
15163 | INI = 2 | |
15164 | ENDIF | |
15165 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
15166 | & PHKK(4,I),INI,IDUM,IDUM) | |
15167 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) | |
15168 | PTOT = SQRT(PT**2+PHKK(3,I)**2) | |
15169 | COSTH = PHKK(3,I)/(PTOT+TINY10) | |
15170 | IF (COSTH.GT.ONE) THEN | |
15171 | THETA = ZERO | |
15172 | ELSEIF (COSTH.LT.-ONE) THEN | |
15173 | THETA = TWOPI/2.0D0 | |
15174 | ELSE | |
15175 | THETA = ACOS(COSTH) | |
15176 | ENDIF | |
15177 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) | |
15178 | IF (PHKK(1,I).LT.0.0D0) | |
15179 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) | |
15180 | ENER = PHKK(4,I) | |
15181 | NN = NN+1 | |
15182 | KTEMP = MSTU(10) | |
15183 | MSTU(10)= 1 | |
15184 | P(NN,5) = PHKK(5,I) | |
15185 | CALL PY1ENT(NN,111,ENER,THETA,PHI) | |
15186 | MSTU(10) = KTEMP | |
15187 | IHISMO(NN)= I | |
15188 | ENDIF | |
15189 | 1 CONTINUE | |
15190 | IF (NN.GT.0) THEN | |
15191 | CALL PYEXEC | |
15192 | NLINES = PYK(0,1) | |
15193 | DO 2 II=1,NLINES | |
15194 | IF (PYK(II,7).EQ.1) THEN | |
15195 | DO 3 KK=1,4 | |
15196 | P1(KK) = PYP(II,KK) | |
15197 | 3 CONTINUE | |
15198 | ID = PYK(II,8) | |
15199 | MO = IHISMO(PYK(II,15)) | |
15200 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) | |
15201 | IF (LEMCCK) | |
15202 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, | |
15203 | & IDUM,IDUM) | |
15204 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) | |
15205 | ISTHKK(MO) = -2 | |
15206 | ENDIF | |
15207 | 2 CONTINUE | |
15208 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) | |
15209 | ENDIF | |
15210 | MDCY(KC,1) = 0 | |
15211 | ||
15212 | RETURN | |
15213 | END | |
15214 | ||
15215 | *$ CREATE DT_DTWOPD.FOR | |
15216 | *COPY DT_DTWOPD | |
15217 | * | |
15218 | *===dtwopd=============================================================* | |
15219 | * | |
15220 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, | |
15221 | & COF2,SIF2,AM1,AM2) | |
15222 | ||
15223 | ************************************************************************ | |
15224 | * Two-particle decay. * | |
15225 | * UMO cm-energy of the decaying system (input) * | |
15226 | * AM1/AM2 masses of the decay products (input) * | |
15227 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * | |
15228 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15229 | * Revised by S. Roesler, 20.11.95 * | |
15230 | ************************************************************************ | |
15231 | ||
15232 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15233 | SAVE | |
15234 | PARAMETER ( LINP = 10 , | |
15235 | & LOUT = 6 , | |
15236 | & LDAT = 9 ) | |
15237 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) | |
15238 | ||
15239 | IF (UMO.LT.(AM1+AM2)) THEN | |
15240 | WRITE(LOUT,1000) UMO,AM1,AM2 | |
15241 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', | |
15242 | & 3E12.3) | |
15243 | STOP | |
15244 | ENDIF | |
15245 | ||
15246 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) | |
15247 | ECM2 = UMO-ECM1 | |
15248 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) | |
15249 | PCM2 = PCM1 | |
15250 | CALL DT_DSFECF(SIF1,COF1) | |
15251 | COD1 = TWO*DT_RNDM(PCM2)-ONE | |
15252 | COD2 = -COD1 | |
15253 | COF2 = -COF1 | |
15254 | SIF2 = -SIF1 | |
15255 | ||
15256 | RETURN | |
15257 | END | |
15258 | ||
15259 | *$ CREATE DT_DTHREP.FOR | |
15260 | *COPY DT_DTHREP | |
15261 | * | |
15262 | *===dthrep=============================================================* | |
15263 | * | |
15264 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, | |
15265 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
15266 | ||
15267 | ************************************************************************ | |
15268 | * Three-particle decay. * | |
15269 | * UMO cm-energy of the decaying system (input) * | |
15270 | * AM1/2/3 masses of the decay products (input) * | |
15271 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * | |
15272 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15273 | * * | |
15274 | * Threpd89: slight revision by A. Ferrari * | |
15275 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * | |
15276 | * Revised by S. Roesler, 20.11.95 * | |
15277 | ************************************************************************ | |
15278 | ||
15279 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15280 | SAVE | |
15281 | PARAMETER ( LINP = 10 , | |
15282 | & LOUT = 6 , | |
15283 | & LDAT = 9 ) | |
15284 | ||
15285 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
15286 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
15287 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
15288 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
15289 | PARAMETER ( ONEONE = 1.D+00 ) | |
15290 | PARAMETER ( TWOTWO = 2.D+00 ) | |
15291 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
15292 | ||
15293 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
15294 | * flags for input different options | |
15295 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15296 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15297 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15298 | ||
15299 | DIMENSION F(5),XX(5) | |
15300 | DATA EPS /AZRZRZ/ | |
15301 | ||
15302 | UMOO=UMO+UMO | |
15303 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 | |
15304 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 | |
15305 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION | |
15306 | UUMO=UMO | |
15307 | AAM1=AM1 | |
15308 | AAM2=AM2 | |
15309 | AAM3=AM3 | |
15310 | GU=(AM2+AM3)**2 | |
15311 | GO=(UMO-AM1)**2 | |
15312 | * UFAK=1.0000000000001D0 | |
15313 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 | |
15314 | IF (GU.GT.GO) THEN | |
15315 | UFAK=ONEMNS | |
15316 | ELSE | |
15317 | UFAK=ONEPLS | |
15318 | END IF | |
15319 | OFAK=2.D0-UFAK | |
15320 | GU=GU*UFAK | |
15321 | GO=GO*OFAK | |
15322 | DS2=(GO-GU)/99.D0 | |
15323 | AM11=AM1*AM1 | |
15324 | AM22=AM2*AM2 | |
15325 | AM33=AM3*AM3 | |
15326 | UMO2=UMO*UMO | |
15327 | RHO2=0.D0 | |
15328 | S22=GU | |
15329 | DO 124 I=1,100 | |
15330 | S21=S22 | |
15331 | S22=GU+(I-1.D0)*DS2 | |
15332 | RHO1=RHO2 | |
15333 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ | |
15334 | * (S22+EPS) | |
15335 | IF(RHO2.LT.RHO1) GO TO 125 | |
15336 | 124 CONTINUE | |
15337 | 125 S2SUP=(S22-S21)*.5D0+S21 | |
15338 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ | |
15339 | * (S2SUP+EPS) | |
15340 | SUPRHO=SUPRHO*1.05D0 | |
15341 | XO=S21-DS2 | |
15342 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU | |
15343 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU | |
15344 | XX(1)=XO | |
15345 | XX(3)=S22 | |
15346 | X1=(XO+S22)*0.5D0 | |
15347 | XX(2)=X1 | |
15348 | F(3)=RHO2 | |
15349 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) | |
15350 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) | |
15351 | DO 126 I=1,16 | |
15352 | X4=(XX(1)+XX(2))*0.5D0 | |
15353 | X5=(XX(2)+XX(3))*0.5D0 | |
15354 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ | |
15355 | * (X4+EPS) | |
15356 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ | |
15357 | * (X5+EPS) | |
15358 | XX(4)=X4 | |
15359 | XX(5)=X5 | |
15360 | DO 128 II=1,5 | |
15361 | IA=II | |
15362 | DO 128 III=IA,5 | |
15363 | IF (F (II).GE.F (III)) GO TO 128 | |
15364 | FH=F(II) | |
15365 | F(II)=F(III) | |
15366 | F(III)=FH | |
15367 | FH=XX(II) | |
15368 | XX(II)=XX(III) | |
15369 | XX(III)=FH | |
15370 | 128 CONTINUE | |
15371 | SUPRHO=F(1) | |
15372 | S2SUP=XX(1) | |
15373 | DO 129 II=1,3 | |
15374 | IA=II | |
15375 | DO 129 III=IA,3 | |
15376 | IF (XX(II).GE.XX(III)) GO TO 129 | |
15377 | FH=F(II) | |
15378 | F(II)=F(III) | |
15379 | F(III)=FH | |
15380 | FH=XX(II) | |
15381 | XX(II)=XX(III) | |
15382 | XX(III)=FH | |
15383 | 129 CONTINUE | |
15384 | 126 CONTINUE | |
15385 | AM23=(AM2+AM3)**2 | |
15386 | ITH=0 | |
15387 | REDU=2.D0 | |
15388 | 1 CONTINUE | |
15389 | ITH=ITH+1 | |
15390 | IF (ITH.GT.200) REDU=-9.D0 | |
15391 | IF (ITH.GT.200) GO TO 400 | |
15392 | C=DT_RNDM(REDU) | |
15393 | * S2=AM23+C*((UMO-AM1)**2-AM23) | |
15394 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) | |
15395 | Y=DT_RNDM(S2) | |
15396 | Y=Y*SUPRHO | |
15397 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 | |
15398 | IF(Y.GT.RHO) GO TO 1 | |
15399 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 | |
15400 | S1=DT_RNDM(S2) | |
15401 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- | |
15402 | &RHO*.5D0 | |
15403 | S3=UMO2+AM11+AM22+AM33-S1-S2 | |
15404 | ECM1=(UMO2+AM11-S2)/UMOO | |
15405 | ECM2=(UMO2+AM22-S3)/UMOO | |
15406 | ECM3=(UMO2+AM33-S1)/UMOO | |
15407 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) | |
15408 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) | |
15409 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) | |
15410 | CALL DT_DSFECF(SFE,CFE) | |
15411 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 | |
15412 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF | |
15413 | PCM12 = PCM1 * PCM2 | |
15414 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 | |
15415 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 | |
15416 | GO TO 300 | |
15417 | 200 CONTINUE | |
15418 | UW=DT_RNDM(S1) | |
15419 | COSTH=(UW-0.5D+00)*2.D+00 | |
15420 | 300 CONTINUE | |
15421 | * IF(ABS(COSTH).GT.0.9999999999999999D0) | |
15422 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) | |
15423 | IF(ABS(COSTH).GT.ONEONE) | |
15424 | &COSTH=SIGN(ONEONE,COSTH) | |
15425 | IF (REDU.LT.1.D+00) RETURN | |
15426 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) | |
15427 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) | |
15428 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) | |
15429 | IF(ABS(COSTH2).GT.ONEONE) | |
15430 | &COSTH2=SIGN(ONEONE,COSTH2) | |
15431 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) | |
15432 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) | |
15433 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 | |
15434 | COSTH1=COSTH*COSTH2+SINTH2*SINTH | |
15435 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA | |
15436 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR | |
15437 | C***THE DIRECTION OF PARTICLE 3 | |
15438 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 | |
15439 | CX11=-COSTH1 | |
15440 | CY11=SINTH1*CFE | |
15441 | CZ11=SINTH1*SFE | |
15442 | CX22=-COSTH2 | |
15443 | CY22=-SINTH2*CFE | |
15444 | CZ22=-SINTH2*SFE | |
15445 | CALL DT_DSFECF(SIF3,COF3) | |
15446 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE | |
15447 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) | |
15448 | 2 FORMAT(5F20.15) | |
15449 | COD1=CX11*COD3+CZ11*SID3 | |
15450 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) | |
15451 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, | |
15452 | &CX11,CZ11 | |
15453 | SID1=SQRT(CHLP) | |
15454 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 | |
15455 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 | |
15456 | COD2=CX22*COD3+CZ22*SID3 | |
15457 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) | |
15458 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 | |
15459 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 | |
15460 | 400 CONTINUE | |
15461 | * === Energy conservation check: === * | |
15462 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 | |
15463 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) | |
15464 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) | |
15465 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) | |
15466 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 | |
15467 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 | |
15468 | & + PCM3 * COF3 * SID3 | |
15469 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 | |
15470 | & + PCM3 * SIF3 * SID3 | |
15471 | EOCMPR = 1.D-12 * UMO | |
15472 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) | |
15473 | & .GT. EOCMPR ) THEN | |
15474 | **sr 5.5.95 output-unit changed | |
15475 | IF (IOULEV(1).GT.0) THEN | |
15476 | WRITE(LOUT,*) | |
15477 | & ' *** Threpd: energy/momentum conservation failure! ***', | |
15478 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK | |
15479 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 | |
15480 | ENDIF | |
15481 | ** | |
15482 | END IF | |
15483 | RETURN | |
15484 | END | |
15485 | ||
15486 | *$ CREATE DT_DBKLAS.FOR | |
15487 | *COPY DT_DBKLAS | |
15488 | * | |
15489 | *===dbklas=============================================================* | |
15490 | * | |
15491 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) | |
15492 | ||
15493 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15494 | SAVE | |
15495 | PARAMETER ( LINP = 10 , | |
15496 | & LOUT = 6 , | |
15497 | & LDAT = 9 ) | |
15498 | ||
15499 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15500 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15501 | & IA08(6,21),IA10(6,21) | |
15502 | ||
15503 | IF (I) 20,20,10 | |
15504 | * baryons | |
15505 | 10 CONTINUE | |
15506 | CALL DT_INDEXD(J,K,IND) | |
15507 | I8 = IB08(I,IND) | |
15508 | I10 = IB10(I,IND) | |
15509 | IF (I8.LE.0) I8 = I10 | |
15510 | RETURN | |
15511 | * antibaryons | |
15512 | 20 CONTINUE | |
15513 | II = IABS(I) | |
15514 | JJ = IABS(J) | |
15515 | KK = IABS(K) | |
15516 | CALL DT_INDEXD(JJ,KK,IND) | |
15517 | I8 = IA08(II,IND) | |
15518 | I10 = IA10(II,IND) | |
15519 | IF (I8.LE.0) I8 = I10 | |
15520 | ||
15521 | RETURN | |
15522 | END | |
15523 | ||
15524 | *$ CREATE DT_INDEXD.FOR | |
15525 | *COPY DT_INDEXD | |
15526 | * | |
15527 | *===indexd=============================================================* | |
15528 | * | |
15529 | SUBROUTINE DT_INDEXD(KA,KB,IND) | |
15530 | ||
15531 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15532 | SAVE | |
15533 | PARAMETER ( LINP = 10 , | |
15534 | & LOUT = 6 , | |
15535 | & LDAT = 9 ) | |
15536 | ||
15537 | KP = KA*KB | |
15538 | KS = KA+KB | |
15539 | IF (KP.EQ.1) IND=1 | |
15540 | IF (KP.EQ.2) IND=2 | |
15541 | IF (KP.EQ.3) IND=3 | |
15542 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 | |
15543 | IF (KP.EQ.5) IND=5 | |
15544 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 | |
15545 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 | |
15546 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 | |
15547 | IF (KP.EQ.8) IND=9 | |
15548 | IF (KP.EQ.10) IND=10 | |
15549 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 | |
15550 | IF (KP.EQ.9) IND=12 | |
15551 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 | |
15552 | IF (KP.EQ.15) IND=14 | |
15553 | IF (KP.EQ.18) IND=15 | |
15554 | IF (KP.EQ.16) IND=16 | |
15555 | IF (KP.EQ.20) IND=17 | |
15556 | IF (KP.EQ.24) IND=18 | |
15557 | IF (KP.EQ.25) IND=19 | |
15558 | IF (KP.EQ.30) IND=20 | |
15559 | IF (KP.EQ.36) IND=21 | |
15560 | ||
15561 | RETURN | |
15562 | END | |
15563 | ||
15564 | *$ CREATE DT_DCHANT.FOR | |
15565 | *COPY DT_DCHANT | |
15566 | * | |
15567 | *===dchant=============================================================* | |
15568 | * | |
15569 | SUBROUTINE DT_DCHANT | |
15570 | ||
15571 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15572 | SAVE | |
15573 | PARAMETER ( LINP = 10 , | |
15574 | & LOUT = 6 , | |
15575 | & LDAT = 9 ) | |
15576 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15577 | ||
15578 | * HADRIN: decay channel information | |
15579 | PARAMETER (IDMAX9=602) | |
15580 | CHARACTER*8 ZKNAME | |
15581 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
15582 | * particle properties (BAMJET index convention) | |
15583 | CHARACTER*8 ANAME | |
15584 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
15585 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
15586 | ||
15587 | DIMENSION HWT(IDMAX9) | |
15588 | ||
15589 | * change of weights wt from absolut values into the sum of wt of a dec. | |
15590 | DO 10 J=1,IDMAX9 | |
15591 | HWT(J) = ZERO | |
15592 | 10 CONTINUE | |
15593 | C DO 999 KKK=1,210 | |
15594 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') | |
15595 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), | |
15596 | C & K1(KKK),K2(KKK) | |
15597 | C 999 CONTINUE | |
15598 | C STOP | |
15599 | DO 30 I=1,210 | |
15600 | IK1 = K1(I) | |
15601 | IK2 = K2(I) | |
15602 | HV = ZERO | |
15603 | DO 20 J=IK1,IK2 | |
15604 | HV = HV+WT(J) | |
15605 | HWT(J) = HV | |
15606 | **sr 13.1.95 | |
15607 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 | |
15608 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) | |
15609 | 20 CONTINUE | |
15610 | 30 CONTINUE | |
15611 | DO 40 J=1,IDMAX9 | |
15612 | WT(J) = HWT(J) | |
15613 | 40 CONTINUE | |
15614 | ||
15615 | RETURN | |
15616 | END | |
15617 | ||
15618 | *$ CREATE DT_DDATAR.FOR | |
15619 | *COPY DT_DDATAR | |
15620 | * | |
15621 | *===ddatar=============================================================* | |
15622 | * | |
15623 | SUBROUTINE DT_DDATAR | |
15624 | ||
15625 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15626 | SAVE | |
15627 | PARAMETER ( LINP = 10 , | |
15628 | & LOUT = 6 , | |
15629 | & LDAT = 9 ) | |
15630 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15631 | ||
15632 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15633 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15634 | & IA08(6,21),IA10(6,21) | |
15635 | ||
15636 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) | |
15637 | ||
15638 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, | |
15639 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, | |
15640 | & 128,129,14*0/ | |
15641 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, | |
15642 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, | |
15643 | & 121,122,14*0/ | |
15644 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, | |
15645 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, | |
15646 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, | |
15647 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, | |
15648 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, | |
15649 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, | |
15650 | & 0, 0, 0,140,137,138,146, 0, 0,142, | |
15651 | & 139,147, 0, 0,145,148, 50*0/ | |
15652 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, | |
15653 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, | |
15654 | & 0, 54, 55,105,162, 0, 0, 56,106,163, | |
15655 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, | |
15656 | & 0, 0,104,105,107,164, 0, 0,106,108, | |
15657 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, | |
15658 | & 0, 0, 0,161,162,164,167, 0, 0,163, | |
15659 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ | |
15660 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, | |
15661 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, | |
15662 | & 0, 2, 9,100,149, 0, 0, 0,101,154, | |
15663 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, | |
15664 | & 0, 0, 99,100,102,150, 0, 0,101,103, | |
15665 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, | |
15666 | & 0, 0, 0,152,149,150,158, 0, 0,154, | |
15667 | & 151,159, 0, 0,157,160, 50*0/ | |
15668 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, | |
15669 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, | |
15670 | & 0, 68, 69,111,172, 0, 0, 70,112,173, | |
15671 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, | |
15672 | & 0, 0,110,111,113,174, 0, 0,112,114, | |
15673 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, | |
15674 | & 0, 0, 0,171,172,174,177, 0, 0,173, | |
15675 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ | |
15676 | ||
15677 | L=0 | |
15678 | DO 2 I=1,6 | |
15679 | DO 1 J=1,6 | |
15680 | L = L+1 | |
15681 | IMPS(I,J) = IP(L) | |
15682 | IMVE(I,J) = IV(L) | |
15683 | 1 CONTINUE | |
15684 | 2 CONTINUE | |
15685 | L=0 | |
15686 | DO 4 I=1,6 | |
15687 | DO 3 J=1,21 | |
15688 | L = L+1 | |
15689 | IB08(I,J) = IB(L) | |
15690 | IB10(I,J) = IBB(L) | |
15691 | IA08(I,J) = IA(L) | |
15692 | IA10(I,J) = IAA(L) | |
15693 | 3 CONTINUE | |
15694 | 4 CONTINUE | |
15695 | C A1 = 0.88D0 | |
15696 | C B1 = 3.0D0 | |
15697 | C B2 = 3.0D0 | |
15698 | C B3 = 8.0D0 | |
15699 | C LT = 0 | |
15700 | C LB = 0 | |
15701 | C BET = 12.0D0 | |
15702 | C AS = 0.25D0 | |
15703 | C B8 = 0.33D0 | |
15704 | C AME = 0.95D0 | |
15705 | C DIQ = 0.375D0 | |
15706 | C ISU = 4 | |
15707 | ||
15708 | RETURN | |
15709 | END | |
15710 | ||
15711 | *$ CREATE DT_INITJS.FOR | |
15712 | *COPY DT_INITJS | |
15713 | * | |
15714 | *===initjs=============================================================* | |
15715 | * | |
15716 | SUBROUTINE DT_INITJS(MODE) | |
15717 | ||
15718 | ************************************************************************ | |
15719 | * Initialize JETSET paramters. * | |
15720 | * MODE = 0 default settings * | |
15721 | * = 1 PHOJET settings * | |
15722 | * = 2 DTUNUC settings * | |
15723 | * This version dated 16.02.96 is written by S. Roesler * | |
15724 | * * | |
15725 | * Last change 27.12.2006 by S. Roesler. * | |
15726 | ************************************************************************ | |
15727 | ||
15728 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15729 | SAVE | |
15730 | PARAMETER ( LINP = 10 , | |
15731 | & LOUT = 6 , | |
15732 | & LDAT = 9 ) | |
15733 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15734 | ||
15735 | LOGICAL LFIRST,LFIRDT,LFIRPH | |
15736 | ||
15737 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15738 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) | |
bd378884 | 15739 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
9aaba0d6 | 15740 | * flags for particle decays |
15741 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
15742 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
15743 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
15744 | * flags for input different options | |
15745 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15746 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15747 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15748 | ||
15749 | INTEGER PYCOMP | |
15750 | ||
15751 | DIMENSION IDXSTA(40) | |
15752 | DATA IDXSTA | |
15753 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 | |
15754 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, | |
15755 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ | |
15756 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, | |
15757 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ | |
15758 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, | |
15759 | * Ksic0 aKsic+aKsic0 sig0 asig0 | |
15760 | & 4132,-4232,-4132, 3212,-3212, 5*0/ | |
15761 | ||
15762 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ | |
15763 | ||
15764 | IF (LFIRST) THEN | |
15765 | * save default settings | |
15766 | PDEF1 = PARJ(1) | |
15767 | PDEF2 = PARJ(2) | |
15768 | PDEF3 = PARJ(3) | |
15769 | PDEF5 = PARJ(5) | |
15770 | PDEF6 = PARJ(6) | |
15771 | PDEF7 = PARJ(7) | |
15772 | PDEF18 = PARJ(18) | |
15773 | PDEF19 = PARJ(19) | |
15774 | PDEF21 = PARJ(21) | |
15775 | PDEF42 = PARJ(42) | |
15776 | MDEF12 = MSTJ(12) | |
15777 | * LUJETS / PYJETS array-dimensions | |
15778 | MSTU(4) = 4000 | |
15779 | * increase maximum number of JETSET-error prints | |
15780 | MSTU(22) = 50000 | |
15781 | * prevent particles decaying | |
15782 | DO 1 I=1,35 | |
15783 | IF (I.LT.34) THEN | |
15784 | KC = PYCOMP(IDXSTA(I)) | |
15785 | IF (KC.GT.0) THEN | |
15786 | IF (I.EQ.2) THEN | |
15787 | * pi0 decay | |
15788 | C MDCY(KC,1) = 1 | |
15789 | MDCY(KC,1) = 0 | |
15790 | **cr mode | |
15791 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. | |
15792 | C & (I.EQ.8).OR.(I.EQ.10)) THEN | |
15793 | C ELSEIF (I.EQ.4) THEN | |
15794 | C MDCY(KC,1) = 1 | |
15795 | ** | |
15796 | ELSE | |
1ddc441c | 15797 | C AM MDCY(KC,1) = 0 |
9aaba0d6 | 15798 | ENDIF |
15799 | ENDIF | |
15800 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN | |
15801 | KC = PYCOMP(IDXSTA(I)) | |
15802 | IF (KC.GT.0) THEN | |
1ddc441c | 15803 | C AM MDCY(KC,1) = 0 |
9aaba0d6 | 15804 | ENDIF |
15805 | ENDIF | |
15806 | 1 CONTINUE | |
15807 | * | |
15808 | * | |
15809 | * popcorn: | |
15810 | IF (PDB.LE.ZERO) THEN | |
15811 | * no popcorn-mechanism | |
15812 | MSTJ(12) = 1 | |
15813 | ELSE | |
15814 | MSTJ(12) = 3 | |
15815 | PARJ(5) = PDB | |
15816 | ENDIF | |
15817 | * set JETSET-parameter requested by input cards | |
15818 | IF (NMSTU.GT.0) THEN | |
15819 | DO 2 I=1,NMSTU | |
15820 | MSTU(IMSTU(I)) = MSTUX(I) | |
15821 | 2 CONTINUE | |
15822 | ENDIF | |
15823 | IF (NMSTJ.GT.0) THEN | |
15824 | DO 3 I=1,NMSTJ | |
15825 | MSTJ(IMSTJ(I)) = MSTJX(I) | |
15826 | 3 CONTINUE | |
15827 | ENDIF | |
15828 | IF (NPARU.GT.0) THEN | |
15829 | DO 4 I=1,NPARU | |
15830 | PARU(IPARU(I)) = PARUX(I) | |
15831 | 4 CONTINUE | |
15832 | ENDIF | |
15833 | LFIRST = .FALSE. | |
15834 | ENDIF | |
15835 | * | |
15836 | * PARJ(1) suppression of qq-aqaq pair prod. compared to | |
15837 | * q-aq pair prod. (default: 0.1) | |
15838 | * PARJ(2) strangeness suppression (default: 0.3) | |
15839 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) | |
15840 | * PARJ(6) extra suppression of sas-pair shared by B and | |
15841 | * aB in BMaB (default: 0.5) | |
15842 | * PARJ(7) extra suppression of strange meson M in BMaB | |
15843 | * configuration (default: 0.5) | |
15844 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) | |
15845 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse | |
15846 | * momentum distrib. for prim. hadrons (default: 0.35) | |
15847 | * PARJ(42) b-parameter for symmetric Lund-fragmentation | |
15848 | * function (default: 0.9 GeV^-2) | |
15849 | * | |
15850 | * PHOJET settings | |
15851 | IF (MODE.EQ.1) THEN | |
15852 | * JETSET default | |
15853 | C PARJ(1) = PDEF1 | |
15854 | C PARJ(2) = PDEF2 | |
15855 | C PARJ(3) = PDEF3 | |
15856 | C PARJ(6) = PDEF6 | |
15857 | C PARJ(7) = PDEF7 | |
15858 | C PARJ(18) = PDEF18 | |
15859 | C PARJ(21) = PDEF21 | |
15860 | C PARJ(42) = PDEF42 | |
15861 | **sr 18.11.98 parameter tuning | |
15862 | C PARJ(1) = 0.092D0 | |
15863 | C PARJ(2) = 0.25D0 | |
15864 | C PARJ(3) = 0.45D0 | |
15865 | C PARJ(19) = 0.3D0 | |
15866 | C PARJ(21) = 0.45D0 | |
15867 | C PARJ(42) = 1.0D0 | |
15868 | **sr 28.04.99 parameter tuning (May 99 minor modifications) | |
15869 | PARJ(1) = 0.085D0 | |
15870 | PARJ(2) = 0.26D0 | |
15871 | PARJ(3) = 0.8D0 | |
15872 | PARJ(11) = 0.38D0 | |
15873 | PARJ(18) = 0.3D0 | |
15874 | PARJ(19) = 0.4D0 | |
15875 | PARJ(21) = 0.36D0 | |
15876 | PARJ(41) = 0.3D0 | |
15877 | PARJ(42) = 0.86D0 | |
15878 | IF (NPARJ.GT.0) THEN | |
15879 | DO 10 I=1,NPARJ | |
15880 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) | |
15881 | 10 CONTINUE | |
15882 | ENDIF | |
15883 | IF (LFIRPH) THEN | |
15884 | WRITE(LOUT,'(1X,A)') | |
15885 | & 'DT_INITJS: JETSET-parameter for PHOJET' | |
15886 | CALL DT_JSPARA(0) | |
15887 | LFIRPH = .FALSE. | |
15888 | ENDIF | |
15889 | * DTUNUC settings | |
15890 | ELSEIF (MODE.EQ.2) THEN | |
15891 | IF (IFRAG(2).EQ.1) THEN | |
15892 | **sr parameters before 9.3.96 | |
15893 | C PARJ(2) = 0.27D0 | |
15894 | C PARJ(3) = 0.6D0 | |
15895 | C PARJ(6) = 0.75D0 | |
15896 | C PARJ(7) = 0.75D0 | |
15897 | C PARJ(21) = 0.55D0 | |
15898 | C PARJ(42) = 1.3D0 | |
15899 | **sr 18.11.98 parameter tuning | |
15900 | C PARJ(1) = 0.05D0 | |
15901 | C PARJ(2) = 0.27D0 | |
15902 | C PARJ(3) = 0.4D0 | |
15903 | C PARJ(19) = 0.2D0 | |
15904 | C PARJ(21) = 0.45D0 | |
15905 | C PARJ(42) = 1.0D0 | |
15906 | **sr 28.04.99 parameter tuning | |
15907 | PARJ(1) = 0.11D0 | |
15908 | PARJ(2) = 0.36D0 | |
15909 | PARJ(3) = 0.8D0 | |
15910 | PARJ(19) = 0.2D0 | |
15911 | PARJ(21) = 0.3D0 | |
15912 | PARJ(41) = 0.3D0 | |
15913 | PARJ(42) = 0.58D0 | |
15914 | IF (NPARJ.GT.0) THEN | |
15915 | DO 20 I=1,NPARJ | |
15916 | IF (IPARJ(I).LT.0) THEN | |
15917 | IDX = ABS(IPARJ(I)) | |
15918 | PARJ(IDX) = PARJX(I) | |
15919 | ENDIF | |
15920 | 20 CONTINUE | |
15921 | ENDIF | |
15922 | IF (LFIRDT) THEN | |
15923 | WRITE(LOUT,'(1X,A)') | |
15924 | & 'DT_INITJS: JETSET-parameter for DTUNUC' | |
15925 | CALL DT_JSPARA(0) | |
15926 | LFIRDT = .FALSE. | |
15927 | ENDIF | |
15928 | ELSEIF (IFRAG(2).EQ.2) THEN | |
15929 | PARJ(1) = 0.11D0 | |
15930 | PARJ(2) = 0.27D0 | |
15931 | PARJ(3) = 0.3D0 | |
15932 | PARJ(6) = 0.35D0 | |
15933 | PARJ(7) = 0.45D0 | |
15934 | PARJ(18) = 0.66D0 | |
15935 | C PARJ(21) = 0.55D0 | |
15936 | C PARJ(42) = 1.0D0 | |
15937 | PARJ(21) = 0.60D0 | |
15938 | PARJ(42) = 1.3D0 | |
15939 | ELSE | |
15940 | PARJ(1) = PDEF1 | |
15941 | PARJ(2) = PDEF2 | |
15942 | PARJ(3) = PDEF3 | |
15943 | PARJ(6) = PDEF6 | |
15944 | PARJ(7) = PDEF7 | |
15945 | PARJ(18) = PDEF18 | |
15946 | PARJ(21) = PDEF21 | |
15947 | PARJ(42) = PDEF42 | |
15948 | ENDIF | |
15949 | ELSE | |
15950 | PARJ(1) = PDEF1 | |
15951 | PARJ(2) = PDEF2 | |
15952 | PARJ(3) = PDEF3 | |
15953 | PARJ(5) = PDEF5 | |
15954 | PARJ(6) = PDEF6 | |
15955 | PARJ(7) = PDEF7 | |
15956 | PARJ(18) = PDEF18 | |
15957 | PARJ(19) = PDEF19 | |
15958 | PARJ(21) = PDEF21 | |
15959 | PARJ(42) = PDEF42 | |
15960 | MSTJ(12) = MDEF12 | |
15961 | ENDIF | |
15962 | ||
15963 | RETURN | |
15964 | END | |
15965 | ||
15966 | *$ CREATE DT_JSPARA.FOR | |
15967 | *COPY DT_JSPARA | |
15968 | * | |
15969 | *===jspara=============================================================* | |
15970 | * | |
15971 | SUBROUTINE DT_JSPARA(MODE) | |
15972 | ||
15973 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15974 | SAVE | |
15975 | PARAMETER ( LINP = 10 , | |
15976 | & LOUT = 6 , | |
15977 | & LDAT = 9 ) | |
15978 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, | |
15979 | & ONE=1.0D0,ZERO=0.0D0) | |
15980 | ||
15981 | LOGICAL LFIRST | |
15982 | ||
15983 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15984 | ||
15985 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) | |
15986 | ||
15987 | DATA LFIRST /.TRUE./ | |
15988 | ||
15989 | * save the default JETSET-parameter on the first call | |
15990 | IF (LFIRST) THEN | |
15991 | DO 1 I=1,200 | |
15992 | ISTU(I) = MSTU(I) | |
15993 | QARU(I) = PARU(I) | |
15994 | ISTJ(I) = MSTJ(I) | |
15995 | QARJ(I) = PARJ(I) | |
15996 | 1 CONTINUE | |
15997 | LFIRST = .FALSE. | |
15998 | ENDIF | |
15999 | ||
16000 | WRITE(LOUT,1000) | |
16001 | 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') | |
16002 | ||
16003 | * compare the default JETSET-parameter with the present values | |
16004 | DO 2 I=1,200 | |
16005 | IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN | |
16006 | WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) | |
16007 | C ISTU(I) = MSTU(I) | |
16008 | ENDIF | |
16009 | DIFF = ABS(PARU(I)-QARU(I)) | |
16010 | IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN | |
16011 | WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) | |
16012 | C QARU(I) = PARU(I) | |
16013 | ENDIF | |
16014 | IF (MSTJ(I).NE.ISTJ(I)) THEN | |
16015 | WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) | |
16016 | C ISTJ(I) = MSTJ(I) | |
16017 | ENDIF | |
16018 | DIFF = ABS(PARJ(I)-QARJ(I)) | |
16019 | IF (DIFF.GE.1.0D-5) THEN | |
16020 | WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) | |
16021 | C QARJ(I) = PARJ(I) | |
16022 | ENDIF | |
16023 | 2 CONTINUE | |
16024 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') | |
16025 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') | |
16026 | ||
16027 | RETURN | |
16028 | END | |
16029 | ||
16030 | *$ CREATE DT_FOZOCA.FOR | |
16031 | *COPY DT_FOZOCA | |
16032 | * | |
16033 | *===fozoca=============================================================* | |
16034 | * | |
16035 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) | |
16036 | ||
16037 | ************************************************************************ | |
16038 | * This subroutine treats the complete FOrmation ZOne supressed intra- * | |
16039 | * nuclear CAscade. * | |
16040 | * LFZC = .true. cascade has been treated * | |
16041 | * = .false. cascade skipped * | |
16042 | * This is a completely revised version of the original FOZOKL. * | |
16043 | * This version dated 18.11.95 is written by S. Roesler * | |
16044 | ************************************************************************ | |
16045 | ||
16046 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16047 | SAVE | |
16048 | PARAMETER ( LINP = 10 , | |
16049 | & LOUT = 6 , | |
16050 | & LDAT = 9 ) | |
16051 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) | |
16052 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16053 | ||
16054 | LOGICAL LSTART,LCAS,LFZC | |
16055 | ||
16056 | * event history | |
16057 | PARAMETER (NMXHKK=200000) | |
16058 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16059 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16060 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16061 | * extended event history | |
16062 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16063 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16064 | & IHIST(2,NMXHKK) | |
16065 | * rejection counter | |
16066 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
16067 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
16068 | & IREXCI(3),IRDIFF(2),IRINC | |
16069 | * properties of interacting particles | |
16070 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
16071 | * Glauber formalism: collision properties | |
16072 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 16073 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
16074 | & NCP,NCT | |
9aaba0d6 | 16075 | * flags for input different options |
16076 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16077 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16078 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16079 | * final state after intranuclear cascade step | |
16080 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16081 | * parameter for intranuclear cascade | |
16082 | LOGICAL LPAULI | |
16083 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16084 | ||
16085 | DIMENSION NCWOUN(2) | |
16086 | ||
16087 | DATA LSTART /.TRUE./ | |
16088 | ||
16089 | LFZC = .TRUE. | |
16090 | IREJ = 0 | |
16091 | ||
16092 | * skip cascade if hadron-hadron interaction or if supressed by user | |
16093 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 | |
16094 | * skip cascade if not all possible chains systems are hadronized | |
16095 | DO 1 I=1,8 | |
16096 | IF (.NOT.LHADRO(I)) GOTO 9999 | |
16097 | 1 CONTINUE | |
16098 | ||
16099 | IF (LSTART) THEN | |
16100 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD | |
16101 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', | |
16102 | & 'maximum of',I4,' generations',/,10X,'formation time ', | |
16103 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) | |
16104 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) | |
16105 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) | |
16106 | 1001 FORMAT(10X,'p_t dependent formation zone',/) | |
16107 | 1002 FORMAT(10X,'constant formation zone',/) | |
16108 | LSTART = .FALSE. | |
16109 | ENDIF | |
16110 | ||
16111 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons | |
16112 | * which may interact with final state particles are stored in a seperate | |
16113 | * array - here all proj./target nucleon-indices (just for simplicity) | |
16114 | NOINC = 0 | |
16115 | DO 9 I=1,NPOINT(1)-1 | |
16116 | NOINC = NOINC+1 | |
16117 | IDXINC(NOINC) = I | |
16118 | 9 CONTINUE | |
16119 | ||
16120 | * initialize Pauli-principle treatment (find wounded nucleons) | |
16121 | NWOUND(1) = 0 | |
16122 | NWOUND(2) = 0 | |
16123 | NCWOUN(1) = 0 | |
16124 | NCWOUN(2) = 0 | |
16125 | DO 2 J=1,NPOINT(1) | |
16126 | DO 3 I=1,2 | |
16127 | IF (ISTHKK(J).EQ.10+I) THEN | |
16128 | NWOUND(I) = NWOUND(I)+1 | |
16129 | EWOUND(I,NWOUND(I)) = PHKK(4,J) | |
16130 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 | |
16131 | ENDIF | |
16132 | 3 CONTINUE | |
16133 | 2 CONTINUE | |
16134 | ||
16135 | * modify nuclear potential for wounded nucleons | |
16136 | IPRCL = IP -NWOUND(1) | |
16137 | IPZRCL = IPZ-NCWOUN(1) | |
16138 | ITRCL = IT -NWOUND(2) | |
16139 | ITZRCL = ITZ-NCWOUN(2) | |
16140 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
16141 | ||
16142 | NSTART = NPOINT(4) | |
16143 | NEND = NHKK | |
16144 | ||
16145 | 7 CONTINUE | |
16146 | DO 8 I=NSTART,NEND | |
16147 | ||
16148 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN | |
16149 | * select nucleus the cascade starts first (proj. - 1, target - -1) | |
16150 | NCAS = 1 | |
16151 | * projectile/target with probab. 1/2 | |
16152 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN | |
16153 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16154 | * in the nucleus with highest mass | |
16155 | ELSEIF (INCMOD.EQ.2) THEN | |
16156 | IF (IP.GT.IT) THEN | |
16157 | NCAS = -NCAS | |
16158 | ELSEIF (IP.EQ.IT) THEN | |
16159 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16160 | ENDIF | |
16161 | * the nucleus the cascade starts first is requested to be the one | |
16162 | * moving in the direction of the secondary | |
16163 | ELSEIF (INCMOD.EQ.3) THEN | |
16164 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) | |
16165 | ENDIF | |
16166 | * check that the selected "nucleus" is not a hadron | |
16167 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. | |
16168 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS | |
16169 | ||
16170 | * treat intranuclear cascade in the nucleus selected first | |
16171 | LCAS = .FALSE. | |
16172 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16173 | IF (IREJ1.NE.0) GOTO 9998 | |
16174 | * treat intranuclear cascade in the other nucleus if this isn't a had. | |
16175 | NCAS = -NCAS | |
16176 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. | |
16177 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN | |
16178 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16179 | IF (IREJ1.NE.0) GOTO 9998 | |
16180 | ENDIF | |
16181 | ||
16182 | ENDIF | |
16183 | ||
16184 | 8 CONTINUE | |
16185 | NSTART = NEND+1 | |
16186 | NEND = NHKK | |
16187 | IF (NSTART.LE.NEND) GOTO 7 | |
16188 | ||
16189 | RETURN | |
16190 | ||
16191 | 9998 CONTINUE | |
16192 | * reject this event | |
16193 | IRINC = IRINC+1 | |
16194 | IREJ = 1 | |
16195 | ||
16196 | 9999 CONTINUE | |
16197 | * intranucl. cascade not treated because of interaction properties or | |
16198 | * it is supressed by user or it was rejected or... | |
16199 | LFZC = .FALSE. | |
16200 | * reset flag characterizing direction of motion in n-n-cms | |
16201 | **sr14-11-95 | |
16202 | C DO 9990 I=NPOINT(5),NHKK | |
16203 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 | |
16204 | C9990 CONTINUE | |
16205 | ||
16206 | RETURN | |
16207 | END | |
16208 | ||
16209 | *$ CREATE DT_INUCAS.FOR | |
16210 | *COPY DT_INUCAS | |
16211 | * | |
16212 | *===inucas=============================================================* | |
16213 | * | |
16214 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) | |
16215 | ||
16216 | ************************************************************************ | |
16217 | * Formation zone supressed IntraNUclear CAScade for one final state * | |
16218 | * particle. * | |
16219 | * IT, IP mass numbers of target, projectile nuclei * | |
16220 | * IDXCAS index of final state particle in DTEVT1 * | |
16221 | * NCAS = 1 intranuclear cascade in projectile * | |
16222 | * = -1 intranuclear cascade in target * | |
16223 | * This version dated 18.11.95 is written by S. Roesler * | |
16224 | ************************************************************************ | |
16225 | ||
16226 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16227 | SAVE | |
16228 | PARAMETER ( LINP = 10 , | |
16229 | & LOUT = 6 , | |
16230 | & LDAT = 9 ) | |
16231 | ||
16232 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
16233 | & OHALF=0.5D0,ONE=1.0D0) | |
16234 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16235 | PARAMETER (TWOPI=6.283185307179586454D+00) | |
16236 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) | |
16237 | ||
16238 | LOGICAL LABSOR,LCAS | |
16239 | ||
16240 | * event history | |
16241 | PARAMETER (NMXHKK=200000) | |
16242 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16243 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16244 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16245 | * extended event history | |
16246 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16247 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16248 | & IHIST(2,NMXHKK) | |
16249 | * final state after inc step | |
16250 | PARAMETER (MAXFSP=10) | |
16251 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
16252 | * flags for input different options | |
16253 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16254 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16255 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16256 | * particle properties (BAMJET index convention) | |
16257 | CHARACTER*8 ANAME | |
16258 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
16259 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
16260 | * Glauber formalism: collision properties | |
16261 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
e3f546f5 | 16262 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
16263 | & NCP,NCT | |
9aaba0d6 | 16264 | * nuclear potential |
16265 | LOGICAL LFERMI | |
16266 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
16267 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
16268 | & ETACOU(2),ICOUL,LFERMI | |
16269 | * parameter for intranuclear cascade | |
16270 | LOGICAL LPAULI | |
16271 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16272 | * final state after intranuclear cascade step | |
16273 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16274 | * nucleon-nucleon event-generator | |
16275 | CHARACTER*8 CMODEL | |
16276 | LOGICAL LPHOIN | |
16277 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
16278 | * statistics: residual nuclei | |
16279 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
16280 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
16281 | & NINCST(2,4),NINCEV(2), | |
16282 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
16283 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
16284 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
16285 | & NEVAFI(2,2) | |
16286 | ||
16287 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), | |
16288 | & PCAS1(5),PNUC(5),BGTA(4), | |
16289 | & BGCAS(2),GACAS(2),BECAS(2), | |
16290 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) | |
16291 | ||
16292 | DATA PDIF /0.545D0/ | |
16293 | ||
16294 | IREJ = 0 | |
16295 | ||
16296 | * update counter | |
16297 | IF (NINCEV(1).NE.NEVHKK) THEN | |
16298 | NINCEV(1) = NEVHKK | |
16299 | NINCEV(2) = NINCEV(2)+1 | |
16300 | ENDIF | |
16301 | ||
16302 | * "BAMJET-index" of this hadron | |
16303 | IDCAS = IDBAM(IDXCAS) | |
16304 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN | |
16305 | ||
16306 | * skip gammas, electrons, etc.. | |
16307 | IF (AAM(IDCAS).LT.TINY2) RETURN | |
16308 | ||
16309 | * Lorentz-trsf. into projectile rest system | |
16310 | IF (IP.GT.1) THEN | |
16311 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16312 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), | |
16313 | & PCAS(1,4),IDCAS,-2) | |
16314 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) | |
16315 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) | |
16316 | IF (PCAS(1,5).GT.ZERO) THEN | |
16317 | PCAS(1,5) = SQRT(PCAS(1,5)) | |
16318 | ELSE | |
16319 | PCAS(1,5) = AAM(IDCAS) | |
16320 | ENDIF | |
16321 | DO 20 K=1,3 | |
16322 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) | |
16323 | 20 CONTINUE | |
16324 | * Lorentz-parameters | |
16325 | * particle rest system --> projectile rest system | |
16326 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) | |
16327 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) | |
16328 | BECAS(1) = BGCAS(1)/GACAS(1) | |
16329 | ELSE | |
16330 | DO 21 K=1,5 | |
16331 | PCAS(1,K) = ZERO | |
16332 | IF (K.LE.3) COSCAS(1,K) = ZERO | |
16333 | 21 CONTINUE | |
16334 | PTOCAS(1) = ZERO | |
16335 | BGCAS(1) = ZERO | |
16336 | GACAS(1) = ZERO | |
16337 | BECAS(1) = ZERO | |
16338 | ENDIF | |
16339 | * Lorentz-trsf. into target rest system | |
16340 | IF (IT.GT.1) THEN | |
16341 | * LEPTO: final state particles are already in target rest frame | |
16342 | C IF (MCGENE.EQ.3) THEN | |
16343 | C PCAS(2,1) = PHKK(1,IDXCAS) | |
16344 | C PCAS(2,2) = PHKK(2,IDXCAS) | |
16345 | C PCAS(2,3) = PHKK(3,IDXCAS) | |
16346 | C PCAS(2,4) = PHKK(4,IDXCAS) | |
16347 | C ELSE | |
16348 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16349 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), | |
16350 | & PCAS(2,4),IDCAS,-3) | |
16351 | C ENDIF | |
16352 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) | |
16353 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) | |
16354 | IF (PCAS(2,5).GT.ZERO) THEN | |
16355 | PCAS(2,5) = SQRT(PCAS(2,5)) | |
16356 | ELSE | |
16357 | PCAS(2,5) = AAM(IDCAS) | |
16358 | ENDIF | |
16359 | DO 22 K=1,3 | |
16360 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) | |
16361 | 22 CONTINUE | |
16362 | * Lorentz-parameters | |
16363 | * particle rest system --> target rest system | |
16364 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) | |
16365 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) | |
16366 | BECAS(2) = BGCAS(2)/GACAS(2) | |
16367 | ELSE | |
16368 | DO 23 K=1,5 | |
16369 | PCAS(2,K) = ZERO | |
16370 | IF (K.LE.3) COSCAS(2,K) = ZERO | |
16371 | 23 CONTINUE | |
16372 | PTOCAS(2) = ZERO | |
16373 | BGCAS(2) = ZERO | |
16374 | GACAS(2) = ZERO | |
16375 | BECAS(2) = ZERO | |
16376 | ENDIF | |
16377 | ||
16378 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- | |
16379 | * potential (see CONUCL) | |
16380 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM | |
16381 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM | |
16382 | * impact parameter (the projectile moving along z) | |
16383 | BIMPC(1) = ZERO | |
16384 | BIMPC(2) = BIMPAC*FM2MM | |
16385 | ||
16386 | * get position of initial hadron in projectile/target rest-syst. | |
16387 | DO 3 K=1,4 | |
16388 | VTXCAS(1,K) = WHKK(K,IDXCAS) | |
16389 | VTXCAS(2,K) = VHKK(K,IDXCAS) | |
16390 | 3 CONTINUE | |
16391 | ||
16392 | ICAS = 1 | |
16393 | I2 = 2 | |
16394 | IF (NCAS.EQ.-1) THEN | |
16395 | ICAS = 2 | |
16396 | I2 = 1 | |
16397 | ENDIF | |
16398 | ||
16399 | IF (PTOCAS(ICAS).LT.TINY10) THEN | |
16400 | WRITE(LOUT,1000) PTOCAS | |
16401 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', | |
16402 | & ' hadron ',/,20X,2E12.4) | |
16403 | GOTO 9999 | |
16404 | ENDIF | |
16405 | ||
16406 | * reset spectator flags | |
16407 | NSPE = 0 | |
16408 | IDXSPE(1) = 0 | |
16409 | IDXSPE(2) = 0 | |
16410 | IDSPE(1) = 0 | |
16411 | IDSPE(2) = 0 | |
16412 | ||
16413 | * formation length (in fm) | |
16414 | C IF (LCAS) THEN | |
16415 | C DEL0 = ZERO | |
16416 | C ELSE | |
16417 | DEL0 = TAUFOR*BGCAS(ICAS) | |
16418 | IF (ITAUVE.EQ.1) THEN | |
16419 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 | |
16420 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT | |
16421 | ENDIF | |
16422 | C ENDIF | |
16423 | * sample from exp(-del/del0) | |
16424 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) | |
16425 | * save formation time | |
16426 | TAUSA1 = DEL1/BGCAS(ICAS) | |
16427 | REL1 = TAUSA1*BGCAS(I2) | |
16428 | ||
16429 | DEL = DEL1 | |
16430 | TAUSAM = DEL/BGCAS(ICAS) | |
16431 | REL = TAUSAM*BGCAS(I2) | |
16432 | ||
16433 | * special treatment for negative particles unable to escape | |
16434 | * nuclear potential (implemented for ap, pi-, K- only) | |
16435 | LABSOR = .FALSE. | |
16436 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN | |
16437 | * threshold energy = nuclear potential + Coulomb potential | |
16438 | * (nuclear potential for hadron-nucleus interactions only) | |
16439 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) | |
16440 | IF (PCAS(ICAS,4).LT.ETHR) THEN | |
16441 | DO 4 K=1,5 | |
16442 | PCAS1(K) = PCAS(ICAS,K) | |
16443 | 4 CONTINUE | |
16444 | * "absorb" negative particle in nucleus | |
16445 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) | |
16446 | IF (IREJ1.NE.0) GOTO 9999 | |
16447 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16448 | ENDIF | |
16449 | ENDIF | |
16450 | ||
16451 | * if the initial particle has not been absorbed proceed with | |
16452 | * "normal" cascade | |
16453 | IF (.NOT.LABSOR) THEN | |
16454 | ||
16455 | * calculate coordinates of hadron at the end of the formation zone | |
16456 | * transport-time and -step in the rest system where this step is | |
16457 | * treated | |
16458 | DSTEP = DEL*FM2MM | |
16459 | DTIME = DSTEP/BECAS(ICAS) | |
16460 | RSTEP = REL*FM2MM | |
16461 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16462 | RTIME = RSTEP/BECAS(I2) | |
16463 | ELSE | |
16464 | RTIME = ZERO | |
16465 | ENDIF | |
16466 | * save step whithout considering the overlapping region | |
16467 | DSTEP1 = DEL1*FM2MM | |
16468 | DTIME1 = DSTEP1/BECAS(ICAS) | |
16469 | RSTEP1 = REL1*FM2MM | |
16470 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16471 | RTIME1 = RSTEP1/BECAS(I2) | |
16472 | ELSE | |
16473 | RTIME1 = ZERO | |
16474 | ENDIF | |
16475 | * transport to the end of the formation zone in this system | |
16476 | DO 5 K=1,3 | |
16477 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) | |
16478 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) | |
16479 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) | |
16480 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) | |
16481 | 5 CONTINUE | |
16482 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 | |
16483 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 | |
16484 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16485 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME | |
16486 | ||
16487 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16488 | XCAS = VTXCAS(ICAS,1) | |
16489 | YCAS = VTXCAS(ICAS,2) | |
16490 | XNCLTA = BIMPAC*FM2MM | |
16491 | RNCLPR = (RPROJ+RNUCLE)*FM2MM | |
16492 | RNCLTA = (RTARG+RNUCLE)*FM2MM | |
16493 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM | |
16494 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM | |
16495 | C RNCLPR = (RPROJ)*FM2MM | |
16496 | C RNCLTA = (RTARG)*FM2MM | |
16497 | RCASPR = SQRT( XCAS**2 +YCAS**2) | |
16498 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) | |
16499 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN | |
16500 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 | |
16501 | ENDIF | |
16502 | ENDIF | |
16503 | ||
16504 | * check if particle is already outside of the corresp. nucleus | |
16505 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ | |
16506 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) | |
16507 | IF (RDIST.GE.RNUC(ICAS)) THEN | |
16508 | * here: IDCH is the generation of the final state part. starting | |
16509 | * with zero for hadronization products | |
16510 | * flag particles of generation 0 being outside the nuclei after | |
16511 | * formation time (to be used for excitation energy calculation) | |
16512 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) | |
16513 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS | |
16514 | GOTO 9997 | |
16515 | ENDIF | |
16516 | DIST = DLARGE | |
16517 | DISTP = DLARGE | |
16518 | DISTN = DLARGE | |
16519 | IDXP = 0 | |
16520 | IDXN = 0 | |
16521 | ||
16522 | * already here: skip particles being outside HADRIN "energy-window" | |
16523 | * to avoid wasting of time | |
16524 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 | |
16525 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN | |
16526 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 | |
16527 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK | |
16528 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', | |
16529 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', | |
16530 | C & E12.4,', above or below HADRIN-thresholds',I6) | |
16531 | NSPE = 0 | |
16532 | GOTO 9997 | |
16533 | ENDIF | |
16534 | ||
16535 | DO 7 IDXHKK=1,NOINC | |
16536 | I = IDXINC(IDXHKK) | |
16537 | * scan DTEVT1 for unwounded or excited nucleons | |
16538 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN | |
16539 | DO 8 K=1,3 | |
16540 | IF (ICAS.EQ.1) THEN | |
16541 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) | |
16542 | ELSEIF (ICAS.EQ.2) THEN | |
16543 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) | |
16544 | ENDIF | |
16545 | 8 CONTINUE | |
16546 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ | |
16547 | & VTXDST(2)*COSCAS(ICAS,2)+ | |
16548 | & VTXDST(3)*COSCAS(ICAS,3) | |
16549 | * check if nucleon is situated in forward direction | |
16550 | IF (POSNUC.GT.ZERO) THEN | |
16551 | * distance between hadron and this nucleon | |
16552 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16553 | & VTXDST(3)**2) | |
16554 | * impact parameter | |
16555 | BIMNU2 = DISTNU**2-POSNUC**2 | |
16556 | IF (BIMNU2.LT.ZERO) THEN | |
16557 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 | |
16558 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', | |
16559 | & ' parameter ',/,20X,3E12.4) | |
16560 | GOTO 7 | |
16561 | ENDIF | |
16562 | BIMNU = SQRT(BIMNU2) | |
16563 | * maximum impact parameter to have interaction | |
16564 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16565 | IDNUC1 = IDT_MCHAD(IDNUC) | |
16566 | IDCAS1 = IDT_MCHAD(IDCAS) | |
16567 | DO 19 K=1,5 | |
16568 | PCAS1(K) = PCAS(ICAS,K) | |
16569 | PNUC(K) = PHKK(K,I) | |
16570 | 19 CONTINUE | |
16571 | * Lorentz-parameter for trafo into rest-system of target | |
16572 | DO 18 K=1,4 | |
16573 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) | |
16574 | 18 CONTINUE | |
16575 | * transformation of projectile into rest-system of target | |
16576 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
16577 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), | |
16578 | & PPTOT,PX,PY,PZ,PE) | |
16579 | ** | |
16580 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) | |
16581 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) | |
16582 | DUMZER = ZERO | |
16583 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) | |
16584 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) | |
16585 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. | |
16586 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 | |
16587 | SIGIN = SIGTOT-SIGEL-SIGAB | |
16588 | C SIGTOT = SIGIN+SIGEL+SIGAB | |
16589 | ** | |
16590 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM | |
16591 | * check if interaction is possible | |
16592 | IF (BIMNU.LE.BIMMAX) THEN | |
16593 | * get nucleon with smallest distance and kind of interaction | |
16594 | * (elastic/inelastic) | |
16595 | IF (DISTNU.LT.DIST) THEN | |
16596 | DIST = DISTNU | |
16597 | BINT = BIMNU | |
16598 | IF (IDNUC.NE.IDSPE(1)) THEN | |
16599 | IDSPE(2) = IDSPE(1) | |
16600 | IDXSPE(2) = IDXSPE(1) | |
16601 | IDSPE(1) = IDNUC | |
16602 | ENDIF | |
16603 | IDXSPE(1) = I | |
16604 | NSPE = 1 | |
16605 | **sr | |
16606 | SELA = SIGEL | |
16607 | SABS = SIGAB | |
16608 | STOT = SIGTOT | |
16609 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN | |
16610 | C SELA = SIGEL | |
16611 | C STOT = SIGIN+SIGEL | |
16612 | C ELSE | |
16613 | C SELA = SIGEL+0.75D0*SIGIN | |
16614 | C STOT = 0.25D0*SIGIN+SELA | |
16615 | C ENDIF | |
16616 | ** | |
16617 | ENDIF | |
16618 | ENDIf | |
16619 | ENDIF | |
16620 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16621 | & VTXDST(3)**2) | |
16622 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16623 | IF (IDNUC.EQ.1) THEN | |
16624 | IF (DISTNU.LT.DISTP) THEN | |
16625 | DISTP = DISTNU | |
16626 | IDXP = I | |
16627 | POSP = POSNUC | |
16628 | ENDIF | |
16629 | ELSEIF (IDNUC.EQ.8) THEN | |
16630 | IF (DISTNU.LT.DISTN) THEN | |
16631 | DISTN = DISTNU | |
16632 | IDXN = I | |
16633 | POSN = POSNUC | |
16634 | ENDIF | |
16635 | ENDIF | |
16636 | ENDIF | |
16637 | 7 CONTINUE | |
16638 | ||
16639 | * there is no nucleon for a secondary interaction | |
16640 | IF (NSPE.EQ.0) GOTO 9997 | |
16641 | ||
16642 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) | |
16643 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE | |
16644 | IF (IDXSPE(2).EQ.0) THEN | |
16645 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN | |
16646 | C DO 80 K=1,3 | |
16647 | C IF (ICAS.EQ.1) THEN | |
16648 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) | |
16649 | C ELSEIF (ICAS.EQ.2) THEN | |
16650 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) | |
16651 | C ENDIF | |
16652 | C 80 CONTINUE | |
16653 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16654 | C & VTXDST(3)**2) | |
16655 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN | |
16656 | IDXSPE(2) = IDXN | |
16657 | IDSPE(2) = 8 | |
16658 | C ELSE | |
16659 | C STOT = STOT-SABS | |
16660 | C SABS = ZERO | |
16661 | C ENDIF | |
16662 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN | |
16663 | C DO 81 K=1,3 | |
16664 | C IF (ICAS.EQ.1) THEN | |
16665 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) | |
16666 | C ELSEIF (ICAS.EQ.2) THEN | |
16667 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) | |
16668 | C ENDIF | |
16669 | C 81 CONTINUE | |
16670 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16671 | C & VTXDST(3)**2) | |
16672 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN | |
16673 | IDXSPE(2) = IDXP | |
16674 | IDSPE(2) = 1 | |
16675 | C ELSE | |
16676 | C STOT = STOT-SABS | |
16677 | C SABS = ZERO | |
16678 | C ENDIF | |
16679 | ELSE | |
16680 | STOT = STOT-SABS | |
16681 | SABS = ZERO | |
16682 | ENDIF | |
16683 | ENDIF | |
16684 | RR = DT_RNDM(DIST) | |
16685 | IF (RR.LT.SELA/STOT) THEN | |
16686 | IPROC = 2 | |
16687 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN | |
16688 | IPROC = 3 | |
16689 | ELSE | |
16690 | IPROC = 1 | |
16691 | ENDIF | |
16692 | ||
16693 | DO 9 K=1,5 | |
16694 | PCAS1(K) = PCAS(ICAS,K) | |
16695 | PNUC(K) = PHKK(K,IDXSPE(1)) | |
16696 | 9 CONTINUE | |
16697 | IF (IPROC.EQ.3) THEN | |
16698 | * 2-nucleon absorption of pion | |
16699 | NSPE = 2 | |
16700 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) | |
16701 | IF (IREJ1.NE.0) GOTO 9999 | |
16702 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16703 | ELSE | |
16704 | * sample secondary interaction | |
16705 | IDNUC = IDBAM(IDXSPE(1)) | |
16706 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) | |
16707 | IF (IREJ1.EQ.1) GOTO 9999 | |
16708 | IF (IREJ1.GT.1) GOTO 9998 | |
16709 | ENDIF | |
16710 | ENDIF | |
16711 | ||
16712 | * update arrays to include Pauli-principle | |
16713 | DO 10 I=1,NSPE | |
16714 | IF (NWOUND(ICAS).LE.299) THEN | |
16715 | NWOUND(ICAS) = NWOUND(ICAS)+1 | |
16716 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) | |
16717 | ENDIF | |
16718 | 10 CONTINUE | |
16719 | ||
16720 | * dump initial hadron for energy-momentum conservation check | |
16721 | IF (LEMCCK) | |
16722 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), | |
16723 | & PCAS(ICAS,4),1,IDUM,IDUM) | |
16724 | ||
16725 | * dump final state particles into DTEVT1 | |
16726 | ||
16727 | * check if Pauli-principle is fulfilled | |
16728 | NPAULI = 0 | |
16729 | NWTMP(1) = NWOUND(1) | |
16730 | NWTMP(2) = NWOUND(2) | |
16731 | DO 111 I=1,NFSP | |
16732 | NPAULI = 0 | |
16733 | J1 = 2 | |
16734 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16735 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16736 | DO 117 J=1,J1 | |
16737 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 | |
16738 | IF (J.EQ.1) THEN | |
16739 | IDX = ICAS | |
16740 | PE = PFSP(4,I) | |
16741 | ELSE | |
16742 | IDX = I2 | |
16743 | MODE = 1 | |
16744 | IF (IDX.EQ.1) MODE = -1 | |
16745 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) | |
16746 | ENDIF | |
16747 | * first check if cascade step is forbidden due to Pauli-principle | |
16748 | * (in case of absorpion this step is forced) | |
16749 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16750 | & (IDFSP(I).EQ.8))) THEN | |
16751 | * get nuclear potential barrier | |
16752 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16753 | IF (IDFSP(I).EQ.1) THEN | |
16754 | POTLOW = POT-EBINDP(IDX) | |
16755 | ELSE | |
16756 | POTLOW = POT-EBINDN(IDX) | |
16757 | ENDIF | |
16758 | * final state particle not able to escape nucleus | |
16759 | IF (PE.LE.POTLOW) THEN | |
16760 | * check if there are wounded nucleons | |
16761 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16762 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16763 | NPAULI = NPAULI+1 | |
16764 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16765 | ELSE | |
16766 | * interaction prohibited by Pauli-principle | |
16767 | NWOUND(1) = NWTMP(1) | |
16768 | NWOUND(2) = NWTMP(2) | |
16769 | GOTO 9997 | |
16770 | ENDIF | |
16771 | ENDIF | |
16772 | ENDIF | |
16773 | 117 CONTINUE | |
16774 | 111 CONTINUE | |
16775 | ||
16776 | NPAULI = 0 | |
16777 | NWOUND(1) = NWTMP(1) | |
16778 | NWOUND(2) = NWTMP(2) | |
16779 | ||
16780 | DO 11 I=1,NFSP | |
16781 | ||
16782 | IST = ISTHKK(IDXCAS) | |
16783 | ||
16784 | NPAULI = 0 | |
16785 | J1 = 2 | |
16786 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16787 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16788 | DO 17 J=1,J1 | |
16789 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 | |
16790 | IDX = ICAS | |
16791 | PE = PFSP(4,I) | |
16792 | IF (J.EQ.2) THEN | |
16793 | IDX = I2 | |
16794 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) | |
16795 | ENDIF | |
16796 | * first check if cascade step is forbidden due to Pauli-principle | |
16797 | * (in case of absorpion this step is forced) | |
16798 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16799 | & (IDFSP(I).EQ.8))) THEN | |
16800 | * get nuclear potential barrier | |
16801 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16802 | IF (IDFSP(I).EQ.1) THEN | |
16803 | POTLOW = POT-EBINDP(IDX) | |
16804 | ELSE | |
16805 | POTLOW = POT-EBINDN(IDX) | |
16806 | ENDIF | |
16807 | * final state particle not able to escape nucleus | |
16808 | IF (PE.LE.POTLOW) THEN | |
16809 | * check if there are wounded nucleons | |
16810 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16811 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16812 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16813 | NPAULI = NPAULI+1 | |
16814 | IST = 14+IDX | |
16815 | ELSE | |
16816 | * interaction prohibited by Pauli-principle | |
16817 | NWOUND(1) = NWTMP(1) | |
16818 | NWOUND(2) = NWTMP(2) | |
16819 | GOTO 9997 | |
16820 | ENDIF | |
16821 | **sr | |
16822 | c ELSEIF (PE.LE.POT) THEN | |
16823 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN | |
16824 | cC NWOUND(IDX) = NWOUND(IDX)-1 | |
16825 | c** | |
16826 | c NPAULI = NPAULI+1 | |
16827 | c IST = 14+IDX | |
16828 | ENDIF | |
16829 | ENDIF | |
16830 | 17 CONTINUE | |
16831 | ||
16832 | * dump final state particles for energy-momentum conservation check | |
16833 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), | |
16834 | & -PFSP(4,I),2,IDUM,IDUM) | |
16835 | ||
16836 | PX = PFSP(1,I) | |
16837 | PY = PFSP(2,I) | |
16838 | PZ = PFSP(3,I) | |
16839 | PE = PFSP(4,I) | |
16840 | IF (ABS(IST).EQ.1) THEN | |
16841 | * transform particles back into n-n cms | |
16842 | * LEPTO: leave final state particles in target rest frame | |
16843 | C IF (MCGENE.EQ.3) THEN | |
16844 | C PFSP(1,I) = PX | |
16845 | C PFSP(2,I) = PY | |
16846 | C PFSP(3,I) = PZ | |
16847 | C PFSP(4,I) = PE | |
16848 | C ELSE | |
16849 | IMODE = ICAS+1 | |
16850 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16851 | & PFSP(4,I),IDFSP(I),IMODE) | |
16852 | C ENDIF | |
16853 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN | |
16854 | * target cascade but fsp got stuck in proj. --> transform it into | |
16855 | * proj. rest system | |
16856 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16857 | & PFSP(4,I),IDFSP(I),-1) | |
16858 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN | |
16859 | * proj. cascade but fsp got stuck in target --> transform it into | |
16860 | * target rest system | |
16861 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16862 | & PFSP(4,I),IDFSP(I),1) | |
16863 | ENDIF | |
16864 | ||
16865 | * dump final state particles into DTEVT1 | |
16866 | IGEN = IDCH(IDXCAS)+1 | |
16867 | ID = IDT_IPDGHA(IDFSP(I)) | |
16868 | IXR = 0 | |
16869 | IF (LABSOR) IXR = 99 | |
16870 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), | |
16871 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) | |
16872 | ||
16873 | * update the counter for particles which got stuck inside the nucleus | |
16874 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN | |
16875 | NOINC = NOINC+1 | |
16876 | IDXINC(NOINC) = NHKK | |
16877 | ENDIF | |
16878 | IF (LABSOR) THEN | |
16879 | * in case of absorption the spatial treatment is an approximate | |
16880 | * solution anyway (the positions of the nucleons which "absorb" the | |
16881 | * cascade particle are not taken into consideration) therefore the | |
16882 | * particles are produced at the position of the cascade particle | |
16883 | DO 12 K=1,4 | |
16884 | WHKK(K,NHKK) = WHKK(K,IDXCAS) | |
16885 | VHKK(K,NHKK) = VHKK(K,IDXCAS) | |
16886 | 12 CONTINUE | |
16887 | ELSE | |
16888 | * DDISTL - distance the cascade particle moves to the intera. point | |
16889 | * (the position where impact-parameter = distance to the interacting | |
16890 | * nucleon), DIST - distance to the interacting nucleon at the time of | |
16891 | * formation of the cascade particle, BINT - impact-parameter of this | |
16892 | * cascade-interaction | |
16893 | DDISTL = SQRT(DIST**2-BINT**2) | |
16894 | DTIME = DDISTL/BECAS(ICAS) | |
16895 | DTIMEL = DDISTL/BGCAS(ICAS) | |
16896 | RDISTL = DTIMEL*BGCAS(I2) | |
16897 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16898 | RTIME = RDISTL/BECAS(I2) | |
16899 | ELSE | |
16900 | RTIME = ZERO | |
16901 | ENDIF | |
16902 | * RDISTL, RTIME are this step and time in the rest system of the other | |
16903 | * nucleus | |
16904 | DO 13 K=1,3 | |
16905 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL | |
16906 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL | |
16907 | 13 CONTINUE | |
16908 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16909 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME | |
16910 | * position of particle production is half the impact-parameter to | |
16911 | * the interacting nucleon | |
16912 | DO 14 K=1,3 | |
16913 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) | |
16914 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) | |
16915 | 14 CONTINUE | |
16916 | * time of production of secondary = time of interaction | |
16917 | WHKK(4,NHKK) = VTXCA1(1,4) | |
16918 | VHKK(4,NHKK) = VTXCA1(2,4) | |
16919 | ENDIF | |
16920 | ||
16921 | 11 CONTINUE | |
16922 | ||
16923 | * modify status and position of cascade particle (the latter for | |
16924 | * statistics reasons only) | |
16925 | ISTHKK(IDXCAS) = 2 | |
16926 | IF (LABSOR) ISTHKK(IDXCAS) = 19 | |
16927 | IF (.NOT.LABSOR) THEN | |
16928 | DO 15 K=1,4 | |
16929 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16930 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16931 | 15 CONTINUE | |
16932 | ENDIF | |
16933 | ||
16934 | DO 16 I=1,NSPE | |
16935 | IS = IDXSPE(I) | |
16936 | * dump interacting nucleons for energy-momentum conservation check | |
16937 | IF (LEMCCK) | |
16938 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), | |
16939 | & 2,IDUM,IDUM) | |
16940 | * modify entry for interacting nucleons | |
16941 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS | |
16942 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 | |
16943 | IF (I.GE.2) THEN | |
16944 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) | |
16945 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) | |
16946 | ENDIF | |
16947 | 16 CONTINUE | |
16948 | ||
16949 | * check energy-momentum conservation | |
16950 | IF (LEMCCK) THEN | |
16951 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) | |
16952 | IF (IREJ1.NE.0) GOTO 9999 | |
16953 | ENDIF | |
16954 | ||
16955 | * update counter | |
16956 | IF (LABSOR) THEN | |
16957 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 | |
16958 | ELSE | |
16959 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 | |
16960 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 | |
16961 | ENDIF | |
16962 | ||
16963 | RETURN | |
16964 | ||
16965 | 9997 CONTINUE | |
16966 | 9998 CONTINUE | |
16967 | * transport-step but no cascade step due to configuration (i.e. there | |
16968 | * is no nucleon for interaction etc.) | |
16969 | IF (LCAS) THEN | |
16970 | DO 100 K=1,4 | |
16971 | C WHKK(K,IDXCAS) = VTXCAS(1,K) | |
16972 | C VHKK(K,IDXCAS) = VTXCAS(2,K) | |
16973 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16974 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16975 | 100 CONTINUE | |
16976 | ENDIF | |
16977 | ||
16978 | C9998 CONTINUE | |
16979 | * no cascade-step because of configuration | |
16980 | * (i.e. hadron outside nucleus etc.) | |
16981 | LCAS = .TRUE. | |
16982 | RETURN | |
16983 | ||
16984 | 9999 CONTINUE | |
16985 | * rejection | |
16986 | IREJ = 1 | |
16987 | RETURN | |
16988 | END | |
16989 | ||
16990 | *$ CREATE DT_ABSORP.FOR | |
16991 | *COPY DT_ABSORP | |
16992 | * | |
16993 | *===absorp=============================================================* | |
16994 | * | |
16995 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) | |
16996 | ||
16997 | ************************************************************************ | |
16998 | * Two-nucleon absorption of antiprotons, pi-, and K-. * | |
16999 | * Antiproton absorption is handled by HADRIN. * | |
17000 | * The following channels for meson-absorption are considered: * | |
17001 | * pi- + p + p ---> n + p * | |
17002 | * pi- + p + n ---> n + n * | |
17003 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * | |
17004 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * | |
17005 | * K- + p + p ---> sigma- + n * | |
17006 | * IDCAS, PCAS identity, momentum of particle to be absorbed * | |
17007 | * NCAS = 1 intranuclear cascade in projectile * | |
17008 | * = -1 intranuclear cascade in target * | |
17009 | * NSPE number of spectator nucleons involved * | |
17010 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * | |
17011 | * Revised version of the original STOPIK written by HJM and J. Ranft. * | |
17012 | * This version dated 24.02.95 is written by S. Roesler * | |
17013 | ************************************************************************ | |
17014 | ||
17015 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17016 | SAVE | |
17017 | PARAMETER ( LINP = 10 , | |
17018 | & LOUT = 6 , | |
17019 | & LDAT = 9 ) | |
17020 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, | |
17021 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) | |
17022 | ||
17023 | * event history | |
17024 | PARAMETER (NMXHKK=200000) | |
17025 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17026 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17027 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17028 | * extended event history | |
17029 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17030 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17031 | & IHIST(2,NMXHKK) | |
17032 | * flags for input different options | |
17033 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17034 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17035 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17036 | * final state after inc step | |
17037 | PARAMETER (MAXFSP=10) | |
17038 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17039 | * particle properties (BAMJET index convention) | |
17040 | CHARACTER*8 ANAME | |
17041 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17042 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17043 | ||
17044 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), | |
17045 | & PTOT3P(4),BG3P(4), | |
17046 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) | |
17047 | ||
17048 | IREJ = 0 | |
17049 | NFSP = 0 | |
17050 | ||
17051 | * skip particles others than ap, pi-, K- for mode=0 | |
17052 | IF ((MODE.EQ.0).AND. | |
17053 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN | |
17054 | * skip particles others than pions for mode=1 | |
17055 | * (2-nucleon absorption in intranuclear cascade) | |
17056 | IF ((MODE.EQ.1).AND. | |
17057 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN | |
17058 | ||
17059 | NUCAS = NCAS | |
17060 | IF (NUCAS.EQ.-1) NUCAS = 2 | |
17061 | ||
17062 | IF (MODE.EQ.0) THEN | |
17063 | * scan spectator nucleons for nucleons being able to "absorb" | |
17064 | NSPE = 0 | |
17065 | IDXSPE(1) = 0 | |
17066 | IDXSPE(2) = 0 | |
17067 | DO 1 I=1,NHKK | |
17068 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN | |
17069 | NSPE = NSPE+1 | |
17070 | IDXSPE(NSPE) = I | |
17071 | IDSPE(NSPE) = IDBAM(I) | |
17072 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 | |
17073 | IF (NSPE.EQ.2) THEN | |
17074 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. | |
17075 | & (IDSPE(2).EQ.8)) THEN | |
17076 | * there is no pi-+n+n channel | |
17077 | NSPE = 1 | |
17078 | GOTO 1 | |
17079 | ELSE | |
17080 | GOTO 2 | |
17081 | ENDIF | |
17082 | ENDIF | |
17083 | ENDIF | |
17084 | 1 CONTINUE | |
17085 | ||
17086 | 2 CONTINUE | |
17087 | ENDIF | |
17088 | * transform excited projectile nucleons (status=15) into proj. rest s. | |
17089 | DO 3 I=1,NSPE | |
17090 | DO 4 K=1,5 | |
17091 | PSPE(I,K) = PHKK(K,IDXSPE(I)) | |
17092 | 4 CONTINUE | |
17093 | 3 CONTINUE | |
17094 | ||
17095 | * antiproton absorption | |
17096 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN | |
17097 | DO 5 K=1,5 | |
17098 | PSPE1(K) = PSPE(1,K) | |
17099 | 5 CONTINUE | |
17100 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) | |
17101 | IF (IREJ1.NE.0) GOTO 9999 | |
17102 | ||
17103 | * meson absorption | |
17104 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) | |
17105 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN | |
17106 | IF (IDCAS.EQ.14) THEN | |
17107 | * pi- absorption | |
17108 | IDFSP(1) = 8 | |
17109 | IDFSP(2) = 8 | |
17110 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 | |
17111 | ELSEIF (IDCAS.EQ.13) THEN | |
17112 | * pi+ absorption | |
17113 | IDFSP(1) = 1 | |
17114 | IDFSP(2) = 1 | |
17115 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 | |
17116 | ELSEIF (IDCAS.EQ.23) THEN | |
17117 | * pi0 absorption | |
17118 | IDFSP(1) = IDSPE(1) | |
17119 | IDFSP(2) = IDSPE(2) | |
17120 | ELSEIF (IDCAS.EQ.16) THEN | |
17121 | * K- absorption | |
17122 | R = DT_RNDM(PCAS) | |
17123 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN | |
17124 | IF (R.LT.ONETHI) THEN | |
17125 | IDFSP(1) = 21 | |
17126 | IDFSP(2) = 8 | |
17127 | ELSEIF (R.LT.TWOTHI) THEN | |
17128 | IDFSP(1) = 17 | |
17129 | IDFSP(2) = 1 | |
17130 | ELSE | |
17131 | IDFSP(1) = 22 | |
17132 | IDFSP(2) = 1 | |
17133 | ENDIF | |
17134 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN | |
17135 | IDFSP(1) = 20 | |
17136 | IDFSP(2) = 8 | |
17137 | ELSE | |
17138 | IF (R.LT.ONETHI) THEN | |
17139 | IDFSP(1) = 20 | |
17140 | IDFSP(2) = 1 | |
17141 | ELSEIF (R.LT.TWOTHI) THEN | |
17142 | IDFSP(1) = 17 | |
17143 | IDFSP(2) = 8 | |
17144 | ELSE | |
17145 | IDFSP(1) = 22 | |
17146 | IDFSP(2) = 8 | |
17147 | ENDIF | |
17148 | ENDIF | |
17149 | ENDIF | |
17150 | * dump initial particles for energy-momentum cons. check | |
17151 | IF (LEMCCK) THEN | |
17152 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) | |
17153 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, | |
17154 | & IDUM,IDUM) | |
17155 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, | |
17156 | & IDUM,IDUM) | |
17157 | ENDIF | |
17158 | * get Lorentz-parameter of 3 particle initial state | |
17159 | DO 6 K=1,4 | |
17160 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) | |
17161 | 6 CONTINUE | |
17162 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) | |
17163 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) | |
17164 | DO 7 K=1,4 | |
17165 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) | |
17166 | 7 CONTINUE | |
17167 | * 2-particle decay of the 3-particle compound system | |
17168 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), | |
17169 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
17170 | & AAM(IDFSP(1)),AAM(IDFSP(2))) | |
17171 | DO 8 I=1,2 | |
17172 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) | |
17173 | PX = PCMF(I)*COFF(I)*SDF | |
17174 | PY = PCMF(I)*SIFF(I)*SDF | |
17175 | PZ = PCMF(I)*CODF(I) | |
17176 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, | |
17177 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17178 | & PFSP(4,I)) | |
17179 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) | |
17180 | * check consistency of kinematics | |
17181 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN | |
17182 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) | |
17183 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', | |
17184 | & ' tree-particle kinematics',/,20X,'id: ',I3, | |
17185 | & ' AAM = ',E10.4,' MFSP = ',E10.4) | |
17186 | ENDIF | |
17187 | * dump final state particles for energy-momentum cons. check | |
17188 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17189 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17190 | 8 CONTINUE | |
17191 | NFSP = 2 | |
17192 | IF (LEMCCK) THEN | |
17193 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) | |
17194 | IF (IREJ1.NE.0) THEN | |
17195 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), | |
17196 | & AM3P | |
17197 | GOTO 9999 | |
17198 | ENDIF | |
17199 | ENDIF | |
17200 | ELSE | |
17201 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE | |
17202 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, | |
17203 | & ' impossible',/,20X,'too few spectators (',I2,')') | |
17204 | NSPE = 0 | |
17205 | ENDIF | |
17206 | ||
17207 | RETURN | |
17208 | ||
17209 | 9999 CONTINUE | |
17210 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' | |
17211 | IREJ = 1 | |
17212 | RETURN | |
17213 | END | |
17214 | ||
17215 | *$ CREATE DT_HADRIN.FOR | |
17216 | *COPY DT_HADRIN | |
17217 | * | |
17218 | *===hadrin=============================================================* | |
17219 | * | |
17220 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) | |
17221 | ||
17222 | ************************************************************************ | |
17223 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17224 | * scattering. * | |
17225 | * IDPR,PPR(5) identity, momentum of projectile * | |
17226 | * IDTA,PTA(5) identity, momentum of target * | |
17227 | * MODE = 1 inelastic interaction * | |
17228 | * = 2 elastic interaction * | |
17229 | * Revised version of the original FHAD. * | |
17230 | * This version dated 27.10.95 is written by S. Roesler * | |
17231 | ************************************************************************ | |
17232 | ||
17233 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17234 | SAVE | |
17235 | PARAMETER ( LINP = 10 , | |
17236 | & LOUT = 6 , | |
17237 | & LDAT = 9 ) | |
17238 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, | |
17239 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) | |
17240 | ||
17241 | LOGICAL LCORR,LMSSG | |
17242 | ||
17243 | * flags for input different options | |
17244 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17245 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17246 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17247 | * final state after inc step | |
17248 | PARAMETER (MAXFSP=10) | |
17249 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17250 | * particle properties (BAMJET index convention) | |
17251 | CHARACTER*8 ANAME | |
17252 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17253 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17254 | * output-common for DHADRI/ELHAIN | |
17255 | * final state from HADRIN interaction | |
17256 | PARAMETER (MAXFIN=10) | |
17257 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
17258 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
17259 | ||
17260 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), | |
17261 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) | |
17262 | ||
17263 | DATA LMSSG /.TRUE./ | |
17264 | ||
17265 | IREJ = 0 | |
17266 | NFSP = 0 | |
17267 | KCORR = 0 | |
17268 | IMCORR(1) = 0 | |
17269 | IMCORR(2) = 0 | |
17270 | LCORR = .FALSE. | |
17271 | ||
17272 | * dump initial particles for energy-momentum cons. check | |
17273 | IF (LEMCCK) THEN | |
17274 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) | |
17275 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) | |
17276 | ENDIF | |
17277 | ||
17278 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 | |
17279 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 | |
17280 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. | |
17281 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. | |
17282 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN | |
17283 | IF (LMSSG.AND.(IOULEV(3).GT.0)) | |
17284 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 | |
17285 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', | |
17286 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', | |
17287 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) | |
17288 | LMSSG = .FALSE. | |
17289 | LCORR = .TRUE. | |
17290 | ENDIF | |
17291 | ||
17292 | * convert initial state particles into particles which can be | |
17293 | * handled by HADRIN | |
17294 | IDHPR = IDPR | |
17295 | IDHTA = IDTA | |
17296 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN | |
17297 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 | |
17298 | DO 1 K=1,4 | |
17299 | P1IN(K) = PPR(K) | |
17300 | P2IN(K) = PTA(K) | |
17301 | 1 CONTINUE | |
17302 | XM1 = AAM(IDHPR) | |
17303 | XM2 = AAM(IDHTA) | |
17304 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17305 | IF (IREJ1.GT.0) THEN | |
17306 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17307 | GOTO 9999 | |
17308 | ENDIF | |
17309 | DO 2 K=1,4 | |
17310 | PPR(K) = P1OUT(K) | |
17311 | PTA(K) = P2OUT(K) | |
17312 | 2 CONTINUE | |
17313 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) | |
17314 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) | |
17315 | ENDIF | |
17316 | ||
17317 | * Lorentz-parameter for trafo into rest-system of target | |
17318 | DO 3 K=1,4 | |
17319 | BGTA(K) = PTA(K)/PTA(5) | |
17320 | 3 CONTINUE | |
17321 | * transformation of projectile into rest-system of target | |
17322 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), | |
17323 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), | |
17324 | & PPR1(4)) | |
17325 | ||
17326 | * direction cosines of projectile in target rest system | |
17327 | CX = PPR1(1)/PPRTO1 | |
17328 | CY = PPR1(2)/PPRTO1 | |
17329 | CZ = PPR1(3)/PPRTO1 | |
17330 | ||
17331 | * sample inelastic interaction | |
17332 | IF (MODE.EQ.1) THEN | |
17333 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) | |
17334 | IF (IRH.EQ.1) GOTO 9998 | |
17335 | * sample elastic interaction | |
17336 | ELSEIF (MODE.EQ.2) THEN | |
17337 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) | |
17338 | IF (IREJ1.NE.0) THEN | |
17339 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' | |
17340 | GOTO 9999 | |
17341 | ENDIF | |
17342 | IF (IRH.EQ.1) GOTO 9998 | |
17343 | ELSE | |
17344 | WRITE(LOUT,1001) MODE,INTHAD | |
17345 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', | |
17346 | & I4,' (INTHAD =',I4,')') | |
17347 | GOTO 9999 | |
17348 | ENDIF | |
17349 | ||
17350 | * transform final state particles back into Lab. | |
17351 | DO 4 I=1,IRH | |
17352 | NFSP = NFSP+1 | |
17353 | PX = CXRH(I)*PLRH(I) | |
17354 | PY = CYRH(I)*PLRH(I) | |
17355 | PZ = CZRH(I)*PLRH(I) | |
17356 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), | |
17357 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), | |
17358 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) | |
17359 | IDFSP(NFSP) = ITRH(I) | |
17360 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- | |
17361 | & PFSP(3,NFSP)**2 | |
17362 | IF (AMFSP2.LT.-TINY3) THEN | |
17363 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), | |
17364 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 | |
17365 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', | |
17366 | & I2,') with negative mass^2',/,1X,5E12.4) | |
17367 | GOTO 9999 | |
17368 | ELSE | |
17369 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) | |
17370 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN | |
17371 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), | |
17372 | & PFSP(5,NFSP) | |
17373 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', | |
17374 | & ' (id = ',I2,') with inconsistent mass',/,1X, | |
17375 | & 2E12.4) | |
17376 | KCORR = KCORR+1 | |
17377 | IF (KCORR.GT.2) GOTO 9999 | |
17378 | IMCORR(KCORR) = NFSP | |
17379 | ENDIF | |
17380 | ENDIF | |
17381 | * dump final state particles for energy-momentum cons. check | |
17382 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17383 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17384 | 4 CONTINUE | |
17385 | ||
17386 | * transform momenta on mass shell in case of inconsistencies in | |
17387 | * HADRIN | |
17388 | IF (KCORR.GT.0) THEN | |
17389 | IF (KCORR.EQ.2) THEN | |
17390 | I1 = IMCORR(1) | |
17391 | I2 = IMCORR(2) | |
17392 | ELSE | |
17393 | IF (IMCORR(1).EQ.1) THEN | |
17394 | I1 = 1 | |
17395 | I2 = 2 | |
17396 | ELSE | |
17397 | I1 = 1 | |
17398 | I2 = IMCORR(1) | |
17399 | ENDIF | |
17400 | ENDIF | |
17401 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), | |
17402 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) | |
17403 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), | |
17404 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) | |
17405 | DO 5 K=1,4 | |
17406 | P1IN(K) = PFSP(K,I1) | |
17407 | P2IN(K) = PFSP(K,I2) | |
17408 | 5 CONTINUE | |
17409 | XM1 = AAM(IDFSP(I1)) | |
17410 | XM2 = AAM(IDFSP(I2)) | |
17411 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17412 | IF (IREJ1.GT.0) THEN | |
17413 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17414 | C GOTO 9999 | |
17415 | ENDIF | |
17416 | DO 6 K=1,4 | |
17417 | PFSP(K,I1) = P1OUT(K) | |
17418 | PFSP(K,I2) = P2OUT(K) | |
17419 | 6 CONTINUE | |
17420 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 | |
17421 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) | |
17422 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 | |
17423 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) | |
17424 | * dump final state particles for energy-momentum cons. check | |
17425 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), | |
17426 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) | |
17427 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), | |
17428 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) | |
17429 | ENDIF | |
17430 | ||
17431 | * check energy-momentum conservation | |
17432 | IF (LEMCCK) THEN | |
17433 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) | |
17434 | IF (IREJ1.NE.0) GOTO 9999 | |
17435 | ENDIF | |
17436 | ||
17437 | RETURN | |
17438 | ||
17439 | 9998 CONTINUE | |
17440 | IREJ = 2 | |
17441 | RETURN | |
17442 | ||
17443 | 9999 CONTINUE | |
17444 | IREJ = 1 | |
17445 | RETURN | |
17446 | END | |
17447 | ||
17448 | *$ CREATE DT_HADCOL.FOR | |
17449 | *COPY DT_HADCOL | |
17450 | * | |
17451 | *===hadcol=============================================================* | |
17452 | * | |
17453 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) | |
17454 | ||
17455 | ************************************************************************ | |
17456 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17457 | * scattering. This subroutine samples hadron-nucleus interactions * | |
17458 | * below DPM-threshold. * | |
17459 | * IDPROJ BAMJET-index of projectile hadron * | |
17460 | * PPN projectile momentum in target rest frame * | |
17461 | * IDXTAR DTEVT1-index of target nucleon undergoing * | |
17462 | * interaction with projectile hadron * | |
17463 | * This subroutine replaces HADHAD. * | |
17464 | * This version dated 5.5.95 is written by S. Roesler * | |
17465 | ************************************************************************ | |
17466 | ||
17467 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17468 | SAVE | |
17469 | PARAMETER ( LINP = 10 , | |
17470 | & LOUT = 6 , | |
17471 | & LDAT = 9 ) | |
17472 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) | |
17473 | ||
17474 | LOGICAL LSTART | |
17475 | ||
17476 | * event history | |
17477 | PARAMETER (NMXHKK=200000) | |
17478 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17479 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17480 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17481 | * extended event history | |
17482 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17483 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17484 | & IHIST(2,NMXHKK) | |
17485 | * nuclear potential | |
17486 | LOGICAL LFERMI | |
17487 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17488 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17489 | & ETACOU(2),ICOUL,LFERMI | |
17490 | * interface HADRIN-DPM | |
17491 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
17492 | * parameter for intranuclear cascade | |
17493 | LOGICAL LPAULI | |
17494 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
17495 | * final state after inc step | |
17496 | PARAMETER (MAXFSP=10) | |
17497 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17498 | * particle properties (BAMJET index convention) | |
17499 | CHARACTER*8 ANAME | |
17500 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17501 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17502 | ||
17503 | DIMENSION PPROJ(5),PNUC(5) | |
17504 | ||
17505 | DATA LSTART /.TRUE./ | |
17506 | ||
17507 | IREJ = 0 | |
17508 | ||
17509 | NPOINT(1) = NHKK+1 | |
17510 | ||
17511 | TAUSAV = TAUFOR | |
17512 | **sr 6/9/01 commented | |
17513 | C TAUFOR = TAUFOR/2.0D0 | |
17514 | ** | |
17515 | IF (LSTART) THEN | |
17516 | WRITE(LOUT,1000) | |
17517 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') | |
17518 | WRITE(LOUT,1001) TAUFOR | |
17519 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', | |
17520 | & F5.1,' fm/c') | |
17521 | LSTART = .FALSE. | |
17522 | ENDIF | |
17523 | ||
17524 | IDNUC = IDBAM(IDXTAR) | |
17525 | IDNUC1 = IDT_MCHAD(IDNUC) | |
17526 | IDPRO1 = IDT_MCHAD(IDPROJ) | |
17527 | ||
17528 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN | |
17529 | IPROC = INTHAD | |
17530 | ELSE | |
17531 | ** | |
17532 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) | |
17533 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) | |
17534 | DUMZER = ZERO | |
17535 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) | |
17536 | SIGIN = SIGTOT-SIGEL | |
17537 | C SIGTOT = SIGIN+SIGEL | |
17538 | ** | |
17539 | IPROC = 1 | |
17540 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 | |
17541 | ENDIF | |
17542 | ||
17543 | PPROJ(1) = ZERO | |
17544 | PPROJ(2) = ZERO | |
17545 | PPROJ(3) = PPN | |
17546 | PPROJ(5) = AAM(IDPROJ) | |
17547 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) | |
17548 | DO 1 K=1,5 | |
17549 | PNUC(K) = PHKK(K,IDXTAR) | |
17550 | 1 CONTINUE | |
17551 | ||
17552 | ILOOP = 0 | |
17553 | 2 CONTINUE | |
17554 | ILOOP = ILOOP+1 | |
17555 | IF (ILOOP.GT.100) GOTO 9999 | |
17556 | ||
17557 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) | |
17558 | IF (IREJ1.EQ.1) GOTO 9999 | |
17559 | ||
17560 | IF (IREJ1.GT.1) THEN | |
17561 | * no interaction possible | |
17562 | * require Pauli blocking | |
17563 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 | |
17564 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 | |
17565 | IF ((IIBAR(IDPROJ).NE.1).AND. | |
17566 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 | |
17567 | * store incoming particle as final state particle | |
17568 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) | |
17569 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) | |
17570 | NPOINT(4) = NHKK | |
17571 | ELSE | |
17572 | * require Pauli blocking for final state nucleons | |
17573 | DO 4 I=1,NFSP | |
17574 | IF ((IDFSP(I).EQ.1).AND. | |
17575 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 | |
17576 | IF ((IDFSP(I).EQ.8).AND. | |
17577 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 | |
17578 | IF ((IIBAR(IDFSP(I)).NE.1).AND. | |
17579 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 | |
17580 | 4 CONTINUE | |
17581 | * store final state particles | |
17582 | DO 5 I=1,NFSP | |
17583 | IST = 1 | |
17584 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. | |
17585 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 | |
17586 | IDHAD = IDT_IPDGHA(IDFSP(I)) | |
17587 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) | |
17588 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), | |
17589 | & PCMS,ECMS,0,0,0) | |
17590 | IF (I.EQ.1) NPOINT(4) = NHKK | |
17591 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) | |
17592 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) | |
17593 | VHKK(3,NHKK) = VHKK(3,IDXTAR) | |
17594 | VHKK(4,NHKK) = VHKK(4,IDXTAR) | |
17595 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) | |
17596 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) | |
17597 | WHKK(3,NHKK) = WHKK(3,1) | |
17598 | WHKK(4,NHKK) = WHKK(4,1) | |
17599 | 5 CONTINUE | |
17600 | ENDIF | |
17601 | TAUFOR = TAUSAV | |
17602 | RETURN | |
17603 | ||
17604 | 9999 CONTINUE | |
17605 | IREJ = 1 | |
17606 | TAUFOR = TAUSAV | |
17607 | RETURN | |
17608 | END | |
17609 | ||
17610 | *$ CREATE DT_GETEMU.FOR | |
17611 | *COPY DT_GETEMU | |
17612 | * | |
17613 | *===getemu=============================================================* | |
17614 | * | |
17615 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) | |
17616 | ||
17617 | ************************************************************************ | |
17618 | * Sampling of emulsion component to be considered as target-nucleus. * | |
17619 | * This version dated 6.5.95 is written by S. Roesler. * | |
17620 | ************************************************************************ | |
17621 | ||
17622 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17623 | SAVE | |
17624 | PARAMETER ( LINP = 10 , | |
17625 | & LOUT = 6 , | |
17626 | & LDAT = 9 ) | |
17627 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
17628 | ||
17629 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
17630 | * emulsion treatment | |
17631 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
17632 | & NCOMPO,IEMUL | |
17633 | * Glauber formalism: flags and parameters for statistics | |
17634 | LOGICAL LPROD | |
17635 | CHARACTER*8 CGLB | |
17636 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
17637 | ||
17638 | IF (MODE.EQ.0) THEN | |
17639 | SUMFRA = ZERO | |
17640 | RR = DT_RNDM(SUMFRA) | |
17641 | IT = 0 | |
17642 | ITZ = 0 | |
17643 | DO 1 ICOMP=1,NCOMPO | |
17644 | SUMFRA = SUMFRA+EMUFRA(ICOMP) | |
17645 | IF (SUMFRA.GT.RR) THEN | |
17646 | IT = IEMUMA(ICOMP) | |
17647 | ITZ = IEMUCH(ICOMP) | |
17648 | KKMAT = ICOMP | |
17649 | GOTO 2 | |
17650 | ENDIF | |
17651 | 1 CONTINUE | |
17652 | 2 CONTINUE | |
17653 | IF (IT.LE.0) THEN | |
17654 | WRITE(LOUT,'(1X,A,E12.3)') | |
17655 | & 'Warning! norm. failure within emulsion fractions', | |
17656 | & SUMFRA | |
17657 | STOP | |
17658 | ENDIF | |
17659 | ELSEIF (MODE.EQ.1) THEN | |
17660 | NDIFF = 10000 | |
17661 | DO 3 I=1,NCOMPO | |
17662 | IDIFF = ABS(IT-IEMUMA(I)) | |
17663 | IF (IDIFF.LT.NDIFF) THEN | |
17664 | KKMAT = I | |
17665 | NDIFF = IDIFF | |
17666 | ENDIF | |
17667 | 3 CONTINUE | |
17668 | ELSE | |
17669 | STOP 'DT_GETEMU' | |
17670 | ENDIF | |
17671 | ||
17672 | * bypass for variable projectile/target/energy runs: the correct | |
17673 | * Glauber data will be always loaded on kkmat=1 | |
17674 | IF (IOGLB.EQ.100) THEN | |
17675 | KKMAT = 1 | |
17676 | ENDIF | |
17677 | ||
17678 | RETURN | |
17679 | END | |
17680 | ||
17681 | *$ CREATE DT_NCLPOT.FOR | |
17682 | *COPY DT_NCLPOT | |
17683 | * | |
17684 | *===nclpot=============================================================* | |
17685 | * | |
17686 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) | |
17687 | ||
17688 | ************************************************************************ | |
17689 | * Calculation of Coulomb and nuclear potential for a given configurat. * | |
17690 | * IPZ, IP charge/mass number of proj. * | |
17691 | * ITZ, IT charge/mass number of targ. * | |
17692 | * AFERP,AFERT factors modifying proj./target pot. * | |
17693 | * if =0, FERMOD is used * | |
17694 | * MODE = 0 calculation of binding energy * | |
17695 | * = 1 pre-calculated binding energy is used * | |
17696 | * This version dated 16.11.95 is written by S. Roesler. * | |
17697 | * * | |
17698 | * Last change 28.12.2006 by S. Roesler. * | |
17699 | ************************************************************************ | |
17700 | ||
17701 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17702 | SAVE | |
17703 | PARAMETER ( LINP = 10 , | |
17704 | & LOUT = 6 , | |
17705 | & LDAT = 9 ) | |
17706 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
17707 | & TINY10=1.0D-10) | |
17708 | ||
17709 | LOGICAL LSTART | |
17710 | ||
17711 | * particle properties (BAMJET index convention) | |
17712 | CHARACTER*8 ANAME | |
17713 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17714 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17715 | * nuclear potential | |
17716 | LOGICAL LFERMI | |
17717 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17718 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17719 | & ETACOU(2),ICOUL,LFERMI | |
17720 | ||
17721 | DIMENSION IDXPOT(14) | |
17722 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- | |
17723 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, | |
17724 | * asig0 asig+ atet0 atet+ | |
17725 | & 100, 101, 102, 103/ | |
17726 | ||
17727 | DATA AN /0.4D0/ | |
17728 | DATA LSTART /.TRUE./ | |
17729 | ||
17730 | IF (MODE.EQ.0) THEN | |
17731 | EBINDP(1) = ZERO | |
17732 | EBINDN(1) = ZERO | |
17733 | EBINDP(2) = ZERO | |
17734 | EBINDN(2) = ZERO | |
17735 | ENDIF | |
17736 | AIP = DBLE(IP) | |
17737 | AIPZ = DBLE(IPZ) | |
17738 | AIT = DBLE(IT) | |
17739 | AITZ = DBLE(ITZ) | |
17740 | ||
17741 | FERMIP = AFERP | |
17742 | IF (AFERP.LE.ZERO) FERMIP = FERMOD | |
17743 | FERMIT = AFERT | |
17744 | IF (AFERT.LE.ZERO) FERMIT = FERMOD | |
17745 | ||
17746 | * Fermi momenta and binding energy for projectile | |
17747 | IF ((IP.GT.1).AND.LFERMI) THEN | |
17748 | IF (MODE.EQ.0) THEN | |
17749 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) | |
17750 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) | |
17751 | BIP = AIP -ONE | |
17752 | BIPZ = AIPZ-ONE | |
17753 | EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ) | |
17754 | & -DT_ENERGY(AIP,AIPZ)) | |
17755 | IF (AIP.LE.AIPZ) THEN | |
17756 | EBINDN(1) = EBINDP(1) | |
17757 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' | |
17758 | ELSE | |
17759 | EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17760 | & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ)) | |
17761 | ENDIF | |
17762 | ENDIF | |
17763 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 | |
17764 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 | |
17765 | ELSE | |
17766 | PFERMP(1) = ZERO | |
17767 | PFERMN(1) = ZERO | |
17768 | ENDIF | |
17769 | * effective nuclear potential for projectile | |
17770 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) | |
17771 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) | |
17772 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) | |
17773 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) | |
17774 | ||
17775 | * Fermi momenta and binding energy for target | |
17776 | IF ((IT.GT.1).AND.LFERMI) THEN | |
17777 | IF (MODE.EQ.0) THEN | |
17778 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) | |
17779 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) | |
17780 | BIT = AIT -ONE | |
17781 | BITZ = AITZ-ONE | |
17782 | ||
17783 | EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ) | |
17784 | & -DT_ENERGY(AIT,AITZ)) | |
17785 | ||
17786 | IF (AIT.LE.AITZ) THEN | |
17787 | EBINDN(2) = EBINDP(2) | |
17788 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' | |
17789 | ELSE | |
17790 | ||
17791 | EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17792 | & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ)) | |
17793 | ||
17794 | ENDIF | |
17795 | ENDIF | |
17796 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 | |
17797 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 | |
17798 | ELSE | |
17799 | PFERMP(2) = ZERO | |
17800 | PFERMN(2) = ZERO | |
17801 | ENDIF | |
17802 | * effective nuclear potential for target | |
17803 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) | |
17804 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) | |
17805 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) | |
17806 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) | |
17807 | ||
17808 | DO 2 I=1,14 | |
17809 | EPOT(1,IDXPOT(I)) = EPOT(1,8) | |
17810 | EPOT(2,IDXPOT(I)) = EPOT(2,8) | |
17811 | 2 CONTINUE | |
17812 | ||
17813 | * Coulomb energy | |
17814 | ETACOU(1) = ZERO | |
17815 | ETACOU(2) = ZERO | |
17816 | IF (ICOUL.EQ.1) THEN | |
17817 | IF (IP.GT.1) | |
17818 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) | |
17819 | IF (IT.GT.1) | |
17820 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) | |
17821 | ENDIF | |
17822 | ||
17823 | IF (LSTART) THEN | |
17824 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, | |
17825 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), | |
17826 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), | |
17827 | & FERMOD,ETACOU | |
17828 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' | |
17829 | & ,' effects',/,12X,'---------------------------', | |
17830 | & '----------------',/,/,38X,'projectile', | |
17831 | & ' target',/,/,1X,'Mass number / charge', | |
17832 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', | |
17833 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' | |
17834 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', | |
17835 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, | |
17836 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, | |
17837 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) | |
17838 | LSTART = .FALSE. | |
17839 | ENDIF | |
17840 | ||
17841 | RETURN | |
17842 | END | |
17843 | ||
17844 | *$ CREATE DT_RESNCL.FOR | |
17845 | *COPY DT_RESNCL | |
17846 | * | |
17847 | *===resncl=============================================================* | |
17848 | * | |
17849 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) | |
17850 | ||
17851 | ************************************************************************ | |
17852 | * Treatment of residual nuclei and nuclear effects. * | |
17853 | * MODE = 1 initializations * | |
17854 | * = 2 treatment of final state * | |
17855 | * This version dated 16.11.95 is written by S. Roesler. * | |
17856 | * * | |
17857 | * Last change 05.01.2007 by S. Roesler. * | |
17858 | ************************************************************************ | |
17859 | ||
17860 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17861 | SAVE | |
17862 | PARAMETER ( LINP = 10 , | |
17863 | & LOUT = 6 , | |
17864 | & LDAT = 9 ) | |
17865 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, | |
17866 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, | |
17867 | & ONETHI=ONE/THREE) | |
17868 | PARAMETER (AMUAMU = 0.93149432D0, | |
17869 | & FM2MM = 1.0D-12, | |
17870 | & RNUCLE = 1.12D0) | |
17871 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
17872 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
17873 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
17874 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
17875 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
17876 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
17877 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
17878 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
17879 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) | |
17880 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) | |
17881 | ||
17882 | * event history | |
17883 | PARAMETER (NMXHKK=200000) | |
17884 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17885 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17886 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17887 | * extended event history | |
17888 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17889 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17890 | & IHIST(2,NMXHKK) | |
17891 | * particle properties (BAMJET index convention) | |
17892 | CHARACTER*8 ANAME | |
17893 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17894 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17895 | * flags for input different options | |
17896 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17897 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17898 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17899 | * nuclear potential | |
17900 | LOGICAL LFERMI | |
17901 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17902 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17903 | & ETACOU(2),ICOUL,LFERMI | |
17904 | * properties of interacting particles | |
17905 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
17906 | * properties of photon/lepton projectiles | |
17907 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
17908 | * Lorentz-parameters of the current interaction | |
17909 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
17910 | & UMO,PPCM,EPROJ,PPROJ | |
17911 | * treatment of residual nuclei: wounded nucleons | |
17912 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
17913 | * treatment of residual nuclei: 4-momenta | |
17914 | LOGICAL LRCLPR,LRCLTA | |
17915 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
17916 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
17917 | ||
17918 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) | |
17919 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), | |
17920 | & IDXCOR(15000),IDXOTH(NMXHKK) | |
17921 | ||
17922 | GOTO (1,2) MODE | |
17923 | ||
17924 | *------- initializations | |
17925 | 1 CONTINUE | |
17926 | ||
17927 | * initialize arrays for residual nuclei | |
17928 | DO 10 K=1,5 | |
17929 | IF (K.LE.4) THEN | |
17930 | PFSP(K) = ZERO | |
17931 | ENDIF | |
17932 | PINIPR(K) = ZERO | |
17933 | PINITA(K) = ZERO | |
17934 | PRCLPR(K) = ZERO | |
17935 | PRCLTA(K) = ZERO | |
17936 | TRCLPR(K) = ZERO | |
17937 | TRCLTA(K) = ZERO | |
17938 | 10 CONTINUE | |
17939 | SCPOT = ONE | |
17940 | NLOOP = 0 | |
17941 | ||
17942 | * correction of projectile 4-momentum for effective target pot. | |
17943 | * and Coulomb-energy (in case of hadron-nucleus interaction only) | |
9b65428d AM |
17944 | * IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
17945 | * EPNI = EPN | |
9aaba0d6 | 17946 | * Coulomb-energy: |
17947 | * positively charged hadron - check energy for Coloumb pot. | |
9b65428d AM |
17948 | * IF (IICH(IJPROJ).EQ.1) THEN |
17949 | * THRESH = ETACOU(2)+AAM(IJPROJ) | |
17950 | * IF (EPNI.LE.THRESH) THEN | |
17951 | * WRITE(LOUT,1000) | |
17952 | * 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', | |
17953 | * & ' below Coulomb threshold - event rejected',/) | |
17954 | * ISTHKK(1) = 1 | |
17955 | * RETURN | |
17956 | * ENDIF | |
9aaba0d6 | 17957 | * negatively charged hadron - increase energy by Coulomb energy |
9b65428d AM |
17958 | * ELSEIF (IICH(IJPROJ).EQ.-1) THEN |
17959 | * EPNI = EPNI+ETACOU(2) | |
17960 | * ENDIF | |
17961 | * IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN | |
9aaba0d6 | 17962 | * Effective target potential |
17963 | *sr 6.6. binding energy only (to avoid negative exc. energies) | |
17964 | C EPNI = EPNI+EPOT(2,IJPROJ) | |
9b65428d AM |
17965 | * EBIPOT = EBINDP(2) |
17966 | * IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) | |
17967 | * & EBIPOT = EBINDN(2) | |
17968 | * EPNI = EPNI+ABS(EBIPOT) | |
9aaba0d6 | 17969 | * re-initialization of DTLTRA |
9b65428d AM |
17970 | * DUM1 = ZERO |
17971 | * DUM2 = ZERO | |
17972 | * | |
17973 | * CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) | |
17974 | * ENDIF | |
17975 | * ENDIF | |
9aaba0d6 | 17976 | |
17977 | * projectile in n-n cms | |
17978 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN | |
17979 | PMASS1 = AAM(IJPROJ) | |
17980 | C* VDM assumption | |
17981 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) | |
17982 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) | |
17983 | PMASS2 = AAM(1) | |
17984 | PM1 = SIGN(PMASS1**2,PMASS1) | |
17985 | PM2 = SIGN(PMASS2**2,PMASS2) | |
17986 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) | |
17987 | PINIPR(5) = PMASS1 | |
17988 | IF (PMASS1.GT.ZERO) THEN | |
17989 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) | |
17990 | & *(PINIPR(4)+PINIPR(5))) | |
17991 | ELSE | |
17992 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) | |
17993 | ENDIF | |
17994 | AIT = DBLE(IT) | |
17995 | AITZ = DBLE(ITZ) | |
17996 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
17997 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
17998 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN | |
17999 | PMASS1 = AAM(1) | |
18000 | PMASS2 = AAM(IJTARG) | |
18001 | PM1 = SIGN(PMASS1**2,PMASS1) | |
18002 | PM2 = SIGN(PMASS2**2,PMASS2) | |
18003 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) | |
18004 | PINITA(5) = PMASS2 | |
18005 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) | |
18006 | & *(PINITA(4)+PINITA(5))) | |
18007 | AIP = DBLE(IP) | |
18008 | AIPZ = DBLE(IPZ) | |
18009 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
18010 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
18011 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
18012 | AIP = DBLE(IP) | |
18013 | AIPZ = DBLE(IPZ) | |
18014 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
18015 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
18016 | AIT = DBLE(IT) | |
18017 | AITZ = DBLE(ITZ) | |
18018 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
18019 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
18020 | ENDIF | |
18021 | ||
18022 | RETURN | |
18023 | ||
18024 | *------- treatment of final state | |
18025 | 2 CONTINUE | |
18026 | ||
18027 | NLOOP = NLOOP+1 | |
18028 | IF (NLOOP.GT.1) SCPOT = 0.10D0 | |
18029 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT | |
18030 | ||
18031 | JPW = NPW | |
18032 | JPCW = NPCW | |
18033 | JTW = NTW | |
18034 | JTCW = NTCW | |
18035 | DO 40 K=1,4 | |
18036 | PFSP(K) = ZERO | |
18037 | 40 CONTINUE | |
18038 | ||
18039 | NOB = 0 | |
18040 | NOM = 0 | |
18041 | DO 900 I=NPOINT(4),NHKK | |
18042 | IDXOTH(I) = -1 | |
18043 | IF (ISTHKK(I).EQ.1) THEN | |
18044 | IF (IDBAM(I).EQ.7) GOTO 900 | |
18045 | IPOT = 0 | |
18046 | IOTHER = 0 | |
18047 | * particle moving into forward direction | |
18048 | IF (PHKK(3,I).GE.ZERO) THEN | |
18049 | * most likely to be effected by projectile potential | |
18050 | IPOT = 1 | |
18051 | * there is no projectile nucleus, try target | |
18052 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN | |
18053 | IPOT = 2 | |
18054 | IF (IP.GT.1) IOTHER = 1 | |
18055 | * there is no target nucleus --> skip | |
18056 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 | |
18057 | ENDIF | |
18058 | * particle moving into backward direction | |
18059 | ELSE | |
18060 | * most likely to be effected by target potential | |
18061 | IPOT = 2 | |
18062 | * there is no target nucleus, try projectile | |
18063 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN | |
18064 | IPOT = 1 | |
18065 | IF (IT.GT.1) IOTHER = 1 | |
18066 | * there is no projectile nucleus --> skip | |
18067 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 | |
18068 | ENDIF | |
18069 | ENDIF | |
18070 | IFLG = -IPOT | |
18071 | * nobam=3: particle is in overlap-region or neither inside proj. nor target | |
18072 | * =1: particle is not in overlap-region AND is inside target (2) | |
18073 | * =2: particle is not in overlap-region AND is inside projectile (1) | |
18074 | * flag particles which are inside the nucleus ipot but not in its | |
18075 | * overlap region | |
18076 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT | |
18077 | IF (IDBAM(I).NE.0) THEN | |
18078 | * baryons: keep all nucleons and all others where flag is set | |
18079 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18080 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) | |
18081 | & THEN | |
18082 | NOB = NOB+1 | |
18083 | PMOMB(NOB) = PHKK(3,I) | |
18084 | IDXB(NOB) = SIGN(10000000*IABS(IFLG) | |
18085 | & +1000000*IOTHER+I,IFLG) | |
18086 | ENDIF | |
18087 | * mesons: keep only those mesons where flag is set | |
18088 | ELSE | |
18089 | IF (IFLG.GT.0) THEN | |
18090 | NOM = NOM+1 | |
18091 | PMOMM(NOM) = PHKK(3,I) | |
18092 | IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I | |
18093 | ENDIF | |
18094 | ENDIF | |
18095 | ENDIF | |
18096 | ENDIF | |
18097 | 900 CONTINUE | |
18098 | * | |
18099 | * sort particles in the arrays according to increasing long. momentum | |
18100 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) | |
18101 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) | |
18102 | * | |
18103 | * shuffle indices into one and the same array according to the later | |
18104 | * sequence of correction | |
18105 | NCOR = 0 | |
18106 | IF (IT.GT.1) THEN | |
18107 | DO 910 I=1,NOB | |
18108 | IF (PMOMB(I).GT.ZERO) GOTO 911 | |
18109 | NCOR = NCOR+1 | |
18110 | IDXCOR(NCOR) = IDXB(I) | |
18111 | 910 CONTINUE | |
18112 | 911 CONTINUE | |
18113 | IF (IP.GT.1) THEN | |
18114 | DO 912 J=1,NOB | |
18115 | I = NOB+1-J | |
18116 | IF (PMOMB(I).LT.ZERO) GOTO 913 | |
18117 | NCOR = NCOR+1 | |
18118 | IDXCOR(NCOR) = IDXB(I) | |
18119 | 912 CONTINUE | |
18120 | 913 CONTINUE | |
18121 | ELSE | |
18122 | DO 914 I=1,NOB | |
18123 | IF (PMOMB(I).GT.ZERO) THEN | |
18124 | NCOR = NCOR+1 | |
18125 | IDXCOR(NCOR) = IDXB(I) | |
18126 | ENDIF | |
18127 | 914 CONTINUE | |
18128 | ENDIF | |
18129 | ELSE | |
18130 | DO 915 J=1,NOB | |
18131 | I = NOB+1-J | |
18132 | NCOR = NCOR+1 | |
18133 | IDXCOR(NCOR) = IDXB(I) | |
18134 | 915 CONTINUE | |
18135 | ENDIF | |
18136 | DO 925 I=1,NOM | |
18137 | IF (PMOMM(I).GT.ZERO) GOTO 926 | |
18138 | NCOR = NCOR+1 | |
18139 | IDXCOR(NCOR) = IDXM(I) | |
18140 | 925 CONTINUE | |
18141 | 926 CONTINUE | |
18142 | DO 927 J=1,NOM | |
18143 | I = NOM+1-J | |
18144 | IF (PMOMM(I).LT.ZERO) GOTO 928 | |
18145 | NCOR = NCOR+1 | |
18146 | IDXCOR(NCOR) = IDXM(I) | |
18147 | 927 CONTINUE | |
18148 | 928 CONTINUE | |
18149 | * | |
18150 | C IF (NEVHKK.EQ.484) THEN | |
18151 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW | |
18152 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) | |
18153 | C WRITE(LOUT,9001) NOB,NOM,NCOR | |
18154 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) | |
18155 | C WRITE(LOUT,'(/,A)') ' baryons ' | |
18156 | C DO 950 I=1,NOB | |
18157 | CC J = IABS(IDXB(I)) | |
18158 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18159 | C IPOT = IABS(IDXB(I))/10000000 | |
18160 | C IOTHER = IABS(IDXB(I))/1000000-IPOT*10 | |
18161 | C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000 | |
18162 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) | |
18163 | C 950 CONTINUE | |
18164 | C WRITE(LOUT,'(/,A)') ' mesons ' | |
18165 | C DO 951 I=1,NOM | |
18166 | CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000 | |
18167 | C IPOT = IABS(IDXM(I))/10000000 | |
18168 | C IOTHER = IABS(IDXM(I))/1000000-IPOT*10 | |
18169 | C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000 | |
18170 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) | |
18171 | C 951 CONTINUE | |
18172 | C 9002 FORMAT(1X,4I14,E14.5) | |
18173 | C WRITE(LOUT,'(/,A)') ' all ' | |
18174 | C DO 952 I=1,NCOR | |
18175 | CC J = IABS(IDXCOR(I)) | |
18176 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18177 | CC IPOT = IABS(IDXCOR(I))/10000000 | |
18178 | C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10 | |
18179 | C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000 | |
18180 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) | |
18181 | C 952 CONTINUE | |
18182 | C 9003 FORMAT(1X,4I14) | |
18183 | C ENDIF | |
18184 | * | |
18185 | DO 20 ICOR=1,NCOR | |
18186 | IPOT = IABS(IDXCOR(ICOR))/10000000 | |
18187 | IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10 | |
18188 | I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000 | |
18189 | IDXOTH(I) = 1 | |
18190 | ||
18191 | IDSEC = IDBAM(I) | |
18192 | ||
18193 | * reduction of particle momentum by corresponding nuclear potential | |
18194 | * (this applies only if Fermi-momenta are requested) | |
18195 | ||
18196 | IF (LFERMI) THEN | |
18197 | ||
18198 | * Lorentz-transformation into the rest system of the selected nucleus | |
18199 | IMODE = -IPOT-1 | |
18200 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18201 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) | |
18202 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) | |
18203 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) | |
18204 | JPMOD = 0 | |
18205 | ||
18206 | CHKLEV = TINY3 | |
18207 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 | |
18208 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 | |
18209 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN | |
18210 | IF (IOULEV(3).GT.0) | |
18211 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) | |
18212 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', | |
18213 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', | |
18214 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) | |
18215 | GOTO 23 | |
18216 | ENDIF | |
18217 | ||
18218 | DO 21 K=1,4 | |
18219 | PSEC0(K) = PSEC(K) | |
18220 | 21 CONTINUE | |
18221 | ||
18222 | * the correction for nuclear potential effects is applied to as many | |
18223 | * p/n as many nucleons were wounded; the momenta of other final state | |
18224 | * particles are corrected only if they materialize inside the corresp. | |
18225 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ | |
18226 | * = 3 part. outside proj. and targ., >=10 in overlapping region) | |
18227 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN | |
18228 | IF (IPOT.EQ.1) THEN | |
18229 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18230 | * this is most likely a wounded nucleon | |
18231 | **test | |
18232 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 | |
18233 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 | |
18234 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) | |
18235 | C RAD = RNUCLE*DBLE(IP)**ONETHI | |
18236 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) | |
18237 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18238 | ** | |
18239 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18240 | JPW = JPW-1 | |
18241 | JPMOD = 1 | |
18242 | ELSE | |
18243 | * correct only if part. was materialized inside nucleus | |
18244 | * and if it is ouside the overlapping region | |
18245 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN | |
18246 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18247 | JPMOD = 1 | |
18248 | ENDIF | |
18249 | ENDIF | |
18250 | ELSEIF (IPOT.EQ.2) THEN | |
18251 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18252 | * this is most likely a wounded nucleon | |
18253 | **test | |
18254 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 | |
18255 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 | |
18256 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) | |
18257 | C RAD = RNUCLE*DBLE(IT)**ONETHI | |
18258 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) | |
18259 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18260 | ** | |
18261 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18262 | JTW = JTW-1 | |
18263 | JPMOD = 1 | |
18264 | ELSE | |
18265 | * correct only if part. was materialized inside nucleus | |
18266 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN | |
18267 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18268 | JPMOD = 1 | |
18269 | ENDIF | |
18270 | ENDIF | |
18271 | ENDIF | |
18272 | ELSE | |
18273 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN | |
18274 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18275 | JPMOD = 1 | |
18276 | ENDIF | |
18277 | ENDIF | |
18278 | ||
18279 | IF (NLOOP.EQ.1) THEN | |
18280 | * Coulomb energy correction: | |
18281 | * the treatment of Coulomb potential correction is similar to the | |
18282 | * one for nuclear potential | |
18283 | IF (IDSEC.EQ.1) THEN | |
18284 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN | |
18285 | JPCW = JPCW-1 | |
18286 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN | |
18287 | JTCW = JTCW-1 | |
18288 | ELSE | |
18289 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18290 | ENDIF | |
18291 | ELSE | |
18292 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18293 | ENDIF | |
18294 | IF (IICH(IDSEC).EQ.1) THEN | |
18295 | * pos. particles: check if they are able to escape Coulomb potential | |
18296 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN | |
18297 | ISTHKK(I) = 14+IPOT | |
18298 | IF (ISTHKK(I).EQ.15) THEN | |
18299 | DO 26 K=1,4 | |
18300 | PHKK(K,I) = PSEC0(K) | |
18301 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18302 | 26 CONTINUE | |
18303 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18304 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18305 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18306 | DO 27 K=1,4 | |
18307 | PHKK(K,I) = PSEC0(K) | |
18308 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18309 | 27 CONTINUE | |
18310 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18311 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18312 | ENDIF | |
18313 | GOTO 20 | |
18314 | ENDIF | |
18315 | ELSEIF (IICH(IDSEC).EQ.-1) THEN | |
18316 | * neg. particles: decrease energy by Coulomb-potential | |
18317 | PSEC(4) = PSEC(4)-ETACOU(IPOT) | |
18318 | JPMOD = 1 | |
18319 | ENDIF | |
18320 | ENDIF | |
18321 | ||
18322 | 25 CONTINUE | |
18323 | ||
18324 | IF (PSEC(4).LT.AMSEC) THEN | |
18325 | IF (IOULEV(6).GT.0) | |
18326 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC | |
18327 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, | |
18328 | & ' is not allowed to escape nucleus',/, | |
18329 | & 8X,'id : ',I3,' reduced energy: ',E15.4, | |
18330 | & ' mass: ',E12.3) | |
18331 | ISTHKK(I) = 14+IPOT | |
18332 | IF (ISTHKK(I).EQ.15) THEN | |
18333 | DO 28 K=1,4 | |
18334 | PHKK(K,I) = PSEC0(K) | |
18335 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18336 | 28 CONTINUE | |
18337 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18338 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18339 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18340 | DO 29 K=1,4 | |
18341 | PHKK(K,I) = PSEC0(K) | |
18342 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18343 | 29 CONTINUE | |
18344 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18345 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18346 | ENDIF | |
18347 | GOTO 20 | |
18348 | ENDIF | |
18349 | ||
18350 | IF (JPMOD.EQ.1) THEN | |
18351 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) | |
18352 | * 4-momentum after correction for nuclear potential | |
18353 | DO 22 K=1,3 | |
18354 | PSEC(K) = PSEC(K)*PSECN/PSECO | |
18355 | 22 CONTINUE | |
18356 | ||
18357 | * store recoil momentum from particles escaping the nuclear potentials | |
18358 | DO 30 K=1,4 | |
18359 | IF (IPOT.EQ.1) THEN | |
18360 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) | |
18361 | ELSEIF (IPOT.EQ.2) THEN | |
18362 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) | |
18363 | ENDIF | |
18364 | 30 CONTINUE | |
18365 | ||
18366 | * transform momentum back into n-n cms | |
18367 | IMODE = IPOT+1 | |
18368 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), | |
18369 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18370 | & IDSEC,IMODE) | |
18371 | ENDIF | |
18372 | ||
18373 | ENDIF | |
18374 | ||
18375 | 23 CONTINUE | |
18376 | DO 31 K=1,4 | |
18377 | PFSP(K) = PFSP(K)+PHKK(K,I) | |
18378 | 31 CONTINUE | |
18379 | ||
18380 | 20 CONTINUE | |
18381 | ||
18382 | DO 33 I=NPOINT(4),NHKK | |
18383 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN | |
18384 | PFSP(1) = PFSP(1)+PHKK(1,I) | |
18385 | PFSP(2) = PFSP(2)+PHKK(2,I) | |
18386 | PFSP(3) = PFSP(3)+PHKK(3,I) | |
18387 | PFSP(4) = PFSP(4)+PHKK(4,I) | |
18388 | ENDIF | |
18389 | 33 CONTINUE | |
18390 | ||
18391 | DO 34 K=1,5 | |
18392 | PRCLPR(K) = TRCLPR(K) | |
18393 | PRCLTA(K) = TRCLTA(K) | |
18394 | 34 CONTINUE | |
18395 | ||
18396 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
18397 | * hadron-nucleus interactions: get residual momentum from energy- | |
18398 | * momentum conservation | |
18399 | DO 32 K=1,4 | |
18400 | PRCLPR(K) = ZERO | |
18401 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) | |
18402 | 32 CONTINUE | |
18403 | ELSE | |
18404 | * nucleus-hadron, nucleus-nucleus: get residual momentum from | |
18405 | * accumulated recoil momenta of particles leaving the spectators | |
18406 | * transform accumulated recoil momenta of residual nuclei into | |
18407 | * n-n cms | |
18408 | PZI = PRCLPR(3) | |
18409 | PEI = PRCLPR(4) | |
18410 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) | |
18411 | PZI = PRCLTA(3) | |
18412 | PEI = PRCLTA(4) | |
18413 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) | |
18414 | C IF (IP.GT.1) THEN | |
18415 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) | |
18416 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) | |
18417 | C ENDIF | |
18418 | IF (IT.GT.1) THEN | |
18419 | PRCLTA(3) = PRCLTA(3)+PINITA(3) | |
18420 | PRCLTA(4) = PRCLTA(4)+PINITA(4) | |
18421 | ENDIF | |
18422 | ENDIF | |
18423 | ||
18424 | * check momenta of residual nuclei | |
18425 | IF (LEMCCK) THEN | |
18426 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), | |
18427 | & 1,IDUM,IDUM) | |
18428 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), | |
18429 | & 2,IDUM,IDUM) | |
18430 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), | |
18431 | & 2,IDUM,IDUM) | |
18432 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), | |
18433 | & 2,IDUM,IDUM) | |
18434 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) | |
18435 | **sr 19.12. changed to avoid output when used with phojet | |
18436 | C CHKLEV = TINY3 | |
18437 | CHKLEV = TINY1 | |
18438 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) | |
18439 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) | |
18440 | C & CALL DT_EVTOUT(4) | |
18441 | IF (IREJ1.GT.0) RETURN | |
18442 | ENDIF | |
18443 | ||
18444 | RETURN | |
18445 | END | |
18446 | ||
18447 | *$ CREATE DT_SCN4BA.FOR | |
18448 | *COPY DT_SCN4BA | |
18449 | * | |
18450 | *===scn4ba=============================================================* | |
18451 | * | |
18452 | SUBROUTINE DT_SCN4BA | |
18453 | ||
18454 | ************************************************************************ | |
18455 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * | |
18456 | * This version dated 12.12.95 is written by S. Roesler. * | |
18457 | ************************************************************************ | |
18458 | ||
18459 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18460 | SAVE | |
18461 | PARAMETER ( LINP = 10 , | |
18462 | & LOUT = 6 , | |
18463 | & LDAT = 9 ) | |
18464 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
18465 | & TINY10=1.0D-10) | |
18466 | ||
18467 | * event history | |
18468 | PARAMETER (NMXHKK=200000) | |
18469 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18470 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18471 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18472 | * extended event history | |
18473 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18474 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18475 | & IHIST(2,NMXHKK) | |
18476 | * particle properties (BAMJET index convention) | |
18477 | CHARACTER*8 ANAME | |
18478 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18479 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18480 | * properties of interacting particles | |
18481 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
18482 | * nuclear potential | |
18483 | LOGICAL LFERMI | |
18484 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18485 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18486 | & ETACOU(2),ICOUL,LFERMI | |
18487 | * treatment of residual nuclei: wounded nucleons | |
18488 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
18489 | * treatment of residual nuclei: 4-momenta | |
18490 | LOGICAL LRCLPR,LRCLTA | |
18491 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18492 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18493 | ||
18494 | DIMENSION PLAB(2,5),PCMS(4) | |
18495 | ||
18496 | IREJ = 0 | |
18497 | ||
18498 | * get number of wounded nucleons | |
18499 | NPW = 0 | |
18500 | NPW0 = 0 | |
18501 | NPCW = 0 | |
18502 | NPSTCK = 0 | |
18503 | NTW = 0 | |
18504 | NTW0 = 0 | |
18505 | NTCW = 0 | |
18506 | NTSTCK = 0 | |
18507 | ||
18508 | ISGLPR = 0 | |
18509 | ISGLTA = 0 | |
18510 | LRCLPR = .FALSE. | |
18511 | LRCLTA = .FALSE. | |
18512 | ||
18513 | C DO 2 I=1,NHKK | |
18514 | DO 2 I=1,NPOINT(1) | |
18515 | * projectile nucleons wounded in primary interaction and in fzc | |
18516 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN | |
18517 | NPW = NPW+1 | |
18518 | IPW(NPW) = I | |
18519 | NPSTCK = NPSTCK+1 | |
18520 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 | |
18521 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 | |
18522 | C IF (IP.GT.1) THEN | |
18523 | DO 5 K=1,4 | |
18524 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) | |
18525 | 5 CONTINUE | |
18526 | C ENDIF | |
18527 | * target nucleons wounded in primary interaction and in fzc | |
18528 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN | |
18529 | NTW = NTW+1 | |
18530 | ITW(NTW) = I | |
18531 | NTSTCK = NTSTCK+1 | |
18532 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 | |
18533 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 | |
18534 | IF (IT.GT.1) THEN | |
18535 | DO 6 K=1,4 | |
18536 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) | |
18537 | 6 CONTINUE | |
18538 | ENDIF | |
18539 | ELSEIF (ISTHKK(I).EQ.13) THEN | |
18540 | ISGLPR = I | |
18541 | ELSEIF (ISTHKK(I).EQ.14) THEN | |
18542 | ISGLTA = I | |
18543 | ENDIF | |
18544 | 2 CONTINUE | |
18545 | ||
18546 | DO 11 I=NPOINT(4),NHKK | |
18547 | * baryons which are unable to escape the nuclear potential of proj. | |
18548 | IF (ISTHKK(I).EQ.15) THEN | |
18549 | ISGLPR = I | |
18550 | NPSTCK = NPSTCK-1 | |
18551 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18552 | NPW = NPW-1 | |
18553 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 | |
18554 | ENDIF | |
18555 | DO 7 K=1,4 | |
18556 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18557 | 7 CONTINUE | |
18558 | * baryons which are unable to escape the nuclear potential of targ. | |
18559 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18560 | ISGLTA = I | |
18561 | NTSTCK = NTSTCK-1 | |
18562 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18563 | NTW = NTW-1 | |
18564 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 | |
18565 | ENDIF | |
18566 | DO 8 K=1,4 | |
18567 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18568 | 8 CONTINUE | |
18569 | ENDIF | |
18570 | 11 CONTINUE | |
18571 | ||
18572 | * residual nuclei so far | |
18573 | IRESP = IP-NPSTCK | |
18574 | IREST = IT-NTSTCK | |
18575 | ||
18576 | * ckeck for "residual nuclei" consisting of one nucleon only | |
18577 | * treat it as final state particle | |
18578 | IF (IRESP.EQ.1) THEN | |
18579 | ID = IDBAM(ISGLPR) | |
18580 | IST = ISTHKK(ISGLPR) | |
18581 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), | |
18582 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), | |
18583 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) | |
18584 | IF (IST.EQ.13) THEN | |
18585 | ISTHKK(ISGLPR) = 11 | |
18586 | ELSE | |
18587 | ISTHKK(ISGLPR) = 2 | |
18588 | ENDIF | |
18589 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, | |
18590 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18591 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) | |
18592 | NOBAM(NHKK) = NOBAM(ISGLPR) | |
18593 | JDAHKK(1,ISGLPR) = NHKK | |
18594 | DO 21 K=1,4 | |
18595 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) | |
18596 | 21 CONTINUE | |
18597 | ENDIF | |
18598 | IF (IREST.EQ.1) THEN | |
18599 | ID = IDBAM(ISGLTA) | |
18600 | IST = ISTHKK(ISGLTA) | |
18601 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), | |
18602 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), | |
18603 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) | |
18604 | IF (IST.EQ.14) THEN | |
18605 | ISTHKK(ISGLTA) = 12 | |
18606 | ELSE | |
18607 | ISTHKK(ISGLTA) = 2 | |
18608 | ENDIF | |
18609 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, | |
18610 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18611 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) | |
18612 | NOBAM(NHKK) = NOBAM(ISGLTA) | |
18613 | JDAHKK(1,ISGLTA) = NHKK | |
18614 | DO 22 K=1,4 | |
18615 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) | |
18616 | 22 CONTINUE | |
18617 | ENDIF | |
18618 | ||
18619 | * get nuclear potential corresp. to the residual nucleus | |
18620 | IPRCL = IP -NPW | |
18621 | IPZRCL = IPZ-NPCW | |
18622 | ITRCL = IT -NTW | |
18623 | ITZRCL = ITZ-NTCW | |
18624 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
18625 | ||
18626 | * baryons unable to escape the nuclear potential are treated as | |
18627 | * excited nucleons (ISTHKK=15,16) | |
18628 | DO 3 I=NPOINT(4),NHKK | |
18629 | IF (ISTHKK(I).EQ.1) THEN | |
18630 | ID = IDBAM(I) | |
18631 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN | |
18632 | * final state n and p not being outside of both nuclei are considered | |
18633 | NPOTP = 1 | |
18634 | NPOTT = 1 | |
18635 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. | |
18636 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN | |
18637 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. | |
18638 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18639 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), | |
18640 | & PLAB(1,4),ID,-2) | |
18641 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) | |
18642 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* | |
18643 | & (PLAB(1,4)+PLABT) )) | |
18644 | EKIN = PLAB(1,4)-PLAB(1,5) | |
18645 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 | |
18646 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 | |
18647 | ENDIF | |
18648 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. | |
18649 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN | |
18650 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. | |
18651 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18652 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), | |
18653 | & PLAB(2,4),ID,-3) | |
18654 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) | |
18655 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* | |
18656 | & (PLAB(2,4)+PLABT) )) | |
18657 | EKIN = PLAB(2,4)-PLAB(2,5) | |
18658 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 | |
18659 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 | |
18660 | ENDIF | |
18661 | IF (PHKK(3,I).GE.ZERO) THEN | |
18662 | ISTHKK(I) = NPOTT | |
18663 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP | |
18664 | ELSE | |
18665 | ISTHKK(I) = NPOTP | |
18666 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT | |
18667 | ENDIF | |
18668 | IF (ISTHKK(I).NE.1) THEN | |
18669 | J = ISTHKK(I)-14 | |
18670 | DO 4 K=1,5 | |
18671 | PHKK(K,I) = PLAB(J,K) | |
18672 | 4 CONTINUE | |
18673 | IF (ISTHKK(I).EQ.15) THEN | |
18674 | NPW = NPW-1 | |
18675 | IF (ID.EQ.1) NPCW = NPCW-1 | |
18676 | DO 9 K=1,4 | |
18677 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18678 | 9 CONTINUE | |
18679 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18680 | NTW = NTW-1 | |
18681 | IF (ID.EQ.1) NTCW = NTCW-1 | |
18682 | DO 10 K=1,4 | |
18683 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18684 | 10 CONTINUE | |
18685 | ENDIF | |
18686 | ENDIF | |
18687 | ENDIF | |
18688 | ENDIF | |
18689 | 3 CONTINUE | |
18690 | ||
18691 | * again: get nuclear potential corresp. to the residual nucleus | |
18692 | IPRCL = IP -NPW | |
18693 | IPZRCL = IPZ-NPCW | |
18694 | ITRCL = IT -NTW | |
18695 | ITZRCL = ITZ-NTCW | |
18696 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) | |
18697 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) | |
18698 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 | |
18699 | C AFERP = 0.0D0 | |
18700 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) | |
18701 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) | |
18702 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 | |
18703 | C AFERT = 0.0D0 | |
18704 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 | |
18705 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 | |
18706 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 | |
18707 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 | |
18708 | AFERP = FERMOD+0.1D0 | |
18709 | AFERT = FERMOD+0.1D0 | |
18710 | ||
18711 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) | |
18712 | ||
18713 | RETURN | |
18714 | END | |
18715 | ||
18716 | *$ CREATE DT_FICONF.FOR | |
18717 | *COPY DT_FICONF | |
18718 | * | |
18719 | *===ficonf=============================================================* | |
18720 | * | |
18721 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) | |
18722 | ||
18723 | ************************************************************************ | |
18724 | * Treatment of FInal CONFiguration including evaporation, fission and * | |
18725 | * Fermi-break-up (for light nuclei only). * | |
18726 | * Adopted from the original routine FINALE and extended to residual * | |
18727 | * projectile nuclei. * | |
18728 | * This version dated 12.12.95 is written by S. Roesler. * | |
18729 | * * | |
18730 | * Last change 27.12.2006 by S. Roesler. * | |
18731 | ************************************************************************ | |
18732 | ||
18733 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18734 | SAVE | |
18735 | PARAMETER ( LINP = 10 , | |
18736 | & LOUT = 6 , | |
18737 | & LDAT = 9 ) | |
18738 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
18739 | PARAMETER (ANGLGB=5.0D-16) | |
18740 | PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3) | |
18741 | ||
18742 | * event history | |
18743 | PARAMETER (NMXHKK=200000) | |
18744 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18745 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18746 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18747 | * extended event history | |
18748 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18749 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18750 | & IHIST(2,NMXHKK) | |
18751 | * rejection counter | |
18752 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
18753 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
18754 | & IREXCI(3),IRDIFF(2),IRINC | |
18755 | * central particle production, impact parameter biasing | |
18756 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
18757 | * particle properties (BAMJET index convention) | |
18758 | CHARACTER*8 ANAME | |
18759 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18760 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18761 | * treatment of residual nuclei: 4-momenta | |
18762 | LOGICAL LRCLPR,LRCLTA | |
18763 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18764 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18765 | * treatment of residual nuclei: properties of residual nuclei | |
18766 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
18767 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
18768 | & NTOTFI(2),NPROFI(2) | |
18769 | * statistics: residual nuclei | |
18770 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
18771 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
18772 | & NINCST(2,4),NINCEV(2), | |
18773 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
18774 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
18775 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
18776 | & NEVAFI(2,2) | |
18777 | * flags for input different options | |
18778 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
18779 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
18780 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
18781 | * (original name: FINUC) | |
18782 | PARAMETER (MXP=999) | |
18783 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
18784 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
18785 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
18786 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
18787 | & KPART (MXP) | |
18788 | * (original name: RESNUC) | |
18789 | LOGICAL LRNFSS, LFRAGM | |
18790 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
18791 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
18792 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
18793 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
18794 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
18795 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
18796 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
18797 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
18798 | & LFRAGM | |
18799 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
18800 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
18801 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
18802 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
18803 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
18804 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
18805 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
18806 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
18807 | * (original name: PAREVT) | |
18808 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
18809 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
18810 | PARAMETER ( NALLWP = 39 ) | |
18811 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
18812 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
18813 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
18814 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
18815 | * event flag | |
18816 | COMMON /DTEVNO/ NEVENT,ICASCA | |
18817 | ||
18818 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), | |
18819 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), | |
18820 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) | |
18821 | ||
18822 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) | |
18823 | LOGICAL LLCPOT | |
18824 | DATA EXC,NEXC /520*ZERO,520*0/ | |
18825 | DATA EXPNUC /4.0D-3,4.0D-3/ | |
18826 | ||
18827 | IREJ = 0 | |
18828 | LRCLPR = .FALSE. | |
18829 | LRCLTA = .FALSE. | |
18830 | ||
18831 | * skip residual nucleus treatment if not requested or in case | |
18832 | * of central collisions | |
18833 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN | |
18834 | ||
18835 | DO 1 K=1,2 | |
18836 | IDPAR(K) = 0 | |
18837 | IDXPAR(K)= 0 | |
18838 | NTOT(K) = 0 | |
18839 | NTOTFI(K)= 0 | |
18840 | NPRO(K) = 0 | |
18841 | NPROFI(K)= 0 | |
18842 | NN(K) = 0 | |
18843 | NH(K) = 0 | |
18844 | NHPOS(K) = 0 | |
18845 | NQ(K) = 0 | |
18846 | EEXC(K) = ZERO | |
18847 | MO1(K) = 0 | |
18848 | MO2(K) = 0 | |
18849 | DO 2 I=1,4 | |
18850 | VRCL(K,I) = ZERO | |
18851 | WRCL(K,I) = ZERO | |
18852 | 2 CONTINUE | |
18853 | 1 CONTINUE | |
18854 | NFSP = 0 | |
18855 | INUC(1) = IP | |
18856 | INUC(2) = IT | |
18857 | ||
18858 | DO 3 I=1,NHKK | |
18859 | ||
18860 | * number of final state particles | |
18861 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
18862 | NFSP = NFSP+1 | |
18863 | IDFSP = IDBAM(I) | |
18864 | ENDIF | |
18865 | ||
18866 | * properties of remaining nucleon configurations | |
18867 | KF = 0 | |
18868 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 | |
18869 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 | |
18870 | IF (KF.GT.0) THEN | |
18871 | IF (MO1(KF).EQ.0) MO1(KF) = I | |
18872 | MO2(KF) = I | |
18873 | * position of residual nucleus = average position of nucleons | |
18874 | DO 4 K=1,4 | |
18875 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) | |
18876 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) | |
18877 | 4 CONTINUE | |
18878 | * total number of particles contributing to each residual nucleus | |
18879 | NTOT(KF) = NTOT(KF)+1 | |
18880 | IDTMP = IDBAM(I) | |
18881 | IDXTMP = I | |
18882 | * total charge of residual nuclei | |
18883 | NQ(KF) = NQ(KF)+IICH(IDTMP) | |
18884 | * number of protons | |
18885 | IF (IDHKK(I).EQ.2212) THEN | |
18886 | NPRO(KF) = NPRO(KF)+1 | |
18887 | * number of neutrons | |
18888 | ELSEIF (IDHKK(I).EQ.2112) THEN | |
18889 | NN(KF) = NN(KF)+1 | |
18890 | ELSE | |
18891 | * number of baryons other than n, p | |
18892 | IF (IIBAR(IDTMP).EQ.1) THEN | |
18893 | NH(KF) = NH(KF)+1 | |
18894 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 | |
18895 | ELSE | |
18896 | * any other mesons (status set to 1) | |
18897 | C WRITE(LOUT,1002) KF,IDTMP | |
18898 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, | |
18899 | C & ' containing meson ',I4,', status set to 1') | |
18900 | ISTHKK(I) = 1 | |
18901 | IDTMP = IDPAR(KF) | |
18902 | IDXTMP = IDXPAR(KF) | |
18903 | NTOT(KF) = NTOT(KF)-1 | |
18904 | ENDIF | |
18905 | ENDIF | |
18906 | IDPAR(KF) = IDTMP | |
18907 | IDXPAR(KF) = IDXTMP | |
18908 | ENDIF | |
18909 | 3 CONTINUE | |
18910 | ||
18911 | * reject elastic events (def: one final state particle = projectile) | |
18912 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN | |
18913 | IREXCI(3) = IREXCI(3)+1 | |
18914 | GOTO 9999 | |
18915 | C RETURN | |
18916 | ENDIF | |
18917 | ||
18918 | * check if one nucleus disappeared.. | |
18919 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN | |
18920 | C DO 5 K=1,4 | |
18921 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) | |
18922 | C PRCLPR(K) = ZERO | |
18923 | C 5 CONTINUE | |
18924 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN | |
18925 | C DO 6 K=1,4 | |
18926 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) | |
18927 | C PRCLTA(K) = ZERO | |
18928 | C 6 CONTINUE | |
18929 | C ENDIF | |
18930 | ||
18931 | ICOR = 0 | |
18932 | INORCL = 0 | |
18933 | DO 7 I=1,2 | |
18934 | DO 8 K=1,4 | |
18935 | * get the average of the nucleon positions | |
18936 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) | |
18937 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) | |
18938 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) | |
18939 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) | |
18940 | 8 CONTINUE | |
18941 | * mass number and charge of residual nuclei | |
18942 | AIF(I) = DBLE(NTOT(I)) | |
18943 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) | |
18944 | IF (NTOT(I).GT.1) THEN | |
18945 | * masses of residual nuclei in ground state | |
18946 | AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I)) | |
18947 | * masses of residual nuclei | |
18948 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) | |
18949 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) | |
18950 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) | |
18951 | * | |
18952 | * M_res^2 < 0 : configuration not allowed | |
18953 | * | |
18954 | * a) re-calculate E_exc with scaled nuclear potential | |
18955 | * (conditional jump to label 9998) | |
18956 | * b) or reject event if N_loop(max) is exceeded | |
18957 | * (conditional jump to label 9999) | |
18958 | * | |
18959 | IF (AMRCL(I).LE.ZERO) THEN | |
18960 | IF (IOULEV(3).GT.0) | |
18961 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), | |
18962 | & PRCL(I,4),NTOT | |
18963 | 1000 FORMAT(1X,'warning! negative excitation energy',/, | |
18964 | & I4,4E15.4,2I4) | |
18965 | AMRCL(I) = ZERO | |
18966 | EEXC(I) = ZERO | |
18967 | IF (NLOOP.LE.500) THEN | |
18968 | GOTO 9998 | |
18969 | ELSE | |
18970 | IREXCI(2) = IREXCI(2)+1 | |
18971 | GOTO 9999 | |
18972 | ENDIF | |
18973 | * | |
18974 | * 0 < M_res < M_res0 : mass below ground-state mass | |
18975 | * | |
18976 | * a) we had residual nuclei with mass N_tot and reasonable E_exc | |
18977 | * before- assign average E_exc of those configurations to this | |
18978 | * one ( Nexc(i,N_tot) > 0 ) | |
18979 | * b) or (and this applies always if run in transport codes) go up | |
18980 | * one mass number and | |
18981 | * i) if mass now larger than proj/targ mass or if run in | |
18982 | * transport codes assign average E_exc per wounded nucleon | |
18983 | * x number of wounded nucleons (Inuc-Ntot) | |
18984 | * ii) or assign average E_exc of those configurations to this | |
18985 | * one ( Nexc(i,m) > 0 ) | |
18986 | * | |
18987 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) | |
18988 | & THEN | |
18989 | M = MIN(NTOT(I),260) | |
18990 | IF (NEXC(I,M).GT.0) THEN | |
18991 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
18992 | ELSE | |
18993 | 70 CONTINUE | |
18994 | M = M+1 | |
18995 | **sr corrected 27.12.06 | |
18996 | * IF (M.GE.INUC(I)) THEN | |
18997 | * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) | |
18998 | IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN | |
18999 | IF ( INUC (I) .GT. NTOT (I) ) THEN | |
19000 | AMRCL(I) = AMRCL0(I) | |
19001 | & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) | |
19002 | ELSE | |
19003 | AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I) | |
19004 | END IF | |
19005 | ** | |
19006 | ELSE | |
19007 | IF (NEXC(I,M).GT.0) THEN | |
19008 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
19009 | ELSE | |
19010 | GOTO 70 | |
19011 | ENDIF | |
19012 | ENDIF | |
19013 | ENDIF | |
19014 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
19015 | ICOR = ICOR+I | |
19016 | * | |
19017 | * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc | |
19018 | * | |
19019 | * a) re-calculate E_exc with scaled nuclear potential | |
19020 | * (conditional jump to label 9998) | |
19021 | * b) or reject event if N_loop(max) is exceeded | |
19022 | * (conditional jump to label 9999) | |
19023 | * | |
19024 | * | |
19025 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN | |
19026 | IF (IOULEV(3).GT.0) | |
19027 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK | |
19028 | 1004 FORMAT(1X,'warning! too high excitation energy',/, | |
19029 | & I4,1P,2E15.4,3I5) | |
19030 | AMRCL(I) = ZERO | |
19031 | EEXC(I) = ZERO | |
19032 | IF (NLOOP.LE.500) THEN | |
19033 | GOTO 9998 | |
19034 | ELSE | |
19035 | IREXCI(2) = IREXCI(2)+1 | |
19036 | GOTO 9999 | |
19037 | ENDIF | |
19038 | * | |
19039 | * Otherwise (reasonable E_exc) : | |
19040 | * E_exc = M_res - M_res0 | |
19041 | * in addition: calculate and save E_exc per wounded nucleon as | |
19042 | * well as E_exc in <E_exc> counter | |
19043 | * | |
19044 | ELSE | |
19045 | * excitation energies of residual nuclei | |
19046 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
19047 | **sr 27.12.06 new excitation energy correction by A.F. | |
19048 | * | |
19049 | * all parts with Ilcopt<3 commented since not used | |
19050 | * | |
19051 | * still to be done/decided: | |
19052 | * Increase Icor and put back both residual nuclei on mass shell | |
19053 | * with the exciting correction further below. | |
19054 | * For the moment the modification in the excitation energy is simply | |
19055 | * corrected by scaling the energy of the residual nucleus. | |
19056 | * | |
19057 | LLCPOT = .TRUE. | |
19058 | ILCOPT = 3 | |
19059 | IF ( LLCPOT ) THEN | |
19060 | NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) | |
19061 | IF ( ILCOPT .LE. 2 ) THEN | |
19062 | C* Patch for Fermi momentum reduction correlated with impact parameter: | |
19063 | C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) | |
19064 | C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) | |
19065 | C AKPRHO = ONE - DLKPRH | |
19066 | C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen | |
19067 | C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, | |
19068 | C & 0.05D+00 ) | |
19069 | C* REDORI = 0.75D+00 | |
19070 | C* REDORI = ONE | |
19071 | C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19072 | ELSE | |
19073 | DLKPRH = ZERO | |
19074 | RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00) | |
19075 | * Take out roughly one/half of the skin: | |
19076 | RDCORE = RDCORE - 0.5D+00 | |
19077 | FRCFLL = RDCORE**3 | |
19078 | PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL | |
19079 | PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL ) | |
19080 | FRCFLL = ONE - PRSKIN | |
19081 | FRMRDC = FRCFLL + 0.5D+00 * PRSKIN | |
19082 | REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19083 | END IF | |
19084 | IF ( NNCHIT .GT. 0 ) THEN | |
19085 | C IF ( ILCOPT .EQ. 1 ) THEN | |
19086 | C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) | |
19087 | C DO 1220 NCH = 1, 10 | |
19088 | C ETAETA = ( ONE - SKINRH**INUC(I) | |
19089 | C & - DBLE(INUC(I))* ( ONE - FRCFLL ) | |
19090 | C & * ( ONE - SKINRH ) ) | |
19091 | C & / ( SKINRH**INUC(I) - DBLE (INUC(I)) | |
19092 | C & * ( ONE - FRCFLL) * SKINRH ) | |
19093 | C SKINRH = SKINRH * ( ONE + ETAETA ) | |
19094 | C 1220 CONTINUE | |
19095 | C PRSKIN = SKINRH**(NNCHIT-1) | |
19096 | C ELSE IF ( ILCOPT .EQ. 2 ) THEN | |
19097 | C PRSKIN = ONE - FRCFLL | |
19098 | C END IF | |
19099 | REDCTN = ZERO | |
19100 | DO 1230 NCH = 1, NNCHIT | |
19101 | IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN | |
19102 | PRFRMI = (( ONE - 2.D+00 * DLKPRH ) | |
19103 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19104 | ELSE | |
19105 | PRFRMI = ( ONE - 2.D+00 * DLKPRH | |
19106 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19107 | END IF | |
19108 | REDCTN = REDCTN + PRFRMI**2 | |
19109 | 1230 CONTINUE | |
19110 | REDCTN = REDCTN / DBLE (NNCHIT) | |
19111 | ELSE | |
19112 | REDCTN = 0.5D+00 | |
19113 | END IF | |
19114 | EEXC (I) = EEXC (I) * REDCTN / REDORI | |
19115 | AMRCL (I) = AMRCL0 (I) + EEXC (I) | |
19116 | PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 ) | |
19117 | END IF | |
19118 | ** | |
19119 | IF (ICASCA.EQ.0) THEN | |
19120 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) | |
19121 | M = MIN(NTOT(I),260) | |
19122 | EXC(I,M) = EXC(I,M)+EEXC(I) | |
19123 | NEXC(I,M) = NEXC(I,M)+1 | |
19124 | ENDIF | |
19125 | ENDIF | |
19126 | ELSEIF (NTOT(I).EQ.1) THEN | |
19127 | WRITE(LOUT,1003) I | |
19128 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') | |
19129 | GOTO 9999 | |
19130 | ELSE | |
19131 | AMRCL0(I) = ZERO | |
19132 | AMRCL(I) = ZERO | |
19133 | EEXC(I) = ZERO | |
19134 | INORCL = INORCL+I | |
19135 | ENDIF | |
19136 | 7 CONTINUE | |
19137 | ||
19138 | PRCLPR(5) = AMRCL(1) | |
19139 | PRCLTA(5) = AMRCL(2) | |
19140 | ||
19141 | IF (ICOR.GT.0) THEN | |
19142 | IF (INORCL.EQ.0) THEN | |
19143 | * one or both residual nuclei consist of one nucleon only, transform | |
19144 | * this nucleon on mass shell | |
19145 | DO 9 K=1,4 | |
19146 | P1IN(K) = PRCL(1,K) | |
19147 | P2IN(K) = PRCL(2,K) | |
19148 | 9 CONTINUE | |
19149 | XM1 = AMRCL(1) | |
19150 | XM2 = AMRCL(2) | |
19151 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
19152 | IF (IREJ1.GT.0) THEN | |
19153 | WRITE(LOUT,*) 'ficonf-mashel rejection' | |
19154 | GOTO 9999 | |
19155 | ENDIF | |
19156 | DO 10 K=1,4 | |
19157 | PRCL(1,K) = P1OUT(K) | |
19158 | PRCL(2,K) = P2OUT(K) | |
19159 | PRCLPR(K) = P1OUT(K) | |
19160 | PRCLTA(K) = P2OUT(K) | |
19161 | 10 CONTINUE | |
19162 | PRCLPR(5) = AMRCL(1) | |
19163 | PRCLTA(5) = AMRCL(2) | |
19164 | ELSE | |
19165 | IF (IOULEV(3).GT.0) | |
19166 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), | |
19167 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), | |
19168 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), | |
19169 | & AMRCL(2),AMRCL(2)-AMRCL0(2) | |
19170 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', | |
19171 | & ' correction',/,11X,'at event',I8, | |
19172 | & ', nucleon config. 1:',2I4,' 2:',2I4, | |
19173 | & 2(/,11X,3E12.3)) | |
19174 | IF (NLOOP.LE.500) THEN | |
19175 | GOTO 9998 | |
19176 | ELSE | |
19177 | IREXCI(1) = IREXCI(1)+1 | |
19178 | ENDIF | |
19179 | ENDIF | |
19180 | ENDIF | |
19181 | ||
19182 | * update counter | |
19183 | C IF (NRESEV(1).NE.NEVHKK) THEN | |
19184 | C NRESEV(1) = NEVHKK | |
19185 | C NRESEV(2) = NRESEV(2)+1 | |
19186 | C ENDIF | |
19187 | NRESEV(2) = NRESEV(2)+1 | |
19188 | DO 15 I=1,2 | |
19189 | EXCDPM(I) = EXCDPM(I)+EEXC(I) | |
19190 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) | |
19191 | NRESTO(I) = NRESTO(I)+NTOT(I) | |
19192 | NRESPR(I) = NRESPR(I)+NPRO(I) | |
19193 | NRESNU(I) = NRESNU(I)+NN(I) | |
19194 | NRESBA(I) = NRESBA(I)+NH(I) | |
19195 | NRESPB(I) = NRESPB(I)+NHPOS(I) | |
19196 | NRESCH(I) = NRESCH(I)+NQ(I) | |
19197 | 15 CONTINUE | |
19198 | ||
19199 | * evaporation | |
19200 | IF (LEVPRT) THEN | |
19201 | DO 13 I=1,2 | |
19202 | * initialize evaporation counter | |
19203 | EEXCFI(I) = ZERO | |
19204 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. | |
19205 | & (EEXC(I).GT.ZERO)) THEN | |
19206 | * put residual nuclei into DTEVT1 | |
19207 | IDRCL = 80000 | |
19208 | JMASS = INT( AIF(I)) | |
19209 | JCHAR = INT(AIZF(I)) | |
19210 | * the following patch is required to transmit the correct excitation | |
19211 | * energy to Eventd | |
19212 | IF (ITRSPT.EQ.1) THEN | |
19213 | IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND. | |
19214 | & (IOULEV(3).GT.0)) | |
19215 | & WRITE(LOUT,*) | |
19216 | & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', | |
19217 | & AMRCL(I),AMRCL0(I),EEXC(I) | |
19218 | PRCL0 = PRCL(I,4) | |
19219 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 | |
19220 | & +PRCL(I,3)**2) | |
19221 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN | |
19222 | WRITE(LOUT,*) | |
19223 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) | |
19224 | ENDIF | |
19225 | ENDIF | |
19226 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), | |
19227 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) | |
19228 | **sr 22.6.97 | |
19229 | NOBAM(NHKK) = I | |
19230 | ** | |
19231 | DO 14 J=1,4 | |
19232 | VHKK(J,NHKK) = VRCL(I,J) | |
19233 | WHKK(J,NHKK) = WRCL(I,J) | |
19234 | 14 CONTINUE | |
19235 | * interface to evaporation module - fill final residual nucleus into | |
19236 | * common FKRESN | |
19237 | * fill resnuc only if code is not used as event generator in Fluka | |
19238 | IF (ITRSPT.NE.1) THEN | |
19239 | PXRES = PRCL(I,1) | |
19240 | PYRES = PRCL(I,2) | |
19241 | PZRES = PRCL(I,3) | |
19242 | IBRES = NPRO(I)+NN(I)+NH(I) | |
19243 | ICRES = NPRO(I)+NHPOS(I) | |
19244 | ANOW = DBLE(IBRES) | |
19245 | ZNOW = DBLE(ICRES) | |
19246 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) | |
19247 | * ground state mass of the residual nucleus (should be equal to AM0T) | |
19248 | AMMRES = AMRCL0(I) | |
19249 | AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES) | |
19250 | * common FKFINU | |
19251 | TV = ZERO | |
19252 | * kinetic energy of residual nucleus | |
19253 | TVRECL = PRCL(I,4)-AMRCL(I) | |
19254 | * excitation energy of residual nucleus | |
19255 | TVCMS = EEXC(I) | |
19256 | PTOLD = PTRES | |
19257 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ | |
19258 | & 2.0D0*(AMMRES+TVCMS)))) | |
19259 | IF (PTOLD.LT.ANGLGB) THEN | |
19260 | CALL DT_RACO(PXRES,PYRES,PZRES) | |
19261 | PTOLD = ONE | |
19262 | ENDIF | |
19263 | PXRES = PXRES*PTRES/PTOLD | |
19264 | PYRES = PYRES*PTRES/PTOLD | |
19265 | PZRES = PZRES*PTRES/PTOLD | |
19266 | * zero counter of secondaries from evaporation | |
19267 | NP = 0 | |
19268 | * evaporation | |
19269 | WE = ONE | |
19270 | CALL DT_EVEVAP(WE) | |
19271 | * put evaporated particles and residual nuclei to DTEVT1 | |
19272 | MO = NHKK | |
19273 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) | |
19274 | ENDIF | |
19275 | EEXCFI(I) = EXCITF | |
19276 | EXCEVA(I) = EXCEVA(I)+EXCITF | |
19277 | ENDIF | |
19278 | 13 CONTINUE | |
19279 | ENDIF | |
19280 | ||
19281 | RETURN | |
19282 | ||
19283 | C9998 IREXCI(1) = IREXCI(1)+1 | |
19284 | 9998 IREJ = IREJ+1 | |
19285 | 9999 CONTINUE | |
19286 | LRCLPR = .TRUE. | |
19287 | LRCLTA = .TRUE. | |
19288 | IREJ = IREJ+1 | |
19289 | RETURN | |
19290 | END | |
19291 | ||
19292 | *$ CREATE DT_EVA2HE.FOR | |
19293 | *COPY DT_EVA2HE | |
19294 | * * | |
19295 | *====eva2he============================================================* | |
19296 | * * | |
19297 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) | |
19298 | ||
19299 | ************************************************************************ | |
19300 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * | |
19301 | * and DTEVT1. * | |
19302 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * | |
19303 | * EEXCF exitation energy of residual nucleus after evaporation * | |
19304 | * IRCL = 1 projectile residual nucleus * | |
19305 | * = 2 target residual nucleus * | |
19306 | * This version dated 19.04.95 is written by S. Roesler. * | |
19307 | * * | |
19308 | * Last change 27.12.2006 by S. Roesler. * | |
19309 | ************************************************************************ | |
19310 | ||
19311 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19312 | SAVE | |
19313 | PARAMETER ( LINP = 10 , | |
19314 | & LOUT = 6 , | |
19315 | & LDAT = 9 ) | |
19316 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) | |
19317 | ||
19318 | * event history | |
19319 | PARAMETER (NMXHKK=200000) | |
19320 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
19321 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
19322 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
19323 | * Note: DTEVT2 - special use for heavy fragments ! | |
19324 | * (IDRES(I) = mass number, IDXRES(I) = charge) | |
19325 | * extended event history | |
19326 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
19327 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
19328 | & IHIST(2,NMXHKK) | |
19329 | * particle properties (BAMJET index convention) | |
19330 | CHARACTER*8 ANAME | |
19331 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
19332 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
19333 | * flags for input different options | |
19334 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
19335 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
19336 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
19337 | * statistics: residual nuclei | |
19338 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
19339 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
19340 | & NINCST(2,4),NINCEV(2), | |
19341 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
19342 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
19343 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
19344 | & NEVAFI(2,2) | |
19345 | * treatment of residual nuclei: properties of residual nuclei | |
19346 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
19347 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
19348 | & NTOTFI(2),NPROFI(2) | |
19349 | * (original name: FINUC) | |
19350 | PARAMETER (MXP=999) | |
19351 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
19352 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
19353 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
19354 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
19355 | & KPART (MXP) | |
19356 | * (original name: FHEAVY,FHEAVC) | |
19357 | PARAMETER ( MXHEAV = 100 ) | |
19358 | CHARACTER*8 ANHEAV | |
19359 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
19360 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
19361 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
19362 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
19363 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
19364 | & IBHEAV ( 12 ) , NPHEAV | |
19365 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
19366 | * (original name: RESNUC) | |
19367 | LOGICAL LRNFSS, LFRAGM | |
19368 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
19369 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
19370 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
19371 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
19372 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
19373 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
19374 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
19375 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
19376 | & LFRAGM | |
19377 | ||
19378 | DIMENSION IPTOKP(39) | |
19379 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
19380 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, | |
19381 | & 100, 101, 97, 102, 98, 103, 109, 115 / | |
19382 | ||
19383 | IREJ = 0 | |
19384 | ||
19385 | * skip if evaporation package is not included | |
19386 | IF (.NOT.LEVAPO) RETURN | |
19387 | ||
19388 | * update counter | |
19389 | IF (NRESEV(3).NE.NEVHKK) THEN | |
19390 | NRESEV(3) = NEVHKK | |
19391 | NRESEV(4) = NRESEV(4)+1 | |
19392 | ENDIF | |
19393 | ||
19394 | IF (LEMCCK) | |
19395 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, | |
19396 | & IDUM,IDUM) | |
19397 | * mass number/charge of residual nucleus before evaporation | |
19398 | IBTOT = IDRES(MO) | |
19399 | IZTOT = IDXRES(MO) | |
19400 | ||
19401 | * protons/neutrons/gammas | |
19402 | DO 1 I=1,NP | |
19403 | PX = CXR(I)*PLR(I) | |
19404 | PY = CYR(I)*PLR(I) | |
19405 | PZ = CZR(I)*PLR(I) | |
19406 | ID = IPTOKP(KPART(I)) | |
19407 | IDPDG = IDT_IPDGHA(ID) | |
19408 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ | |
19409 | & (2.0D0*MAX(TKI(I),TINY10)) | |
19410 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN | |
19411 | WRITE(LOUT,1000) ID,AM,AAM(ID) | |
19412 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', | |
19413 | & 'particle',I3,2E10.3) | |
19414 | ENDIF | |
19415 | PE = TKI(I)+AM | |
19416 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) | |
19417 | NOBAM(NHKK) = IRCL | |
19418 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19419 | IBTOT = IBTOT-IIBAR(ID) | |
19420 | IZTOT = IZTOT-IICH(ID) | |
19421 | 1 CONTINUE | |
19422 | ||
19423 | * heavy fragments | |
19424 | DO 2 I=1,NPHEAV | |
19425 | PX = CXHEAV(I)*PHEAVY(I) | |
19426 | PY = CYHEAV(I)*PHEAVY(I) | |
19427 | PZ = CZHEAV(I)*PHEAVY(I) | |
19428 | IDHEAV = 80000 | |
19429 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ | |
19430 | & (2.0D0*MAX(TKHEAV(I),TINY10)) | |
19431 | PE = TKHEAV(I)+AM | |
19432 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, | |
19433 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) | |
19434 | NOBAM(NHKK) = IRCL | |
19435 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19436 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) | |
19437 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) | |
19438 | 2 CONTINUE | |
19439 | ||
19440 | IF (IBRES.GT.0) THEN | |
19441 | * residual nucleus after evaporation | |
19442 | IDNUC = 80000 | |
19443 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, | |
19444 | & IBRES,ICRES,0) | |
19445 | NOBAM(NHKK) = IRCL | |
19446 | ENDIF | |
19447 | EEXCF = TVCMS | |
19448 | NTOTFI(IRCL) = IBRES | |
19449 | NPROFI(IRCL) = ICRES | |
19450 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) | |
19451 | IBTOT = IBTOT-IBRES | |
19452 | IZTOT = IZTOT-ICRES | |
19453 | ||
19454 | * count events with fission | |
19455 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 | |
19456 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 | |
19457 | ||
19458 | * energy-momentum conservation check | |
19459 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) | |
19460 | C IF (IREJ.GT.0) THEN | |
19461 | C CALL DT_EVTOUT(4) | |
19462 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV | |
19463 | C ENDIF | |
19464 | * baryon-number/charge conservation check | |
19465 | IF (IBTOT+IZTOT.NE.0) THEN | |
19466 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT | |
19467 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', | |
19468 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) | |
19469 | ENDIF | |
19470 | ||
19471 | RETURN | |
19472 | END | |
19473 | ||
19474 | *$ CREATE DT_EBIND.FOR | |
19475 | *COPY DT_EBIND | |
19476 | * | |
19477 | *===ebind==============================================================* | |
19478 | * | |
19479 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) | |
19480 | ||
19481 | ************************************************************************ | |
19482 | * Binding energy for nuclei. * | |
19483 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * | |
19484 | * IA mass number * | |
19485 | * IZ atomic number * | |
19486 | * This version dated 5.5.95 is updated by S. Roesler. * | |
19487 | ************************************************************************ | |
19488 | ||
19489 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19490 | SAVE | |
19491 | PARAMETER ( LINP = 10 , | |
19492 | & LOUT = 6 , | |
19493 | & LDAT = 9 ) | |
19494 | PARAMETER (ZERO=0.0D0) | |
19495 | ||
19496 | DATA A1, A2, A3, A4, A5 | |
19497 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ | |
19498 | ||
19499 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN | |
19500 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ | |
19501 | DT_EBIND = ZERO | |
19502 | RETURN | |
19503 | ENDIF | |
19504 | AA = IA | |
19505 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) | |
19506 | & -A4*(IA-2*IZ)**2/AA | |
19507 | IF (MOD(IA,2).EQ.1) THEN | |
19508 | IA5 = 0 | |
19509 | ELSEIF (MOD(IZ,2).EQ.1) THEN | |
19510 | IA5 = 1 | |
19511 | ELSE | |
19512 | IA5 = -1 | |
19513 | ENDIF | |
19514 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) | |
19515 | ||
19516 | RETURN | |
19517 | END | |
19518 | ||
19519 | **sr 30.6. routine replaced completely | |
19520 | *$ CREATE DT_ENERGY.FOR | |
19521 | *COPY DT_ENERGY | |
19522 | * * | |
19523 | *=== energy ===========================================================* | |
19524 | * * | |
19525 | DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z ) | |
19526 | ||
19527 | C INCLUDE '(DBLPRC)' | |
19528 | * DBLPRC.ADD | |
19529 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19530 | SAVE | |
19531 | * (original name: GLOBAL) | |
19532 | PARAMETER ( KALGNM = 2 ) | |
19533 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
19534 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
19535 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
19536 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
19537 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
19538 | PARAMETER ( AINFNT = 1.0D+30 ) | |
19539 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
19540 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
19541 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
19542 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
19543 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
19544 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
19545 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
19546 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
19547 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
19548 | PARAMETER ( ZERZER = 0.D+00 ) | |
19549 | PARAMETER ( ONEONE = 1.D+00 ) | |
19550 | PARAMETER ( TWOTWO = 2.D+00 ) | |
19551 | PARAMETER ( THRTHR = 3.D+00 ) | |
19552 | PARAMETER ( FOUFOU = 4.D+00 ) | |
19553 | PARAMETER ( FIVFIV = 5.D+00 ) | |
19554 | PARAMETER ( SIXSIX = 6.D+00 ) | |
19555 | PARAMETER ( SEVSEV = 7.D+00 ) | |
19556 | PARAMETER ( EIGEIG = 8.D+00 ) | |
19557 | PARAMETER ( ANINEN = 9.D+00 ) | |
19558 | PARAMETER ( TENTEN = 10.D+00 ) | |
19559 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
19560 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
19561 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
19562 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
19563 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
19564 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
19565 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
19566 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
19567 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
19568 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
19569 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
19570 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
19571 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
19572 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
19573 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
19574 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
19575 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
19576 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
19577 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
19578 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
19579 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
19580 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
19581 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
19582 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
19583 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
19584 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
19585 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
19586 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
19587 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
19588 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
19589 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
19590 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
19591 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
19592 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
19593 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
19594 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
19595 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
19596 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
19597 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
19598 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
19599 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
19600 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
19601 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
19602 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
19603 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
19604 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
19605 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
19606 | & * 1.D-09 ) | |
19607 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
19608 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
19609 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
19610 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
19611 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
19612 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
19613 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
19614 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
19615 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
19616 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
19617 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
19618 | LOGICAL LGBIAS, LGBANA | |
19619 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
19620 | C INCLUDE '(DIMPAR)' | |
19621 | * DIMPAR.ADD | |
19622 | PARAMETER ( MXXRGN = 5000 ) | |
19623 | PARAMETER ( MXXMDF = 82 ) | |
19624 | PARAMETER ( MXXMDE = 54 ) | |
19625 | PARAMETER ( MFSTCK = 1000 ) | |
19626 | PARAMETER ( MESTCK = 100 ) | |
19627 | PARAMETER ( NALLWP = 39 ) | |
19628 | PARAMETER ( NELEMX = 80 ) | |
19629 | PARAMETER ( MPDPDX = 8 ) | |
19630 | PARAMETER ( ICOMAX = 180 ) | |
19631 | PARAMETER ( NSTBIS = 304 ) | |
19632 | PARAMETER ( IDMAXP = 220 ) | |
19633 | PARAMETER ( IDMXDC = 640 ) | |
19634 | PARAMETER ( MKBMX1 = 1 ) | |
19635 | PARAMETER ( MKBMX2 = 1 ) | |
19636 | C INCLUDE '(IOUNIT)' | |
19637 | * IOUNIT.ADD | |
19638 | PARAMETER ( LUNIN = 5 ) | |
19639 | PARAMETER ( LUNOUT = 6 ) | |
19640 | **sr 19.5. set error output-unit from 15 to 6 | |
19641 | PARAMETER ( LUNERR = 6 ) | |
19642 | PARAMETER ( LUNBER = 14 ) | |
19643 | PARAMETER ( LUNECH = 8 ) | |
19644 | PARAMETER ( LUNFLU = 13 ) | |
19645 | PARAMETER ( LUNGEO = 16 ) | |
19646 | PARAMETER ( LUNPMF = 12 ) | |
19647 | PARAMETER ( LUNRAN = 2 ) | |
19648 | PARAMETER ( LUNXSC = 9 ) | |
19649 | PARAMETER ( LUNDET = 17 ) | |
19650 | PARAMETER ( LUNRAY = 10 ) | |
19651 | PARAMETER ( LUNRDB = 1 ) | |
19652 | PARAMETER ( LUNPGO = 7 ) | |
19653 | PARAMETER ( LUNPGS = 4 ) | |
19654 | PARAMETER ( LUNSCR = 3 ) | |
19655 | * | |
19656 | *----------------------------------------------------------------------* | |
19657 | * * | |
19658 | * Revised version of the original routine from EVAP: * | |
19659 | * * | |
19660 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
19661 | * Infn - Milan * | |
19662 | * * | |
19663 | * Last change on 19-sep-95 by Alfredo Ferrari * | |
19664 | * * | |
19665 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19666 | * !!! It is supposed to be used with the updated atomic !!! * | |
19667 | * !!! mass data file !!! * | |
19668 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19669 | * * | |
19670 | *----------------------------------------------------------------------* | |
19671 | * | |
19672 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19673 | * reported in the mass tabulations are completely unstable and made | |
19674 | * up by Z proton masses + N neutron masses: | |
19675 | PARAMETER ( KAFREE = 4 ) | |
19676 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19677 | * reported in the mass tabulations are supposed to be particle unstable | |
19678 | PARAMETER ( KAPUNS = 12 ) | |
19679 | * Minimum energy required for particle unstable isotopes | |
19680 | PARAMETER ( DEPUNS = 0.5D+00 ) | |
19681 | * | |
19682 | * (original name: EVA0) | |
19683 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
19684 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
19685 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
19686 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
19687 | * APRIME (250), IA (6), IZ (6) | |
19688 | * (original name: ISOTOP) | |
19689 | PARAMETER ( NAMSMX = 270 ) | |
19690 | PARAMETER ( NZGVAX = 15 ) | |
19691 | PARAMETER ( NISMMX = 574 ) | |
19692 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
19693 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
19694 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
19695 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
19696 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
19697 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
19698 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
19699 | & INWISM (0:NAMSMX) | |
19700 | * | |
454792a9 | 19701 | CPH SAVE KA0, KZ0, IZ0 |
9aaba0d6 | 19702 | DATA KA0, KZ0, IZ0 / -1, -1, -1 / |
19703 | * | |
19704 | IFLAG = 1 | |
19705 | GO TO 10 | |
19706 | *======================================================================* | |
19707 | * * | |
19708 | * Entry ENergy - KNOWn * | |
19709 | * * | |
19710 | *======================================================================* | |
19711 | ENTRY DT_ENKNOW ( A, Z, IZZ0 ) | |
19712 | IZZ0 =-1 | |
19713 | IFLAG = 2 | |
19714 | 10 CONTINUE | |
19715 | * | |
19716 | KA0 = NINT ( A ) | |
19717 | KZ0 = NINT ( Z ) | |
19718 | N = KA0 - KZ0 | |
19719 | * +-------------------------------------------------------------------* | |
19720 | * | Null residual nucleus: | |
19721 | IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN | |
19722 | IF ( IFLAG .EQ. 1 ) THEN | |
19723 | DT_ENERGY = ZERZER | |
19724 | ELSE | |
19725 | DT_ENKNOW = ZERZER | |
19726 | IZZ0 = -1 | |
19727 | END IF | |
19728 | RETURN | |
19729 | * | | |
19730 | * +-------------------------------------------------------------------* | |
19731 | * | Only protons: | |
19732 | ELSE IF ( N .LE. 0 ) THEN | |
19733 | IF ( N .LT. 0 ) THEN | |
19734 | WRITE ( LUNOUT, * ) | |
19735 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19736 | & KA0, KZ0 | |
19737 | WRITE ( LUNOUT, * ) | |
19738 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19739 | & KA0, KZ0 | |
19740 | WRITE ( 77, * ) | |
19741 | & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!', | |
19742 | & KA0, KZ0 | |
19743 | STOP 'DT_ENERGY:KA0-KZ0' | |
19744 | END IF | |
19745 | IZ0 = -1 | |
19746 | IF ( IFLAG .EQ. 1 ) THEN | |
19747 | DT_ENERGY = Z * WAPS ( 1, 2 ) | |
19748 | ELSE | |
19749 | DT_ENKNOW = Z * WAPS ( 1, 2 ) | |
19750 | IZZ0 = -1 | |
19751 | END IF | |
19752 | RETURN | |
19753 | * | | |
19754 | * +-------------------------------------------------------------------* | |
19755 | * | Only neutrons: | |
19756 | ELSE IF ( KZ0 .LE. 0 ) THEN | |
19757 | IF ( KZ0 .LT. 0 ) THEN | |
19758 | WRITE ( LUNOUT, * ) | |
19759 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19760 | WRITE ( LUNOUT, * ) | |
19761 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19762 | WRITE ( 77, * ) | |
19763 | &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19764 | STOP 'DT_ENERGY:KZ0<0' | |
19765 | END IF | |
19766 | IZ0 = -1 | |
19767 | IF ( IFLAG .EQ. 1 ) THEN | |
19768 | DT_ENERGY = A * WAPS ( 1, 1 ) | |
19769 | ELSE | |
19770 | DT_ENKNOW = A * WAPS ( 1, 1 ) | |
19771 | IZZ0 = -1 | |
19772 | END IF | |
19773 | RETURN | |
19774 | END IF | |
19775 | * | | |
19776 | * +-------------------------------------------------------------------* | |
19777 | * +-------------------------------------------------------------------* | |
19778 | * | No actual nucleus | |
19779 | * | | |
19780 | * +-------------------------------------------------------------------* | |
19781 | * +-------------------------------------------------------------------* | |
19782 | * | A larger than maximum allowed: | |
19783 | IF ( KA0 .GT. NAMSMX ) THEN | |
19784 | IZ0 = -1 | |
19785 | IF ( IFLAG .EQ. 1 ) THEN | |
19786 | DT_ENERGY = DT_ENRG( A, Z ) | |
19787 | ELSE | |
19788 | DT_ENKNOW = DT_ENRG( A, Z ) | |
19789 | IZZ0 = -1 | |
19790 | END IF | |
19791 | RETURN | |
19792 | END IF | |
19793 | * | | |
19794 | * +-------------------------------------------------------------------* | |
19795 | IZZ = INWAPS ( KA0 ) | |
19796 | * +-------------------------------------------------------------------* | |
19797 | * | Too much neutron rich with respect to the stability line: | |
19798 | IF ( KZ0 .LT. IZZ ) THEN | |
19799 | * | +----------------------------------------------------------------* | |
19800 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19801 | IF ( KA0 .LE. KAFREE ) THEN | |
19802 | DT_ENERGY = AINFNT | |
19803 | * | | | |
19804 | * | +----------------------------------------------------------------* | |
19805 | * | | Up to Kapuns: be sure it is particle unstable | |
19806 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19807 | * | | Exp. excess mass for A,IZZ | |
19808 | ENEEXP = WAPS ( KA0, 1 ) | |
19809 | * | | Cameron excess mass for A, IZZ | |
19810 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19811 | * | | Cameron excess mass for A, Z | |
19812 | DT_ENERGY = DT_ENRG( A, Z ) | |
19813 | * | | Use just the difference according to Cameron!!! | |
19814 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19815 | JZZ = INWAPS ( KA0 - 1 ) | |
19816 | LZZ = INWAPS ( KA0 - 2 ) | |
19817 | * | | +-------------------------------------------------------------* | |
19818 | * | | | Residual mass for n-decay known: | |
19819 | IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN | |
19820 | IZ0 = KZ0 - JZZ + 1 | |
19821 | DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1) | |
19822 | & + DEPUNS ) | |
19823 | * | | | | |
19824 | * | | +-------------------------------------------------------------* | |
19825 | * | | | Residual mass for 2n-decay known: | |
19826 | ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN | |
19827 | IZ0 = KZ0 - LZZ + 1 | |
19828 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19829 | & ( WAPS (1,1) + DEPUNS ) ) | |
19830 | * | | | | |
19831 | * | | +-------------------------------------------------------------* | |
19832 | * | | | Set it unbound: | |
19833 | ELSE | |
19834 | DT_ENERGY = AINFNT | |
19835 | END IF | |
19836 | * | | | | |
19837 | * | | +-------------------------------------------------------------* | |
19838 | * | | | |
19839 | * | +----------------------------------------------------------------* | |
19840 | * | | Proceed as usual: | |
19841 | ELSE | |
19842 | * | | Exp. excess mass for A,IZZ | |
19843 | ENEEXP = WAPS ( KA0, 1 ) | |
19844 | * | | Cameron excess mass for A, IZZ | |
19845 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19846 | * | | Cameron excess mass for A, Z | |
19847 | DT_ENERGY = DT_ENRG( A, Z ) | |
19848 | * | | Use just the difference according to Cameron!!! | |
19849 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19850 | END IF | |
19851 | * | | | |
19852 | * | +----------------------------------------------------------------* | |
19853 | * | Be sure not to have a positive energy state: | |
19854 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19855 | IZ0 = -1 | |
19856 | IF ( IFLAG .EQ. 2 ) THEN | |
19857 | DT_ENKNOW = DT_ENERGY | |
19858 | IZZ0 = -1 | |
19859 | END IF | |
19860 | RETURN | |
19861 | * | | |
19862 | * +-------------------------------------------------------------------* | |
19863 | * | Too much proton rich with respect to the stability line: | |
19864 | ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN | |
19865 | * | +----------------------------------------------------------------* | |
19866 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19867 | IF ( KA0 .LE. KAFREE ) THEN | |
19868 | DT_ENERGY = AINFNT | |
19869 | * | | | |
19870 | * | +----------------------------------------------------------------* | |
19871 | * | | Up to Kapuns: be sure it is particle unstable | |
19872 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19873 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19874 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19875 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19876 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19877 | * | | Cameron excess mass for A, Z | |
19878 | DT_ENERGY = DT_ENRG( A, Z ) | |
19879 | * | | Use just the difference according to Cameron!!! | |
19880 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19881 | JZZ = INWAPS ( KA0 - 1 ) | |
19882 | LZZ = INWAPS ( KA0 - 2 ) | |
19883 | * | | +-------------------------------------------------------------* | |
19884 | * | | | Residual mass for p-decay known: | |
19885 | IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN | |
19886 | IZ0 = KZ0 - 1 - JZZ + 1 | |
19887 | DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2) | |
19888 | & + DEPUNS ) | |
19889 | * | | | | |
19890 | * | | +-------------------------------------------------------------* | |
19891 | * | | | Residual mass for 2p-decay known: | |
19892 | ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 ) | |
19893 | & THEN | |
19894 | IZ0 = KZ0 - 2 - LZZ + 1 | |
19895 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19896 | & ( WAPS (1,2) + DEPUNS ) ) | |
19897 | * | | | | |
19898 | * | | +-------------------------------------------------------------* | |
19899 | * | | | Set it unbound: | |
19900 | ELSE | |
19901 | DT_ENERGY = AINFNT | |
19902 | END IF | |
19903 | * | | | | |
19904 | * | | +-------------------------------------------------------------* | |
19905 | * | | | |
19906 | * | +----------------------------------------------------------------* | |
19907 | * | | Proceed as usual: | |
19908 | ELSE | |
19909 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19910 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19911 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19912 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19913 | * | | Cameron excess mass for A, Z | |
19914 | DT_ENERGY = DT_ENRG( A, Z ) | |
19915 | * | | Use just the difference according to Cameron!!! | |
19916 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19917 | END IF | |
19918 | * | | | |
19919 | * | +----------------------------------------------------------------* | |
19920 | * | Be sure not to have a positive energy state: | |
19921 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19922 | IZ0 = -1 | |
19923 | IF ( IFLAG .EQ. 2 ) THEN | |
19924 | DT_ENKNOW = DT_ENERGY | |
19925 | IZZ0 = -1 | |
19926 | END IF | |
19927 | RETURN | |
19928 | * | | |
19929 | * +-------------------------------------------------------------------* | |
19930 | * | Known isotope or anyway isotope "inside" the stability zone | |
19931 | ELSE | |
19932 | IZ0 = KZ0 - IZZ + 1 | |
19933 | DT_ENERGY = WAPS ( KA0, IZ0 ) | |
19934 | IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0 | |
19935 | * | +----------------------------------------------------------------* | |
19936 | * | | Mass not known | |
19937 | IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0 | |
19938 | & .NE. 6) ) THEN | |
19939 | IF ( IFLAG .EQ. 2 ) IZZ0 = -1 | |
19940 | * | | +-------------------------------------------------------------* | |
19941 | * | | | Set it unbound: | |
19942 | IF ( KA0 .LE. KAFREE ) THEN | |
19943 | DT_ENERGY = AINFNT | |
19944 | * | | | | |
19945 | * | | +-------------------------------------------------------------* | |
19946 | * | | | Try to get a reasonable excess mass: | |
19947 | ELSE | |
19948 | JZ0 = -100 | |
19949 | * | | | +----------------------------------------------------------* | |
19950 | * | | | | Check the closest one known: | |
19951 | DO 500 JZZ = 1, NZGVAX | |
19952 | IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND. | |
19953 | & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ | |
19954 | IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550 | |
19955 | 500 CONTINUE | |
19956 | * | | | | | |
19957 | * | | | +----------------------------------------------------------* | |
19958 | 550 CONTINUE | |
19959 | * | | | Exp. excess mass for A,IZZ+JZ0-1 | |
19960 | ENEEXP = WAPS ( KA0, JZ0 ) | |
19961 | * | | | Cameron excess mass for A, IZZ+JZ0-1 | |
19962 | ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) ) | |
19963 | * | | | Cameron excess mass for A, Z | |
19964 | DT_ENERGY = DT_ENRG( A, Z ) | |
19965 | * | | | Use just the difference according to Cameron!!! | |
19966 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19967 | IZ0 = -1 | |
19968 | END IF | |
19969 | * | | | | |
19970 | * | | +-------------------------------------------------------------* | |
19971 | * | | Be sure not to have a positive energy state: | |
19972 | DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) ) | |
19973 | END IF | |
19974 | * | | | |
19975 | * | +----------------------------------------------------------------* | |
19976 | IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY | |
19977 | RETURN | |
19978 | END IF | |
19979 | * | | |
19980 | * +-------------------------------------------------------------------* | |
19981 | *=== End of Function Energy ===========================================* | |
19982 | * RETURN | |
19983 | END | |
19984 | ** | |
19985 | ||
19986 | *$ CREATE DT_ENRG.FOR | |
19987 | *COPY DT_ENRG | |
19988 | * * | |
19989 | *=== enrg =============================================================* | |
19990 | * * | |
19991 | DOUBLE PRECISION FUNCTION DT_ENRG(A,Z) | |
19992 | ||
19993 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19994 | SAVE | |
19995 | ||
19996 | PARAMETER ( ZERZER = 0.D+00 ) | |
19997 | PARAMETER ( ONEONE = 1.D+00 ) | |
19998 | PARAMETER ( LUNIN = 5 ) | |
19999 | PARAMETER ( LUNOUT = 6 ) | |
20000 | * | |
20001 | *----------------------------------------------------------------------* | |
20002 | * * | |
20003 | * Revised version of the original routine from EVAP: * | |
20004 | * * | |
20005 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
20006 | * Infn - Milan * | |
20007 | * * | |
20008 | * Last change on 01-oct-94 by Alfredo Ferrari * | |
20009 | * * | |
20010 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
20011 | * !!! It is supposed to be used with the updated atomic !!! * | |
20012 | * !!! mass data file !!! * | |
20013 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
20014 | * * | |
20015 | *----------------------------------------------------------------------* | |
20016 | * | |
20017 | PARAMETER ( O16OLD = 931.145 D+00 ) | |
20018 | PARAMETER ( O16NEW = 931.19826D+00 ) | |
20019 | PARAMETER ( O16RAT = O16NEW / O16OLD ) | |
20020 | PARAMETER ( C12NEW = 931.49432D+00 ) | |
20021 | PARAMETER ( ADJUST = -8.322737768178909D-02 ) | |
20022 | PARAMETER ( AINFNT = 1.0D+30 ) | |
20023 | * (original name: EVA0) | |
20024 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
20025 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
20026 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
20027 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
20028 | * APRIME (250), IA (6), IZ (6) | |
20029 | LOGICAL LFIRST | |
454792a9 | 20030 | CPH SAVE LFIRST, EXHYDR, EXNEUT |
9aaba0d6 | 20031 | DATA LFIRST / .TRUE. / |
20032 | * | |
20033 | IF ( LFIRST ) THEN | |
20034 | LFIRST = .FALSE. | |
20035 | **sr 30.6. | |
20036 | C EXHYDR = DT_ENERGY( ONEONE, ONEONE ) | |
20037 | C EXNEUT = DT_ENERGY( ONEONE, ZERZER ) | |
20038 | EXHYDR = A | |
20039 | EXNEUT = Z | |
20040 | DT_ENRG = -AINFNT | |
20041 | RETURN | |
20042 | ** | |
20043 | END IF | |
20044 | IZ0 = NINT (Z) | |
20045 | IF ( IZ0 .LE. 0 ) THEN | |
20046 | DT_ENRG = A * EXNEUT | |
20047 | RETURN | |
20048 | END IF | |
20049 | N = NINT (A-Z) | |
20050 | IF ( N .LE. 0 ) THEN | |
20051 | DT_ENRG = Z * EXHYDR | |
20052 | RETURN | |
20053 | END IF | |
20054 | AM2ZOA= (A-Z-Z)/A | |
20055 | AM2ZOA=AM2ZOA*AM2ZOA | |
20056 | A13 = RMASS(NINT(A)) | |
20057 | * A13 = A**.3333333333333333D+00 | |
20058 | AM13 = 1.D+00/A13 | |
20059 | EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A | |
20060 | ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)* | |
20061 | & (1.D+00 -0.62025D+00*AM13*AM13)* | |
20062 | & (A13*A13 -.62025D+00) | |
20063 | EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)* | |
20064 | & AM13-1.5849D+00)* | |
20065 | & AM13*AM13 +1.D+00) | |
20066 | EEX= -0.4323D+00*AM13*Z**1.3333333D+00* | |
20067 | & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13 | |
20068 | & + 1.D+00) | |
20069 | DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N) | |
20070 | DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST ) | |
20071 | DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT ) | |
20072 | RETURN | |
20073 | *=== End of function Enrg =============================================* | |
20074 | END | |
20075 | ||
20076 | *$ CREATE DT_INCINI.FOR | |
20077 | *COPY DT_INCINI | |
20078 | * * | |
20079 | *=== incini ===========================================================* | |
20080 | * * | |
20081 | SUBROUTINE DT_INCINI | |
20082 | ||
20083 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20084 | SAVE | |
20085 | ||
20086 | PARAMETER ( ZERZER = 0.D+00 ) | |
20087 | PARAMETER ( ONEONE = 1.D+00 ) | |
20088 | PARAMETER ( TWOTWO = 2.D+00 ) | |
20089 | PARAMETER ( THRTHR = 3.D+00 ) | |
20090 | PARAMETER ( FOUFOU = 4.D+00 ) | |
20091 | PARAMETER ( EIGEIG = 8.D+00 ) | |
20092 | PARAMETER ( ANINEN = 9.D+00 ) | |
20093 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
20094 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20095 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20096 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
20097 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
20098 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20099 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
20100 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
20101 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
20102 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20103 | ||
20104 | PARAMETER ( LUNOUT = 6 ) | |
20105 | * | |
20106 | *----------------------------------------------------------------------* | |
20107 | * * | |
20108 | * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala * | |
20109 | * Infn - Milan * | |
20110 | * * | |
20111 | * Last change on 02-may-95 by Alfredo Ferrari * | |
20112 | * * | |
20113 | * * | |
20114 | *----------------------------------------------------------------------* | |
20115 | * | |
20116 | * (original name: FHEAVY,FHEAVC) | |
20117 | PARAMETER ( MXHEAV = 100 ) | |
20118 | CHARACTER*8 ANHEAV | |
20119 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
20120 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
20121 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
20122 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
20123 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
20124 | & IBHEAV ( 12 ) , NPHEAV | |
20125 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
20126 | * (original name: INPFLG) | |
20127 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20128 | * (original name: FRBKCM) | |
20129 | PARAMETER ( MXFFBK = 6 ) | |
20130 | PARAMETER ( MXZFBK = 9 ) | |
20131 | PARAMETER ( MXNFBK = 10 ) | |
20132 | PARAMETER ( MXAFBK = 16 ) | |
20133 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20134 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20135 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20136 | PARAMETER ( MXPSST = 300 ) | |
20137 | PARAMETER ( MXPSFB = 41000 ) | |
20138 | LOGICAL LFRMBK, LNCMSS | |
20139 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20140 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20141 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20142 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20143 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20144 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20145 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20146 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20147 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20148 | * (original name: NUCDAT) | |
20149 | PARAMETER ( AMUAMU = AMUGEV ) | |
20150 | PARAMETER ( AMPROT = AMPRTN ) | |
20151 | PARAMETER ( AMNEUT = AMNTRN ) | |
20152 | PARAMETER ( AMELEC = AMELCT ) | |
20153 | PARAMETER ( R0NUCL = 1.12 D+00 ) | |
20154 | PARAMETER ( RCCOUL = 1.7 D+00 ) | |
20155 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
20156 | PARAMETER ( EXPEBN = 2.39 D+00 ) | |
20157 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
20158 | PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 ) | |
20159 | PARAMETER ( AMHYDR = AMPRTN + AMELCT ) | |
20160 | PARAMETER ( AMHTON = AMHYDR - AMNTRN ) | |
20161 | PARAMETER ( AMNTOU = AMNTRN - AMUC12 ) | |
20162 | PARAMETER ( AMUCSQ = AMUC12 * AMUC12 ) | |
20163 | PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 ) | |
20164 | PARAMETER ( GAMMIN = 1.0D-06 ) | |
20165 | PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) | |
20166 | PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) | |
20167 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
20168 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
20169 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
20170 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
20171 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
20172 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
20173 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
20174 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
20175 | * (original name: PAREVT) | |
20176 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20177 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20178 | PARAMETER ( NALLWP = 39 ) | |
20179 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20180 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20181 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20182 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20183 | * (original name: NUCOLD) | |
20184 | COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2), | |
20185 | & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ, | |
20186 | & FSPRED, FEX0RD | |
20187 | * | |
20188 | BBOLD = - 1.D+10 | |
20189 | ZZOLD = - 1.D+10 | |
20190 | SQROLD = - 1.D+10 | |
20191 | APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL | |
20192 | AMNUCL (1) = AMPROT | |
20193 | AMNUCL (2) = AMNEUT | |
20194 | AMNUSQ (1) = AMPROT * AMPROT | |
20195 | AMNUSQ (2) = AMNEUT * AMNEUT | |
20196 | AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) ) | |
20197 | ASQHLP = AMNHLP**2 | |
20198 | * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) ) | |
20199 | AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP | |
20200 | AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 / | |
20201 | & ( 5.6D+00 * ASQHLP ) ) | |
20202 | AV0WEL = AEFRMX + EBNDAV | |
20203 | EBNDNG (1) = EBNDAV | |
20204 | EBNDNG (2) = EBNDAV | |
20205 | AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 ) | |
20206 | CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 ) | |
20207 | AMMC12 = 12.D+00 * AMUGEV + AEXC12 | |
20208 | AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN | |
20209 | AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 ) | |
20210 | CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 ) | |
20211 | AMMO16 = 16.D+00 * AMUGEV + AEXO16 | |
20212 | AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN | |
20213 | AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 ) | |
20214 | CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 ) | |
20215 | AMMS28 = 28.D+00 * AMUGEV + AEXS28 | |
20216 | AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN | |
20217 | AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 ) | |
20218 | CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 ) | |
20219 | AMMC40 = 40.D+00 * AMUGEV + AEXC40 | |
20220 | AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN | |
20221 | AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 ) | |
20222 | CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 ) | |
20223 | AMMF56 = 56.D+00 * AMUGEV + AEXF56 | |
20224 | AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN | |
20225 | AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 ) | |
20226 | CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 ) | |
20227 | AMM107 = 107.D+00 * AMUGEV + AEX107 | |
20228 | AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN | |
20229 | AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 ) | |
20230 | CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 ) | |
20231 | AMM132 = 132.D+00 * AMUGEV + AEX132 | |
20232 | AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN | |
20233 | AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 ) | |
20234 | CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 ) | |
20235 | AMM181 = 181.D+00 * AMUGEV + AEX181 | |
20236 | AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN | |
20237 | AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 ) | |
20238 | CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 ) | |
20239 | AMM208 = 208.D+00 * AMUGEV + AEX208 | |
20240 | AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN | |
20241 | AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 ) | |
20242 | CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 ) | |
20243 | AMM238 = 238.D+00 * AMUGEV + AEX238 | |
20244 | AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN | |
20245 | ||
20246 | AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER ) | |
20247 | AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE ) | |
20248 | AMHEAV (3) = TWOTWO * AMUGEV | |
20249 | & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE ) | |
20250 | AMHEAV (4) = THRTHR * AMUGEV | |
20251 | & + EMVGEV * DT_ENERGY( THRTHR, ONEONE ) | |
20252 | AMHEAV (5) = THRTHR * AMUGEV | |
20253 | & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO ) | |
20254 | AMHEAV (6) = FOUFOU * AMUGEV | |
20255 | & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO ) | |
20256 | ELBNDE (0) = ZERZER | |
20257 | ELBNDE (1) = 13.6D-09 | |
20258 | DO 2000 IZ = 2, 100 | |
20259 | ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN | |
20260 | 2000 CONTINUE | |
20261 | AMNHEA (1) = AMHEAV (1) + ELBNDE (0) | |
20262 | AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1) | |
20263 | AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1) | |
20264 | AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1) | |
20265 | AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2) | |
20266 | AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2) | |
20267 | IF ( LEVPRT ) THEN | |
20268 | WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus', | |
20269 | & ' activated **** ' | |
20270 | IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma', | |
20271 | & ' production activated **** ' | |
20272 | **sr 18.5.95 | |
20273 | * commented, since obsolete | |
20274 | C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"', | |
20275 | C & ' transport activated **** ' | |
20276 | IF ( IFISS .GT. 0 ) | |
20277 | & WRITE ( LUNOUT, * )' **** High Energy fission ', | |
20278 | & ' requested & activated **** ' | |
20279 | IF ( LFRMBK ) | |
20280 | & WRITE ( LUNOUT, * )' **** Fermi Break Up ', | |
20281 | & ' requested & activated **** ' | |
20282 | IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.) | |
20283 | ELSE | |
20284 | LDEEXG = .FALSE. | |
20285 | LHEAVY = .FALSE. | |
20286 | LFRMBK = .FALSE. | |
20287 | IFISS = 0 | |
20288 | END IF | |
20289 | RETURN | |
20290 | *=== End of subroutine incini =========================================* | |
20291 | END | |
20292 | ||
20293 | *$ CREATE DT_STALIN.FOR | |
20294 | *COPY DT_STALIN | |
20295 | * * | |
20296 | *=== stalin ===========================================================* | |
20297 | * * | |
20298 | SUBROUTINE DT_STALIN | |
20299 | ||
20300 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20301 | SAVE | |
20302 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
20303 | PARAMETER ( ZERZER = 0.D+00 ) | |
20304 | PARAMETER ( ONEONE = 1.D+00 ) | |
20305 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20306 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20307 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20308 | PARAMETER ( NSTBIS = 304 ) | |
20309 | PARAMETER ( LUNIN = 5 ) | |
20310 | PARAMETER ( LUNOUT = 6 ) | |
20311 | * | |
20312 | *----------------------------------------------------------------------* | |
20313 | * * | |
20314 | * STAbility LINe calculation: * | |
20315 | * * | |
20316 | * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala * | |
20317 | * Infn - Milan * | |
20318 | * * | |
20319 | * Last change on 04-dec-92 by Alfredo Ferrari * | |
20320 | * * | |
20321 | * * | |
20322 | *----------------------------------------------------------------------* | |
20323 | * | |
20324 | * (original name: ISOTOP) | |
20325 | PARAMETER ( NAMSMX = 270 ) | |
20326 | PARAMETER ( NZGVAX = 15 ) | |
20327 | PARAMETER ( NISMMX = 574 ) | |
20328 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20329 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20330 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20331 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20332 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20333 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20334 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20335 | & INWISM (0:NAMSMX) | |
20336 | * | |
20337 | DIMENSION ZNORM (260) | |
20338 | * +-------------------------------------------------------------------* | |
20339 | * | | |
20340 | DO 1000 IZ=1,100 | |
20341 | DO 500 J=1,2 | |
20342 | ASTLIN (J,IZ) = ZERZER | |
20343 | 500 CONTINUE | |
20344 | 1000 CONTINUE | |
20345 | * | | |
20346 | * +-------------------------------------------------------------------* | |
20347 | * +-------------------------------------------------------------------* | |
20348 | * | | |
20349 | DO 2000 IA=1,260 | |
20350 | ZNORM (IA) = ZERZER | |
20351 | DO 1500 J=1,2 | |
20352 | ZSTLIN (J,IA) = ZERZER | |
20353 | 1500 CONTINUE | |
20354 | 2000 CONTINUE | |
20355 | * | | |
20356 | * +-------------------------------------------------------------------* | |
20357 | * +-------------------------------------------------------------------* | |
20358 | * | Loop on the Atomic Number | |
20359 | DO 3000 IZ=1,100 | |
20360 | AMSSST (IZ) = ZERZER | |
20361 | ANORM = ONEONE | |
20362 | ZTAR = IZ | |
20363 | * | +----------------------------------------------------------------* | |
20364 | * | | Loop on the stable isotopes | |
20365 | DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ) | |
20366 | IA = ISOMNM (IS) | |
20367 | ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA | |
20368 | ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2 | |
20369 | ZNORM (IA) = ZNORM (IA) + ABUISO (IS) | |
20370 | ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ | |
20371 | ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2 | |
20372 | AHELP = IA | |
20373 | IF ( AHELP .LE. 1.00001D+00 ) THEN | |
20374 | ANORM = ONEONE / ( ONEONE - ABUISO (IS) ) | |
20375 | GO TO 2500 | |
20376 | END IF | |
20377 | AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV | |
20378 | & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ) | |
20379 | 2500 CONTINUE | |
20380 | * | | | |
20381 | * | +----------------------------------------------------------------* | |
20382 | AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV | |
20383 | * | Normalize and print A_stab versus Z data: | |
20384 | ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2), | |
20385 | & 0.5D+00 ) | |
20386 | * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)), | |
20387 | * & ' Sigma_st',SNGL(ASTLIN(2,IZ)) | |
20388 | 3000 CONTINUE | |
20389 | * | | |
20390 | * +-------------------------------------------------------------------* | |
20391 | * +-------------------------------------------------------------------* | |
20392 | * | Normalize and print Z_stab versus A data: | |
20393 | DO 4000 IA=1,260 | |
20394 | ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20395 | ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20396 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 ) | |
20397 | IF ( ZNORM (IA) .GT. ANGLGB ) | |
20398 | **sr 2.11. avoid underflows at Pentium | |
20399 | & ZSTLIN (2,IA) = | |
20400 | & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ), | |
20401 | C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2), | |
20402 | & 0.3D+00 ) | |
20403 | 4000 CONTINUE | |
20404 | * | | |
20405 | * +-------------------------------------------------------------------* | |
20406 | * +-------------------------------------------------------------------* | |
20407 | * | Normalize and print Z_stab versus A data: | |
20408 | DO 5000 IA=1,260 | |
20409 | IF ( ZNORM (IA) .LE. ANGLGB ) THEN | |
20410 | DO 4200 JA = IA-1,1,-1 | |
20411 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20412 | IA1 = JA | |
20413 | GO TO 4300 | |
20414 | END IF | |
20415 | 4200 CONTINUE | |
20416 | 4300 CONTINUE | |
20417 | DO 4400 JA = IA+1,260 | |
20418 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20419 | IA2 = JA | |
20420 | GO TO 4500 | |
20421 | END IF | |
20422 | 4400 CONTINUE | |
20423 | IA2 = IA1 | |
20424 | IA1 = IA1 - 1 | |
20425 | 4500 CONTINUE | |
20426 | ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20427 | & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) ) | |
20428 | & + ZSTLIN (1,IA1) | |
20429 | ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20430 | & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) ) | |
20431 | & + ZSTLIN (2,IA1) | |
20432 | END IF | |
20433 | IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) ) | |
20434 | ATOZ = IZ / ASTLIN (1,IZ) | |
20435 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) ) | |
20436 | * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)), | |
20437 | * & ' Sigma_st',SNGL(ZSTLIN(2,IA)) | |
20438 | 5000 CONTINUE | |
20439 | * | | |
20440 | * +-------------------------------------------------------------------* | |
20441 | RETURN | |
20442 | END | |
20443 | ||
20444 | *$ CREATE DT_BERTTP.FOR | |
20445 | *COPY DT_BERTTP | |
20446 | * | |
20447 | *=== berttp ===========================================================* | |
20448 | * * | |
20449 | SUBROUTINE DT_BERTTP | |
20450 | ||
20451 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20452 | SAVE | |
20453 | ||
20454 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
20455 | PARAMETER ( ZERZER = 0.D+00 ) | |
20456 | PARAMETER ( ONEONE = 1.D+00 ) | |
20457 | PARAMETER ( THRTHR = 3.D+00 ) | |
20458 | PARAMETER ( SIXSIX = 6.D+00 ) | |
20459 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20460 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20461 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
20462 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
20463 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20464 | ||
20465 | PARAMETER ( NSTBIS = 304 ) | |
20466 | ||
20467 | PARAMETER ( LUNIN = 5 ) | |
20468 | PARAMETER ( LUNOUT = 6 ) | |
20469 | **sr 19.5. set error output-unit from 15 to 6 | |
20470 | PARAMETER ( LUNERR = 6 ) | |
20471 | C--------------------------------------------------------------------- | |
20472 | C SUBNAME = DT_BERTTP --- READ BERTINI DATA | |
20473 | C--------------------------------------------------------------------- | |
20474 | C ---------------------------------- I-N-C DATA | |
20475 | C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849) | |
20476 | C REAL*8 R8,R8B,CRSC,CS | |
20477 | C REAL*4 R4 | |
20478 | C --------------------------------- EVAPORATION DATA | |
20479 | * (original name: COOKCM) | |
20480 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
20481 | LOGICAL LDEFOZ, LDEFON | |
20482 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
20483 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
20484 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
20485 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
20486 | * (original name: EVA0) | |
20487 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
20488 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
20489 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
20490 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
20491 | * APRIME (250), IA (6), IZ (6) | |
20492 | * (original name: FRBKCM) | |
20493 | PARAMETER ( MXFFBK = 6 ) | |
20494 | PARAMETER ( MXZFBK = 9 ) | |
20495 | PARAMETER ( MXNFBK = 10 ) | |
20496 | PARAMETER ( MXAFBK = 16 ) | |
20497 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20498 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20499 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20500 | PARAMETER ( MXPSST = 300 ) | |
20501 | PARAMETER ( MXPSFB = 41000 ) | |
20502 | LOGICAL LFRMBK, LNCMSS | |
20503 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20504 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20505 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20506 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20507 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20508 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20509 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20510 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20511 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20512 | * (original name: HETTP) | |
20513 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
20514 | * (original name: INPFLG) | |
20515 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20516 | * (original name: ISOTOP) | |
20517 | PARAMETER ( NAMSMX = 270 ) | |
20518 | PARAMETER ( NZGVAX = 15 ) | |
20519 | PARAMETER ( NISMMX = 574 ) | |
20520 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20521 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20522 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20523 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20524 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20525 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20526 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20527 | & INWISM (0:NAMSMX) | |
20528 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
20529 | PARAMETER ( PI = PIPIPI ) | |
20530 | PARAMETER ( PISQ = PIPISQ ) | |
20531 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
20532 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
20533 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
20534 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
20535 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
20536 | & / R0PROT ) | |
20537 | PARAMETER ( RLLE04 = RZNUCL ) | |
20538 | PARAMETER ( RLLE16 = RZNUCL ) | |
20539 | PARAMETER ( RLGT16 = RZNUCL ) | |
20540 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
20541 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
20542 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
20543 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
20544 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
20545 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
20546 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
20547 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
20548 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
20549 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
20550 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
20551 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
20552 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
20553 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
20554 | PARAMETER ( POTBA0 = 1.D+00 ) | |
20555 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
20556 | PARAMETER ( RADPIM = 0.035D+00 ) | |
20557 | PARAMETER ( RDPMHL = 14.D+00 ) | |
20558 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
20559 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
20560 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
20561 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
20562 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
20563 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
20564 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
20565 | PARAMETER ( MXSCIN = 50 ) | |
20566 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
20567 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
20568 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
20569 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
20570 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
20571 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
20572 | & PFRTAB (2:260) | |
20573 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
20574 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
20575 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
20576 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
20577 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
20578 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
20579 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
20580 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
20581 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
20582 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
20583 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
20584 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
20585 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
20586 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
20587 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
20588 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
20589 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
20590 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
20591 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
20592 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
20593 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
20594 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
20595 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
20596 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
20597 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
20598 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
20599 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
20600 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
20601 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
20602 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
20603 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
20604 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
20605 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
20606 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
20607 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
20608 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
20609 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
20610 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
20611 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
20612 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
20613 | & LNCDCY, LNUSCT | |
20614 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
20615 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
20616 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
20617 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
20618 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
20619 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
20620 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
20621 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
20622 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
20623 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
20624 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
20625 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
20626 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
20627 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
20628 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
20629 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
20630 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
20631 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
20632 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
20633 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
20634 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
20635 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
20636 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
20637 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
20638 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
20639 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
20640 | * (original name: NUCLEV) | |
20641 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
20642 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
20643 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
20644 | & CUMRAD (0:160,2), RUSNUC (2), | |
20645 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
20646 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
20647 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
20648 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
20649 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
20650 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
20651 | & LFLVSL, LRLVSL, LEQSBL | |
20652 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
20653 | & MGSSPR (19) , MGSSNE (25) | |
20654 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
20655 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
20656 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
20657 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
20658 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
20659 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
20660 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
20661 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
20662 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
20663 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
20664 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
20665 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
20666 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
20667 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
20668 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
20669 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
20670 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
20671 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
20672 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
20673 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
20674 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
20675 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
20676 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
20677 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
20678 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
20679 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
20680 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
20681 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
20682 | * (original name: PAREVT) | |
20683 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20684 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20685 | PARAMETER ( NALLWP = 39 ) | |
20686 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20687 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20688 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20689 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20690 | * (original name: XSEPAR) | |
20691 | COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100), | |
20692 | & DDNXSE (100), EENXSE (100), ZZNXSE (100), | |
20693 | & EMNXSE (100), XMNXSE (100), | |
20694 | & AAPXSE (100), BBPXSE (100), CCPXSE (100), | |
20695 | & DDPXSE (100), EEPXSE (100), FFPXSE (100), | |
20696 | & ZZPXSE (100), EMPXSE (100), XMPXSE (100) | |
20697 | ||
20698 | C--------------------------------------------------------------------- | |
20699 | **sr 17.5.95 | |
20700 | * modified for use in DPMJET | |
20701 | C WRITE( LUNOUT,'(A,I2)') | |
20702 | C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP | |
20703 | C REWIND NBERTP | |
20704 | IF (LEVPRT) WRITE(LUNOUT,1000) | |
20705 | 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module', | |
20706 | & /,12X,'------------------------------------',/) | |
20707 | NBERNW = 23 | |
f87dab60 | 20708 | CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN') |
9aaba0d6 | 20709 | |
20710 | **sr 17.5. | |
20711 | *!!!! changed to be able to read the ASCII !!!! | |
20712 | ** | |
20713 | C A. Ferrari: first of all read isotopic data | |
20714 | READ (NBERNW,*) ISONDX | |
20715 | READ (NBERNW,*) ISOMNM | |
20716 | READ (NBERNW,*) ABUISO | |
20717 | C READ (NBERTP) ISONDX | |
20718 | C READ (NBERTP) ISOMNM | |
20719 | C READ (NBERTP) ABUISO | |
20720 | DO 1 I=1,4 | |
20721 | C READ (NBERTP) (CRSC(J,I),J=1,600) | |
20722 | C A. Ferrari: commented also the dummy read to save disk space | |
20723 | C READ (NBERTP) | |
20724 | 1 CONTINUE | |
20725 | C READ (NBERTP) CS | |
20726 | C A. Ferrari: commented also the dummy read to save disk space | |
20727 | C READ (NBERTP) | |
20728 | C--------------------------------------------------------------------- | |
20729 | READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001) | |
20730 | READ (NBERNW,*) IA,IZ | |
20731 | DO 2 I=1,6 | |
20732 | FLA(I)=IA(I) | |
20733 | FLZ(I)=IZ(I) | |
20734 | 2 CONTINUE | |
20735 | READ (NBERNW,*) RHO,OMEGA | |
20736 | READ (NBERNW,*) EXMASS | |
20737 | READ (NBERNW,*) CAM2 | |
20738 | READ (NBERNW,*) CAM3 | |
20739 | READ (NBERNW,*) CAM4 | |
20740 | READ (NBERNW,*) CAM5 | |
20741 | READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3) | |
20742 | DO 3 I=1,7 | |
20743 | T(4,I) = ZERZER | |
20744 | 3 CONTINUE | |
20745 | READ (NBERNW,*) RMASS | |
20746 | READ (NBERNW,*) ALPH | |
20747 | READ (NBERNW,*) BET | |
20748 | READ (NBERNW,*) INWAPS | |
20749 | READ (NBERNW,*) WAPS | |
20750 | READ (NBERNW,*) T12NUC | |
20751 | READ (NBERNW,*) JSPNUC | |
20752 | READ (NBERNW,*) JPTNUC | |
20753 | READ (NBERNW,*) INWISM | |
20754 | READ (NBERNW,*) IZWISM | |
20755 | READ (NBERNW,*) WAPISM | |
20756 | READ (NBERNW,*) T12ISM | |
20757 | READ (NBERNW,*) JSPISM | |
20758 | READ (NBERNW,*) JPTISM | |
20759 | READ (NBERNW,*) APRIME | |
20760 | IF (LEVPRT) | |
20761 | &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20762 | READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20763 | IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20764 | & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20765 | WRITE (LUNOUT,*) | |
20766 | & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20767 | STOP | |
20768 | END IF | |
20769 | READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20770 | & EKATAB, PFATAB, PFRTAB | |
20771 | READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20772 | & EMNXSE, XMNXSE | |
20773 | READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20774 | & ZZPXSE, EMPXSE, XMPXSE | |
20775 | * Data about Fermi-breakup: | |
20776 | READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20777 | IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20778 | & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20779 | WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20780 | & ' in the Nuclear Data file ***' | |
20781 | STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20782 | END IF | |
20783 | READ (NBERNW,*) IFRBKN | |
20784 | READ (NBERNW,*) IFRBKZ | |
20785 | READ (NBERNW,*) IFBKSP | |
20786 | READ (NBERNW,*) IFBKST | |
20787 | READ (NBERNW,*) EEXFBK | |
20788 | ||
20789 | CLOSE (UNIT=NBERNW) | |
20790 | ||
20791 | C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001) | |
20792 | C READ (NBERTP) IA,IZ | |
20793 | C DO 2 I=1,6 | |
20794 | C FLA(I)=IA(I) | |
20795 | C FLZ(I)=IZ(I) | |
20796 | C 2 CONTINUE | |
20797 | C READ (NBERTP) RHO,OMEGA | |
20798 | C READ (NBERTP) EXMASS | |
20799 | C READ (NBERTP) CAM2 | |
20800 | C READ (NBERTP) CAM3 | |
20801 | C READ (NBERTP) CAM4 | |
20802 | C READ (NBERTP) CAM5 | |
20803 | C READ (NBERTP) ((T(I,J),J=1,7),I=1,3) | |
20804 | C DO 3 I=1,7 | |
20805 | C T(4,I) = ZERZER | |
20806 | C 3 CONTINUE | |
20807 | C READ (NBERTP) RMASS | |
20808 | C READ (NBERTP) ALPH | |
20809 | C READ (NBERTP) BET | |
20810 | C READ (NBERTP) INWAPS | |
20811 | C READ (NBERTP) WAPS | |
20812 | C READ (NBERTP) T12NUC | |
20813 | C READ (NBERTP) JSPNUC | |
20814 | C READ (NBERTP) JPTNUC | |
20815 | C READ (NBERTP) INWISM | |
20816 | C READ (NBERTP) IZWISM | |
20817 | C READ (NBERTP) WAPISM | |
20818 | C READ (NBERTP) T12ISM | |
20819 | C READ (NBERTP) JSPISM | |
20820 | C READ (NBERTP) JPTISM | |
20821 | C READ (NBERTP) APRIME | |
20822 | C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20823 | C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20824 | C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20825 | C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20826 | C WRITE (LUNOUT,*) | |
20827 | C & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20828 | C STOP | |
20829 | C END IF | |
20830 | C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20831 | C & EKATAB, PFATAB, PFRTAB | |
20832 | C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20833 | C & EMNXSE, XMNXSE | |
20834 | C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20835 | C & ZZPXSE, EMPXSE, XMPXSE | |
20836 | * Data about Fermi-breakup: | |
20837 | C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20838 | C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20839 | C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20840 | C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20841 | C & ' in the Nuclear Data file ***' | |
20842 | C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20843 | C END IF | |
20844 | C READ (NBERTP) IFRBKN | |
20845 | C READ (NBERTP) IFRBKZ | |
20846 | C READ (NBERTP) IFBKSP | |
20847 | C READ (NBERTP) IFBKST | |
20848 | C READ (NBERTP) EEXFBK | |
20849 | C CLOSE (UNIT=NBERTP) | |
20850 | DO 100 JZ = 1, 130 | |
20851 | SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) ) | |
20852 | 100 CONTINUE | |
20853 | DO 200 JA = 1, 200 | |
20854 | SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) ) | |
20855 | 200 CONTINUE | |
20856 | CALL DT_STALIN | |
20857 | IF ( ILVMOD .LE. 0 ) THEN | |
20858 | ILVMOD = IB0 | |
20859 | ELSE | |
20860 | IB0 = ILVMOD | |
20861 | END IF | |
20862 | IF ( LLVMOD ) THEN | |
20863 | DO 300 JZ = 1, IZCOOK | |
20864 | CAM4 (JZ) = PZCOOK (JZ) | |
20865 | 300 CONTINUE | |
20866 | DO 400 JN = 1, INCOOK | |
20867 | CAM5 (JN) = PNCOOK (JZ) | |
20868 | 400 CONTINUE | |
20869 | END IF | |
20870 | **sr | |
20871 | IF (LEVPRT) THEN | |
20872 | WRITE (LUNOUT,*) | |
20873 | IF ( ILVMOD .EQ. 1 ) THEN | |
20874 | WRITE (LUNOUT,*) | |
20875 | & ' **** Standard EVAP T=0 level density used ****' | |
20876 | ELSE IF ( ILVMOD .EQ. 2 ) THEN | |
20877 | WRITE (LUNOUT,*) | |
20878 | & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****' | |
20879 | ELSE IF ( ILVMOD .EQ. 3 ) THEN | |
20880 | WRITE (LUNOUT,*) | |
20881 | & ' **** Julich A-dependent level density used ****' | |
20882 | ELSE IF ( ILVMOD .EQ. 4 ) THEN | |
20883 | WRITE (LUNOUT,*) | |
20884 | & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used', | |
20885 | & ' ****' | |
20886 | ELSE | |
20887 | WRITE (LUNOUT,*) | |
20888 | & ' **** Unknown T=0 level density option requested ****' | |
20889 | STOP 'BERTTP-ILVMOD' | |
20890 | END IF | |
20891 | IF ( JLVMOD .LE. 0 ) THEN | |
20892 | GAMIGN = ZERZER | |
20893 | WRITE (LUNOUT,*) | |
20894 | & ' **** No Excitation en. dependence for level densities ****' | |
20895 | ELSE IF ( JLVMOD .EQ. 1 ) THEN | |
20896 | WRITE (LUNOUT,*) | |
20897 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20898 | WRITE (LUNOUT,*) | |
20899 | & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo', | |
20900 | & ' ****' | |
20901 | GAMIGN = 0.054D+00 | |
20902 | BETIGN = -6.3 D-05 | |
20903 | ALPIGN = 0.154D+00 | |
20904 | POWIGN = ZERZER | |
20905 | ELSE IF ( JLVMOD .EQ. 2 ) THEN | |
20906 | WRITE (LUNOUT,*) | |
20907 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20908 | WRITE (LUNOUT,*) | |
20909 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20910 | STOP 'BERTTP-JLVMOD' | |
20911 | ELSE IF ( JLVMOD .EQ. 3 ) THEN | |
20912 | WRITE (LUNOUT,*) | |
20913 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20914 | WRITE (LUNOUT,*) | |
20915 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20916 | STOP 'BERTTP-JLVMOD' | |
20917 | ELSE IF ( JLVMOD .EQ. 4 ) THEN | |
20918 | WRITE (LUNOUT,*) | |
20919 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20920 | WRITE (LUNOUT,*) | |
20921 | & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo', | |
20922 | & ' ****' | |
20923 | GAMIGN = 0.054D+00 | |
20924 | BETIGN = 0.162D+00 | |
20925 | ALPIGN = 0.114D+00 | |
20926 | POWIGN = -ONETHI | |
20927 | ELSE IF ( JLVMOD .EQ. 5 ) THEN | |
20928 | WRITE (LUNOUT,*) | |
20929 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20930 | WRITE (LUNOUT,*) | |
20931 | & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****' | |
20932 | GAMIGN = 0.051D+00 | |
20933 | BETIGN = 0.098D+00 | |
20934 | ALPIGN = 0.114D+00 | |
20935 | POWIGN = -ONETHI | |
20936 | ELSE IF ( JLVMOD .EQ. 6 ) THEN | |
20937 | WRITE (LUNOUT,*) | |
20938 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20939 | WRITE (LUNOUT,*) | |
20940 | & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****' | |
20941 | GAMIGN = -0.46D+00 | |
20942 | BETIGN = 0.107D+00 | |
20943 | ALPIGN = 0.111D+00 | |
20944 | POWIGN = -ONETHI | |
20945 | ELSE IF ( JLVMOD .EQ. 7 ) THEN | |
20946 | WRITE (LUNOUT,*) | |
20947 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20948 | WRITE (LUNOUT,*) | |
20949 | & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****' | |
20950 | GAMIGN = 0.059D+00 | |
20951 | BETIGN = 0.257D+00 | |
20952 | ALPIGN = 0.072D+00 | |
20953 | POWIGN = -ONETHI | |
20954 | ELSE IF ( JLVMOD .EQ. 8 ) THEN | |
20955 | WRITE (LUNOUT,*) | |
20956 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20957 | WRITE (LUNOUT,*) | |
20958 | & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****' | |
20959 | GAMIGN = -0.37D+00 | |
20960 | BETIGN = 0.229D+00 | |
20961 | ALPIGN = 0.077D+00 | |
20962 | POWIGN = -ONETHI | |
20963 | ELSE | |
20964 | WRITE (LUNOUT,*) | |
20965 | & ' **** Unknown T=oo level density option requested ****' | |
20966 | STOP 'BERTTP-JLVMOD' | |
20967 | END IF | |
20968 | IF ( LLVMOD ) THEN | |
20969 | WRITE (LUNOUT,*) | |
20970 | & ' **** Cook''s modified pairing energy used ****' | |
20971 | ELSE | |
20972 | WRITE (LUNOUT,*) | |
20973 | & ' **** Original Gilbert/Cameron pairing energy used ****' | |
20974 | END IF | |
20975 | ENDIF | |
20976 | ** | |
20977 | ||
20978 | ILVMOD = IB0 | |
20979 | DO 500 JZ = 1, 130 | |
20980 | PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ) | |
20981 | 500 CONTINUE | |
20982 | DO 600 JA = 1, 200 | |
20983 | PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA) | |
20984 | 600 CONTINUE | |
20985 | RETURN | |
20986 | END | |
20987 | ||
20988 | *$ CREATE DT_EVEVAP.FOR | |
20989 | *COPY DT_EVEVAP | |
20990 | * | |
20991 | *====evevap============================================================* | |
20992 | * | |
20993 | SUBROUTINE DT_EVEVAP(WE) | |
20994 | ||
20995 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20996 | SAVE | |
20997 | PARAMETER ( LINP = 10 , | |
20998 | & LOUT = 6 , | |
20999 | & LDAT = 9 ) | |
21000 | ||
21001 | * flags for input different options | |
21002 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
21003 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
21004 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
21005 | ||
21006 | LEVAPO = .FALSE. | |
21007 | ||
21008 | RETURN | |
21009 | END | |
21010 | ||
21011 | *$ CREATE DT_FRBKIN.FOR | |
21012 | *COPY DT_FRBKIN | |
21013 | * | |
21014 | *====frbkin============================================================* | |
21015 | * | |
21016 | SUBROUTINE DT_FRBKIN(LDUM1,LDUM2) | |
21017 | ||
21018 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21019 | SAVE | |
21020 | PARAMETER ( LINP = 10 , | |
21021 | & LOUT = 6 , | |
21022 | & LDAT = 9 ) | |
21023 | ||
21024 | LOGICAL LDUM1,LDUM2 | |
21025 | ||
21026 | RETURN | |
21027 | END | |
21028 | ||
21029 | *$ CREATE DT_EXPLOD.FOR | |
21030 | *COPY DT_EXPLOD | |
21031 | * | |
21032 | *=== explod ===========================================================* | |
21033 | * | |
21034 | SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
21035 | & PYEXPL, PZEXPL ) | |
21036 | ||
21037 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21038 | SAVE | |
21039 | ||
21040 | DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL), | |
21041 | & ETEXPL (NPEXPL), AMEXPL (NPEXPL) | |
21042 | ||
21043 | RETURN | |
21044 | END | |
21045 | ||
21046 | ************************************************************************ | |
21047 | * * | |
21048 | * DPMJET 3.0: cross section routines * | |
21049 | * * | |
21050 | ************************************************************************ | |
21051 | * | |
21052 | * | |
21053 | * SUBROUTINE DT_SHNDIF | |
21054 | * diffractive cross sections (all energies) | |
21055 | * SUBROUTINE DT_PHOXS | |
21056 | * total and inel. cross sections from PHOJET interpol. tables | |
21057 | * SUBROUTINE DT_XSHN | |
21058 | * total and el. cross sections for all energies | |
21059 | * SUBROUTINE DT_SIHNAB | |
21060 | * pion 2-nucleon absorption cross sections | |
21061 | * SUBROUTINE DT_SIGEMU | |
21062 | * cross section for target "compounds" | |
21063 | * SUBROUTINE DT_SIGGA | |
21064 | * photon nucleus cross sections | |
21065 | * SUBROUTINE DT_SIGGAT | |
21066 | * photon nucleus cross sections from tables | |
21067 | * SUBROUTINE DT_SANO | |
21068 | * anomalous hard photon-nucleon cross sections from tables | |
21069 | * SUBROUTINE DT_SIGGP | |
21070 | * photon nucleon cross sections | |
21071 | * SUBROUTINE DT_SIGVEL | |
21072 | * quasi-elastic vector meson prod. cross sections | |
21073 | * DOUBLE PRECISION FUNCTION DT_SIGVP | |
21074 | * sigma_VN(tilde) | |
21075 | * DOUBLE PRECISION FUNCTION DT_RRM2 | |
21076 | * DOUBLE PRECISION FUNCTION DT_RM2 | |
21077 | * DOUBLE PRECISION FUNCTION DT_SAM2 | |
21078 | * SUBROUTINE DT_CKMT | |
21079 | * SUBROUTINE DT_CKMTX | |
21080 | * SUBROUTINE DT_PDF0 | |
21081 | * SUBROUTINE DT_CKMTQ0 | |
21082 | * SUBROUTINE DT_CKMTDE | |
21083 | * SUBROUTINE DT_CKMTPR | |
21084 | * FUNCTION DT_CKMTFF | |
21085 | * | |
21086 | * SUBROUTINE DT_FLUINI | |
21087 | * total nucleon cross section fluctuation treatment | |
21088 | * | |
21089 | * SUBROUTINE DT_SIGTBL | |
21090 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL | |
21091 | * SUBROUTINE DT_XSTABL | |
21092 | * service routines | |
21093 | * | |
21094 | * | |
21095 | *$ CREATE DT_SHNDIF.FOR | |
21096 | *COPY DT_SHNDIF | |
21097 | * | |
21098 | *===shndif===============================================================* | |
21099 | * | |
21100 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) | |
21101 | ||
21102 | ********************************************************************** | |
21103 | * Single diffractive hadron-nucleon cross sections * | |
21104 | * S.Roesler 14/1/93 * | |
21105 | * * | |
21106 | * The cross sections are calculated from extrapolated single * | |
21107 | * diffractive antiproton-proton cross sections (DTUJET92) using * | |
21108 | * scaling relations between total and single diffractive cross * | |
21109 | * sections. * | |
21110 | ********************************************************************** | |
21111 | ||
21112 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21113 | SAVE | |
21114 | PARAMETER (ZERO=0.0D0) | |
21115 | ||
21116 | * particle properties (BAMJET index convention) | |
21117 | CHARACTER*8 ANAME | |
21118 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21119 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21120 | * | |
21121 | CSD1 = 4.201483727D0 | |
21122 | CSD4 = -0.4763103556D-02 | |
21123 | CSD5 = 0.4324148297D0 | |
21124 | * | |
21125 | CHMSD1 = 0.8519297242D0 | |
21126 | CHMSD4 = -0.1443076599D-01 | |
21127 | CHMSD5 = 0.4014954567D0 | |
21128 | * | |
21129 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) | |
21130 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) | |
21131 | * | |
21132 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21133 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) | |
21134 | FRAC = SHMSD/SDIAPP | |
21135 | * | |
21136 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, | |
21137 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, | |
21138 | & 10, 10, 20, 20, 20) KPROJ | |
21139 | * | |
21140 | 10 CONTINUE | |
21141 | *---------------------------- p - p , n - p , sigma0+- - p , | |
21142 | * Lambda - p | |
21143 | CSD1 = 6.004476070D0 | |
21144 | CSD4 = -0.1257784606D-03 | |
21145 | CSD5 = 0.2447335720D0 | |
21146 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21147 | SIGDIH = FRAC*SIGDIF | |
21148 | RETURN | |
21149 | * | |
21150 | 20 CONTINUE | |
21151 | * | |
21152 | KPSCAL = 2 | |
21153 | KTSCAL = 1 | |
21154 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) | |
21155 | DUMZER = ZERO | |
21156 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) | |
21157 | F = SDIAPP/SIGTO | |
21158 | KT = 1 | |
21159 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F | |
21160 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) | |
21161 | SIGDIF = SIGTO*F | |
21162 | SIGDIH = FRAC*SIGDIF | |
21163 | RETURN | |
21164 | * | |
21165 | 999 CONTINUE | |
21166 | *-------------------------- leptons.. | |
21167 | SIGDIF = 1.D-10 | |
21168 | SIGDIH = 1.D-10 | |
21169 | RETURN | |
21170 | END | |
21171 | ||
21172 | *$ CREATE DT_PHOXS.FOR | |
21173 | *COPY DT_PHOXS | |
21174 | * | |
21175 | *===phoxs================================================================* | |
21176 | * | |
21177 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) | |
21178 | ||
21179 | ************************************************************************ | |
21180 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * | |
21181 | * interpolation tables. * | |
21182 | * This version dated 05.11.97 is written by S. Roesler * | |
21183 | ************************************************************************ | |
21184 | ||
21185 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21186 | SAVE | |
21187 | ||
21188 | PARAMETER ( LINP = 10 , | |
21189 | & LOUT = 6 , | |
21190 | & LDAT = 9 ) | |
21191 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21192 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
21193 | & PI = TWOPI/TWO, | |
21194 | & GEV2MB = 0.38938D0) | |
21195 | ||
21196 | LOGICAL LFIRST | |
21197 | DATA LFIRST /.TRUE./ | |
21198 | ||
21199 | * nucleon-nucleon event-generator | |
21200 | CHARACTER*8 CMODEL | |
21201 | LOGICAL LPHOIN | |
21202 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21203 | * particle properties (BAMJET index convention) | |
21204 | CHARACTER*8 ANAME | |
21205 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21206 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21207 | ||
21208 | **PHOJET105a | |
21209 | C PARAMETER (IEETAB=10) | |
21210 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21211 | **PHOJET110 | |
21212 | C energy-interpolation table | |
21213 | INTEGER IEETA2 | |
21214 | PARAMETER ( IEETA2 = 20 ) | |
21215 | INTEGER ISIMAX | |
21216 | DOUBLE PRECISION SIGTAB,SIGECM | |
21217 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21218 | ** | |
21219 | ||
21220 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN | |
21221 | WRITE(LOUT,*) MCGENE | |
21222 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') | |
21223 | STOP | |
21224 | ENDIF | |
21225 | ||
21226 | IF (ECM.LE.ZERO) THEN | |
21227 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) | |
21228 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) | |
21229 | ENDIF | |
21230 | ||
21231 | IF (MODE.EQ.1) THEN | |
21232 | * DL | |
21233 | DELDL = 0.0808D0 | |
21234 | EPSDL = -0.4525D0 | |
21235 | S = ECM*ECM | |
21236 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL | |
21237 | ALPHAP= 0.25D0 | |
21238 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) | |
21239 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) | |
21240 | SINE = STOT-SIGEL | |
21241 | SDIF1 = ZERO | |
21242 | ELSE | |
21243 | * Phojet | |
21244 | IP = 1 | |
21245 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
21246 | I1 = 1 | |
21247 | I2 = 1 | |
21248 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
21249 | DO 1 I=2,ISIMAX | |
21250 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 | |
21251 | 1 CONTINUE | |
21252 | 2 CONTINUE | |
21253 | I1 = I-1 | |
21254 | I2 = I | |
21255 | ELSE | |
21256 | IF (LFIRST) THEN | |
21257 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
21258 | & 'PHOXS: warning! energy above initialization limit (', | |
21259 | & ECM,SIGECM(IP,ISIMAX) | |
21260 | LFIRST = .FALSE. | |
21261 | ENDIF | |
21262 | I1 = ISIMAX | |
21263 | I2 = ISIMAX | |
21264 | ENDIF | |
21265 | FAC2 = ZERO | |
21266 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
21267 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
21268 | FAC1 = ONE-FAC2 | |
21269 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
21270 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
21271 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ | |
21272 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) | |
21273 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) | |
21274 | ENDIF | |
21275 | ||
21276 | RETURN | |
21277 | END | |
21278 | ||
21279 | *$ CREATE DT_XSHN.FOR | |
21280 | *COPY DT_XSHN | |
21281 | * | |
21282 | *===xshn===============================================================* | |
21283 | * | |
21284 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) | |
21285 | ||
21286 | ************************************************************************ | |
21287 | * Total and elastic hadron-nucleon cross section. * | |
21288 | * Below 500GeV cross sections are based on the '98 data compilation * | |
21289 | * of the PDG. At higher energies PHOJET results are used (patched to * | |
21290 | * the low energy data at 500GeV). * | |
21291 | * IP projectile index (BAMJET numbering scheme) * | |
21292 | * (should be in the range 1..25) * | |
21293 | * IT target index (BAMJET numbering scheme) * | |
21294 | * (1 = proton, 8 = neutron) * | |
21295 | * PL laboratory momentum * | |
21296 | * ECM cm. energy (ignored if PL>0) * | |
21297 | * STOT total cross section * | |
21298 | * SELA elastic cross section * | |
21299 | * Last change: 24.4.99 by S. Roesler * | |
21300 | ************************************************************************ | |
21301 | ||
21302 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21303 | SAVE | |
21304 | ||
21305 | PARAMETER ( LINP = 10 , | |
21306 | & LOUT = 6 , | |
21307 | & LDAT = 9 ) | |
21308 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
21309 | ||
21310 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, | |
21311 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) | |
21312 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) | |
21313 | ||
21314 | LOGICAL LFIRST | |
21315 | * particle properties (BAMJET index convention) | |
21316 | CHARACTER*8 ANAME | |
21317 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21318 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21319 | * nucleon-nucleon event-generator | |
21320 | CHARACTER*8 CMODEL | |
21321 | LOGICAL LPHOIN | |
21322 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21323 | **PHOJET105a | |
21324 | C PARAMETER (IEETAB=10) | |
21325 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21326 | **PHOJET110 | |
21327 | C energy-interpolation table | |
21328 | INTEGER IEETA2 | |
21329 | PARAMETER ( IEETA2 = 20 ) | |
21330 | INTEGER ISIMAX | |
21331 | DOUBLE PRECISION SIGTAB,SIGECM | |
21332 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21333 | ||
21334 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) | |
21335 | DIMENSION IDXDAT(25,2) | |
21336 | * | |
21337 | DATA APL / | |
21338 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, | |
21339 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, | |
21340 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, | |
21341 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, | |
21342 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, | |
21343 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, | |
21344 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ | |
21345 | * | |
21346 | * total cross sections: | |
21347 | * p p | |
21348 | DATA (ASIGTO(1,K),K=1,NPOINT) / | |
21349 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21350 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21351 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, | |
21352 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, | |
21353 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, | |
21354 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, | |
21355 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ | |
21356 | * pbar p | |
21357 | DATA (ASIGTO(2,K),K=1,NPOINT) / | |
21358 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, | |
21359 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, | |
21360 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, | |
21361 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, | |
21362 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, | |
21363 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, | |
21364 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ | |
21365 | * n p | |
21366 | DATA (ASIGTO(3,K),K=1,NPOINT) / | |
21367 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21368 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21369 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21370 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, | |
21371 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21372 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21373 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21374 | * pi+ p | |
21375 | DATA (ASIGTO(4,K),K=1,NPOINT) / | |
21376 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21377 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21378 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, | |
21379 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, | |
21380 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, | |
21381 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, | |
21382 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ | |
21383 | * pi- p | |
21384 | DATA (ASIGTO(5,K),K=1,NPOINT) / | |
21385 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, | |
21386 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, | |
21387 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, | |
21388 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, | |
21389 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, | |
21390 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, | |
21391 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ | |
21392 | * K+ p | |
21393 | DATA (ASIGTO(6,K),K=1,NPOINT) / | |
21394 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21395 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21396 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, | |
21397 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, | |
21398 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, | |
21399 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, | |
21400 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ | |
21401 | * K- p | |
21402 | DATA (ASIGTO(7,K),K=1,NPOINT) / | |
21403 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, | |
21404 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, | |
21405 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, | |
21406 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, | |
21407 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, | |
21408 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, | |
21409 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ | |
21410 | * K+ n | |
21411 | DATA (ASIGTO(8,K),K=1,NPOINT) / | |
21412 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21413 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21414 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, | |
21415 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, | |
21416 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, | |
21417 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, | |
21418 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ | |
21419 | * K- n | |
21420 | DATA (ASIGTO(9,K),K=1,NPOINT) / | |
21421 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, | |
21422 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, | |
21423 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, | |
21424 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, | |
21425 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, | |
21426 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, | |
21427 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ | |
21428 | * Lambda p | |
21429 | DATA (ASIGTO(10,K),K=1,NPOINT) / | |
21430 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21431 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, | |
21432 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, | |
21433 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, | |
21434 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21435 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21436 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21437 | * | |
21438 | * elastic cross sections: | |
21439 | * p p | |
21440 | DATA (ASIGEL(1,K),K=1,NPOINT) / | |
21441 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21442 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21443 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, | |
21444 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, | |
21445 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, | |
21446 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, | |
21447 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ | |
21448 | * pbar p | |
21449 | DATA (ASIGEL(2,K),K=1,NPOINT) / | |
21450 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, | |
21451 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, | |
21452 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, | |
21453 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, | |
21454 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, | |
21455 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, | |
21456 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ | |
21457 | * n p | |
21458 | DATA (ASIGEL(3,K),K=1,NPOINT) / | |
21459 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21460 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21461 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21462 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, | |
21463 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21464 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21465 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21466 | * pi+ p | |
21467 | DATA (ASIGEL(4,K),K=1,NPOINT) / | |
21468 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21469 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21470 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, | |
21471 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, | |
21472 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, | |
21473 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, | |
21474 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ | |
21475 | * pi- p | |
21476 | DATA (ASIGEL(5,K),K=1,NPOINT) / | |
21477 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, | |
21478 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, | |
21479 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, | |
21480 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, | |
21481 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, | |
21482 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, | |
21483 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ | |
21484 | * K+ p | |
21485 | DATA (ASIGEL(6,K),K=1,NPOINT) / | |
21486 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, | |
21487 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, | |
21488 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, | |
21489 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, | |
21490 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, | |
21491 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, | |
21492 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ | |
21493 | * K- p | |
21494 | DATA (ASIGEL(7,K),K=1,NPOINT) / | |
21495 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, | |
21496 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, | |
21497 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, | |
21498 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, | |
21499 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, | |
21500 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, | |
21501 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ | |
21502 | * K+ n | |
21503 | DATA (ASIGEL(8,K),K=1,NPOINT) / | |
21504 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21505 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21506 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, | |
21507 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, | |
21508 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, | |
21509 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, | |
21510 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ | |
21511 | * K- n | |
21512 | DATA (ASIGEL(9,K),K=1,NPOINT) / | |
21513 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, | |
21514 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, | |
21515 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, | |
21516 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, | |
21517 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, | |
21518 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, | |
21519 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ | |
21520 | * Lambda p | |
21521 | DATA (ASIGEL(10,K),K=1,NPOINT) / | |
21522 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21523 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, | |
21524 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, | |
21525 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, | |
21526 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21527 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21528 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21529 | ||
21530 | DATA (IDXDAT(K,1),K=1,25) / | |
21531 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, | |
21532 | & 1, 3,45, 8, 9/ | |
21533 | DATA (IDXDAT(K,2),K=1,25) / | |
21534 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, | |
21535 | & 3, 1,45, 6, 7/ | |
21536 | ||
21537 | DATA LFIRST /.TRUE./ | |
21538 | ||
21539 | IF (LFIRST) THEN | |
21540 | APLABL = LOG10(PLABLO) | |
21541 | APLABH = LOG10(PLABHI) | |
21542 | APTHRE = LOG10(PTHRE) | |
21543 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) | |
21544 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) | |
21545 | DUM0 = ZERO | |
21546 | PHOPLA = PLABHI | |
21547 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) | |
21548 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) | |
21549 | IF (MCGENE.EQ.2) THEN | |
21550 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN | |
21551 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21552 | ELSE | |
21553 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21554 | ENDIF | |
21555 | ELSE | |
21556 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21557 | ENDIF | |
21558 | PHOSEL = PHOSTO-PHOSIN | |
21559 | APHOST = LOG10(PHOSTO) | |
21560 | APHOSE = LOG10(PHOSEL) | |
21561 | LFIRST = .FALSE. | |
21562 | ENDIF | |
21563 | STOT = ZERO | |
21564 | SELA = ZERO | |
21565 | PLAB = PL | |
21566 | ECMS = ECM | |
21567 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN | |
21568 | WRITE(LOUT,1000) IP,IT | |
21569 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', | |
21570 | & 'proj/target',2I4) | |
21571 | STOP | |
21572 | ENDIF | |
21573 | ||
21574 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN | |
21575 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) | |
21576 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) | |
21577 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN | |
21578 | WRITE(LOUT,1001) PLAB,ECMS | |
21579 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) | |
21580 | STOP | |
21581 | ENDIF | |
21582 | ||
21583 | * index of spectrum | |
21584 | IDXP = IP | |
21585 | IF (IP.GT.25) THEN | |
21586 | IF (AAM(IP).GT.ZERO) THEN | |
21587 | IF (ABS(IIBAR(IP)).GT.0) THEN | |
21588 | IDXP = 1 | |
21589 | ELSE | |
21590 | IDXP = 13 | |
21591 | ENDIF | |
21592 | ELSE | |
21593 | IDXP = 7 | |
21594 | ENDIF | |
21595 | ENDIF | |
21596 | IDXT = 1 | |
21597 | IF (IT.EQ.8) IDXT = 2 | |
21598 | IDXS = IDXDAT(IDXP,IDXT) | |
21599 | IF (IDXS.EQ.0) RETURN | |
21600 | ||
21601 | * compute momentum bin indices | |
21602 | IF (PLAB.LT.PLABLO) THEN | |
21603 | IDX0 = 1 | |
21604 | IDX1 = 1 | |
21605 | ELSEIF (PLAB.GE.PLABHI) THEN | |
21606 | IDX0 = NPOINT | |
21607 | IDX1 = NPOINT | |
21608 | ELSE | |
21609 | APLAB = LOG10(PLAB) | |
21610 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN | |
21611 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 | |
21612 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN | |
21613 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 | |
21614 | ENDIF | |
21615 | IDX1 = IDX0+1 | |
21616 | ENDIF | |
21617 | ||
21618 | * interpolate cross section | |
21619 | IF (IDXS.GT.10) THEN | |
21620 | IDXS1 = IDXS/10 | |
21621 | IDXS2 = IDXS-10*IDXS1 | |
21622 | IF (IDX0.EQ.IDX1) THEN | |
21623 | IF (IDX0.EQ.1) THEN | |
21624 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) | |
21625 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) | |
21626 | ELSE | |
21627 | DUM0 = ZERO | |
21628 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21629 | PHOSEL = PHOSTO-PHOSIN | |
21630 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) | |
21631 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21632 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) | |
21633 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21634 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21635 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21636 | ENDIF | |
21637 | ELSE | |
21638 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21639 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ | |
21640 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) | |
21641 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ | |
21642 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) | |
21643 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21644 | ASELA1 = ASIGEL(IDXS1,IDX0)+ | |
21645 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) | |
21646 | ASELA2 = ASIGEL(IDXS2,IDX0)+ | |
21647 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) | |
21648 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21649 | ENDIF | |
21650 | ELSE | |
21651 | IF (IDX0.EQ.IDX1) THEN | |
21652 | IF (IDX0.EQ.1) THEN | |
21653 | ASTOT = ASIGTO(IDXS,IDX0) | |
21654 | ASELA = ASIGEL(IDXS,IDX0) | |
21655 | ELSE | |
21656 | DUM0 = ZERO | |
21657 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21658 | PHOSEL = PHOSTO-PHOSIN | |
21659 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) | |
21660 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21661 | ENDIF | |
21662 | ELSE | |
21663 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21664 | ASTOT = ASIGTO(IDXS,IDX0)+ | |
21665 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) | |
21666 | ASELA = ASIGEL(IDXS,IDX0)+ | |
21667 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) | |
21668 | ENDIF | |
21669 | ENDIF | |
21670 | STOT = 10.0D0**ASTOT | |
21671 | SELA = 10.0D0**ASELA | |
21672 | ||
21673 | RETURN | |
21674 | END | |
21675 | ||
21676 | *$ CREATE DT_SIHNAB.FOR | |
21677 | *COPY DT_SIHNAB | |
21678 | * | |
21679 | *===sihnab===============================================================* | |
21680 | * | |
21681 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) | |
21682 | ||
21683 | ********************************************************************** | |
21684 | * Pion 2-nucleon absorption cross sections. * | |
21685 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * | |
21686 | * taken from Ritchie PRC 28 (1983) 926 ) * | |
21687 | * This version dated 18.05.96 is written by S. Roesler * | |
21688 | ********************************************************************** | |
21689 | ||
21690 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21691 | SAVE | |
21692 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) | |
21693 | PARAMETER (AMPR = 938.0D0, | |
21694 | & AMPI = 140.0D0, | |
21695 | & AMDE = TWO*AMPR, | |
21696 | & A = -1.2D0, | |
21697 | & B = 3.5D0, | |
21698 | & C = 7.4D0, | |
21699 | & D = 5600.0D0, | |
21700 | & ER = 2136.0D0) | |
21701 | ||
21702 | SIGABS = ZERO | |
21703 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) | |
21704 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN | |
21705 | PTOT = PLAB*1.0D3 | |
21706 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI | |
21707 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN | |
21708 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) | |
21709 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) | |
21710 | * approximate 3N-abs., I=1-abs. etc. | |
21711 | SIGABS = SIGABS/0.40D0 | |
21712 | * pi0-absorption (rough approximation!!) | |
21713 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS | |
21714 | ||
21715 | RETURN | |
21716 | END | |
21717 | ||
21718 | *$ CREATE DT_SIGEMU.FOR | |
21719 | *COPY DT_SIGEMU | |
21720 | * | |
21721 | *===sigemu=============================================================* | |
21722 | * | |
21723 | SUBROUTINE DT_SIGEMU | |
21724 | ||
21725 | ************************************************************************ | |
21726 | * Combined cross section for target compounds. * | |
21727 | * This version dated 6.4.98 is written by S. Roesler * | |
21728 | ************************************************************************ | |
21729 | ||
21730 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21731 | SAVE | |
21732 | PARAMETER ( LINP = 10 , | |
21733 | & LOUT = 6 , | |
21734 | & LDAT = 9 ) | |
21735 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21736 | & OHALF=0.5D0,ONE=1.0D0) | |
21737 | ||
21738 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21739 | * Glauber formalism: cross sections | |
21740 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21741 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21742 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21743 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21744 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21745 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21746 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21747 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21748 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21749 | & BSLOPE,NEBINI,NQBINI | |
21750 | * emulsion treatment | |
21751 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
21752 | & NCOMPO,IEMUL | |
21753 | * nucleon-nucleon event-generator | |
21754 | CHARACTER*8 CMODEL | |
21755 | LOGICAL LPHOIN | |
21756 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21757 | ||
21758 | IF (MCGENE.NE.4) THEN | |
21759 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' | |
21760 | WRITE(LOUT,'(15X,A)') '-----------------------' | |
21761 | ENDIF | |
21762 | DO 1 IE=1,NEBINI | |
21763 | DO 2 IQ=1,NQBINI | |
21764 | SIGTOT = ZERO | |
21765 | SIGELA = ZERO | |
21766 | SIGQEP = ZERO | |
21767 | SIGQET = ZERO | |
21768 | SIGQE2 = ZERO | |
21769 | SIGPRO = ZERO | |
21770 | SIGDEL = ZERO | |
21771 | SIGDQE = ZERO | |
21772 | ERRTOT = ZERO | |
21773 | ERRELA = ZERO | |
21774 | ERRQEP = ZERO | |
21775 | ERRQET = ZERO | |
21776 | ERRQE2 = ZERO | |
21777 | ERRPRO = ZERO | |
21778 | ERRDEL = ZERO | |
21779 | ERRDQE = ZERO | |
21780 | IF (NCOMPO.GT.0) THEN | |
21781 | DO 3 IC=1,NCOMPO | |
21782 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) | |
21783 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) | |
21784 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) | |
21785 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) | |
21786 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) | |
21787 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) | |
21788 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) | |
21789 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) | |
21790 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 | |
21791 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 | |
21792 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 | |
21793 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 | |
21794 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 | |
21795 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 | |
21796 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 | |
21797 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 | |
21798 | 3 CONTINUE | |
21799 | ERRTOT = SQRT(ERRTOT) | |
21800 | ERRELA = SQRT(ERRELA) | |
21801 | ERRQEP = SQRT(ERRQEP) | |
21802 | ERRQET = SQRT(ERRQET) | |
21803 | ERRQE2 = SQRT(ERRQE2) | |
21804 | ERRPRO = SQRT(ERRPRO) | |
21805 | ERRDEL = SQRT(ERRDEL) | |
21806 | ERRDQE = SQRT(ERRDQE) | |
21807 | ELSE | |
21808 | SIGTOT = XSTOT(IE,IQ,1) | |
21809 | SIGELA = XSELA(IE,IQ,1) | |
21810 | SIGQEP = XSQEP(IE,IQ,1) | |
21811 | SIGQET = XSQET(IE,IQ,1) | |
21812 | SIGQE2 = XSQE2(IE,IQ,1) | |
21813 | SIGPRO = XSPRO(IE,IQ,1) | |
21814 | SIGDEL = XSDEL(IE,IQ,1) | |
21815 | SIGDQE = XSDQE(IE,IQ,1) | |
21816 | ERRTOT = XETOT(IE,IQ,1) | |
21817 | ERRELA = XEELA(IE,IQ,1) | |
21818 | ERRQEP = XEQEP(IE,IQ,1) | |
21819 | ERRQET = XEQET(IE,IQ,1) | |
21820 | ERRQE2 = XEQE2(IE,IQ,1) | |
21821 | ERRPRO = XEPRO(IE,IQ,1) | |
21822 | ERRDEL = XEDEL(IE,IQ,1) | |
21823 | ERRDQE = XEDQE(IE,IQ,1) | |
21824 | ENDIF | |
21825 | IF (MCGENE.NE.4) THEN | |
21826 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) | |
21827 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) | |
21828 | WRITE(LOUT,1001) SIGTOT,ERRTOT | |
21829 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') | |
21830 | WRITE(LOUT,1002) SIGELA,ERRELA | |
21831 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') | |
21832 | WRITE(LOUT,1003) SIGQEP,ERRQEP | |
21833 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', | |
21834 | & F11.5,' mb') | |
21835 | WRITE(LOUT,1004) SIGQET,ERRQET | |
21836 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', | |
21837 | & F11.5,' mb') | |
21838 | WRITE(LOUT,1005) SIGQE2,ERRQE2 | |
21839 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, | |
21840 | & ' +-',F11.5,' mb') | |
21841 | WRITE(LOUT,1006) SIGPRO,ERRPRO | |
21842 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') | |
21843 | WRITE(LOUT,1007) SIGDEL,ERRDEL | |
21844 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') | |
21845 | WRITE(LOUT,1008) SIGDQE,ERRDQE | |
21846 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') | |
21847 | ENDIF | |
21848 | ||
21849 | 2 CONTINUE | |
21850 | 1 CONTINUE | |
21851 | ||
21852 | RETURN | |
21853 | END | |
21854 | ||
21855 | *$ CREATE DT_SIGGA.FOR | |
21856 | *COPY DT_SIGGA | |
21857 | * | |
21858 | *===sigga==============================================================* | |
21859 | * | |
21860 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) | |
21861 | ||
21862 | ************************************************************************ | |
21863 | * Total/inelastic photon-nucleus cross sections. * | |
21864 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * | |
21865 | * production runs !!!! * | |
21866 | * This version dated 27.03.96 is written by S. Roesler * | |
21867 | ************************************************************************ | |
21868 | ||
21869 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21870 | SAVE | |
21871 | PARAMETER ( LINP = 10 , | |
21872 | & LOUT = 6 , | |
21873 | & LDAT = 9 ) | |
21874 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21875 | & OHALF=0.5D0,ONE=1.0D0) | |
21876 | PARAMETER (AMPROT = 0.938D0) | |
21877 | ||
21878 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21879 | * Glauber formalism: cross sections | |
21880 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21881 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21882 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21883 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21884 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21885 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21886 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21887 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21888 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21889 | & BSLOPE,NEBINI,NQBINI | |
21890 | ||
21891 | NT = NTI | |
21892 | X = XI | |
21893 | Q2 = Q2I | |
21894 | ECM = ECMI | |
21895 | XNU = XNUI | |
21896 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21897 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) | |
21898 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) | |
21899 | STOT = XSTOT(1,1,1) | |
21900 | ETOT = XETOT(1,1,1) | |
21901 | SIN = XSPRO(1,1,1) | |
21902 | EIN = XEPRO(1,1,1) | |
21903 | ||
21904 | RETURN | |
21905 | END | |
21906 | ||
21907 | *$ CREATE DT_SIGGAT.FOR | |
21908 | *COPY DT_SIGGAT | |
21909 | * | |
21910 | *===siggat=============================================================* | |
21911 | * | |
21912 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) | |
21913 | ||
21914 | ************************************************************************ | |
21915 | * Total/inelastic photon-nucleus cross sections. * | |
21916 | * Uses pre-tabulated cross section. * | |
21917 | * This version dated 29.07.96 is written by S. Roesler * | |
21918 | ************************************************************************ | |
21919 | ||
21920 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21921 | SAVE | |
21922 | PARAMETER ( LINP = 10 , | |
21923 | & LOUT = 6 , | |
21924 | & LDAT = 9 ) | |
21925 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21926 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21927 | ||
21928 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21929 | * Glauber formalism: cross sections | |
21930 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21931 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21932 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21933 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21934 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21935 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21936 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21937 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21938 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21939 | & BSLOPE,NEBINI,NQBINI | |
21940 | ||
21941 | NTARG = ABS(NT) | |
21942 | I1 = 1 | |
21943 | I2 = 1 | |
21944 | RATE = ONE | |
21945 | IF (NEBINI.GT.1) THEN | |
21946 | IF (ECMI.GE.ECMNN(NEBINI)) THEN | |
21947 | I1 = NEBINI | |
21948 | I2 = NEBINI | |
21949 | RATE = ONE | |
21950 | ELSEIF (ECMI.GT.ECMNN(1)) THEN | |
21951 | DO 1 I=2,NEBINI | |
21952 | IF (ECMI.LT.ECMNN(I)) THEN | |
21953 | I1 = I-1 | |
21954 | I2 = I | |
21955 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
21956 | GOTO 2 | |
21957 | ENDIF | |
21958 | 1 CONTINUE | |
21959 | 2 CONTINUE | |
21960 | ENDIF | |
21961 | ENDIF | |
21962 | J1 = 1 | |
21963 | J2 = 1 | |
21964 | RATQ = ONE | |
21965 | IF (NQBINI.GT.1) THEN | |
21966 | IF (Q2I.GE.Q2G(NQBINI)) THEN | |
21967 | J1 = NQBINI | |
21968 | J2 = NQBINI | |
21969 | RATQ = ONE | |
21970 | ELSEIF (Q2I.GT.Q2G(1)) THEN | |
21971 | DO 3 I=2,NQBINI | |
21972 | IF (Q2I.LT.Q2G(I)) THEN | |
21973 | J1 = I-1 | |
21974 | J2 = I | |
21975 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ | |
21976 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
21977 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
21978 | GOTO 4 | |
21979 | ENDIF | |
21980 | 3 CONTINUE | |
21981 | 4 CONTINUE | |
21982 | ENDIF | |
21983 | ENDIF | |
21984 | ||
21985 | STOT = XSTOT(I1,J1,NTARG)+ | |
21986 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21987 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21988 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ | |
21989 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) | |
21990 | ||
21991 | RETURN | |
21992 | END | |
21993 | ||
21994 | *$ CREATE DT_SANO.FOR | |
21995 | *COPY DT_SANO | |
21996 | * | |
21997 | *===sigano=============================================================* | |
21998 | * | |
21999 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) | |
22000 | ||
22001 | ************************************************************************ | |
22002 | * This version dated 31.07.96 is written by S. Roesler * | |
22003 | ************************************************************************ | |
22004 | ||
22005 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22006 | SAVE | |
22007 | PARAMETER ( LINP = 10 , | |
22008 | & LOUT = 6 , | |
22009 | & LDAT = 9 ) | |
22010 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
22011 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
22012 | PARAMETER (NE = 8) | |
22013 | ||
22014 | * VDM parameter for photon-nucleus interactions | |
22015 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22016 | * properties of interacting particles | |
22017 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
22018 | ||
22019 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) | |
22020 | DATA ECMANO / | |
22021 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, | |
22022 | & 0.100D+04,0.200D+04,0.500D+04 | |
22023 | & / | |
22024 | * fixed cut (3 GeV/c) | |
22025 | DATA FRAANO / | |
22026 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, | |
22027 | & 0.062D+00,0.054D+00,0.042D+00 | |
22028 | & / | |
22029 | DATA SIGHRD / | |
22030 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, | |
22031 | & 3.3086D-01,7.6255D-01,2.1319D+00 | |
22032 | & / | |
22033 | * running cut (based on obsolete Phojet-caluclations, bugs..) | |
22034 | C DATA FRAANO / | |
22035 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, | |
22036 | C & 0.167E+00,0.150E+00,0.131E+00 | |
22037 | C & / | |
22038 | C DATA SIGHRD / | |
22039 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, | |
22040 | C & 2.5736E-01,4.5593E-01,8.2550E-01 | |
22041 | C & / | |
22042 | ||
22043 | DT_SANO = ZERO | |
22044 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN | |
22045 | J1 = 0 | |
22046 | J2 = 0 | |
22047 | RATE = ONE | |
22048 | IF (ECM.GE.ECMANO(NE)) THEN | |
22049 | J1 = NE | |
22050 | J2 = NE | |
22051 | ELSEIF (ECM.GT.ECMANO(1)) THEN | |
22052 | DO 1 IE=2,NE | |
22053 | IF (ECM.LT.ECMANO(IE)) THEN | |
22054 | J1 = IE-1 | |
22055 | J2 = IE | |
22056 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) | |
22057 | GOTO 2 | |
22058 | ENDIF | |
22059 | 1 CONTINUE | |
22060 | 2 CONTINUE | |
22061 | ENDIF | |
22062 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN | |
22063 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) | |
22064 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) | |
22065 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) | |
22066 | ENDIF | |
22067 | ||
22068 | RETURN | |
22069 | END | |
22070 | ||
22071 | *$ CREATE DT_SIGGP.FOR | |
22072 | *COPY DT_SIGGP | |
22073 | * | |
22074 | *===siggp==============================================================* | |
22075 | * | |
22076 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) | |
22077 | ||
22078 | ************************************************************************ | |
22079 | * Total/inelastic photon-nucleon cross sections. * | |
22080 | * This version dated 30.04.96 is written by S. Roesler * | |
22081 | ************************************************************************ | |
22082 | ||
22083 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22084 | SAVE | |
22085 | PARAMETER ( LINP = 10 , | |
22086 | & LOUT = 6 , | |
22087 | & LDAT = 9 ) | |
22088 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22089 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22090 | & PI = TWOPI/TWO, | |
22091 | & GEV2MB = 0.38938D0, | |
22092 | & ALPHEM = ONE/137.0D0) | |
22093 | ||
22094 | * particle properties (BAMJET index convention) | |
22095 | CHARACTER*8 ANAME | |
22096 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22097 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22098 | * VDM parameter for photon-nucleus interactions | |
22099 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22100 | ||
22101 | **PHOJET105a | |
22102 | C CHARACTER*8 MDLNA | |
22103 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
22104 | C PARAMETER (IEETAB=10) | |
22105 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
22106 | **PHOJET110 | |
22107 | C model switches and parameters | |
22108 | CHARACTER*8 MDLNA | |
22109 | INTEGER ISWMDL,IPAMDL | |
22110 | DOUBLE PRECISION PARMDL | |
22111 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
22112 | C energy-interpolation table | |
22113 | INTEGER IEETA2 | |
22114 | PARAMETER ( IEETA2 = 20 ) | |
22115 | INTEGER ISIMAX | |
22116 | DOUBLE PRECISION SIGTAB,SIGECM | |
22117 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
22118 | ** | |
22119 | ||
22120 | C PARAMETER (NPOINT=80) | |
22121 | PARAMETER (NPOINT=16) | |
22122 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22123 | ||
22124 | STOT = ZERO | |
22125 | SINE = ZERO | |
22126 | SDIR = ZERO | |
22127 | ||
22128 | W2 = ECMI**2 | |
22129 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22130 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22131 | Q2 = Q2I | |
22132 | X = XI | |
22133 | * photoprod. | |
22134 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22135 | Q2 = 0.0001D0 | |
22136 | X = Q2/(W2+Q2-AAM(1)**2) | |
22137 | * DIS | |
22138 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22139 | X = Q2/(W2+Q2-AAM(1)**2) | |
22140 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22141 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22142 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22143 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22144 | ELSE | |
22145 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X | |
22146 | STOP | |
22147 | ENDIF | |
22148 | ECM = SQRT(W2) | |
22149 | ||
22150 | IF (MODEGA.EQ.1) THEN | |
22151 | SCALE = SQRT(Q2) | |
22152 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22153 | & IDPDF) | |
22154 | C W = SQRT(W2) | |
22155 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22156 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22157 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22158 | SINE = ZERO | |
22159 | SDIR = ZERO | |
22160 | ELSEIF (MODEGA.EQ.2) THEN | |
22161 | IF (INTRGE(1).EQ.1) THEN | |
22162 | AMLO2 = (3.0D0*AAM(13))**2 | |
22163 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22164 | AMLO2 = AAM(33)**2 | |
22165 | ELSE | |
22166 | AMLO2 = AAM(96)**2 | |
22167 | ENDIF | |
22168 | IF (INTRGE(2).EQ.1) THEN | |
22169 | AMHI2 = W2/TWO | |
22170 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22171 | AMHI2 = W2/4.0D0 | |
22172 | ELSE | |
22173 | AMHI2 = W2 | |
22174 | ENDIF | |
22175 | AMHI20 = (ECM-AAM(1))**2 | |
22176 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22177 | XAMLO = LOG( AMLO2+Q2 ) | |
22178 | XAMHI = LOG( AMHI2+Q2 ) | |
22179 | **PHOJET105a | |
22180 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22181 | **PHOJET112 | |
22182 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22183 | ** | |
22184 | SUM = ZERO | |
22185 | DO 1 J=1,NPOINT | |
22186 | AM2 = EXP(ABSZX(J))-Q2 | |
22187 | IF (AM2.LT.16.0D0) THEN | |
22188 | R = TWO | |
22189 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN | |
22190 | R = 10.0D0/3.0D0 | |
22191 | ELSE | |
22192 | R = 11.0D0/3.0D0 | |
22193 | ENDIF | |
22194 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22195 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22196 | & * (ONE+EPSPOL*Q2/AM2) | |
22197 | SUM = SUM+WEIGHT(J)*FAC | |
22198 | 1 CONTINUE | |
22199 | SINE = SUM | |
22200 | SDIR = DT_SIGVP(X,Q2) | |
22201 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR | |
22202 | SDIR = SDIR/(0.588D0+RL2+Q2) | |
22203 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) | |
22204 | ELSEIF (MODEGA.EQ.3) THEN | |
22205 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) | |
22206 | ELSEIF (MODEGA.EQ.4) THEN | |
22207 | * load cross sections from PHOJET interpolation table | |
22208 | IP = 1 | |
22209 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
22210 | I1 = 1 | |
22211 | I2 = 1 | |
22212 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
22213 | DO 2 I=2,ISIMAX | |
22214 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 | |
22215 | 2 CONTINUE | |
22216 | 3 CONTINUE | |
22217 | I1 = I-1 | |
22218 | I2 = I | |
22219 | ELSE | |
22220 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
22221 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
22222 | I1 = ISIMAX | |
22223 | I2 = ISIMAX | |
22224 | ENDIF | |
22225 | FAC2 = ZERO | |
22226 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
22227 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
22228 | FAC1 = ONE-FAC2 | |
22229 | * cross section dependence on photon virtuality | |
22230 | FSUP1 = ZERO | |
22231 | DO 4 I=1,3 | |
22232 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) | |
22233 | & /(1.D0+Q2/PARMDL(30+I))**2 | |
22234 | 4 CONTINUE | |
22235 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) | |
22236 | FAC1 = FAC1*FSUP1 | |
22237 | FAC2 = FAC2*FSUP1 | |
22238 | FSUP2 = 1.0D0 | |
22239 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
22240 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
22241 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
22242 | **re: | |
22243 | STOT = STOT-SDIR | |
22244 | ** | |
22245 | SDIR = SDIR/(FSUP1*FSUP2) | |
22246 | **re: | |
22247 | STOT = STOT+SDIR | |
22248 | ** | |
22249 | ENDIF | |
22250 | ||
22251 | RETURN | |
22252 | END | |
22253 | ||
22254 | *$ CREATE DT_SIGVEL.FOR | |
22255 | *COPY DT_SIGVEL | |
22256 | * | |
22257 | *===sigvel=============================================================* | |
22258 | * | |
22259 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) | |
22260 | ||
22261 | ************************************************************************ | |
22262 | * Cross section for elastic vector meson production * | |
22263 | * This version dated 10.05.96 is written by S. Roesler * | |
22264 | ************************************************************************ | |
22265 | ||
22266 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22267 | SAVE | |
22268 | PARAMETER ( LINP = 10 , | |
22269 | & LOUT = 6 , | |
22270 | & LDAT = 9 ) | |
22271 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22272 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22273 | & PI = TWOPI/TWO, | |
22274 | & GEV2MB = 0.38938D0, | |
22275 | & ALPHEM = ONE/137.0D0) | |
22276 | ||
22277 | * particle properties (BAMJET index convention) | |
22278 | CHARACTER*8 ANAME | |
22279 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22280 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22281 | * VDM parameter for photon-nucleus interactions | |
22282 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22283 | ||
22284 | W2 = ECMI**2 | |
22285 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22286 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22287 | Q2 = Q2I | |
22288 | X = XI | |
22289 | * photoprod. | |
22290 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22291 | Q2 = 0.0001D0 | |
22292 | X = Q2/(W2+Q2-AAM(1)**2) | |
22293 | * DIS | |
22294 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22295 | X = Q2/(W2+Q2-AAM(1)**2) | |
22296 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22297 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22298 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22299 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22300 | ELSE | |
22301 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X | |
22302 | STOP | |
22303 | ENDIF | |
22304 | ECM = SQRT(W2) | |
22305 | ||
22306 | AMV = AAM(IDXV) | |
22307 | AMV2 = AMV**2 | |
22308 | ||
22309 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
22310 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB | |
22311 | ROSH = 0.1D0 | |
22312 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) | |
22313 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) | |
22314 | ||
22315 | IF (IDXV.EQ.33) THEN | |
22316 | COUPL = 0.00365D0 | |
22317 | ELSE | |
22318 | STOP | |
22319 | ENDIF | |
22320 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) | |
22321 | SIG2 = SELVP | |
22322 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 | |
22323 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP | |
22324 | ||
22325 | RETURN | |
22326 | END | |
22327 | ||
22328 | *$ CREATE DT_SIGVP.FOR | |
22329 | *COPY DT_SIGVP | |
22330 | * | |
22331 | *===sigvp==============================================================* | |
22332 | * | |
22333 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) | |
22334 | ||
22335 | ************************************************************************ | |
22336 | * sigma_Vp * | |
22337 | ************************************************************************ | |
22338 | ||
22339 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22340 | SAVE | |
22341 | ||
22342 | PARAMETER ( LINP = 10 , | |
22343 | & LOUT = 6 , | |
22344 | & LDAT = 9 ) | |
22345 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22346 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22347 | & PI = TWOPI/TWO, | |
22348 | & GEV2MB = 0.38938D0, | |
22349 | & AMPROT = 0.938D0, | |
22350 | & ALPHEM = ONE/137.0D0) | |
22351 | * VDM parameter for photon-nucleus interactions | |
22352 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22353 | ||
22354 | X = XI | |
22355 | Q2 = Q2I | |
22356 | IF (XI.LE.ZERO) X = 0.0001D0 | |
22357 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 | |
22358 | ||
22359 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) | |
22360 | ||
22361 | SCALE = SQRT(Q2) | |
22362 | IF (MODEGA.EQ.1) THEN | |
22363 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22364 | & IDPDF) | |
22365 | C W = ECM | |
22366 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22367 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22368 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22369 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) | |
22370 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB | |
22371 | ELSEIF (MODEGA.EQ.4) THEN | |
22372 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) | |
22373 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT | |
22374 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT | |
22375 | ELSE | |
22376 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' | |
22377 | ENDIF | |
22378 | ||
22379 | RETURN | |
22380 | ||
22381 | END | |
22382 | ||
22383 | *$ CREATE DT_RRM2.FOR | |
22384 | *COPY DT_RRM2 | |
22385 | * | |
22386 | *===RRM2===============================================================* | |
22387 | * | |
22388 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) | |
22389 | ||
22390 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22391 | SAVE | |
22392 | PARAMETER ( LINP = 10 , | |
22393 | & LOUT = 6 , | |
22394 | & LDAT = 9 ) | |
22395 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22396 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22397 | & PI = TWOPI/TWO, | |
22398 | & GEV2MB = 0.38938D0) | |
22399 | ||
22400 | * particle properties (BAMJET index convention) | |
22401 | CHARACTER*8 ANAME | |
22402 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22403 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22404 | * VDM parameter for photon-nucleus interactions | |
22405 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22406 | ||
22407 | S = Q2*(ONE-X)/X+AAM(1)**2 | |
22408 | ECM = SQRT(S) | |
22409 | ||
22410 | IF (INTRGE(1).EQ.1) THEN | |
22411 | AMLO2 = (3.0D0*AAM(13))**2 | |
22412 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22413 | AMLO2 = AAM(33)**2 | |
22414 | ELSE | |
22415 | AMLO2 = AAM(96)**2 | |
22416 | ENDIF | |
22417 | IF (INTRGE(2).EQ.1) THEN | |
22418 | AMHI2 = S/TWO | |
22419 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22420 | AMHI2 = S/4.0D0 | |
22421 | ELSE | |
22422 | AMHI2 = S | |
22423 | ENDIF | |
22424 | AMHI20 = (ECM-AAM(1))**2 | |
22425 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22426 | ||
22427 | AM1C2 = 16.0D0 | |
22428 | AM2C2 = 121.0D0 | |
22429 | IF (AMHI2.LE.AM1C2) THEN | |
22430 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) | |
22431 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22432 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22433 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) | |
22434 | ELSE | |
22435 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22436 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ | |
22437 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) | |
22438 | ENDIF | |
22439 | ||
22440 | RETURN | |
22441 | END | |
22442 | ||
22443 | *$ CREATE DT_RM2.FOR | |
22444 | *COPY DT_RM2 | |
22445 | * | |
22446 | *===RM2================================================================* | |
22447 | * | |
22448 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) | |
22449 | ||
22450 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22451 | SAVE | |
22452 | PARAMETER ( LINP = 10 , | |
22453 | & LOUT = 6 , | |
22454 | & LDAT = 9 ) | |
22455 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22456 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22457 | & PI = TWOPI/TWO, | |
22458 | & GEV2MB = 0.38938D0) | |
22459 | * VDM parameter for photon-nucleus interactions | |
22460 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22461 | ||
22462 | IF (RL2.LE.ZERO) THEN | |
22463 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - | |
22464 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22465 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22466 | ELSE | |
22467 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) | |
22468 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) | |
22469 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI | |
22470 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) | |
22471 | & +EPSPOL*( | |
22472 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI | |
22473 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) | |
22474 | ENDIF | |
22475 | ||
22476 | RETURN | |
22477 | END | |
22478 | ||
22479 | *$ CREATE DT_SAM2.FOR | |
22480 | *COPY DT_SAM2 | |
22481 | * | |
22482 | *===SAM2===============================================================* | |
22483 | * | |
22484 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) | |
22485 | ||
22486 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22487 | SAVE | |
22488 | PARAMETER ( LINP = 10 , | |
22489 | & LOUT = 6 , | |
22490 | & LDAT = 9 ) | |
22491 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
22492 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) | |
22493 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22494 | & PI = TWOPI/TWO, | |
22495 | & GEV2MB = 0.38938D0) | |
22496 | ||
22497 | * particle properties (BAMJET index convention) | |
22498 | CHARACTER*8 ANAME | |
22499 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22500 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22501 | * VDM parameter for photon-nucleus interactions | |
22502 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22503 | ||
22504 | S = ECM**2 | |
22505 | IF (INTRGE(1).EQ.1) THEN | |
22506 | AMLO2 = (3.0D0*AAM(13))**2 | |
22507 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22508 | AMLO2 = AAM(33)**2 | |
22509 | ELSE | |
22510 | AMLO2 = AAM(96)**2 | |
22511 | ENDIF | |
22512 | IF (INTRGE(2).EQ.1) THEN | |
22513 | AMHI2 = S/TWO | |
22514 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22515 | AMHI2 = S/4.0D0 | |
22516 | ELSE | |
22517 | AMHI2 = S | |
22518 | ENDIF | |
22519 | AMHI20 = (ECM-AAM(1))**2 | |
22520 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22521 | ||
22522 | AM1C2 = 16.0D0 | |
22523 | AM2C2 = 121.0D0 | |
22524 | YLO = LOG(AMLO2+Q2) | |
22525 | YC1 = LOG(AM1C2+Q2) | |
22526 | YC2 = LOG(AM2C2+Q2) | |
22527 | YHI = LOG(AMHI2+Q2) | |
22528 | IF (AMHI2.LE.AM1C2) THEN | |
22529 | FACHI = TWO | |
22530 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22531 | FACHI = TENTRD | |
22532 | ELSE | |
22533 | FACHI = ELVTRD | |
22534 | ENDIF | |
22535 | ||
22536 | 1 CONTINUE | |
22537 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) | |
22538 | IF (YSAM2.LE.YC1) THEN | |
22539 | FAC = TWO | |
22540 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN | |
22541 | FAC = TENTRD | |
22542 | ELSE | |
22543 | FAC = ELVTRD | |
22544 | ENDIF | |
22545 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) | |
22546 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) | |
22547 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 | |
22548 | ||
22549 | DT_SAM2 = EXP(YSAM2)-Q2 | |
22550 | ||
22551 | RETURN | |
22552 | END | |
22553 | ||
22554 | *$ CREATE DT_CKMT.FOR | |
22555 | *COPY DT_CKMT | |
22556 | * | |
22557 | *===ckmt===============================================================* | |
22558 | * | |
22559 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, | |
22560 | & F2,IPAR) | |
22561 | ||
22562 | ************************************************************************ | |
22563 | * This version dated 31.01.96 is written by S. Roesler * | |
22564 | ************************************************************************ | |
22565 | ||
22566 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22567 | SAVE | |
22568 | PARAMETER ( LINP = 10 , | |
22569 | & LOUT = 6 , | |
22570 | & LDAT = 9 ) | |
22571 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) | |
22572 | ||
22573 | PARAMETER (Q02 = 2.0D0, | |
22574 | & DQ2 = 10.05D0, | |
22575 | & Q12 = Q02+DQ2) | |
22576 | ||
22577 | DIMENSION PD(-6:6),SEA(3),VAL(2) | |
22578 | ||
22579 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) | |
22580 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) | |
22581 | ADQ2 = LOG10(Q12)-LOG10(Q02) | |
22582 | F2P = (F2Q1-F2Q0)/ADQ2 | |
22583 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) | |
22584 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) | |
22585 | F2PP = (F2PQ1-F2PQ0)/ADQ2 | |
22586 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 | |
22587 | ||
22588 | Q2 = MAX(SCALE**2.0D0,TINY10) | |
22589 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 | |
22590 | IF (Q2.LT.Q02) THEN | |
22591 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22592 | UPV = VAL(1) | |
22593 | DNV = VAL(2) | |
22594 | USEA = SEA(1) | |
22595 | DSEA = SEA(2) | |
22596 | STR = SEA(3) | |
22597 | CHM = 0.0D0 | |
22598 | BOT = 0.0D0 | |
22599 | TOP = 0.0D0 | |
22600 | GL = GLU | |
22601 | ELSE | |
22602 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) | |
22603 | F2 = F2*SMOOTH | |
22604 | UPV = PD(2)-PD(3) | |
22605 | DNV = PD(1)-PD(3) | |
22606 | USEA = PD(3) | |
22607 | DSEA = PD(3) | |
22608 | STR = PD(3) | |
22609 | CHM = PD(4) | |
22610 | BOT = PD(5) | |
22611 | TOP = PD(6) | |
22612 | GL = PD(0) | |
22613 | C UPV = UPV*SMOOTH | |
22614 | C DNV = DNV*SMOOTH | |
22615 | C USEA = USEA*SMOOTH | |
22616 | C DSEA = DSEA*SMOOTH | |
22617 | C STR = STR*SMOOTH | |
22618 | C CHM = CHM*SMOOTH | |
22619 | C GL = GL*SMOOTH | |
22620 | ENDIF | |
22621 | ||
22622 | RETURN | |
22623 | END | |
22624 | C | |
22625 | ||
22626 | *$ CREATE DT_CKMTX.FOR | |
22627 | *COPY DT_CKMTX | |
22628 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) | |
22629 | C********************************************************************** | |
22630 | C | |
22631 | C PDF based on Regge theory, evolved with .... by .... | |
22632 | C | |
22633 | C input: IPAR 2212 proton (not installed) | |
22634 | C 45 Pomeron | |
22635 | C 100 Deuteron | |
22636 | C | |
22637 | C output: PD(-6:6) x*f(x) parton distribution functions | |
22638 | C (PDFLIB convention: d = PD(1), u = PD(2) ) | |
22639 | C | |
22640 | C********************************************************************** | |
22641 | ||
22642 | SAVE | |
22643 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 | |
22644 | PARAMETER ( LINP = 10 , | |
22645 | & LOUT = 6 , | |
22646 | & LDAT = 9 ) | |
22647 | DIMENSION QQ(7) | |
22648 | C | |
22649 | Q2=SNGL(SCALE2) | |
22650 | Q1S=Q2 | |
22651 | XX=SNGL(X) | |
22652 | C QCD lambda for evolution | |
22653 | OWLAM = 0.23D0 | |
22654 | OWLAM2=OWLAM**2 | |
22655 | C Q0**2 for evolution | |
22656 | Q02 = 2.D0 | |
22657 | C | |
22658 | C | |
22659 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... | |
22660 | C q(6)=x*charm, q(7)=x*gluon | |
22661 | C | |
22662 | SB=0. | |
22663 | IF(Q2-Q02) 1,1,2 | |
22664 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) | |
22665 | 1 CONTINUE | |
22666 | IF(IPAR.EQ.2212) THEN | |
22667 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) | |
22668 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) | |
22669 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) | |
22670 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) | |
22671 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) | |
22672 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) | |
22673 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) | |
22674 | C ELSEIF (IPAR.EQ.45) THEN | |
22675 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) | |
22676 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) | |
22677 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) | |
22678 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) | |
22679 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) | |
22680 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) | |
22681 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) | |
22682 | ELSEIF (IPAR.EQ.100) THEN | |
22683 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) | |
22684 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) | |
22685 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) | |
22686 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) | |
22687 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) | |
22688 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) | |
22689 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) | |
22690 | ELSE | |
22691 | WRITE(LOUT,'(1X,A,I4,A)') | |
22692 | & 'CKMTX: IPAR =',IPAR,' not implemented!' | |
22693 | STOP | |
22694 | ENDIF | |
22695 | C | |
22696 | PD(-6) = 0.D0 | |
22697 | PD(-5) = 0.D0 | |
22698 | PD(-4) = DBLE(QQ(6)) | |
22699 | PD(-3) = DBLE(QQ(3)) | |
22700 | PD(-2) = DBLE(QQ(4)) | |
22701 | PD(-1) = DBLE(QQ(5)) | |
22702 | PD(0) = DBLE(QQ(7)) | |
22703 | PD(1) = DBLE(QQ(2)) | |
22704 | PD(2) = DBLE(QQ(1)) | |
22705 | PD(3) = DBLE(QQ(3)) | |
22706 | PD(4) = DBLE(QQ(6)) | |
22707 | PD(5) = 0.D0 | |
22708 | PD(6) = 0.D0 | |
22709 | IF(IPAR.EQ.45) THEN | |
22710 | CDN = (PD(1)-PD(-1))/2.D0 | |
22711 | CUP = (PD(2)-PD(-2))/2.D0 | |
22712 | PD(-1) = PD(-1) + CDN | |
22713 | PD(-2) = PD(-2) + CUP | |
22714 | PD(1) = PD(-1) | |
22715 | PD(2) = PD(-2) | |
22716 | ENDIF | |
22717 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ | |
22718 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ | |
22719 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) | |
22720 | END | |
22721 | C | |
22722 | ||
22723 | *$ CREATE DT_PDF0.FOR | |
22724 | *COPY DT_PDF0 | |
22725 | * | |
22726 | *===pdf0===============================================================* | |
22727 | * | |
22728 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22729 | ||
22730 | ************************************************************************ | |
22731 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22732 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22733 | * IPAR = 2212 proton * | |
22734 | * = 100 deuteron * | |
22735 | * This version dated 31.01.96 is written by S. Roesler * | |
22736 | ************************************************************************ | |
22737 | ||
22738 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22739 | SAVE | |
22740 | PARAMETER ( LINP = 10 , | |
22741 | & LOUT = 6 , | |
22742 | & LDAT = 9 ) | |
22743 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22744 | ||
22745 | PARAMETER ( | |
22746 | & AA = 0.1502D0, | |
22747 | & BBDEU = 1.2D0, | |
22748 | & BUD = 0.754D0, | |
22749 | & BDD = 0.4495D0, | |
22750 | & BUP = 1.2064D0, | |
22751 | & BDP = 0.1798D0, | |
22752 | & DELTA0 = 0.07684D0, | |
22753 | & D = 1.117D0, | |
22754 | & C = 3.5489D0, | |
22755 | & A = 0.2631D0, | |
22756 | & B = 0.6452D0, | |
22757 | & ALPHAR = 0.415D0, | |
22758 | & E = 0.1D0 | |
22759 | & ) | |
22760 | ||
22761 | PARAMETER (NPOINT=16) | |
22762 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22763 | DIMENSION SEA(3),VAL(2) | |
22764 | ||
22765 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22766 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22767 | * proton, deuteron | |
22768 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22769 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22770 | SEA(1) = 0.75D0*SEA0 | |
22771 | SEA(2) = SEA(1) | |
22772 | SEA(3) = SEA(1) | |
22773 | VAL(1) = 9.0D0/4.0D0*VALU0 | |
22774 | VAL(2) = 9.0D0*VALD0 | |
22775 | GLU0 = SEA(1)/(1.0D0-X) | |
22776 | F2 = SEA0+VALU0+VALD0 | |
22777 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ | |
22778 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ | |
22779 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) | |
22780 | IF (ABS(F2-F2PDF).GT.TINY9) THEN | |
22781 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF | |
22782 | STOP | |
22783 | ENDIF | |
22784 | **PHOJET105a | |
22785 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22786 | **PHOJET112 | |
22787 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22788 | ** | |
22789 | C SUMQ = ZERO | |
22790 | C SUMG = ZERO | |
22791 | C DO 1 J=1,NPOINT | |
22792 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) | |
22793 | C VALU0 = 9.0D0/4.0D0*VALU0 | |
22794 | C VALD0 = 9.0D0*VALD0 | |
22795 | C SEA0 = 0.75D0*SEA0 | |
22796 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) | |
22797 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) | |
22798 | C 1 CONTINUE | |
22799 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG | |
22800 | ELSE | |
22801 | WRITE(LOUT,'(1X,A,I4,A)') | |
22802 | & 'PDF0: IPAR =',IPAR,' not implemented!' | |
22803 | STOP | |
22804 | ENDIF | |
22805 | ||
22806 | RETURN | |
22807 | END | |
22808 | ||
22809 | *$ CREATE DT_CKMTQ0.FOR | |
22810 | *COPY DT_CKMTQ0 | |
22811 | * | |
22812 | *===ckmtq0=============================================================* | |
22813 | * | |
22814 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22815 | ||
22816 | ************************************************************************ | |
22817 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22818 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22819 | * IPAR = 2212 proton * | |
22820 | * = 100 deuteron * | |
22821 | * This version dated 31.01.96 is written by S. Roesler * | |
22822 | ************************************************************************ | |
22823 | ||
22824 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22825 | SAVE | |
22826 | PARAMETER ( LINP = 10 , | |
22827 | & LOUT = 6 , | |
22828 | & LDAT = 9 ) | |
22829 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22830 | ||
22831 | PARAMETER ( | |
22832 | & AA = 0.1502D0, | |
22833 | & BBDEU = 1.2D0, | |
22834 | & BUD = 0.754D0, | |
22835 | & BDD = 0.4495D0, | |
22836 | & BUP = 1.2064D0, | |
22837 | & BDP = 0.1798D0, | |
22838 | & DELTA0 = 0.07684D0, | |
22839 | & D = 1.117D0, | |
22840 | & C = 3.5489D0, | |
22841 | & A = 0.2631D0, | |
22842 | & B = 0.6452D0, | |
22843 | & ALPHAR = 0.415D0, | |
22844 | & E = 0.1D0 | |
22845 | & ) | |
22846 | ||
22847 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22848 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22849 | * proton, deuteron | |
22850 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22851 | IF (IPAR.EQ.2212) THEN | |
22852 | BU = BUP | |
22853 | BD = BDP | |
22854 | ELSE | |
22855 | BU = BUD | |
22856 | BD = BDD | |
22857 | ENDIF | |
22858 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* | |
22859 | & (Q2/(Q2+A))**(1.0D0+DELTA) | |
22860 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* | |
22861 | & (Q2/(Q2+B))**(ALPHAR) | |
22862 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* | |
22863 | & (Q2/(Q2+B))**(ALPHAR) | |
22864 | ELSE | |
22865 | WRITE(LOUT,'(1X,A,I4,A)') | |
22866 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' | |
22867 | STOP | |
22868 | ENDIF | |
22869 | RETURN | |
22870 | END | |
22871 | C | |
22872 | C | |
22873 | ||
22874 | *$ CREATE DT_CKMTDE.FOR | |
22875 | *COPY DT_CKMTDE | |
22876 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) | |
22877 | C | |
22878 | C********************************************************************** | |
22879 | C Deuteron - PDFs | |
22880 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
22881 | C ANS = PDF(I) | |
22882 | C This version by S. Roesler, 30.01.96 | |
22883 | C********************************************************************** | |
22884 | ||
22885 | SAVE | |
22886 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
22887 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
22888 | DATA DELTA/.13/ | |
22889 | C | |
22890 | DATA (DL(K),K= 1, 85) / | |
22891 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
22892 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, | |
22893 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, | |
22894 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, | |
22895 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, | |
22896 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, | |
22897 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, | |
22898 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, | |
22899 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, | |
22900 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, | |
22901 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, | |
22902 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, | |
22903 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, | |
22904 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, | |
22905 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, | |
22906 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, | |
22907 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ | |
22908 | DATA (DL(K),K= 86, 170) / | |
22909 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, | |
22910 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, | |
22911 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, | |
22912 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, | |
22913 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, | |
22914 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, | |
22915 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, | |
22916 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22917 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22918 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22919 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22920 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22921 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22922 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22923 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22924 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
22925 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ | |
22926 | DATA (DL(K),K= 171, 255) / | |
22927 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, | |
22928 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, | |
22929 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, | |
22930 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, | |
22931 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, | |
22932 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, | |
22933 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, | |
22934 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, | |
22935 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, | |
22936 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, | |
22937 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, | |
22938 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, | |
22939 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, | |
22940 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, | |
22941 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, | |
22942 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, | |
22943 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ | |
22944 | DATA (DL(K),K= 256, 340) / | |
22945 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, | |
22946 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, | |
22947 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, | |
22948 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, | |
22949 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, | |
22950 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22951 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22952 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22953 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22954 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22955 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22956 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22957 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22958 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
22959 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, | |
22960 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, | |
22961 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ | |
22962 | DATA (DL(K),K= 341, 425) / | |
22963 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, | |
22964 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, | |
22965 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, | |
22966 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, | |
22967 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, | |
22968 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, | |
22969 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, | |
22970 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, | |
22971 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, | |
22972 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, | |
22973 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, | |
22974 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, | |
22975 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, | |
22976 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, | |
22977 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, | |
22978 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, | |
22979 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ | |
22980 | DATA (DL(K),K= 426, 510) / | |
22981 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, | |
22982 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, | |
22983 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, | |
22984 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22985 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22986 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22987 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22988 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22989 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22990 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22991 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22992 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
22993 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, | |
22994 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, | |
22995 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, | |
22996 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, | |
22997 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ | |
22998 | DATA (DL(K),K= 511, 595) / | |
22999 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, | |
23000 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, | |
23001 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, | |
23002 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, | |
23003 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, | |
23004 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, | |
23005 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, | |
23006 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, | |
23007 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, | |
23008 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, | |
23009 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, | |
23010 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, | |
23011 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, | |
23012 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, | |
23013 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, | |
23014 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, | |
23015 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ | |
23016 | DATA (DL(K),K= 596, 680) / | |
23017 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, | |
23018 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23019 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23020 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23021 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23022 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23023 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23024 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23025 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23026 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23027 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, | |
23028 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, | |
23029 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, | |
23030 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, | |
23031 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, | |
23032 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, | |
23033 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ | |
23034 | DATA (DL(K),K= 681, 765) / | |
23035 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, | |
23036 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, | |
23037 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, | |
23038 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, | |
23039 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, | |
23040 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, | |
23041 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, | |
23042 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, | |
23043 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, | |
23044 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, | |
23045 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, | |
23046 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, | |
23047 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, | |
23048 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, | |
23049 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, | |
23050 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, | |
23051 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23052 | DATA (DL(K),K= 766, 850) / | |
23053 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23054 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23055 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23056 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23057 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23058 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23059 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23060 | &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23061 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, | |
23062 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, | |
23063 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, | |
23064 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, | |
23065 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, | |
23066 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, | |
23067 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, | |
23068 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, | |
23069 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ | |
23070 | DATA (DL(K),K= 851, 935) / | |
23071 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, | |
23072 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, | |
23073 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, | |
23074 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, | |
23075 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, | |
23076 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, | |
23077 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, | |
23078 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, | |
23079 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, | |
23080 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, | |
23081 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, | |
23082 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, | |
23083 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, | |
23084 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, | |
23085 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23086 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23087 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23088 | DATA (DL(K),K= 936, 1020) / | |
23089 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23090 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23091 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23092 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23093 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23094 | &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23095 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, | |
23096 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, | |
23097 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, | |
23098 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, | |
23099 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, | |
23100 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, | |
23101 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, | |
23102 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, | |
23103 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, | |
23104 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, | |
23105 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ | |
23106 | DATA (DL(K),K= 1021, 1105) / | |
23107 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, | |
23108 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, | |
23109 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, | |
23110 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, | |
23111 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, | |
23112 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, | |
23113 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, | |
23114 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, | |
23115 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, | |
23116 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, | |
23117 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, | |
23118 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, | |
23119 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23120 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23121 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23122 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23123 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23124 | DATA (DL(K),K= 1106, 1190) / | |
23125 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23126 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23127 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23128 | &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
23129 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, | |
23130 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, | |
23131 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, | |
23132 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, | |
23133 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, | |
23134 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, | |
23135 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, | |
23136 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, | |
23137 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, | |
23138 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, | |
23139 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, | |
23140 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, | |
23141 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ | |
23142 | DATA (DL(K),K= 1191, 1275) / | |
23143 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, | |
23144 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, | |
23145 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, | |
23146 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, | |
23147 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, | |
23148 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, | |
23149 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, | |
23150 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, | |
23151 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, | |
23152 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, | |
23153 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23154 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23155 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23156 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23157 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23158 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23159 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23160 | DATA (DL(K),K= 1276, 1360) / | |
23161 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23162 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
23163 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, | |
23164 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, | |
23165 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, | |
23166 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, | |
23167 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, | |
23168 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, | |
23169 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, | |
23170 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, | |
23171 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, | |
23172 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, | |
23173 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, | |
23174 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, | |
23175 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, | |
23176 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, | |
23177 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ | |
23178 | DATA (DL(K),K= 1361, 1445) / | |
23179 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, | |
23180 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, | |
23181 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, | |
23182 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, | |
23183 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, | |
23184 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, | |
23185 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, | |
23186 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, | |
23187 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23188 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23189 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23190 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23191 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23192 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23193 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23194 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23195 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
23196 | DATA (DL(K),K= 1446, 1530) / | |
23197 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, | |
23198 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, | |
23199 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, | |
23200 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, | |
23201 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, | |
23202 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, | |
23203 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, | |
23204 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, | |
23205 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, | |
23206 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, | |
23207 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, | |
23208 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, | |
23209 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, | |
23210 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, | |
23211 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, | |
23212 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, | |
23213 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ | |
23214 | DATA (DL(K),K= 1531, 1615) / | |
23215 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, | |
23216 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, | |
23217 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, | |
23218 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, | |
23219 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, | |
23220 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, | |
23221 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23222 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23223 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23224 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23225 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23226 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23227 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23228 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23229 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
23230 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, | |
23231 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ | |
23232 | DATA (DL(K),K= 1616, 1700) / | |
23233 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, | |
23234 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, | |
23235 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, | |
23236 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, | |
23237 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, | |
23238 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, | |
23239 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, | |
23240 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, | |
23241 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, | |
23242 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, | |
23243 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, | |
23244 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, | |
23245 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, | |
23246 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, | |
23247 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, | |
23248 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, | |
23249 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ | |
23250 | DATA (DL(K),K= 1701, 1785) / | |
23251 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, | |
23252 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, | |
23253 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, | |
23254 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, | |
23255 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23256 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23257 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23258 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23259 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23260 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23261 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23262 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23263 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
23264 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, | |
23265 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, | |
23266 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, | |
23267 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ | |
23268 | DATA (DL(K),K= 1786, 1870) / | |
23269 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, | |
23270 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, | |
23271 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, | |
23272 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, | |
23273 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, | |
23274 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, | |
23275 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, | |
23276 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, | |
23277 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, | |
23278 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, | |
23279 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, | |
23280 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, | |
23281 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, | |
23282 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, | |
23283 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, | |
23284 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, | |
23285 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ | |
23286 | DATA (DL(K),K= 1871, 1955) / | |
23287 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, | |
23288 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, | |
23289 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23290 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23291 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23292 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23293 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23294 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23295 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23296 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23297 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
23298 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, | |
23299 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, | |
23300 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, | |
23301 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, | |
23302 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, | |
23303 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ | |
23304 | DATA (DL(K),K= 1956, 2040) / | |
23305 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, | |
23306 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, | |
23307 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, | |
23308 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, | |
23309 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, | |
23310 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, | |
23311 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, | |
23312 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, | |
23313 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, | |
23314 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, | |
23315 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, | |
23316 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, | |
23317 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, | |
23318 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, | |
23319 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, | |
23320 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, | |
23321 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ | |
23322 | DATA (DL(K),K= 2041, 2125) / | |
23323 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23324 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23325 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23326 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23327 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23328 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23329 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23330 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23331 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
23332 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, | |
23333 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, | |
23334 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, | |
23335 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, | |
23336 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, | |
23337 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, | |
23338 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, | |
23339 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ | |
23340 | DATA (DL(K),K= 2126, 2210) / | |
23341 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, | |
23342 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, | |
23343 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, | |
23344 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, | |
23345 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, | |
23346 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, | |
23347 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, | |
23348 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, | |
23349 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, | |
23350 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, | |
23351 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, | |
23352 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, | |
23353 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, | |
23354 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, | |
23355 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, | |
23356 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23357 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23358 | DATA (DL(K),K= 2211, 2295) / | |
23359 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23360 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23361 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23362 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23363 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23364 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23365 | &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
23366 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, | |
23367 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, | |
23368 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, | |
23369 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, | |
23370 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, | |
23371 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, | |
23372 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, | |
23373 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, | |
23374 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, | |
23375 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ | |
23376 | DATA (DL(K),K= 2296, 2380) / | |
23377 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, | |
23378 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, | |
23379 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, | |
23380 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, | |
23381 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, | |
23382 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, | |
23383 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, | |
23384 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, | |
23385 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, | |
23386 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, | |
23387 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, | |
23388 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, | |
23389 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, | |
23390 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23391 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23392 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23393 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23394 | DATA (DL(K),K= 2381, 2465) / | |
23395 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23396 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23397 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23398 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23399 | &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
23400 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, | |
23401 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, | |
23402 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, | |
23403 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, | |
23404 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, | |
23405 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, | |
23406 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, | |
23407 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, | |
23408 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, | |
23409 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, | |
23410 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, | |
23411 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ | |
23412 | DATA (DL(K),K= 2466, 2550) / | |
23413 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, | |
23414 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, | |
23415 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, | |
23416 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, | |
23417 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, | |
23418 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, | |
23419 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, | |
23420 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, | |
23421 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, | |
23422 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, | |
23423 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, | |
23424 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23425 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23426 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23427 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23428 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23429 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23430 | DATA (DL(K),K= 2551, 2635) / | |
23431 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23432 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23433 | &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, | |
23434 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, | |
23435 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, | |
23436 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, | |
23437 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, | |
23438 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, | |
23439 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, | |
23440 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, | |
23441 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, | |
23442 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, | |
23443 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, | |
23444 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, | |
23445 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, | |
23446 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, | |
23447 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ | |
23448 | DATA (DL(K),K= 2636, 2720) / | |
23449 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, | |
23450 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, | |
23451 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, | |
23452 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, | |
23453 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, | |
23454 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, | |
23455 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, | |
23456 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, | |
23457 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, | |
23458 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23459 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23460 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23461 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23462 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23463 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23464 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23465 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23466 | DATA (DL(K),K= 2721, 2805) / | |
23467 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, | |
23468 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, | |
23469 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, | |
23470 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, | |
23471 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, | |
23472 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, | |
23473 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, | |
23474 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, | |
23475 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, | |
23476 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, | |
23477 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, | |
23478 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, | |
23479 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, | |
23480 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, | |
23481 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, | |
23482 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, | |
23483 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ | |
23484 | DATA (DL(K),K= 2806, 2890) / | |
23485 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, | |
23486 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, | |
23487 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, | |
23488 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, | |
23489 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, | |
23490 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, | |
23491 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, | |
23492 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23493 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23494 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23495 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23496 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23497 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23498 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23499 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23500 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, | |
23501 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ | |
23502 | DATA (DL(K),K= 2891, 2975) / | |
23503 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, | |
23504 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, | |
23505 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, | |
23506 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, | |
23507 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, | |
23508 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, | |
23509 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, | |
23510 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, | |
23511 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, | |
23512 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, | |
23513 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, | |
23514 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, | |
23515 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, | |
23516 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, | |
23517 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, | |
23518 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, | |
23519 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ | |
23520 | DATA (DL(K),K= 2976, 3060) / | |
23521 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, | |
23522 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, | |
23523 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, | |
23524 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, | |
23525 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, | |
23526 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23527 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23528 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23529 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23530 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23531 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23532 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23533 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23534 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
23535 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, | |
23536 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, | |
23537 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ | |
23538 | DATA (DL(K),K= 3061, 3145) / | |
23539 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, | |
23540 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, | |
23541 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, | |
23542 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, | |
23543 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, | |
23544 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, | |
23545 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, | |
23546 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, | |
23547 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, | |
23548 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, | |
23549 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, | |
23550 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, | |
23551 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, | |
23552 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, | |
23553 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, | |
23554 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, | |
23555 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ | |
23556 | DATA (DL(K),K= 3146, 3230) / | |
23557 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, | |
23558 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, | |
23559 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, | |
23560 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23561 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23562 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23563 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23564 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23565 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23566 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23567 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23568 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
23569 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, | |
23570 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, | |
23571 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, | |
23572 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, | |
23573 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ | |
23574 | DATA (DL(K),K= 3231, 3315) / | |
23575 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, | |
23576 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, | |
23577 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, | |
23578 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, | |
23579 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, | |
23580 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, | |
23581 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, | |
23582 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, | |
23583 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, | |
23584 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, | |
23585 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, | |
23586 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, | |
23587 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, | |
23588 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, | |
23589 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, | |
23590 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, | |
23591 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ | |
23592 | DATA (DL(K),K= 3316, 3400) / | |
23593 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, | |
23594 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23595 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23596 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23597 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23598 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23599 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23600 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23601 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23602 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, | |
23603 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, | |
23604 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, | |
23605 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, | |
23606 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, | |
23607 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, | |
23608 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, | |
23609 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ | |
23610 | DATA (DL(K),K= 3401, 3485) / | |
23611 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, | |
23612 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, | |
23613 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, | |
23614 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, | |
23615 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, | |
23616 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, | |
23617 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, | |
23618 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, | |
23619 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, | |
23620 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, | |
23621 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, | |
23622 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, | |
23623 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, | |
23624 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, | |
23625 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, | |
23626 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, | |
23627 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23628 | DATA (DL(K),K= 3486, 3570) / | |
23629 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23630 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23631 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23632 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23633 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23634 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23635 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23636 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, | |
23637 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, | |
23638 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, | |
23639 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, | |
23640 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, | |
23641 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, | |
23642 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, | |
23643 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, | |
23644 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, | |
23645 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ | |
23646 | DATA (DL(K),K= 3571, 3655) / | |
23647 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, | |
23648 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, | |
23649 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, | |
23650 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, | |
23651 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, | |
23652 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, | |
23653 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, | |
23654 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, | |
23655 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, | |
23656 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, | |
23657 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, | |
23658 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, | |
23659 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, | |
23660 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, | |
23661 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23662 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23663 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23664 | DATA (DL(K),K= 3656, 3740) / | |
23665 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23666 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23667 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23668 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23669 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23670 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
23671 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, | |
23672 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, | |
23673 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, | |
23674 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, | |
23675 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, | |
23676 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, | |
23677 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, | |
23678 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, | |
23679 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, | |
23680 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, | |
23681 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ | |
23682 | DATA (DL(K),K= 3741, 3825) / | |
23683 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, | |
23684 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, | |
23685 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, | |
23686 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, | |
23687 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, | |
23688 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, | |
23689 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, | |
23690 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, | |
23691 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, | |
23692 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, | |
23693 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, | |
23694 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, | |
23695 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23696 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23697 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23698 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23699 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23700 | DATA (DL(K),K= 3826, 3910) / | |
23701 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23702 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23703 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23704 | &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
23705 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, | |
23706 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, | |
23707 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, | |
23708 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, | |
23709 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, | |
23710 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, | |
23711 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, | |
23712 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, | |
23713 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, | |
23714 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, | |
23715 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, | |
23716 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, | |
23717 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ | |
23718 | DATA (DL(K),K= 3911, 3995) / | |
23719 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, | |
23720 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, | |
23721 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, | |
23722 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, | |
23723 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, | |
23724 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, | |
23725 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, | |
23726 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, | |
23727 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, | |
23728 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, | |
23729 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23730 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23731 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23732 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23733 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23734 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23735 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23736 | DATA (DL(K),K= 3996, 4000) / | |
23737 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23738 | C | |
23739 | ANS = 0. | |
23740 | IF (X.GT.0.9985) RETURN | |
23741 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
23742 | C | |
23743 | IS = S/DELTA+1 | |
23744 | IS1 = IS+1 | |
23745 | DO 1 L=1,25 | |
23746 | KL = L+NDRV*25 | |
23747 | F1(L) = GF(I,IS,KL) | |
23748 | F2(L) = GF(I,IS1,KL) | |
23749 | 1 CONTINUE | |
23750 | A1 = DT_CKMTFF(X,F1) | |
23751 | A2 = DT_CKMTFF(X,F2) | |
23752 | C A1=ALOG(A1) | |
23753 | C A2=ALOG(A2) | |
23754 | S1 = (IS-1)*DELTA | |
23755 | S2 = S1+DELTA | |
23756 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
23757 | C ANS=EXP(ANS) | |
23758 | RETURN | |
23759 | END | |
23760 | C | |
23761 | C | |
23762 | ||
23763 | *$ CREATE DT_CKMTPR.FOR | |
23764 | *COPY DT_CKMTPR | |
23765 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) | |
23766 | C | |
23767 | C********************************************************************** | |
23768 | C Proton - PDFs | |
23769 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
23770 | C ANS = PDF(I) | |
23771 | C This version by S. Roesler, 31.01.96 | |
23772 | C********************************************************************** | |
23773 | ||
23774 | SAVE | |
23775 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
23776 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
23777 | DATA DELTA/.10/ | |
23778 | C | |
23779 | DATA (DL(K),K= 1, 85) / | |
23780 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
23781 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, | |
23782 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, | |
23783 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, | |
23784 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, | |
23785 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, | |
23786 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, | |
23787 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, | |
23788 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, | |
23789 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, | |
23790 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, | |
23791 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, | |
23792 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, | |
23793 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, | |
23794 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, | |
23795 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, | |
23796 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ | |
23797 | DATA (DL(K),K= 86, 170) / | |
23798 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, | |
23799 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, | |
23800 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, | |
23801 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, | |
23802 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, | |
23803 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, | |
23804 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, | |
23805 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, | |
23806 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, | |
23807 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, | |
23808 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, | |
23809 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, | |
23810 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, | |
23811 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23812 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23813 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
23814 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ | |
23815 | DATA (DL(K),K= 171, 255) / | |
23816 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, | |
23817 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, | |
23818 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, | |
23819 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, | |
23820 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, | |
23821 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, | |
23822 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, | |
23823 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, | |
23824 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, | |
23825 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, | |
23826 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, | |
23827 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, | |
23828 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, | |
23829 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, | |
23830 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, | |
23831 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, | |
23832 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ | |
23833 | DATA (DL(K),K= 256, 340) / | |
23834 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, | |
23835 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, | |
23836 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, | |
23837 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, | |
23838 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, | |
23839 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, | |
23840 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, | |
23841 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, | |
23842 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, | |
23843 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, | |
23844 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, | |
23845 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23846 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23847 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
23848 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, | |
23849 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, | |
23850 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ | |
23851 | DATA (DL(K),K= 341, 425) / | |
23852 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, | |
23853 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, | |
23854 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, | |
23855 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, | |
23856 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, | |
23857 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, | |
23858 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, | |
23859 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, | |
23860 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, | |
23861 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, | |
23862 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, | |
23863 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, | |
23864 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, | |
23865 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, | |
23866 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, | |
23867 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, | |
23868 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ | |
23869 | DATA (DL(K),K= 426, 510) / | |
23870 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, | |
23871 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, | |
23872 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, | |
23873 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, | |
23874 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, | |
23875 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, | |
23876 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, | |
23877 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, | |
23878 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, | |
23879 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23880 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23881 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
23882 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, | |
23883 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, | |
23884 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, | |
23885 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, | |
23886 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ | |
23887 | DATA (DL(K),K= 511, 595) / | |
23888 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, | |
23889 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, | |
23890 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, | |
23891 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, | |
23892 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, | |
23893 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, | |
23894 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, | |
23895 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, | |
23896 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, | |
23897 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, | |
23898 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, | |
23899 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, | |
23900 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, | |
23901 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, | |
23902 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, | |
23903 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, | |
23904 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ | |
23905 | DATA (DL(K),K= 596, 680) / | |
23906 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, | |
23907 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, | |
23908 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, | |
23909 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, | |
23910 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, | |
23911 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, | |
23912 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, | |
23913 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23914 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23915 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23916 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, | |
23917 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, | |
23918 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, | |
23919 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, | |
23920 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, | |
23921 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, | |
23922 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ | |
23923 | DATA (DL(K),K= 681, 765) / | |
23924 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, | |
23925 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, | |
23926 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, | |
23927 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, | |
23928 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, | |
23929 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, | |
23930 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, | |
23931 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, | |
23932 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, | |
23933 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, | |
23934 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, | |
23935 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, | |
23936 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, | |
23937 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, | |
23938 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, | |
23939 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, | |
23940 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ | |
23941 | DATA (DL(K),K= 766, 850) / | |
23942 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, | |
23943 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, | |
23944 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, | |
23945 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, | |
23946 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, | |
23947 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23948 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23949 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23950 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, | |
23951 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, | |
23952 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, | |
23953 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, | |
23954 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, | |
23955 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, | |
23956 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, | |
23957 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, | |
23958 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ | |
23959 | DATA (DL(K),K= 851, 935) / | |
23960 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, | |
23961 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, | |
23962 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, | |
23963 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, | |
23964 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, | |
23965 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, | |
23966 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, | |
23967 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, | |
23968 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, | |
23969 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, | |
23970 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, | |
23971 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, | |
23972 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, | |
23973 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, | |
23974 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, | |
23975 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, | |
23976 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ | |
23977 | DATA (DL(K),K= 936, 1020) / | |
23978 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, | |
23979 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, | |
23980 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, | |
23981 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23982 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23983 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23984 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, | |
23985 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, | |
23986 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, | |
23987 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, | |
23988 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, | |
23989 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, | |
23990 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, | |
23991 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, | |
23992 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, | |
23993 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, | |
23994 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ | |
23995 | DATA (DL(K),K= 1021, 1105) / | |
23996 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, | |
23997 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, | |
23998 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, | |
23999 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, | |
24000 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, | |
24001 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, | |
24002 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, | |
24003 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, | |
24004 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, | |
24005 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, | |
24006 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, | |
24007 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, | |
24008 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, | |
24009 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, | |
24010 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, | |
24011 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, | |
24012 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ | |
24013 | DATA (DL(K),K= 1106, 1190) / | |
24014 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, | |
24015 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
24016 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24017 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
24018 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, | |
24019 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, | |
24020 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, | |
24021 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, | |
24022 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, | |
24023 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, | |
24024 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, | |
24025 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, | |
24026 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, | |
24027 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, | |
24028 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, | |
24029 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, | |
24030 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ | |
24031 | DATA (DL(K),K= 1191, 1275) / | |
24032 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, | |
24033 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, | |
24034 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, | |
24035 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, | |
24036 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, | |
24037 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, | |
24038 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, | |
24039 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, | |
24040 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, | |
24041 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, | |
24042 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, | |
24043 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, | |
24044 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, | |
24045 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, | |
24046 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, | |
24047 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, | |
24048 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24049 | DATA (DL(K),K= 1276, 1360) / | |
24050 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24051 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
24052 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, | |
24053 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, | |
24054 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, | |
24055 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, | |
24056 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, | |
24057 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, | |
24058 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, | |
24059 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, | |
24060 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, | |
24061 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, | |
24062 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, | |
24063 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, | |
24064 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, | |
24065 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, | |
24066 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ | |
24067 | DATA (DL(K),K= 1361, 1445) / | |
24068 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, | |
24069 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, | |
24070 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, | |
24071 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, | |
24072 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, | |
24073 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, | |
24074 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, | |
24075 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, | |
24076 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, | |
24077 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, | |
24078 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, | |
24079 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, | |
24080 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, | |
24081 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, | |
24082 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
24083 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24084 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
24085 | DATA (DL(K),K= 1446, 1530) / | |
24086 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, | |
24087 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, | |
24088 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, | |
24089 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, | |
24090 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, | |
24091 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, | |
24092 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, | |
24093 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, | |
24094 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, | |
24095 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, | |
24096 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, | |
24097 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, | |
24098 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, | |
24099 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, | |
24100 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, | |
24101 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, | |
24102 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ | |
24103 | DATA (DL(K),K= 1531, 1615) / | |
24104 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, | |
24105 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, | |
24106 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, | |
24107 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, | |
24108 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, | |
24109 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, | |
24110 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, | |
24111 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, | |
24112 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, | |
24113 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, | |
24114 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, | |
24115 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, | |
24116 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24117 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24118 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
24119 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, | |
24120 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ | |
24121 | DATA (DL(K),K= 1616, 1700) / | |
24122 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, | |
24123 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, | |
24124 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, | |
24125 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, | |
24126 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, | |
24127 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, | |
24128 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, | |
24129 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, | |
24130 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, | |
24131 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, | |
24132 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, | |
24133 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, | |
24134 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, | |
24135 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, | |
24136 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, | |
24137 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, | |
24138 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ | |
24139 | DATA (DL(K),K= 1701, 1785) / | |
24140 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, | |
24141 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, | |
24142 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, | |
24143 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, | |
24144 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, | |
24145 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, | |
24146 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, | |
24147 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, | |
24148 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, | |
24149 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, | |
24150 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24151 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24152 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
24153 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, | |
24154 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, | |
24155 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, | |
24156 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ | |
24157 | DATA (DL(K),K= 1786, 1870) / | |
24158 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, | |
24159 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, | |
24160 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, | |
24161 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, | |
24162 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, | |
24163 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, | |
24164 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, | |
24165 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, | |
24166 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, | |
24167 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, | |
24168 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, | |
24169 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, | |
24170 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, | |
24171 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, | |
24172 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, | |
24173 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, | |
24174 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ | |
24175 | DATA (DL(K),K= 1871, 1955) / | |
24176 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, | |
24177 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, | |
24178 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, | |
24179 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, | |
24180 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, | |
24181 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, | |
24182 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, | |
24183 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, | |
24184 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24185 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24186 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
24187 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, | |
24188 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, | |
24189 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, | |
24190 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, | |
24191 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, | |
24192 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ | |
24193 | DATA (DL(K),K= 1956, 2040) / | |
24194 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, | |
24195 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, | |
24196 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, | |
24197 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, | |
24198 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, | |
24199 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, | |
24200 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, | |
24201 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, | |
24202 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, | |
24203 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, | |
24204 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, | |
24205 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, | |
24206 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, | |
24207 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, | |
24208 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, | |
24209 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, | |
24210 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ | |
24211 | DATA (DL(K),K= 2041, 2125) / | |
24212 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, | |
24213 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, | |
24214 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, | |
24215 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, | |
24216 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, | |
24217 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, | |
24218 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24219 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24220 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
24221 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, | |
24222 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, | |
24223 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, | |
24224 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, | |
24225 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, | |
24226 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, | |
24227 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, | |
24228 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ | |
24229 | DATA (DL(K),K= 2126, 2210) / | |
24230 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, | |
24231 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, | |
24232 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, | |
24233 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, | |
24234 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, | |
24235 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, | |
24236 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, | |
24237 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, | |
24238 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, | |
24239 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, | |
24240 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, | |
24241 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, | |
24242 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, | |
24243 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, | |
24244 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, | |
24245 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, | |
24246 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ | |
24247 | DATA (DL(K),K= 2211, 2295) / | |
24248 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, | |
24249 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, | |
24250 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, | |
24251 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, | |
24252 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24253 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24254 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
24255 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, | |
24256 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, | |
24257 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, | |
24258 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, | |
24259 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, | |
24260 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, | |
24261 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, | |
24262 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, | |
24263 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, | |
24264 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ | |
24265 | DATA (DL(K),K= 2296, 2380) / | |
24266 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, | |
24267 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, | |
24268 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, | |
24269 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, | |
24270 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, | |
24271 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, | |
24272 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, | |
24273 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, | |
24274 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, | |
24275 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, | |
24276 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, | |
24277 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, | |
24278 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, | |
24279 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, | |
24280 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, | |
24281 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, | |
24282 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ | |
24283 | DATA (DL(K),K= 2381, 2465) / | |
24284 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, | |
24285 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, | |
24286 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24287 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24288 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
24289 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, | |
24290 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, | |
24291 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, | |
24292 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, | |
24293 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, | |
24294 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, | |
24295 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, | |
24296 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, | |
24297 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, | |
24298 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, | |
24299 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, | |
24300 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ | |
24301 | DATA (DL(K),K= 2466, 2550) / | |
24302 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, | |
24303 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, | |
24304 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, | |
24305 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, | |
24306 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, | |
24307 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, | |
24308 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, | |
24309 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, | |
24310 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, | |
24311 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, | |
24312 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, | |
24313 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, | |
24314 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, | |
24315 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, | |
24316 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, | |
24317 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, | |
24318 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ | |
24319 | DATA (DL(K),K= 2551, 2635) / | |
24320 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24321 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24322 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, | |
24323 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, | |
24324 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, | |
24325 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, | |
24326 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, | |
24327 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, | |
24328 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, | |
24329 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, | |
24330 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, | |
24331 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, | |
24332 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, | |
24333 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, | |
24334 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, | |
24335 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, | |
24336 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ | |
24337 | DATA (DL(K),K= 2636, 2720) / | |
24338 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, | |
24339 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, | |
24340 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, | |
24341 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, | |
24342 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, | |
24343 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, | |
24344 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, | |
24345 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, | |
24346 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, | |
24347 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, | |
24348 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, | |
24349 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, | |
24350 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, | |
24351 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, | |
24352 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, | |
24353 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24354 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24355 | DATA (DL(K),K= 2721, 2805) / | |
24356 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, | |
24357 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, | |
24358 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, | |
24359 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, | |
24360 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, | |
24361 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, | |
24362 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, | |
24363 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, | |
24364 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, | |
24365 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, | |
24366 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, | |
24367 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, | |
24368 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, | |
24369 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, | |
24370 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, | |
24371 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, | |
24372 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ | |
24373 | DATA (DL(K),K= 2806, 2890) / | |
24374 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, | |
24375 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, | |
24376 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, | |
24377 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, | |
24378 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, | |
24379 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, | |
24380 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, | |
24381 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, | |
24382 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, | |
24383 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, | |
24384 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, | |
24385 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, | |
24386 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, | |
24387 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24388 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24389 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, | |
24390 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ | |
24391 | DATA (DL(K),K= 2891, 2975) / | |
24392 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, | |
24393 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, | |
24394 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, | |
24395 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, | |
24396 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, | |
24397 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, | |
24398 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, | |
24399 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, | |
24400 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, | |
24401 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, | |
24402 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, | |
24403 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, | |
24404 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, | |
24405 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, | |
24406 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, | |
24407 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, | |
24408 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ | |
24409 | DATA (DL(K),K= 2976, 3060) / | |
24410 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, | |
24411 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, | |
24412 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, | |
24413 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, | |
24414 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, | |
24415 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, | |
24416 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, | |
24417 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, | |
24418 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, | |
24419 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, | |
24420 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, | |
24421 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24422 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24423 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
24424 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, | |
24425 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, | |
24426 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ | |
24427 | DATA (DL(K),K= 3061, 3145) / | |
24428 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, | |
24429 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, | |
24430 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, | |
24431 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, | |
24432 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, | |
24433 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, | |
24434 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, | |
24435 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, | |
24436 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, | |
24437 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, | |
24438 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, | |
24439 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, | |
24440 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, | |
24441 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, | |
24442 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, | |
24443 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, | |
24444 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ | |
24445 | DATA (DL(K),K= 3146, 3230) / | |
24446 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, | |
24447 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, | |
24448 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, | |
24449 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, | |
24450 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, | |
24451 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, | |
24452 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, | |
24453 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, | |
24454 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, | |
24455 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24456 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24457 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
24458 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, | |
24459 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, | |
24460 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, | |
24461 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, | |
24462 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ | |
24463 | DATA (DL(K),K= 3231, 3315) / | |
24464 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, | |
24465 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, | |
24466 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, | |
24467 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, | |
24468 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, | |
24469 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, | |
24470 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, | |
24471 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, | |
24472 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, | |
24473 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, | |
24474 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, | |
24475 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, | |
24476 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, | |
24477 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, | |
24478 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, | |
24479 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, | |
24480 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ | |
24481 | DATA (DL(K),K= 3316, 3400) / | |
24482 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, | |
24483 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, | |
24484 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, | |
24485 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, | |
24486 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, | |
24487 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, | |
24488 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, | |
24489 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24490 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24491 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, | |
24492 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, | |
24493 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, | |
24494 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, | |
24495 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, | |
24496 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, | |
24497 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, | |
24498 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ | |
24499 | DATA (DL(K),K= 3401, 3485) / | |
24500 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, | |
24501 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, | |
24502 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, | |
24503 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, | |
24504 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, | |
24505 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, | |
24506 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, | |
24507 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, | |
24508 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, | |
24509 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, | |
24510 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, | |
24511 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, | |
24512 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, | |
24513 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, | |
24514 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, | |
24515 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, | |
24516 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ | |
24517 | DATA (DL(K),K= 3486, 3570) / | |
24518 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, | |
24519 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, | |
24520 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, | |
24521 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, | |
24522 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, | |
24523 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24524 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24525 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, | |
24526 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, | |
24527 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, | |
24528 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, | |
24529 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, | |
24530 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, | |
24531 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, | |
24532 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, | |
24533 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, | |
24534 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ | |
24535 | DATA (DL(K),K= 3571, 3655) / | |
24536 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, | |
24537 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, | |
24538 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, | |
24539 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, | |
24540 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, | |
24541 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, | |
24542 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, | |
24543 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, | |
24544 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, | |
24545 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, | |
24546 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, | |
24547 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, | |
24548 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, | |
24549 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, | |
24550 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, | |
24551 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, | |
24552 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ | |
24553 | DATA (DL(K),K= 3656, 3740) / | |
24554 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, | |
24555 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, | |
24556 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, | |
24557 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, | |
24558 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24559 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
24560 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, | |
24561 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, | |
24562 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, | |
24563 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, | |
24564 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, | |
24565 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, | |
24566 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, | |
24567 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, | |
24568 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, | |
24569 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, | |
24570 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ | |
24571 | DATA (DL(K),K= 3741, 3825) / | |
24572 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, | |
24573 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, | |
24574 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, | |
24575 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, | |
24576 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, | |
24577 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, | |
24578 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, | |
24579 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, | |
24580 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, | |
24581 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, | |
24582 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, | |
24583 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, | |
24584 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, | |
24585 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, | |
24586 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, | |
24587 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, | |
24588 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ | |
24589 | DATA (DL(K),K= 3826, 3910) / | |
24590 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, | |
24591 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, | |
24592 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24593 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
24594 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, | |
24595 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, | |
24596 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, | |
24597 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, | |
24598 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, | |
24599 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, | |
24600 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, | |
24601 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, | |
24602 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, | |
24603 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, | |
24604 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, | |
24605 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, | |
24606 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ | |
24607 | DATA (DL(K),K= 3911, 3995) / | |
24608 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, | |
24609 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, | |
24610 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, | |
24611 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, | |
24612 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, | |
24613 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, | |
24614 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, | |
24615 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, | |
24616 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, | |
24617 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, | |
24618 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, | |
24619 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, | |
24620 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, | |
24621 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, | |
24622 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, | |
24623 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, | |
24624 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24625 | DATA (DL(K),K= 3996, 4000) / | |
24626 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24627 | C | |
24628 | ANS = 0. | |
24629 | IF (X.GT.0.9985) RETURN | |
24630 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
24631 | C | |
24632 | IS = S/DELTA+1 | |
24633 | IS1 = IS+1 | |
24634 | DO 1 L=1,25 | |
24635 | KL = L+NDRV*25 | |
24636 | F1(L) = GF(I,IS,KL) | |
24637 | F2(L) = GF(I,IS1,KL) | |
24638 | 1 CONTINUE | |
24639 | A1 = DT_CKMTFF(X,F1) | |
24640 | A2 = DT_CKMTFF(X,F2) | |
24641 | C A1=ALOG(A1) | |
24642 | C A2=ALOG(A2) | |
24643 | S1 = (IS-1)*DELTA | |
24644 | S2 = S1+DELTA | |
24645 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
24646 | C ANS=EXP(ANS) | |
24647 | RETURN | |
24648 | END | |
24649 | C | |
24650 | ||
24651 | *$ CREATE DT_CKMTFF.FOR | |
24652 | *COPY DT_CKMTFF | |
24653 | FUNCTION DT_CKMTFF(X,FVL) | |
24654 | C********************************************************************** | |
24655 | C | |
24656 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE | |
24657 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. | |
24658 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED | |
24659 | C IN MAIN ROUTINE. | |
24660 | C | |
24661 | C********************************************************************** | |
24662 | ||
24663 | SAVE | |
24664 | DIMENSION FVL(25),XGRID(25) | |
24665 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, | |
24666 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ | |
24667 | C | |
24668 | DT_CKMTFF=0. | |
24669 | DO 1 I=1,NX | |
24670 | IF(X.LT.XGRID(I)) GO TO 2 | |
24671 | 1 CONTINUE | |
24672 | 2 I=I-1 | |
24673 | IF(I.EQ.0) THEN | |
24674 | I=I+1 | |
24675 | ELSE IF(I.GT.23) THEN | |
24676 | I=23 | |
24677 | ENDIF | |
24678 | J=I+1 | |
24679 | K=J+1 | |
24680 | AXI=LOG(XGRID(I)) | |
24681 | BXI=LOG(1.-XGRID(I)) | |
24682 | AXJ=LOG(XGRID(J)) | |
24683 | BXJ=LOG(1.-XGRID(J)) | |
24684 | AXK=LOG(XGRID(K)) | |
24685 | BXK=LOG(1.-XGRID(K)) | |
24686 | FI=LOG(ABS(FVL(I)) +1.E-15) | |
24687 | FJ=LOG(ABS(FVL(J)) +1.E-16) | |
24688 | FK=LOG(ABS(FVL(K)) +1.E-17) | |
24689 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) | |
24690 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* | |
24691 | $ BXI))/DET | |
24692 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET | |
24693 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET | |
24694 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) | |
24695 | 1RETURN | |
24696 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN | |
24697 | C WRITE(6,2001) X,FVL | |
24698 | C 2001 FORMAT(8E12.4) | |
24699 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET | |
24700 | C ENDIF | |
24701 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA | |
24702 | RETURN | |
24703 | END | |
24704 | ||
24705 | *$ CREATE DT_FLUINI.FOR | |
24706 | *COPY DT_FLUINI | |
24707 | * | |
24708 | *===fluini=============================================================* | |
24709 | * | |
24710 | SUBROUTINE DT_FLUINI | |
24711 | ||
24712 | ************************************************************************ | |
24713 | * Initialisation of the nucleon-nucleon cross section fluctuation * | |
24714 | * treatment. The original version by J. Ranft. * | |
24715 | * This version dated 21.04.95 is revised by S. Roesler. * | |
24716 | ************************************************************************ | |
24717 | ||
24718 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24719 | SAVE | |
24720 | PARAMETER ( LINP = 10 , | |
24721 | & LOUT = 6 , | |
24722 | & LDAT = 9 ) | |
24723 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
24724 | ||
24725 | PARAMETER ( A = 0.1D0, | |
24726 | & B = 0.893D0, | |
24727 | & OM = 1.1D0, | |
24728 | & N = 6, | |
24729 | & DX = 0.003D0) | |
24730 | ||
24731 | * n-n cross section fluctuations | |
24732 | PARAMETER (NBINS = 1000) | |
24733 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
24734 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) | |
24735 | ||
24736 | WRITE(LOUT,1000) | |
24737 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', | |
24738 | & 'treated') | |
24739 | ||
24740 | FLUSU = ZERO | |
24741 | FLUSUU = ZERO | |
24742 | ||
24743 | DO 1 I=1,NBINS | |
24744 | X = DBLE(I)*DX | |
24745 | FLUIX(I) = X | |
24746 | FLUS = ((X-B)/(OM*B))**N | |
24747 | IF (FLUS.LE.20.0D0) THEN | |
24748 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) | |
24749 | ELSE | |
24750 | FLUSI(I) = ZERO | |
24751 | ENDIF | |
24752 | FLUSU = FLUSU+FLUSI(I) | |
24753 | 1 CONTINUE | |
24754 | DO 2 I=1,NBINS | |
24755 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU | |
24756 | FLUSI(I) = FLUSUU | |
24757 | 2 CONTINUE | |
24758 | ||
24759 | C WRITE(LOUT,1001) | |
24760 | C1001 FORMAT(1X,'FLUCTUATIONS') | |
24761 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) | |
24762 | ||
24763 | DO 3 I=1,NBINS | |
24764 | AF = DBLE(I)*0.001D0 | |
24765 | DO 4 J=1,NBINS | |
24766 | IF (AF.LE.FLUSI(J)) THEN | |
24767 | FLUIXX(I) = FLUIX(J) | |
24768 | GOTO 5 | |
24769 | ENDIF | |
24770 | 4 CONTINUE | |
24771 | 5 CONTINUE | |
24772 | 3 CONTINUE | |
24773 | FLUIXX(1) = FLUIX(1) | |
24774 | FLUIXX(NBINS) = FLUIX(NBINS) | |
24775 | ||
24776 | RETURN | |
24777 | END | |
24778 | ||
24779 | *$ CREATE DT_SIGTBL.FOR | |
24780 | *COPY DT_SIGTBL | |
24781 | * | |
24782 | *===sigtab=============================================================* | |
24783 | * | |
24784 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) | |
24785 | ||
24786 | ************************************************************************ | |
24787 | * This version dated 18.11.95 is written by S. Roesler * | |
24788 | ************************************************************************ | |
24789 | ||
24790 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24791 | SAVE | |
24792 | PARAMETER ( LINP = 10 , | |
24793 | & LOUT = 6 , | |
24794 | & LDAT = 9 ) | |
24795 | ||
24796 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24797 | & OHALF=0.5D0,ONE=1.0D0) | |
24798 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) | |
24799 | ||
24800 | LOGICAL LINIT | |
24801 | ||
24802 | * particle properties (BAMJET index convention) | |
24803 | CHARACTER*8 ANAME | |
24804 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24805 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24806 | ||
24807 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) | |
24808 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, | |
24809 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, | |
24810 | & 0, 0, 5/ | |
24811 | DATA LINIT /.FALSE./ | |
24812 | ||
24813 | * precalculation and tabulation of elastic cross sections | |
24814 | IF (ABS(MODE).EQ.1) THEN | |
24815 | IF (MODE.EQ.1) | |
24816 | & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN') | |
24817 | PLABLX = LOG10(PLO) | |
24818 | PLABHX = LOG10(PHI) | |
24819 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) | |
24820 | DO 1 I=1,NBINS+1 | |
24821 | PLAB = PLABLX+DBLE(I-1)*DPLAB | |
24822 | PLAB = 10**PLAB | |
24823 | DO 2 IPROJ=1,23 | |
24824 | IDX = IDSIG(IPROJ) | |
24825 | IF (IDX.GT.0) THEN | |
24826 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) | |
24827 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) | |
24828 | DUMZER = ZERO | |
24829 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) | |
24830 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) | |
24831 | ENDIF | |
24832 | 2 CONTINUE | |
24833 | IF (MODE.EQ.1) THEN | |
24834 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), | |
24835 | & (SIGEN(IDX,I),IDX=1,5) | |
24836 | 1000 FORMAT(F5.1,10F7.2) | |
24837 | ENDIF | |
24838 | 1 CONTINUE | |
24839 | IF (MODE.EQ.1) CLOSE(LDAT) | |
24840 | LINIT = .TRUE. | |
24841 | ELSE | |
24842 | SIGE = -ONE | |
24843 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) | |
24844 | & .AND.(PTOT.LE.PHI) ) THEN | |
24845 | IDX = IDSIG(JP) | |
24846 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN | |
24847 | PLABX = LOG10(PTOT) | |
24848 | IF (PLABX.LE.PLABLX) THEN | |
24849 | I1 = 1 | |
24850 | I2 = 1 | |
24851 | ELSEIF (PLABX.GE.PLABHX) THEN | |
24852 | I1 = NBINS+1 | |
24853 | I2 = NBINS+1 | |
24854 | ELSE | |
24855 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 | |
24856 | I2 = I1+1 | |
24857 | ENDIF | |
24858 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB | |
24859 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB | |
24860 | PBIN = PLAB2X-PLAB1X | |
24861 | IF (PBIN.GT.TINY10) THEN | |
24862 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) | |
24863 | ELSE | |
24864 | RATX = ZERO | |
24865 | ENDIF | |
24866 | IF (JT.EQ.1) THEN | |
24867 | SIG1 = SIGEP(IDX,I1) | |
24868 | SIG2 = SIGEP(IDX,I2) | |
24869 | ELSE | |
24870 | SIG1 = SIGEN(IDX,I1) | |
24871 | SIG2 = SIGEN(IDX,I2) | |
24872 | ENDIF | |
24873 | SIGE = SIG1+RATX*(SIG2-SIG1) | |
24874 | ENDIF | |
24875 | ENDIF | |
24876 | ENDIF | |
24877 | ||
24878 | RETURN | |
24879 | END | |
24880 | ||
24881 | *$ CREATE DT_XSTABL.FOR | |
24882 | *COPY DT_XSTABL | |
24883 | * | |
24884 | *===xstabl=============================================================* | |
24885 | * | |
24886 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
24887 | ||
24888 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24889 | SAVE | |
24890 | PARAMETER ( LINP = 10 , | |
24891 | & LOUT = 6 , | |
24892 | & LDAT = 9 ) | |
24893 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24894 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) | |
24895 | LOGICAL LLAB,LELOG,LQLOG | |
24896 | ||
24897 | * particle properties (BAMJET index convention) | |
24898 | CHARACTER*8 ANAME | |
24899 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24900 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24901 | * properties of interacting particles | |
24902 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
24903 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
24904 | * Glauber formalism: cross sections | |
24905 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
24906 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
24907 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
24908 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
24909 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
24910 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
24911 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
24912 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
24913 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
24914 | & BSLOPE,NEBINI,NQBINI | |
24915 | * emulsion treatment | |
24916 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
24917 | & NCOMPO,IEMUL | |
24918 | ||
24919 | DIMENSION WHAT(6) | |
24920 | ||
24921 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) | |
24922 | ELO = ABS(WHAT(1)) | |
24923 | EHI = ABS(WHAT(2)) | |
24924 | IF (ELO.GT.EHI) ELO = EHI | |
24925 | LELOG = WHAT(3).LT.ZERO | |
24926 | NEBINS = MAX(INT(ABS(WHAT(3))),1) | |
24927 | DEBINS = (EHI-ELO)/DBLE(NEBINS) | |
24928 | IF (LELOG) THEN | |
24929 | AELO = LOG10(ELO) | |
24930 | AEHI = LOG10(EHI) | |
24931 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) | |
24932 | ENDIF | |
24933 | Q2LO = WHAT(4) | |
24934 | Q2HI = WHAT(5) | |
24935 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI | |
24936 | LQLOG = WHAT(6).LT.ZERO | |
24937 | NQBINS = MAX(INT(ABS(WHAT(6))),1) | |
24938 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) | |
24939 | IF (LQLOG) THEN | |
24940 | AQ2LO = LOG10(Q2LO) | |
24941 | AQ2HI = LOG10(Q2HI) | |
24942 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) | |
24943 | ENDIF | |
24944 | ||
24945 | IF ( ELO.EQ. EHI) NEBINS = 0 | |
24946 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 | |
24947 | ||
24948 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT | |
24949 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, | |
24950 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, | |
24951 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, | |
24952 | & ' A_p = ',I3,' A_t = ',I3,/) | |
24953 | ||
24954 | C IF (IJPROJ.NE.7) THEN | |
24955 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' | |
24956 | * normalize fractions of emulsion components | |
24957 | IF (NCOMPO.GT.0) THEN | |
24958 | SUMFRA = ZERO | |
24959 | DO 10 I=1,NCOMPO | |
24960 | SUMFRA = SUMFRA+EMUFRA(I) | |
24961 | 10 CONTINUE | |
24962 | IF (SUMFRA.GT.ZERO) THEN | |
24963 | DO 11 I=1,NCOMPO | |
24964 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
24965 | 11 CONTINUE | |
24966 | ENDIF | |
24967 | ENDIF | |
24968 | C ELSE | |
24969 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' | |
24970 | C ENDIF | |
24971 | DO 1 I=1,NEBINS+1 | |
24972 | IF (LELOG) THEN | |
24973 | E = 10**(AELO+DBLE(I-1)*ADEBIN) | |
24974 | ELSE | |
24975 | E = ELO+DBLE(I-1)*DEBINS | |
24976 | ENDIF | |
24977 | DO 2 J=1,NQBINS+1 | |
24978 | IF (LQLOG) THEN | |
24979 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) | |
24980 | ELSE | |
24981 | Q2 = Q2LO+DBLE(J-1)*DQBINS | |
24982 | ENDIF | |
24983 | c IF (IJPROJ.NE.7) THEN | |
24984 | IF (LLAB) THEN | |
24985 | PLAB = ZERO | |
24986 | ECM = ZERO | |
24987 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) | |
24988 | ELSE | |
24989 | ECM = E | |
24990 | ENDIF | |
24991 | XI = ZERO | |
24992 | Q2I = ZERO | |
24993 | IF (IJPROJ.EQ.7) Q2I = Q2 | |
24994 | IF (NCOMPO.GT.0) THEN | |
24995 | DO 20 IC=1,NCOMPO | |
24996 | IIT = IEMUMA(IC) | |
24997 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) | |
24998 | 20 CONTINUE | |
24999 | ELSE | |
25000 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) | |
25001 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) | |
25002 | ENDIF | |
25003 | IF (NCOMPO.GT.0) THEN | |
25004 | XTOT = ZERO | |
25005 | ETOT = ZERO | |
25006 | XELA = ZERO | |
25007 | EELA = ZERO | |
25008 | XQEP = ZERO | |
25009 | EQEP = ZERO | |
25010 | XQET = ZERO | |
25011 | EQET = ZERO | |
25012 | XQE2 = ZERO | |
25013 | EQE2 = ZERO | |
25014 | XPRO = ZERO | |
25015 | EPRO = ZERO | |
25016 | XPRO1= ZERO | |
25017 | XDEL = ZERO | |
25018 | EDEL = ZERO | |
25019 | XDQE = ZERO | |
25020 | EDQE = ZERO | |
25021 | DO 21 IC=1,NCOMPO | |
25022 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) | |
25023 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 | |
25024 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) | |
25025 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 | |
25026 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) | |
25027 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 | |
25028 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) | |
25029 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 | |
25030 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) | |
25031 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 | |
25032 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) | |
25033 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 | |
25034 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) | |
25035 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 | |
25036 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) | |
25037 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 | |
25038 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) | |
25039 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) | |
25040 | & -XSQE2(1,1,IC) | |
25041 | XPRO1= XPRO1+EMUFRA(IC)*YPRO | |
25042 | 21 CONTINUE | |
25043 | ETOT = SQRT(ETOT) | |
25044 | EELA = SQRT(EELA) | |
25045 | EQEP = SQRT(EQEP) | |
25046 | EQET = SQRT(EQET) | |
25047 | EQE2 = SQRT(EQE2) | |
25048 | EPRO = SQRT(EPRO) | |
25049 | EDEL = SQRT(EDEL) | |
25050 | EDQE = SQRT(EDQE) | |
25051 | WRITE(LOUT,'(8E9.3)') | |
25052 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 | |
25053 | C WRITE(LOUT,'(4E9.3)') | |
25054 | C & E,XDEL,XDQE,XDEL+XDQE | |
25055 | ELSE | |
25056 | WRITE(LOUT,'(11E10.3)') | |
25057 | & E, | |
25058 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), | |
25059 | & XSQE2(1,1,1),XSPRO(1,1,1), | |
25060 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) | |
25061 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), | |
25062 | & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25063 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), | |
25064 | C & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25065 | ENDIF | |
25066 | c ELSE | |
25067 | c IF (LLAB) THEN | |
25068 | c IF (IT.GT.1) THEN | |
25069 | c IF (IXSQEL.EQ.0) THEN | |
25070 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, | |
25071 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, | |
25072 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, | |
25073 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25074 | c IF (IRATIO.EQ.1) THEN | |
25075 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) | |
25076 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) | |
25077 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) | |
25078 | c*!! save cross sections | |
25079 | c STOTA = STOT | |
25080 | c ETOTA = ETOT | |
25081 | c STOTP = STGP | |
25082 | c*!! | |
25083 | c STOT = STOT/(DBLE(IT)*STGP) | |
25084 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25085 | c STOT0 = STGP | |
25086 | c ETOT = ZERO | |
25087 | c EIN = ZERO | |
25088 | c ENDIF | |
25089 | c ELSE | |
25090 | c WRITE(LOUT,*) | |
25091 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25092 | c STOP | |
25093 | c ENDIF | |
25094 | c ELSE | |
25095 | c ETOT = ZERO | |
25096 | c EIN = ZERO | |
25097 | c STOT0= ZERO | |
25098 | c IF (IXSQEL.EQ.0) THEN | |
25099 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) | |
25100 | c ELSE | |
25101 | c SIN = ZERO | |
25102 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) | |
25103 | c ENDIF | |
25104 | c ENDIF | |
25105 | c ELSE | |
25106 | c IF (IT.GT.1) THEN | |
25107 | c IF (IXSQEL.EQ.0) THEN | |
25108 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, | |
25109 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25110 | c IF (IRATIO.EQ.1) THEN | |
25111 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) | |
25112 | c*!! save cross sections | |
25113 | c STOTA = STOT | |
25114 | c ETOTA = ETOT | |
25115 | c STOTP = STGP | |
25116 | c*!! | |
25117 | c STOT = STOT/(DBLE(IT)*STGP) | |
25118 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25119 | c STOT0 = STGP | |
25120 | c ETOT = ZERO | |
25121 | c EIN = ZERO | |
25122 | c ENDIF | |
25123 | c ELSE | |
25124 | c WRITE(LOUT,*) | |
25125 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25126 | c STOP | |
25127 | c ENDIF | |
25128 | c ELSE | |
25129 | c ETOT = ZERO | |
25130 | c EIN = ZERO | |
25131 | c STOT0= ZERO | |
25132 | c IF (IXSQEL.EQ.0) THEN | |
25133 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) | |
25134 | c ELSE | |
25135 | c SIN = ZERO | |
25136 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) | |
25137 | c ENDIF | |
25138 | c ENDIF | |
25139 | c ENDIF | |
25140 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO | |
25141 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR | |
25142 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 | |
25143 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN | |
25144 | c ENDIF | |
25145 | 2 CONTINUE | |
25146 | 1 CONTINUE | |
25147 | ||
25148 | RETURN | |
25149 | END | |
25150 | ||
25151 | *$ CREATE DT_TESTXS.FOR | |
25152 | *COPY DT_TESTXS | |
25153 | * | |
25154 | *===testxs=============================================================* | |
25155 | * | |
25156 | SUBROUTINE DT_TESTXS | |
25157 | ||
25158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25159 | SAVE | |
25160 | ||
25161 | DIMENSION XSTOT(26,2),XSELA(26,2) | |
25162 | ||
25163 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') | |
25164 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') | |
25165 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') | |
25166 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') | |
25167 | DUMECM = 0.0D0 | |
25168 | PLABL = 0.01D0 | |
25169 | PLABH = 10000.0D0 | |
25170 | NBINS = 120 | |
25171 | APLABL = LOG10(PLABL) | |
25172 | APLABH = LOG10(PLABH) | |
25173 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) | |
25174 | DO 1 I=1,NBINS+1 | |
25175 | ADP = APLABL+DBLE(I-1)*ADPLAB | |
25176 | P = 10.0D0**ADP | |
25177 | DO 2 J=1,26 | |
25178 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) | |
25179 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) | |
25180 | 2 CONTINUE | |
25181 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) | |
25182 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) | |
25183 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) | |
25184 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) | |
25185 | 1 CONTINUE | |
25186 | 1000 FORMAT(F8.3,26F9.3) | |
25187 | ||
25188 | RETURN | |
25189 | END | |
25190 | ||
25191 | ************************************************************************ | |
25192 | * * | |
25193 | * DTUNUC 2.0: library routines * | |
25194 | * processed by S. Roesler, 6.5.95 * | |
25195 | * * | |
25196 | ************************************************************************ | |
25197 | * | |
25198 | * 1) Handling of parton momenta | |
25199 | * SUBROUTINE MASHEL | |
25200 | * SUBROUTINE DFERMI | |
25201 | * | |
25202 | * 2) Handling of parton flavors and particle indices | |
25203 | * INTEGER FUNCTION IPDG2B | |
25204 | * INTEGER FUNCTION IB2PDG | |
25205 | * INTEGER FUNCTION IQUARK | |
25206 | * INTEGER FUNCTION IBJQUA | |
25207 | * INTEGER FUNCTION ICIHAD | |
25208 | * INTEGER FUNCTION IPDGHA | |
25209 | * INTEGER FUNCTION MCHAD | |
25210 | * SUBROUTINE FLAHAD | |
25211 | * | |
25212 | * 3) Energy-momentum and quantum number conservation check routines | |
25213 | * SUBROUTINE EMC1 | |
25214 | * SUBROUTINE EMC2 | |
25215 | * SUBROUTINE EVTEMC | |
25216 | * SUBROUTINE EVTFLC | |
25217 | * SUBROUTINE EVTCHG | |
25218 | * | |
25219 | * 4) Transformations | |
25220 | * SUBROUTINE LTINI | |
25221 | * SUBROUTINE LTRANS | |
25222 | * SUBROUTINE LTNUC | |
25223 | * SUBROUTINE DALTRA | |
25224 | * SUBROUTINE DTRAFO | |
25225 | * SUBROUTINE STTRAN | |
25226 | * SUBROUTINE MYTRAN | |
25227 | * SUBROUTINE LT2LAO | |
25228 | * SUBROUTINE LT2LAB | |
25229 | * | |
25230 | * 5) Sampling from distributions | |
25231 | * INTEGER FUNCTION NPOISS | |
25232 | * DOUBLE PRECISION FUNCTION SAMPXB | |
25233 | * DOUBLE PRECISION FUNCTION SAMPEX | |
25234 | * DOUBLE PRECISION FUNCTION SAMSQX | |
25235 | * DOUBLE PRECISION FUNCTION BETREJ | |
25236 | * DOUBLE PRECISION FUNCTION DGAMRN | |
25237 | * DOUBLE PRECISION FUNCTION DBETAR | |
25238 | * SUBROUTINE RANNOR | |
25239 | * SUBROUTINE DPOLI | |
25240 | * SUBROUTINE DSFECF | |
25241 | * SUBROUTINE RACO | |
25242 | * | |
25243 | * 6) Special functions, algorithms and service routines | |
25244 | * DOUBLE PRECISION FUNCTION YLAMB | |
25245 | * SUBROUTINE SORT | |
25246 | * SUBROUTINE SORT1 | |
25247 | * SUBROUTINE DT_XTIME | |
25248 | * | |
25249 | * 7) Random number generator package | |
25250 | * DOUBLE PRECISION FUNCTION DT_RNDM | |
25251 | * SUBROUTINE DT_RNDMST | |
25252 | * SUBROUTINE DT_RNDMIN | |
25253 | * SUBROUTINE DT_RNDMOU | |
25254 | * SUBROUTINE DT_RNDMTE | |
25255 | * | |
25256 | ************************************************************************ | |
25257 | * * | |
25258 | * 1) Handling of parton momenta * | |
25259 | * * | |
25260 | ************************************************************************ | |
25261 | *$ CREATE DT_MASHEL.FOR | |
25262 | *COPY DT_MASHEL | |
25263 | * | |
25264 | *===mashel=============================================================* | |
25265 | * | |
25266 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) | |
25267 | ||
25268 | ************************************************************************ | |
25269 | * * | |
25270 | * rescaling of momenta of two partons to put both * | |
25271 | * on mass shell * | |
25272 | * * | |
25273 | * input: PA1,PA2 input momentum vectors * | |
25274 | * XM1,2 desired masses of particles afterwards * | |
25275 | * P1,P2 changed momentum vectors * | |
25276 | * * | |
25277 | * The original version is written by R. Engel. * | |
25278 | * This version dated 12.12.94 is modified by S. Roesler. * | |
25279 | ************************************************************************ | |
25280 | ||
25281 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25282 | SAVE | |
25283 | PARAMETER ( LINP = 10 , | |
25284 | & LOUT = 6 , | |
25285 | & LDAT = 9 ) | |
25286 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
25287 | ||
25288 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
25289 | ||
25290 | IREJ = 0 | |
25291 | ||
25292 | * Lorentz transformation into system CMS | |
25293 | PX = PA1(1)+PA2(1) | |
25294 | PY = PA1(2)+PA2(2) | |
25295 | PZ = PA1(3)+PA2(3) | |
25296 | EE = PA1(4)+PA2(4) | |
25297 | XPTOT = SQRT(PX**2+PY**2+PZ**2) | |
25298 | XMS = (EE-XPTOT)*(EE+XPTOT) | |
25299 | IF(XMS.LT.(XM1+XM2)**2) THEN | |
25300 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 | |
25301 | GOTO 9999 | |
25302 | ENDIF | |
25303 | XMS = SQRT(XMS) | |
25304 | BGX = PX/XMS | |
25305 | BGY = PY/XMS | |
25306 | BGZ = PZ/XMS | |
25307 | GAM = EE/XMS | |
25308 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), | |
25309 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25310 | * rotation angles | |
25311 | COD = P1(3)/PTOT1 | |
25312 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
25313 | PPT = SQRT(P1(1)**2+P1(2)**2) | |
25314 | SID = PPT/PTOT1 | |
25315 | COF = ONE | |
25316 | SIF = ZERO | |
25317 | IF(PTOT1*SID.GT.TINY10) THEN | |
25318 | COF = P1(1)/(SID*PTOT1) | |
25319 | SIF = P1(2)/(SID*PTOT1) | |
25320 | ANORF = SQRT(COF*COF+SIF*SIF) | |
25321 | COF = COF/ANORF | |
25322 | SIF = SIF/ANORF | |
25323 | ENDIF | |
25324 | * new CM momentum and energies (for masses XM1,XM2) | |
25325 | XM12 = SIGN(XM1**2,XM1) | |
25326 | XM22 = SIGN(XM2**2,XM2) | |
25327 | SS = XMS**2 | |
25328 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) | |
25329 | EE1 = SQRT(XM12+PCMP**2) | |
25330 | EE2 = XMS-EE1 | |
25331 | * back rotation | |
25332 | MODE = 1 | |
25333 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) | |
25334 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, | |
25335 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25336 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, | |
25337 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) | |
25338 | * check consistency | |
25339 | DEL = XMS*0.0001D0 | |
25340 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN | |
25341 | IDEV = 1 | |
25342 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN | |
25343 | IDEV = 2 | |
25344 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN | |
25345 | IDEV = 3 | |
25346 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN | |
25347 | IDEV = 4 | |
25348 | ELSE | |
25349 | IDEV = 0 | |
25350 | ENDIF | |
25351 | IF (IDEV.NE.0) THEN | |
25352 | WRITE(LOUT,'(/1X,A,I3)') | |
25353 | & 'MASHEL: inconsistent transformation',IDEV | |
25354 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' | |
25355 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 | |
25356 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 | |
25357 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' | |
25358 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) | |
25359 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) | |
25360 | ENDIF | |
25361 | RETURN | |
25362 | ||
25363 | 9999 CONTINUE | |
25364 | IREJ = 1 | |
25365 | RETURN | |
25366 | END | |
25367 | ||
25368 | *$ CREATE DT_DFERMI.FOR | |
25369 | *COPY DT_DFERMI | |
25370 | * | |
25371 | *===dfermi=============================================================* | |
25372 | * | |
25373 | SUBROUTINE DT_DFERMI(GPART) | |
25374 | ||
25375 | ************************************************************************ | |
25376 | * Find largest of three random numbers. * | |
25377 | ************************************************************************ | |
25378 | ||
25379 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25380 | SAVE | |
25381 | ||
25382 | DIMENSION G(3) | |
25383 | ||
25384 | DO 10 I=1,3 | |
25385 | G(I)=DT_RNDM(GPART) | |
25386 | 10 CONTINUE | |
25387 | IF (G(3).LT.G(2)) GOTO 40 | |
25388 | IF (G(3).LT.G(1)) GOTO 30 | |
25389 | GPART = G(3) | |
25390 | 20 RETURN | |
25391 | 30 GPART = G(1) | |
25392 | GOTO 20 | |
25393 | 40 IF (G(2).LT.G(1)) GOTO 30 | |
25394 | GPART = G(2) | |
25395 | GOTO 20 | |
25396 | ||
25397 | END | |
25398 | ||
25399 | ************************************************************************ | |
25400 | * * | |
25401 | * 2) Handling of parton flavors and particle indices * | |
25402 | * * | |
25403 | ************************************************************************ | |
25404 | *$ CREATE IDT_IPDG2B.FOR | |
25405 | *COPY IDT_IPDG2B | |
25406 | * | |
25407 | *===ipdg2b=============================================================* | |
25408 | * | |
25409 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) | |
25410 | ||
25411 | ************************************************************************ | |
25412 | * * | |
25413 | * conversion of quark numbering scheme * | |
25414 | * * | |
25415 | * input: PDG parton numbering * | |
25416 | * for diquarks: NN number of the constituent quark * | |
25417 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * | |
25418 | * * | |
25419 | * output: BAMJET particle codes * | |
25420 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25421 | * 2 d 8 a-d -2 a-d * | |
25422 | * 3 s 9 a-s -3 a-s * | |
25423 | * 4 c 10 a-c -4 a-c * | |
25424 | * * | |
25425 | * This is a modified version of ICONV2 written by R. Engel. * | |
25426 | * This version dated 13.12.94 is written by S. Roesler. * | |
25427 | ************************************************************************ | |
25428 | ||
25429 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25430 | SAVE | |
25431 | PARAMETER ( LINP = 10 , | |
25432 | & LOUT = 6 , | |
25433 | & LDAT = 9 ) | |
25434 | ||
25435 | IDA = ABS(ID) | |
25436 | * diquarks | |
25437 | IF (IDA.GT.6) THEN | |
25438 | KF = 3 | |
25439 | IF (IDA.GE.1000) KF = 4 | |
25440 | IDA = IDA/(10**(KF-NN)) | |
25441 | IDA = MOD(IDA,10) | |
25442 | ENDIF | |
25443 | * exchange up and dn quarks | |
25444 | IF (IDA.EQ.1) THEN | |
25445 | IDA = 2 | |
25446 | ELSEIF (IDA.EQ.2) THEN | |
25447 | IDA = 1 | |
25448 | ENDIF | |
25449 | * antiquarks | |
25450 | IF (ID.LT.0) THEN | |
25451 | IF (MODE.EQ.1) THEN | |
25452 | IDA = IDA+6 | |
25453 | ELSE | |
25454 | IDA = -IDA | |
25455 | ENDIF | |
25456 | ENDIF | |
25457 | IDT_IPDG2B = IDA | |
25458 | ||
25459 | RETURN | |
25460 | END | |
25461 | ||
25462 | *$ CREATE IDT_IB2PDG.FOR | |
25463 | *COPY IDT_IB2PDG | |
25464 | * | |
25465 | *===ib2pdg=============================================================* | |
25466 | * | |
25467 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) | |
25468 | ||
25469 | ************************************************************************ | |
25470 | * * | |
25471 | * conversion of quark numbering scheme * | |
25472 | * * | |
25473 | * input: BAMJET particle codes * | |
25474 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25475 | * 2 d 8 a-d -2 a-d * | |
25476 | * 3 s 9 a-s -3 a-s * | |
25477 | * 4 c 10 a-c -4 a-c * | |
25478 | * * | |
25479 | * output: PDG parton numbering * | |
25480 | * * | |
25481 | * This version dated 13.12.94 is written by S. Roesler. * | |
25482 | ************************************************************************ | |
25483 | ||
25484 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25485 | SAVE | |
25486 | PARAMETER ( LINP = 10 , | |
25487 | & LOUT = 6 , | |
25488 | & LDAT = 9 ) | |
25489 | ||
25490 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) | |
25491 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ | |
25492 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, | |
25493 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, | |
25494 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ | |
25495 | ||
25496 | IDA = ID1 | |
25497 | IDB = ID2 | |
25498 | IF (MODE.EQ.1) THEN | |
25499 | IF (ID1.GT.6) IDA = -(ID1-6) | |
25500 | IF (ID2.GT.6) IDB = -(ID2-6) | |
25501 | ENDIF | |
25502 | IF (ID2.EQ.0) THEN | |
25503 | IDT_IB2PDG = IHKKQ(IDA) | |
25504 | ELSE | |
25505 | IDT_IB2PDG = IHKKQQ(IDA,IDB) | |
25506 | ENDIF | |
25507 | ||
25508 | RETURN | |
25509 | END | |
25510 | ||
25511 | *$ CREATE IDT_IQUARK.FOR | |
25512 | *COPY IDT_IQUARK | |
25513 | * | |
25514 | *===ipdgqu=============================================================* | |
25515 | * | |
25516 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) | |
25517 | ||
25518 | ************************************************************************ | |
25519 | * * | |
25520 | * quark contents according to PDG conventions * | |
25521 | * (random selection in case of quark mixing) * | |
25522 | * * | |
25523 | * input: IDBAMJ BAMJET particle code * | |
25524 | * K 1..3 quark number * | |
25525 | * * | |
25526 | * output: 1 d (anti --> neg.) * | |
25527 | * 2 u * | |
25528 | * 3 s * | |
25529 | * 4 c * | |
25530 | * * | |
25531 | * This version written by R. Engel. * | |
25532 | ************************************************************************ | |
25533 | ||
25534 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25535 | SAVE | |
25536 | ||
25537 | IQ = IDT_IBJQUA(K,IDBAMJ) | |
25538 | * quark-antiquark | |
25539 | IF (IQ.GT.6) THEN | |
25540 | IQ = 6-IQ | |
25541 | ENDIF | |
25542 | * exchange of up and down | |
25543 | IF (ABS(IQ).EQ.1) THEN | |
25544 | IQ = SIGN(2,IQ) | |
25545 | ELSEIF (ABS(IQ).EQ.2) THEN | |
25546 | IQ = SIGN(1,IQ) | |
25547 | ENDIF | |
25548 | IDT_IQUARK = IQ | |
25549 | ||
25550 | RETURN | |
25551 | END | |
25552 | ||
25553 | *$ CREATE IDT_IBJQUA.FOR | |
25554 | *COPY IDT_IBJQUA | |
25555 | * | |
25556 | *===ibamq==============================================================* | |
25557 | * | |
25558 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) | |
25559 | ||
25560 | ************************************************************************ | |
25561 | * * | |
25562 | * quark contents according to BAMJET conventions * | |
25563 | * (random selection in case of quark mixing) * | |
25564 | * * | |
25565 | * input: IDBAMJ BAMJET particle code * | |
25566 | * K 1..3 quark number * | |
25567 | * * | |
25568 | * output: 1 u 7 u bar * | |
25569 | * 2 d 8 d bar * | |
25570 | * 3 s 9 s bar * | |
25571 | * 4 c 10 c bar * | |
25572 | * * | |
25573 | * This version written by R. Engel. * | |
25574 | ************************************************************************ | |
25575 | ||
25576 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25577 | SAVE | |
25578 | ||
25579 | DIMENSION ITAB(3,210) | |
25580 | DATA ((ITAB(I,K),I=1,3),K=1,30) / | |
25581 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, | |
25582 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25583 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, | |
25584 | *sr 10.1.94 | |
25585 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25586 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, | |
25587 | * | |
25588 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, | |
25589 | *sr 10.1.94 | |
25590 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, | |
25591 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, | |
25592 | *sr 10.1.94 | |
25593 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, | |
25594 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, | |
25595 | * | |
25596 | & 1, 2, 3, 201,202, 0, 2, 9, 0, | |
25597 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, | |
25598 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25599 | DATA ((ITAB(I,K),I=1,3),K=31,60) / | |
25600 | & 3, 9, 0, 1, 8, 0, 203,204, 0, | |
25601 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, | |
25602 | & 2, 9, 0, 3, 7, 0, 3, 8, 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, 1, 1, 1, 1, 1, 2, | |
25608 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, | |
25609 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25610 | DATA ((ITAB(I,K),I=1,3),K=61,90) / | |
25611 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25612 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25613 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, | |
25614 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, | |
25615 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25616 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25617 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25618 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25619 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25620 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25621 | DATA ((ITAB(I,K),I=1,3),K=91,120) / | |
25622 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25623 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, | |
25624 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, | |
25625 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, | |
25626 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, | |
25627 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, | |
25628 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, | |
25629 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, | |
25630 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, | |
25631 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / | |
25632 | DATA ((ITAB(I,K),I=1,3),K=121,150) / | |
25633 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, | |
25634 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, | |
25635 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, | |
25636 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25637 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25638 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, | |
25639 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, | |
25640 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, | |
25641 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25642 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / | |
25643 | DATA ((ITAB(I,K),I=1,3),K=151,180) / | |
25644 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, | |
25645 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, | |
25646 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, | |
25647 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, | |
25648 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, | |
25649 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25650 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, | |
25651 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, | |
25652 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, | |
25653 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / | |
25654 | DATA ((ITAB(I,K),I=1,3),K=181,210) / | |
25655 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25656 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25657 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25658 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25659 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25660 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25661 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, | |
25662 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, | |
25663 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25664 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25665 | DATA IDOLD /0/ | |
25666 | ||
25667 | ONE = 1.0D0 | |
25668 | IF (ITAB(1,IDBAMJ).LE.200) THEN | |
25669 | ID = ITAB(K,IDBAMJ) | |
25670 | ELSE | |
25671 | IF(IDOLD.NE.IDBAMJ) THEN | |
25672 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* | |
25673 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) | |
25674 | ELSE | |
25675 | IDOLD = 0 | |
25676 | ENDIF | |
25677 | ID = ITAB(K,IT) | |
25678 | ENDIF | |
25679 | IDOLD = IDBAMJ | |
25680 | IDT_IBJQUA = ID | |
25681 | ||
25682 | RETURN | |
25683 | END | |
25684 | ||
25685 | *$ CREATE IDT_ICIHAD.FOR | |
25686 | *COPY IDT_ICIHAD | |
25687 | * | |
25688 | *===icihad=============================================================* | |
25689 | * | |
25690 | INTEGER FUNCTION IDT_ICIHAD(MCIND) | |
25691 | ||
25692 | ************************************************************************ | |
25693 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * | |
25694 | * This is a completely new version dated 25.10.95. * | |
25695 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25696 | ************************************************************************ | |
25697 | ||
25698 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25699 | SAVE | |
25700 | ||
25701 | * hadron index conversion (BAMJET <--> PDG) | |
25702 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25703 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25704 | & IAMCIN(210) | |
25705 | ||
25706 | IDT_ICIHAD = 0 | |
25707 | KPDG = ABS(MCIND) | |
25708 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN | |
25709 | IF (MCIND.LT.0) THEN | |
25710 | JSIGN = 1 | |
25711 | ELSE | |
25712 | JSIGN = 2 | |
25713 | ENDIF | |
25714 | IF (KPDG.GE.10000) THEN | |
25715 | DO 1 I=1,19 | |
25716 | IDT_ICIHAD = IBAM5(JSIGN,I) | |
25717 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 | |
25718 | IDT_ICIHAD = 0 | |
25719 | 1 CONTINUE | |
25720 | ELSEIF (KPDG.GE.1000) THEN | |
25721 | DO 2 I=1,29 | |
25722 | IDT_ICIHAD = IBAM4(JSIGN,I) | |
25723 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 | |
25724 | IDT_ICIHAD = 0 | |
25725 | 2 CONTINUE | |
25726 | ELSEIF (KPDG.GE.100) THEN | |
25727 | DO 3 I=1,22 | |
25728 | IDT_ICIHAD = IBAM3(JSIGN,I) | |
25729 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 | |
25730 | IDT_ICIHAD = 0 | |
25731 | 3 CONTINUE | |
25732 | ELSEIF (KPDG.GE.10) THEN | |
25733 | DO 4 I=1,7 | |
25734 | IDT_ICIHAD = IBAM2(JSIGN,I) | |
25735 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 | |
25736 | IDT_ICIHAD = 0 | |
25737 | 4 CONTINUE | |
25738 | ENDIF | |
25739 | 5 CONTINUE | |
25740 | ||
25741 | RETURN | |
25742 | END | |
25743 | ||
25744 | *$ CREATE IDT_IPDGHA.FOR | |
25745 | *COPY IDT_IPDGHA | |
25746 | * | |
25747 | *===ipdgha=============================================================* | |
25748 | * | |
25749 | INTEGER FUNCTION IDT_IPDGHA(MCIND) | |
25750 | ||
25751 | ************************************************************************ | |
25752 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * | |
25753 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * | |
25754 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25755 | ************************************************************************ | |
25756 | ||
25757 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25758 | SAVE | |
25759 | ||
25760 | * hadron index conversion (BAMJET <--> PDG) | |
25761 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25762 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25763 | & IAMCIN(210) | |
25764 | ||
25765 | IDT_IPDGHA = IAMCIN(MCIND) | |
25766 | ||
25767 | RETURN | |
25768 | END | |
25769 | ||
25770 | *$ CREATE DT_FLAHAD.FOR | |
25771 | *COPY DT_FLAHAD | |
25772 | * | |
25773 | *===flahad=============================================================* | |
25774 | * | |
25775 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) | |
25776 | ||
25777 | ************************************************************************ | |
25778 | * sampling of FLAvor composition for HADrons/photons * | |
25779 | * ID BAMJET-id of hadron * | |
25780 | * IF1,2,3 flavor content * | |
25781 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * | |
25782 | * Note: - u,d numbering as in BAMJET * | |
25783 | * - ID .le. 30 !! * | |
25784 | * This version dated 12.03.96 is written by S. Roesler * | |
25785 | ************************************************************************ | |
25786 | ||
25787 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25788 | SAVE | |
25789 | ||
25790 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
25791 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
25792 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
25793 | & IQTCHR(-6:6),MQUARK(3,39) | |
25794 | ||
25795 | DIMENSION JSEL(3,6) | |
25796 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ | |
25797 | ||
25798 | ONE = 1.0D0 | |
25799 | IF (ID.EQ.7) THEN | |
25800 | * photon (charge dependent flavour sampling) | |
25801 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) | |
25802 | IF (K.LE.4) THEN | |
25803 | IF1 = 2 | |
25804 | IF2 = -2 | |
25805 | ELSE IF(K.EQ.5) THEN | |
25806 | IF1 = 1 | |
25807 | IF2 = -1 | |
25808 | ELSE | |
25809 | IF1 = 3 | |
25810 | IF2 = -3 | |
25811 | ENDIF | |
25812 | IF(DT_RNDM(ONE).LT.0.5D0) THEN | |
25813 | K = IF1 | |
25814 | IF1 = IF2 | |
25815 | IF2 = K | |
25816 | ENDIF | |
25817 | IF3 = 0 | |
25818 | ELSE | |
25819 | * hadron | |
25820 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) | |
25821 | IF1 = MQUARK(JSEL(1,IX),ID) | |
25822 | IF2 = MQUARK(JSEL(2,IX),ID) | |
25823 | IF3 = MQUARK(JSEL(3,IX),ID) | |
25824 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN | |
25825 | IF1 = IF3 | |
25826 | IF3 = 0 | |
25827 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN | |
25828 | IF2 = IF3 | |
25829 | IF3 = 0 | |
25830 | ENDIF | |
25831 | ENDIF | |
25832 | ||
25833 | RETURN | |
25834 | END | |
25835 | ||
25836 | *$ CREATE IDT_MCHAD.FOR | |
25837 | *COPY IDT_MCHAD | |
25838 | * | |
25839 | *===mchad==============================================================* | |
25840 | * | |
25841 | INTEGER FUNCTION IDT_MCHAD(ITDTU) | |
25842 | ||
25843 | ************************************************************************ | |
25844 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * | |
25845 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * | |
25846 | * * | |
25847 | * Last change 28.12.2006 by S. Roesler. * | |
25848 | ************************************************************************ | |
25849 | ||
25850 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25851 | SAVE | |
25852 | ||
25853 | DIMENSION ITRANS(210) | |
25854 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, | |
25855 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, | |
25856 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, | |
25857 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, | |
25858 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, | |
25859 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, | |
25860 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ | |
25861 | ||
25862 | IF ( ITDTU .GT. 0 ) THEN | |
25863 | IDT_MCHAD = ITRANS(ITDTU) | |
25864 | ELSE | |
25865 | IDT_MCHAD = -1 | |
25866 | END IF | |
25867 | ||
25868 | RETURN | |
25869 | END | |
25870 | ||
25871 | ************************************************************************ | |
25872 | * * | |
25873 | * 3) Energy-momentum and quantum number conservation check routines * | |
25874 | * * | |
25875 | ************************************************************************ | |
25876 | *$ CREATE DT_EMC1.FOR | |
25877 | *COPY DT_EMC1 | |
25878 | * | |
25879 | *===emc1===============================================================* | |
25880 | * | |
25881 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) | |
25882 | ||
25883 | ************************************************************************ | |
25884 | * This version dated 15.12.94 is written by S. Roesler * | |
25885 | ************************************************************************ | |
25886 | ||
25887 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25888 | SAVE | |
25889 | PARAMETER ( LINP = 10 , | |
25890 | & LOUT = 6 , | |
25891 | & LDAT = 9 ) | |
25892 | PARAMETER (TINY10=1.0D-10) | |
25893 | ||
25894 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
25895 | ||
25896 | IREJ = 0 | |
25897 | ||
25898 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) | |
25899 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE | |
25900 | ||
25901 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN | |
25902 | IF (MODE.EQ.1) THEN | |
25903 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) | |
25904 | ELSEIF (MODE.EQ.2) THEN | |
25905 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) | |
25906 | ENDIF | |
25907 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) | |
25908 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) | |
25909 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) | |
25910 | ELSEIF (MODE.LT.0) THEN | |
25911 | IF (MODE.EQ.-1) THEN | |
25912 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) | |
25913 | ELSEIF (MODE.EQ.-2) THEN | |
25914 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) | |
25915 | ENDIF | |
25916 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) | |
25917 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) | |
25918 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) | |
25919 | ENDIF | |
25920 | ||
25921 | IF (ABS(MODE).EQ.3) THEN | |
25922 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) | |
25923 | IF (IREJ1.NE.0) GOTO 9999 | |
25924 | ENDIF | |
25925 | RETURN | |
25926 | ||
25927 | 9999 CONTINUE | |
25928 | IREJ = 1 | |
25929 | RETURN | |
25930 | END | |
25931 | ||
25932 | *$ CREATE DT_EMC2.FOR | |
25933 | *COPY DT_EMC2 | |
25934 | * | |
25935 | *===emc2===============================================================* | |
25936 | * | |
25937 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, | |
25938 | & MODE,IPOS,IREJ) | |
25939 | ||
25940 | ************************************************************************ | |
25941 | * MODE = 1 energy-momentum cons. check * | |
25942 | * = 2 flavor-cons. check * | |
25943 | * = 3 energy-momentum & flavor cons. check * | |
25944 | * = 4 energy-momentum & charge cons. check * | |
25945 | * = 5 energy-momentum & flavor & charge cons. check * | |
25946 | * This version dated 16.01.95 is written by S. Roesler * | |
25947 | ************************************************************************ | |
25948 | ||
25949 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25950 | SAVE | |
25951 | PARAMETER ( LINP = 10 , | |
25952 | & LOUT = 6 , | |
25953 | & LDAT = 9 ) | |
25954 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
25955 | ||
25956 | * event history | |
25957 | PARAMETER (NMXHKK=200000) | |
25958 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25959 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25960 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25961 | * extended event history | |
25962 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
25963 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
25964 | & IHIST(2,NMXHKK) | |
25965 | ||
25966 | IREJ = 0 | |
25967 | IREJ1 = 0 | |
25968 | IREJ2 = 0 | |
25969 | IREJ3 = 0 | |
25970 | ||
25971 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25972 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) | |
25973 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25974 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) | |
25975 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) | |
25976 | DO 1 I=1,NHKK | |
25977 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. | |
25978 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. | |
25979 | & (ISTHKK(I).EQ.IP5)) THEN | |
25980 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25981 | & .OR.(MODE.EQ.5)) | |
25982 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
25983 | & 2,IDUM,IDUM) | |
25984 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25985 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) | |
25986 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25987 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) | |
25988 | ENDIF | |
25989 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. | |
25990 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. | |
25991 | & (ISTHKK(I).EQ.IN5)) THEN | |
25992 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25993 | & .OR.(MODE.EQ.5)) | |
25994 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), | |
25995 | & 2,IDUM,IDUM) | |
25996 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25997 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) | |
25998 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25999 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) | |
26000 | ENDIF | |
26001 | 1 CONTINUE | |
26002 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
26003 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) | |
26004 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
26005 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) | |
26006 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) | |
26007 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 | |
26008 | ||
26009 | RETURN | |
26010 | ||
26011 | 9999 CONTINUE | |
26012 | IREJ = 1 | |
26013 | RETURN | |
26014 | END | |
26015 | ||
26016 | *$ CREATE DT_EVTEMC.FOR | |
26017 | *COPY DT_EVTEMC | |
26018 | * | |
26019 | *===evtemc=============================================================* | |
26020 | * | |
26021 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) | |
26022 | ||
26023 | ************************************************************************ | |
26024 | * This version dated 13.12.94 is written by S. Roesler * | |
26025 | ************************************************************************ | |
26026 | ||
26027 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26028 | SAVE | |
26029 | PARAMETER ( LINP = 10 , | |
26030 | & LOUT = 6 , | |
26031 | & LDAT = 9 ) | |
26032 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, | |
26033 | & ZERO=0.0D0) | |
26034 | ||
26035 | * event history | |
26036 | PARAMETER (NMXHKK=200000) | |
26037 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26038 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26039 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26040 | * flags for input different options | |
26041 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
26042 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
26043 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
26044 | ||
26045 | IREJ = 0 | |
26046 | ||
26047 | MODE = IMODE | |
26048 | CHKLEV = TINY10 | |
26049 | IF (MODE.EQ.4) THEN | |
26050 | CHKLEV = TINY2 | |
26051 | MODE = 3 | |
26052 | ELSEIF (MODE.EQ.5) THEN | |
26053 | CHKLEV = TINY1 | |
26054 | MODE = 3 | |
26055 | ELSEIF (MODE.EQ.-1) THEN | |
26056 | CHKLEV = EIO | |
26057 | MODE = 3 | |
26058 | ENDIF | |
26059 | ||
26060 | IF (ABS(MODE).EQ.3) THEN | |
26061 | PXDEV = PX | |
26062 | PYDEV = PY | |
26063 | PZDEV = PZ | |
26064 | EDEV = E | |
26065 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 | |
26066 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. | |
26067 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN | |
26068 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') | |
26069 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, | |
26070 | & ' event ',NEVHKK, | |
26071 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV | |
26072 | PX = 0.0D0 | |
26073 | PY = 0.0D0 | |
26074 | PZ = 0.0D0 | |
26075 | E = 0.0D0 | |
26076 | GOTO 9999 | |
26077 | ENDIF | |
26078 | PX = 0.0D0 | |
26079 | PY = 0.0D0 | |
26080 | PZ = 0.0D0 | |
26081 | E = 0.0D0 | |
26082 | RETURN | |
26083 | ENDIF | |
26084 | ||
26085 | IF (MODE.EQ.1) THEN | |
26086 | PX = 0.0D0 | |
26087 | PY = 0.0D0 | |
26088 | PZ = 0.0D0 | |
26089 | E = 0.0D0 | |
26090 | ENDIF | |
26091 | ||
26092 | PX = PX+PXIO | |
26093 | PY = PY+PYIO | |
26094 | PZ = PZ+PZIO | |
26095 | E = E+EIO | |
26096 | ||
26097 | RETURN | |
26098 | ||
26099 | 9999 CONTINUE | |
26100 | IREJ = 1 | |
26101 | RETURN | |
26102 | END | |
26103 | ||
26104 | *$ CREATE DT_EVTFLC.FOR | |
26105 | *COPY DT_EVTFLC | |
26106 | * | |
26107 | *===evtflc=============================================================* | |
26108 | * | |
26109 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) | |
26110 | ||
26111 | ************************************************************************ | |
26112 | * Flavor conservation check. * | |
26113 | * ID identity of particle * | |
26114 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * | |
26115 | * = 2 ID for particle/resonance in BAMJET numbering scheme * | |
26116 | * = 3 ID for particle/resonance in PDG numbering scheme * | |
26117 | * MODE = 1 initialization and add ID * | |
26118 | * =-1 initialization and subtract ID * | |
26119 | * = 2 add ID * | |
26120 | * =-2 subtract ID * | |
26121 | * = 3 check flavor cons. * | |
26122 | * IPOS flag to give position of call of EVTFLC to output * | |
26123 | * unit in case of violation * | |
26124 | * This version dated 10.01.95 is written by S. Roesler * | |
26125 | ************************************************************************ | |
26126 | ||
26127 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26128 | SAVE | |
26129 | PARAMETER ( LINP = 10 , | |
26130 | & LOUT = 6 , | |
26131 | & LDAT = 9 ) | |
26132 | PARAMETER (TINY10=1.0D-10) | |
26133 | ||
26134 | IREJ = 0 | |
26135 | ||
26136 | IF (MODE.EQ.3) THEN | |
26137 | IF (IFL.NE.0) THEN | |
26138 | WRITE(LOUT,'(1X,A,I3,A,I3)') | |
26139 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, | |
26140 | & ' ! IFL = ',IFL | |
26141 | IFL = 0 | |
26142 | GOTO 9999 | |
26143 | ENDIF | |
26144 | IFL = 0 | |
26145 | RETURN | |
26146 | ENDIF | |
26147 | ||
26148 | IF (MODE.EQ.1) IFL = 0 | |
26149 | IF (ID.EQ.0) RETURN | |
26150 | ||
26151 | IF (ID1.EQ.1) THEN | |
26152 | IDD = ABS(ID) | |
26153 | NQ = 1 | |
26154 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 | |
26155 | IF (IDD.GE.1000) NQ = 3 | |
26156 | DO 1 I=1,NQ | |
26157 | IFBAM = IDT_IPDG2B(ID,I,2) | |
26158 | IF (ABS(IFBAM).EQ.1) THEN | |
26159 | IFBAM = SIGN(2,IFBAM) | |
26160 | ELSEIF (ABS(IFBAM).EQ.2) THEN | |
26161 | IFBAM = SIGN(1,IFBAM) | |
26162 | ENDIF | |
26163 | IF (MODE.GT.0) THEN | |
26164 | IFL = IFL+IFBAM | |
26165 | ELSE | |
26166 | IFL = IFL-IFBAM | |
26167 | ENDIF | |
26168 | 1 CONTINUE | |
26169 | RETURN | |
26170 | ENDIF | |
26171 | ||
26172 | IDD = ID | |
26173 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) | |
26174 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN | |
26175 | DO 2 I=1,3 | |
26176 | IF (MODE.GT.0) THEN | |
26177 | IFL = IFL+IDT_IQUARK(I,IDD) | |
26178 | ELSE | |
26179 | IFL = IFL-IDT_IQUARK(I,IDD) | |
26180 | ENDIF | |
26181 | 2 CONTINUE | |
26182 | ENDIF | |
26183 | RETURN | |
26184 | ||
26185 | 9999 CONTINUE | |
26186 | IREJ = 1 | |
26187 | RETURN | |
26188 | END | |
26189 | ||
26190 | *$ CREATE DT_EVTCHG.FOR | |
26191 | *COPY DT_EVTCHG | |
26192 | * | |
26193 | *===evtchg=============================================================* | |
26194 | * | |
26195 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) | |
26196 | ||
26197 | ************************************************************************ | |
26198 | * Charge conservation check. * | |
26199 | * ID identity of particle (PDG-numbering scheme) * | |
26200 | * MODE = 1 initialization * | |
26201 | * =-2 subtract ID-charge * | |
26202 | * = 2 add ID-charge * | |
26203 | * = 3 check charge cons. * | |
26204 | * IPOS flag to give position of call of EVTCHG to output * | |
26205 | * unit in case of violation * | |
26206 | * This version dated 10.01.95 is written by S. Roesler * | |
26207 | * Last change: s.r. 21.01.01 * | |
26208 | ************************************************************************ | |
26209 | ||
26210 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26211 | SAVE | |
26212 | PARAMETER ( LINP = 10 , | |
26213 | & LOUT = 6 , | |
26214 | & LDAT = 9 ) | |
26215 | ||
26216 | * event history | |
26217 | PARAMETER (NMXHKK=200000) | |
26218 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26219 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26220 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26221 | * particle properties (BAMJET index convention) | |
26222 | CHARACTER*8 ANAME | |
26223 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26224 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26225 | ||
26226 | IREJ = 0 | |
26227 | ||
26228 | IF (MODE.EQ.1) THEN | |
26229 | ICH = 0 | |
26230 | IBAR = 0 | |
26231 | RETURN | |
26232 | ENDIF | |
26233 | ||
26234 | IF (MODE.EQ.3) THEN | |
26235 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN | |
26236 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') | |
26237 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, | |
26238 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK | |
26239 | ICH = 0 | |
26240 | IBAR = 0 | |
26241 | GOTO 9999 | |
26242 | ENDIF | |
26243 | ICH = 0 | |
26244 | IBAR = 0 | |
26245 | RETURN | |
26246 | ENDIF | |
26247 | ||
26248 | IF (ID.EQ.0) RETURN | |
26249 | ||
26250 | IDD = IDT_ICIHAD(ID) | |
26251 | * modification 21.1.01: use intrinsic phojet-functions to determine charge | |
26252 | * and baryon number | |
26253 | C IF (IDD.GT.0) THEN | |
26254 | C IF (MODE.EQ.2) THEN | |
26255 | C ICH = ICH+IICH(IDD) | |
26256 | C IBAR = IBAR+IIBAR(IDD) | |
26257 | C ELSEIF (MODE.EQ.-2) THEN | |
26258 | C ICH = ICH-IICH(IDD) | |
26259 | C IBAR = IBAR-IIBAR(IDD) | |
26260 | C ENDIF | |
26261 | C ELSE | |
26262 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID | |
26263 | C CALL DT_EVTOUT(4) | |
26264 | C STOP | |
26265 | C ENDIF | |
26266 | IF (MODE.EQ.2) THEN | |
26267 | ICH = ICH+IPHO_CHR3(ID,1)/3 | |
26268 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 | |
26269 | ELSEIF (MODE.EQ.-2) THEN | |
26270 | ICH = ICH-IPHO_CHR3(ID,1)/3 | |
26271 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 | |
26272 | ENDIF | |
26273 | ||
26274 | RETURN | |
26275 | ||
26276 | 9999 CONTINUE | |
26277 | IREJ = 1 | |
26278 | RETURN | |
26279 | END | |
26280 | ||
26281 | ************************************************************************ | |
26282 | * * | |
26283 | * 4) Transformations * | |
26284 | * * | |
26285 | ************************************************************************ | |
26286 | *$ CREATE DT_LTINI.FOR | |
26287 | *COPY DT_LTINI | |
26288 | * | |
26289 | *===ltini==============================================================* | |
26290 | * | |
26291 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) | |
26292 | ||
26293 | ************************************************************************ | |
26294 | * Initializations of Lorentz-transformations, calculation of Lorentz- * | |
26295 | * parameters. * | |
26296 | * This version dated 13.11.95 is written by S. Roesler. * | |
26297 | ************************************************************************ | |
26298 | ||
26299 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26300 | SAVE | |
26301 | PARAMETER ( LINP = 10 , | |
26302 | & LOUT = 6 , | |
26303 | & LDAT = 9 ) | |
26304 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, | |
26305 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
26306 | ||
26307 | * Lorentz-parameters of the current interaction | |
26308 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26309 | & UMO,PPCM,EPROJ,PPROJ | |
26310 | * properties of photon/lepton projectiles | |
26311 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
26312 | * particle properties (BAMJET index convention) | |
26313 | CHARACTER*8 ANAME | |
26314 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26315 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26316 | * nucleon-nucleon event-generator | |
26317 | CHARACTER*8 CMODEL | |
26318 | LOGICAL LPHOIN | |
26319 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
26320 | ||
26321 | Q2 = VIRT | |
26322 | IDP = IDPR | |
26323 | IF (MCGENE.NE.3) THEN | |
26324 | * lepton-projectiles and PHOJET: initialize real photon instead | |
26325 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26326 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. | |
26327 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN | |
26328 | IDP = 7 | |
26329 | Q2 = ZERO | |
26330 | ENDIF | |
26331 | ENDIF | |
26332 | IDT = IDTA | |
26333 | EPN = EPN0 | |
26334 | PPN = PPN0 | |
26335 | ECM = ECM0 | |
26336 | AMP = AAM(IDP)-SQRT(ABS(Q2)) | |
26337 | AMT = AAM(IDT) | |
26338 | AMP2 = SIGN(AMP**2,AMP) | |
26339 | AMT2 = AMT**2 | |
26340 | IF (ECM0.GT.ZERO) THEN | |
26341 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
26342 | IF (AMP2.GT.ZERO) THEN | |
26343 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26344 | ELSE | |
26345 | PPN = SQRT(EPN**2-AMP2) | |
26346 | ENDIF | |
26347 | ELSE | |
26348 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26349 | IF (IDP.EQ.7) EPN = ABS(EPN) | |
26350 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP | |
26351 | IF (AMP2.GT.ZERO) THEN | |
26352 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26353 | ELSE | |
26354 | PPN = SQRT(EPN**2-AMP2) | |
26355 | ENDIF | |
26356 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26357 | IF (AMP2.GT.ZERO) THEN | |
26358 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) | |
26359 | ELSE | |
26360 | EPN = SQRT(PPN**2+AMP2) | |
26361 | ENDIF | |
26362 | ENDIF | |
26363 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) | |
26364 | ENDIF | |
26365 | UMO = ECM | |
26366 | EPROJ = EPN | |
26367 | PPROJ = PPN | |
26368 | IF (AMP2.GT.ZERO) THEN | |
26369 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) | |
26370 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) | |
26371 | ELSE | |
26372 | ETARG = TINY10 | |
26373 | PTARG = TINY10 | |
26374 | ENDIF | |
26375 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) | |
26376 | IF (IDP.EQ.7) THEN | |
26377 | PGAMM(1) = ZERO | |
26378 | PGAMM(2) = ZERO | |
26379 | AMGAM = AMP | |
26380 | AMGAM2 = AMP2 | |
26381 | IF (ECM0.GT.ZERO) THEN | |
26382 | S = ECM0**2 | |
26383 | ELSE | |
26384 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26385 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) | |
26386 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26387 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) | |
26388 | ENDIF | |
26389 | ENDIF | |
26390 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 | |
26391 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) | |
26392 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) | |
26393 | IF (MODE.EQ.1) THEN | |
26394 | PNUCL(1) = ZERO | |
26395 | PNUCL(2) = ZERO | |
26396 | PNUCL(3) = -PGAMM(3) | |
26397 | PNUCL(4) = SQRT(S)-PGAMM(4) | |
26398 | ENDIF | |
26399 | ENDIF | |
26400 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26401 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN | |
26402 | PLEPT0(1) = ZERO | |
26403 | PLEPT0(2) = ZERO | |
26404 | * neglect lepton masses | |
26405 | C AMLPT2 = AAM(IDPR)**2 | |
26406 | AMLPT2 = ZERO | |
26407 | * | |
26408 | IF (ECM0.GT.ZERO) THEN | |
26409 | S = ECM0**2 | |
26410 | ELSE | |
26411 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26412 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) | |
26413 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26414 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) | |
26415 | ENDIF | |
26416 | ENDIF | |
26417 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 | |
26418 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) | |
26419 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) | |
26420 | PNUCL(1) = ZERO | |
26421 | PNUCL(2) = ZERO | |
26422 | PNUCL(3) = -PLEPT0(3) | |
26423 | PNUCL(4) = SQRT(S)-PLEPT0(4) | |
26424 | ENDIF | |
26425 | * Lorentz-parameter for transformation Lab. - projectile rest system | |
26426 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN | |
26427 | GALAB = TINY10 | |
26428 | BGLAB = TINY10 | |
26429 | BLAB = TINY10 | |
26430 | ELSE | |
26431 | GALAB = EPROJ/AMP | |
26432 | BGLAB = PPROJ/AMP | |
26433 | BLAB = BGLAB/GALAB | |
26434 | ENDIF | |
26435 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. | |
26436 | IF (IDP.EQ.7) THEN | |
26437 | GACMS(1) = TINY10 | |
26438 | BGCMS(1) = TINY10 | |
26439 | ELSE | |
26440 | GACMS(1) = (ETARG+AMP)/UMO | |
26441 | BGCMS(1) = PTARG/UMO | |
26442 | ENDIF | |
26443 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. | |
26444 | GACMS(2) = (EPROJ+AMT)/UMO | |
26445 | BGCMS(2) = PPROJ/UMO | |
26446 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ | |
26447 | ||
26448 | EPN0 = EPN | |
26449 | PPN0 = PPN | |
26450 | ECM0 = ECM | |
26451 | ||
26452 | RETURN | |
26453 | END | |
26454 | ||
26455 | *$ CREATE DT_LTRANS.FOR | |
26456 | *COPY DT_LTRANS | |
26457 | * | |
26458 | *===ltrans=============================================================* | |
26459 | * | |
26460 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) | |
26461 | ||
26462 | ************************************************************************ | |
26463 | * Lorentz-transformations. * | |
26464 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26465 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26466 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26467 | * This version dated 01.11.95 is written by S. Roesler. * | |
26468 | ************************************************************************ | |
26469 | ||
26470 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26471 | SAVE | |
26472 | PARAMETER ( LINP = 10 , | |
26473 | & LOUT = 6 , | |
26474 | & LDAT = 9 ) | |
26475 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) | |
26476 | ||
26477 | PARAMETER (SQTINF=1.0D+15) | |
26478 | ||
26479 | * particle properties (BAMJET index convention) | |
26480 | CHARACTER*8 ANAME | |
26481 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26482 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26483 | ||
26484 | PXO = PXI | |
26485 | PYO = PYI | |
26486 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) | |
26487 | ||
26488 | * check particle mass for consistency (numerical rounding errors) | |
26489 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) | |
26490 | AMO2 = (PEO-PO)*(PEO+PO) | |
26491 | AMORQ2 = AAM(ID)**2 | |
26492 | AMDIF2 = ABS(AMO2-AMORQ2) | |
26493 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN | |
26494 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) | |
26495 | PEO = PEO+DELTA | |
26496 | PO1 = PO -DELTA | |
26497 | PXO = PXO*PO1/PO | |
26498 | PYO = PYO*PO1/PO | |
26499 | PZO = PZO*PO1/PO | |
26500 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID | |
26501 | ENDIF | |
26502 | ||
26503 | RETURN | |
26504 | END | |
26505 | ||
26506 | *$ CREATE DT_LTNUC.FOR | |
26507 | *COPY DT_LTNUC | |
26508 | * | |
26509 | *===ltnuc==============================================================* | |
26510 | * | |
26511 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) | |
26512 | ||
26513 | ************************************************************************ | |
26514 | * Lorentz-transformations. * | |
26515 | * PIN longitudnal momentum (input) * | |
26516 | * EIN energy (input) * | |
26517 | * POUT transformed long. momentum (output) * | |
26518 | * EOUT transformed energy (output) * | |
26519 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26520 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26521 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26522 | * This version dated 01.11.95 is written by S. Roesler. * | |
26523 | ************************************************************************ | |
26524 | ||
26525 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26526 | SAVE | |
26527 | PARAMETER ( LINP = 10 , | |
26528 | & LOUT = 6 , | |
26529 | & LDAT = 9 ) | |
26530 | PARAMETER (ZERO=0.0D0) | |
26531 | ||
26532 | * Lorentz-parameters of the current interaction | |
26533 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26534 | & UMO,PPCM,EPROJ,PPROJ | |
26535 | ||
26536 | BDUM1 = ZERO | |
26537 | BDUM2 = ZERO | |
26538 | PDUM1 = ZERO | |
26539 | PDUM2 = ZERO | |
26540 | IF (ABS(MODE).EQ.1) THEN | |
26541 | BG = -SIGN(BGLAB,DBLE(MODE)) | |
26542 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, | |
26543 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26544 | ELSEIF (ABS(MODE).EQ.2) THEN | |
26545 | BG = SIGN(BGCMS(1),DBLE(MODE)) | |
26546 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26547 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26548 | ELSEIF (ABS(MODE).EQ.3) THEN | |
26549 | BG = -SIGN(BGCMS(2),DBLE(MODE)) | |
26550 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26551 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26552 | ELSE | |
26553 | WRITE(LOUT,1000) MODE | |
26554 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') | |
26555 | EOUT = EIN | |
26556 | POUT = PIN | |
26557 | ENDIF | |
26558 | ||
26559 | RETURN | |
26560 | END | |
26561 | ||
26562 | *$ CREATE DT_DALTRA.FOR | |
26563 | *COPY DT_DALTRA | |
26564 | * | |
26565 | *===daltra=============================================================* | |
26566 | * | |
26567 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) | |
26568 | ||
26569 | ************************************************************************ | |
26570 | * Arbitrary Lorentz-transformation. * | |
26571 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * | |
26572 | ************************************************************************ | |
26573 | ||
26574 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26575 | SAVE | |
26576 | PARAMETER (ONE=1.0D0) | |
26577 | ||
26578 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ | |
26579 | PE = EP/(GA+ONE)+EC | |
26580 | PX = PCX+BGX*PE | |
26581 | PY = PCY+BGY*PE | |
26582 | PZ = PCZ+BGZ*PE | |
26583 | P = SQRT(PX*PX+PY*PY+PZ*PZ) | |
26584 | E = GA*EC+EP | |
26585 | ||
26586 | RETURN | |
26587 | END | |
26588 | ||
26589 | *$ CREATE DT_DTRAFO.FOR | |
26590 | *COPY DT_DTRAFO | |
26591 | * | |
26592 | *====dtrafo============================================================* | |
26593 | * | |
26594 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, | |
26595 | & PL,CXL,CYL,CZL,EL) | |
26596 | ||
26597 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM | |
26598 | ||
26599 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26600 | SAVE | |
26601 | ||
26602 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) | |
26603 | SID = SQRT(1.D0-COD*COD) | |
26604 | PLX = P*SID*COF | |
26605 | PLY = P*SID*SIF | |
26606 | PCMZ = P*COD | |
26607 | PLZ = GAM*PCMZ+BGAM*ECM | |
26608 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) | |
26609 | EL = GAM*ECM+BGAM*PCMZ | |
26610 | C ROTATION INTO THE ORIGINAL DIRECTION | |
26611 | COZ = PLZ/PL | |
26612 | SIZ = SQRT(1.D0-COZ**2) | |
26613 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) | |
26614 | ||
26615 | RETURN | |
26616 | END | |
26617 | ||
26618 | *$ CREATE DT_STTRAN.FOR | |
26619 | *COPY DT_STTRAN | |
26620 | * | |
26621 | *====sttran============================================================* | |
26622 | * | |
26623 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) | |
26624 | ||
26625 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26626 | SAVE | |
26627 | DATA ANGLSQ/1.D-30/ | |
26628 | ************************************************************************ | |
26629 | * VERSION BY J. RANFT * | |
26630 | * LEIPZIG * | |
26631 | * * | |
26632 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * | |
26633 | * * | |
26634 | * INPUT VARIABLES: * | |
26635 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * | |
26636 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * | |
26637 | * ANGLE OF "SCATTERING" * | |
26638 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * | |
26639 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * | |
26640 | * OF "SCATTERING" * | |
26641 | * * | |
26642 | * OUTPUT VARIABLES: * | |
26643 | * X,Y,Z = NEW DIRECTION COSINES * | |
26644 | * * | |
26645 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * | |
26646 | ************************************************************************ | |
26647 | * | |
26648 | * | |
26649 | * Changed by A. Ferrari | |
26650 | * | |
26651 | * IF (ABS(XO)-0.0001D0) 1,1,2 | |
26652 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 | |
26653 | * 3 CONTINUE | |
26654 | A = XO**2 + YO**2 | |
26655 | IF ( A .LT. ANGLSQ ) THEN | |
26656 | X=SDE*CFE | |
26657 | Y=SDE*SFE | |
26658 | Z=CDE*ZO | |
26659 | ELSE | |
26660 | XI=SDE*CFE | |
26661 | YI=SDE*SFE | |
26662 | ZI=CDE | |
26663 | A=SQRT(A) | |
26664 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI | |
26665 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI | |
26666 | Z=A*YI+ZO*ZI | |
26667 | ENDIF | |
26668 | ||
26669 | RETURN | |
26670 | END | |
26671 | ||
26672 | *$ CREATE DT_MYTRAN.FOR | |
26673 | *COPY DT_MYTRAN | |
26674 | * | |
26675 | *===mytran=============================================================* | |
26676 | * | |
26677 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) | |
26678 | ||
26679 | ************************************************************************ | |
26680 | * This subroutine rotates the coordinate frame * | |
26681 | * a) theta around y * | |
26682 | * b) phi around z if IMODE = 1 * | |
26683 | * * | |
26684 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * | |
26685 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * | |
26686 | * z' 0 0 1 -sin(th) 0 cos(th) z * | |
26687 | * * | |
26688 | * and vice versa if IMODE = 0. * | |
26689 | * This version dated 5.4.94 is based on the original version DTRAN * | |
26690 | * by J. Ranft and is written by S. Roesler. * | |
26691 | ************************************************************************ | |
26692 | ||
26693 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26694 | SAVE | |
26695 | PARAMETER ( LINP = 10 , | |
26696 | & LOUT = 6 , | |
26697 | & LDAT = 9 ) | |
26698 | ||
26699 | IF (IMODE.EQ.1) THEN | |
26700 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO | |
26701 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO | |
26702 | Z=-SDE *XO +CDE *ZO | |
26703 | ELSE | |
26704 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO | |
26705 | Y= -SFE*XO+CFE*YO | |
26706 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO | |
26707 | ENDIF | |
26708 | RETURN | |
26709 | END | |
26710 | ||
26711 | *$ CREATE DT_LT2LAO.FOR | |
26712 | *COPY DT_LT2LAO | |
26713 | * | |
26714 | *===lt2lab=============================================================* | |
26715 | * | |
26716 | SUBROUTINE DT_LT2LAO | |
26717 | ||
26718 | ************************************************************************ | |
26719 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26720 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26721 | * and transforms them back to the lab. * | |
26722 | * This version dated 16.11.95 is written by S. Roesler * | |
26723 | ************************************************************************ | |
26724 | ||
26725 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26726 | SAVE | |
26727 | PARAMETER ( LINP = 10 , | |
26728 | & LOUT = 6 , | |
26729 | & LDAT = 9 ) | |
26730 | ||
26731 | * event history | |
26732 | PARAMETER (NMXHKK=200000) | |
26733 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26734 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26735 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26736 | * extended event history | |
26737 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26738 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26739 | & IHIST(2,NMXHKK) | |
26740 | ||
26741 | NEND = NHKK | |
26742 | NPOINT(5) = NHKK+1 | |
26743 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN | |
26744 | DO 1 I=NPOINT(4),NEND | |
26745 | C DO 1 I=1,NEND | |
26746 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26747 | & (ISTHKK(I).EQ.1001)) THEN | |
26748 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26749 | NOB = NOBAM(I) | |
26750 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), | |
26751 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) | |
26752 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN | |
26753 | ISTHKK(I) = 3*ISTHKK(I) | |
26754 | NOBAM(NHKK) = NOB | |
26755 | ELSE | |
26756 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB | |
26757 | ISTHKK(I) = SIGN(3,ISTHKK(I)) | |
26758 | ENDIF | |
26759 | JDAHKK(1,I) = NHKK | |
26760 | ENDIF | |
26761 | 1 CONTINUE | |
26762 | ||
26763 | RETURN | |
26764 | END | |
26765 | ||
26766 | *$ CREATE DT_LT2LAB.FOR | |
26767 | *COPY DT_LT2LAB | |
26768 | * | |
26769 | *===lt2lab=============================================================* | |
26770 | * | |
26771 | SUBROUTINE DT_LT2LAB | |
26772 | ||
26773 | ************************************************************************ | |
26774 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26775 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26776 | * and transforms them to the lab. * | |
26777 | * This version dated 07.01.96 is written by S. Roesler * | |
26778 | ************************************************************************ | |
26779 | ||
26780 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26781 | SAVE | |
26782 | PARAMETER ( LINP = 10 , | |
26783 | & LOUT = 6 , | |
26784 | & LDAT = 9 ) | |
26785 | ||
26786 | * event history | |
26787 | PARAMETER (NMXHKK=200000) | |
26788 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26789 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26790 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26791 | * extended event history | |
26792 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26793 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26794 | & IHIST(2,NMXHKK) | |
26795 | ||
26796 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
26797 | DO 1 I=NPOINT(4),NHKK | |
26798 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26799 | & (ISTHKK(I).EQ.1001)) THEN | |
430525dd | 26800 | |
9aaba0d6 | 26801 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
26802 | PHKK(3,I) = PZ | |
26803 | PHKK(4,I) = PE | |
26804 | ENDIF | |
26805 | 1 CONTINUE | |
26806 | ||
26807 | RETURN | |
26808 | END | |
26809 | ||
26810 | ************************************************************************ | |
26811 | * * | |
26812 | * 5) Sampling from distributions * | |
26813 | * * | |
26814 | ************************************************************************ | |
26815 | *$ CREATE IDT_NPOISS.FOR | |
26816 | *COPY IDT_NPOISS | |
26817 | * | |
26818 | *===npoiss=============================================================* | |
26819 | * | |
26820 | INTEGER FUNCTION IDT_NPOISS(AVN) | |
26821 | ||
26822 | ************************************************************************ | |
26823 | * Sample according to Poisson distribution with Poisson parameter AVN. * | |
26824 | * The original version written by J. Ranft. * | |
26825 | * This version dated 11.1.95 is written by S. Roesler. * | |
26826 | ************************************************************************ | |
26827 | ||
26828 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26829 | SAVE | |
26830 | PARAMETER ( LINP = 10 , | |
26831 | & LOUT = 6 , | |
26832 | & LDAT = 9 ) | |
26833 | ||
26834 | EXPAVN = EXP(-AVN) | |
26835 | K = 1 | |
26836 | A = 1.0D0 | |
26837 | ||
26838 | 10 CONTINUE | |
26839 | A = DT_RNDM(A)*A | |
26840 | IF (A.GE.EXPAVN) THEN | |
26841 | K = K+1 | |
26842 | GOTO 10 | |
26843 | ENDIF | |
26844 | IDT_NPOISS = K-1 | |
26845 | ||
26846 | RETURN | |
26847 | END | |
26848 | ||
26849 | *$ CREATE DT_SAMPXB.FOR | |
26850 | *COPY DT_SAMPXB | |
26851 | * | |
26852 | *===sampxb=============================================================* | |
26853 | * | |
26854 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) | |
26855 | ||
26856 | ************************************************************************ | |
26857 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * | |
26858 | * Processed by S. Roesler, 6.5.95 * | |
26859 | ************************************************************************ | |
26860 | ||
26861 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26862 | SAVE | |
26863 | PARAMETER (TWO=2.0D0) | |
26864 | ||
26865 | A1 = LOG(X1+SQRT(X1**2+B**2)) | |
26866 | A2 = LOG(X2+SQRT(X2**2+B**2)) | |
26867 | AN = A2-A1 | |
26868 | A = AN*DT_RNDM(A1)+A1 | |
26869 | BB = EXP(A) | |
26870 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) | |
26871 | ||
26872 | RETURN | |
26873 | END | |
26874 | ||
26875 | *$ CREATE DT_SAMPEX.FOR | |
26876 | *COPY DT_SAMPEX | |
26877 | * | |
26878 | *===sampex=============================================================* | |
26879 | * | |
26880 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) | |
26881 | ||
26882 | ************************************************************************ | |
26883 | * Sampling from f(x)=1./x between x1 and x2. * | |
26884 | * Processed by S. Roesler, 6.5.95 * | |
26885 | ************************************************************************ | |
26886 | ||
26887 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26888 | SAVE | |
26889 | PARAMETER (ONE=1.0D0) | |
26890 | ||
26891 | R = DT_RNDM(X1) | |
26892 | AL1 = LOG(X1) | |
26893 | AL2 = LOG(X2) | |
26894 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) | |
26895 | ||
26896 | RETURN | |
26897 | END | |
26898 | ||
26899 | *$ CREATE DT_SAMSQX.FOR | |
26900 | *COPY DT_SAMSQX | |
26901 | * | |
26902 | *===samsqx=============================================================* | |
26903 | * | |
26904 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) | |
26905 | ||
26906 | ************************************************************************ | |
26907 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * | |
26908 | * Processed by S. Roesler, 6.5.95 * | |
26909 | ************************************************************************ | |
26910 | ||
26911 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26912 | SAVE | |
26913 | PARAMETER (ONE=1.0D0) | |
26914 | ||
26915 | R = DT_RNDM(X1) | |
26916 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 | |
26917 | ||
26918 | RETURN | |
26919 | END | |
26920 | ||
26921 | *$ CREATE DT_SAMPLW.FOR | |
26922 | *COPY DT_SAMPLW | |
26923 | * | |
26924 | *===samplw=============================================================* | |
26925 | * | |
26926 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) | |
26927 | ||
26928 | ************************************************************************ | |
26929 | * Sampling from f(x)=1/x^b between x_min and x_max. * | |
26930 | * S. Roesler, 18.4.98 * | |
26931 | ************************************************************************ | |
26932 | ||
26933 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26934 | SAVE | |
26935 | PARAMETER (ONE=1.0D0) | |
26936 | ||
26937 | R = DT_RNDM(B) | |
26938 | IF (B.EQ.ONE) THEN | |
26939 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) | |
26940 | ELSE | |
26941 | ONEMB = ONE-B | |
26942 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) | |
26943 | ENDIF | |
26944 | ||
26945 | RETURN | |
26946 | END | |
26947 | ||
26948 | *$ CREATE DT_BETREJ.FOR | |
26949 | *COPY DT_BETREJ | |
26950 | * | |
26951 | *===betrej=============================================================* | |
26952 | * | |
26953 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) | |
26954 | ||
26955 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26956 | SAVE | |
26957 | ||
26958 | PARAMETER ( LINP = 10 , | |
26959 | & LOUT = 6 , | |
26960 | & LDAT = 9 ) | |
26961 | PARAMETER (ONE=1.0D0) | |
26962 | ||
26963 | IF (XMIN.GE.XMAX)THEN | |
26964 | WRITE (LOUT,500) XMIN,XMAX | |
26965 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) | |
26966 | STOP | |
26967 | ENDIF | |
26968 | ||
26969 | 10 CONTINUE | |
26970 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) | |
26971 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) | |
26972 | YY = BETMAX*DT_RNDM(XX) | |
26973 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) | |
26974 | IF (YY.GT.BETXX) GOTO 10 | |
26975 | DT_BETREJ = XX | |
26976 | ||
26977 | RETURN | |
26978 | END | |
26979 | ||
26980 | *$ CREATE DT_DGAMRN.FOR | |
26981 | *COPY DT_DGAMRN | |
26982 | * | |
26983 | *===dgamrn=============================================================* | |
26984 | * | |
26985 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) | |
26986 | ||
26987 | ************************************************************************ | |
26988 | * Sampling from Gamma-distribution. * | |
26989 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * | |
26990 | * Processed by S. Roesler, 6.5.95 * | |
26991 | ************************************************************************ | |
26992 | ||
26993 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26994 | SAVE | |
26995 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) | |
26996 | ||
26997 | NCOU = 0 | |
26998 | N = INT(ETA) | |
26999 | F = ETA-DBLE(N) | |
27000 | IF (F.EQ.ZERO) GOTO 20 | |
27001 | 10 R = DT_RNDM(F) | |
27002 | NCOU = NCOU+1 | |
27003 | IF (NCOU.GE.11) GOTO 20 | |
27004 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 | |
27005 | YYY = LOG(DT_RNDM(R)+TINY9)/F | |
27006 | IF (ABS(YYY).GT.50.0D0) GOTO 20 | |
27007 | Y = EXP(YYY) | |
27008 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 | |
27009 | GOTO 40 | |
27010 | 20 Y = 0.0D0 | |
27011 | GOTO 50 | |
27012 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) | |
27013 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 | |
27014 | 40 IF (N.EQ.0) GOTO 70 | |
27015 | 50 Z = 1.0D0 | |
27016 | DO 60 I = 1,N | |
27017 | 60 Z = Z*DT_RNDM(Z) | |
27018 | Y = Y-LOG(Z+TINY9) | |
27019 | 70 DT_DGAMRN = Y/ALAM | |
27020 | ||
27021 | RETURN | |
27022 | END | |
27023 | ||
27024 | *$ CREATE DT_DBETAR.FOR | |
27025 | *COPY DT_DBETAR | |
27026 | * | |
27027 | *===dbetar=============================================================* | |
27028 | * | |
27029 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) | |
27030 | ||
27031 | ************************************************************************ | |
27032 | * Sampling from Beta -distribution between 0.0 and 1.0 * | |
27033 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* | |
27034 | * Processed by S. Roesler, 6.5.95 * | |
27035 | ************************************************************************ | |
27036 | ||
27037 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27038 | SAVE | |
27039 | ||
27040 | Y = DT_DGAMRN(1.0D0,GAM) | |
27041 | Z = DT_DGAMRN(1.0D0,ETA) | |
27042 | DT_DBETAR = Y/(Y+Z) | |
27043 | ||
27044 | RETURN | |
27045 | END | |
27046 | ||
27047 | *$ CREATE DT_RANNOR.FOR | |
27048 | *COPY DT_RANNOR | |
27049 | * | |
27050 | *===rannor=============================================================* | |
27051 | * | |
27052 | SUBROUTINE DT_RANNOR(X,Y) | |
27053 | ||
27054 | ************************************************************************ | |
27055 | * Sampling from Gaussian distribution. * | |
27056 | * Processed by S. Roesler, 6.5.95 * | |
27057 | ************************************************************************ | |
27058 | ||
27059 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27060 | SAVE | |
27061 | PARAMETER (TINY10=1.0D-10) | |
27062 | ||
27063 | CALL DT_DSFECF(SFE,CFE) | |
27064 | V = MAX(TINY10,DT_RNDM(X)) | |
27065 | A = SQRT(-2.D0*LOG(V)) | |
27066 | X = A*SFE | |
27067 | Y = A*CFE | |
27068 | ||
27069 | RETURN | |
27070 | END | |
27071 | ||
27072 | *$ CREATE DT_DPOLI.FOR | |
27073 | *COPY DT_DPOLI | |
27074 | * | |
27075 | *===dpoli==============================================================* | |
27076 | * | |
27077 | SUBROUTINE DT_DPOLI(CS,SI) | |
27078 | ||
27079 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27080 | SAVE | |
27081 | ||
27082 | U = DT_RNDM(CS) | |
27083 | CS = DT_RNDM(U) | |
27084 | IF (U.LT.0.5D0) CS=-CS | |
27085 | SI = SQRT(1.0D0-CS*CS+1.0D-10) | |
27086 | ||
27087 | RETURN | |
27088 | END | |
27089 | ||
27090 | *$ CREATE DT_DSFECF.FOR | |
27091 | *COPY DT_DSFECF | |
27092 | * | |
27093 | *===dsfecf=============================================================* | |
27094 | * | |
27095 | SUBROUTINE DT_DSFECF(SFE,CFE) | |
27096 | ||
27097 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27098 | SAVE | |
27099 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27100 | ||
27101 | 1 CONTINUE | |
27102 | X = DT_RNDM(SFE) | |
27103 | Y = DT_RNDM(X) | |
27104 | XX = X*X | |
27105 | YY = Y*Y | |
27106 | XY = XX+YY | |
27107 | IF (XY.GT.ONE) GOTO 1 | |
27108 | CFE = (XX-YY)/XY | |
27109 | SFE = TWO*X*Y/XY | |
27110 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE | |
27111 | RETURN | |
27112 | END | |
27113 | ||
27114 | *$ CREATE DT_RACO.FOR | |
27115 | *COPY DT_RACO | |
27116 | * | |
27117 | *===raco===============================================================* | |
27118 | * | |
27119 | SUBROUTINE DT_RACO(WX,WY,WZ) | |
27120 | ||
27121 | ************************************************************************ | |
27122 | * Direction cosines of random uniform (isotropic) direction in three * | |
27123 | * dimensional space * | |
27124 | * Processed by S. Roesler, 20.11.95 * | |
27125 | ************************************************************************ | |
27126 | ||
27127 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27128 | SAVE | |
27129 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27130 | ||
27131 | 10 CONTINUE | |
27132 | X = TWO*DT_RNDM(WX)-ONE | |
27133 | Y = DT_RNDM(X) | |
27134 | X2 = X*X | |
27135 | Y2 = Y*Y | |
27136 | IF (X2+Y2.GT.ONE) GOTO 10 | |
27137 | ||
27138 | CFE = (X2-Y2)/(X2+Y2) | |
27139 | SFE = TWO*X*Y/(X2+Y2) | |
27140 | * z = 1/2 [ 1 + cos (theta) ] | |
27141 | Z = DT_RNDM(X) | |
27142 | * 1/2 sin (theta) | |
27143 | WZ = SQRT(Z*(ONE-Z)) | |
27144 | WX = TWO*WZ*CFE | |
27145 | WY = TWO*WZ*SFE | |
27146 | WZ = TWO*Z-ONE | |
27147 | ||
27148 | RETURN | |
27149 | END | |
27150 | ||
27151 | ************************************************************************ | |
27152 | * * | |
27153 | * 6) Special functions, algorithms and service routines * | |
27154 | * * | |
27155 | ************************************************************************ | |
27156 | *$ CREATE DT_YLAMB.FOR | |
27157 | *COPY DT_YLAMB | |
27158 | * | |
27159 | *===ylamb==============================================================* | |
27160 | * | |
27161 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) | |
27162 | ||
27163 | ************************************************************************ | |
27164 | * * | |
27165 | * auxiliary function for three particle decay mode * | |
27166 | * (standard LAMBDA**(1/2) function) * | |
27167 | * * | |
27168 | * Adopted from an original version written by R. Engel. * | |
27169 | * This version dated 12.12.94 is written by S. Roesler. * | |
27170 | ************************************************************************ | |
27171 | ||
27172 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27173 | SAVE | |
27174 | ||
27175 | YZ = Y-Z | |
27176 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ | |
27177 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) | |
27178 | DT_YLAMB = SQRT(XLAM) | |
27179 | ||
27180 | RETURN | |
27181 | END | |
27182 | ||
27183 | *$ CREATE DT_SORT.FOR | |
27184 | *COPY DT_SORT | |
27185 | * | |
27186 | *===sort1==============================================================* | |
27187 | * | |
27188 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) | |
27189 | ||
27190 | ************************************************************************ | |
27191 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27192 | * of A(3,i). * | |
27193 | * MODE = 1 increasing in A(3,i=1..N) * | |
27194 | * = 2 decreasing in A(3,i=1..N) * | |
27195 | * This version dated 21.04.95 is revised by S. Roesler * | |
27196 | ************************************************************************ | |
27197 | ||
27198 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27199 | SAVE | |
27200 | ||
27201 | DIMENSION A(3,N) | |
27202 | ||
27203 | M = I1 | |
27204 | 10 CONTINUE | |
27205 | M = I1-1 | |
27206 | IF (M.LE.0) RETURN | |
27207 | L = 0 | |
27208 | DO 20 I=I0,M | |
27209 | J = I+1 | |
27210 | IF (MODE.EQ.1) THEN | |
27211 | IF (A(3,I).LE.A(3,J)) GOTO 20 | |
27212 | ELSE | |
27213 | IF (A(3,I).GE.A(3,J)) GOTO 20 | |
27214 | ENDIF | |
27215 | B = A(3,I) | |
27216 | C = A(1,I) | |
27217 | D = A(2,I) | |
27218 | A(3,I) = A(3,J) | |
27219 | A(2,I) = A(2,J) | |
27220 | A(1,I) = A(1,J) | |
27221 | A(3,J) = B | |
27222 | A(1,J) = C | |
27223 | A(2,J) = D | |
27224 | L = 1 | |
27225 | 20 CONTINUE | |
27226 | IF (L.EQ.1) GOTO 10 | |
27227 | ||
27228 | RETURN | |
27229 | END | |
27230 | ||
27231 | *$ CREATE DT_SORT1.FOR | |
27232 | *COPY DT_SORT1 | |
27233 | * | |
27234 | *===sort1==============================================================* | |
27235 | * | |
27236 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) | |
27237 | ||
27238 | ************************************************************************ | |
27239 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27240 | * of A(i). * | |
27241 | * MODE = 1 increasing in A(i=1..N) * | |
27242 | * = 2 decreasing in A(i=1..N) * | |
27243 | * This version dated 21.04.95 is revised by S. Roesler * | |
27244 | ************************************************************************ | |
27245 | ||
27246 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27247 | SAVE | |
27248 | ||
27249 | DIMENSION A(N),IDX(N) | |
27250 | ||
27251 | M = I1 | |
27252 | 10 CONTINUE | |
27253 | M = I1-1 | |
27254 | IF (M.LE.0) RETURN | |
27255 | L = 0 | |
27256 | DO 20 I=I0,M | |
27257 | J = I+1 | |
27258 | IF (MODE.EQ.1) THEN | |
27259 | IF (A(I).LE.A(J)) GOTO 20 | |
27260 | ELSE | |
27261 | IF (A(I).GE.A(J)) GOTO 20 | |
27262 | ENDIF | |
27263 | B = A(I) | |
27264 | A(I) = A(J) | |
27265 | A(J) = B | |
27266 | IX = IDX(I) | |
27267 | IDX(I) = IDX(J) | |
27268 | IDX(J) = IX | |
27269 | L = 1 | |
27270 | 20 CONTINUE | |
27271 | IF (L.EQ.1) GOTO 10 | |
27272 | ||
27273 | RETURN | |
27274 | END | |
27275 | ||
27276 | *$ CREATE DT_XTIME.FOR | |
27277 | *COPY DT_XTIME | |
27278 | * | |
27279 | *===xtime==============================================================* | |
27280 | * | |
27281 | SUBROUTINE DT_XTIME | |
27282 | ||
27283 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27284 | SAVE | |
27285 | PARAMETER ( LINP = 10 , | |
27286 | & LOUT = 6 , | |
27287 | & LDAT = 9 ) | |
27288 | ||
27289 | CHARACTER DAT*9,TIM*11 | |
27290 | ||
27291 | DAT = ' ' | |
27292 | TIM = ' ' | |
27293 | C CALL GETDAT(IYEAR,IMONTH,IDAY) | |
27294 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) | |
27295 | ||
27296 | C CALL DATE(DAT) | |
27297 | C CALL TIME(TIM) | |
27298 | C WRITE(LOUT,1000) DAT,TIM | |
27299 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) | |
27300 | ||
27301 | RETURN | |
27302 | END | |
27303 | ||
27304 | ************************************************************************ | |
27305 | * * | |
27306 | * 7) Random number generator package * | |
27307 | * * | |
27308 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * | |
27309 | * SERVICE ROUTINES. * | |
27310 | * THE ALGORITHM IS FROM * | |
27311 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * | |
27312 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * | |
27313 | * IMPLEMENTATION BY K. HAHN DEC. 88, * | |
27314 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * | |
27315 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * | |
27316 | * THE PERIOD IS ABOUT 2**144, * | |
27317 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * | |
27318 | * THE PACKAGE CONTAINS * | |
27319 | * FUNCTION DT_RNDM(I) : GENERATOR * | |
27320 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * | |
27321 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * | |
27322 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * | |
27323 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * | |
27324 | *--- * | |
27325 | * FUNCTION DT_RNDM(I) * | |
27326 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * | |
27327 | * I - DUMMY VARIABLE, NOT USED * | |
27328 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * | |
27329 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * | |
27330 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * | |
27331 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * | |
27332 | * 12,34,56 ARE THE STANDARD VALUES * | |
27333 | * NB1 MUST BE IN 1..168 * | |
27334 | * 78 IS THE STANDARD VALUE * | |
27335 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * | |
27336 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * | |
27337 | * AS AFTER THE LAST DT_RNDMOU CALL ) * | |
27338 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * | |
27339 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * | |
27340 | * TAKES SEED FROM GENERATOR * | |
27341 | * U(97),C,CD,CM,I,J - SEED VALUES * | |
27342 | * SUBROUTINE DT_RNDMTE(IO) * | |
27343 | * TEST OF THE GENERATOR * | |
27344 | * IO - DEFINES OUTPUT * | |
27345 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * | |
27346 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * | |
27347 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * | |
27348 | * SAME STATUS * | |
27349 | * AS BEFORE CALL OF DT_RNDMTE * | |
27350 | ************************************************************************ | |
27351 | *$ CREATE DT_RNDM.FOR | |
27352 | *COPY DT_RNDM | |
27353 | * | |
839efe5b | 27354 | c$$$*===rndm===============================================================* |
27355 | c$$$* | |
27356 | c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) | |
27357 | c$$$ | |
27358 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27359 | c$$$ SAVE | |
27360 | c$$$ | |
27361 | c$$$* random number generator | |
27362 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27363 | c$$$ | |
27364 | c$$$* counter of calls to random number generator | |
27365 | c$$$* uncomment if needed | |
27366 | c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1 | |
27367 | c$$$C LOGICAL LFIRST | |
27368 | c$$$C DATA LFIRST /.TRUE./ | |
27369 | c$$$ | |
27370 | c$$$* counter of calls to random number generator | |
27371 | c$$$* uncomment if needed | |
27372 | c$$$C IF (LFIRST) THEN | |
27373 | c$$$C IRNCT0 = 0 | |
27374 | c$$$C IRNCT1 = 0 | |
27375 | c$$$C LFIRST = .FALSE. | |
27376 | c$$$C ENDIF | |
27377 | c$$$ 100 CONTINUE | |
27378 | c$$$ DT_RNDM = U(I)-U(J) | |
27379 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27380 | c$$$ U(I) = DT_RNDM | |
27381 | c$$$ I = I-1 | |
27382 | c$$$ IF ( I.EQ.0 ) I = 97 | |
27383 | c$$$ J = J-1 | |
27384 | c$$$ IF ( J.EQ.0 ) J = 97 | |
27385 | c$$$ C = C-CD | |
27386 | c$$$ IF ( C.LT.0.0D0 ) C = C+CM | |
27387 | c$$$ DT_RNDM = DT_RNDM-C | |
27388 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27389 | c$$$ | |
27390 | c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100 | |
27391 | c$$$ | |
27392 | c$$$* counter of calls to random number generator | |
27393 | c$$$* uncomment if needed | |
27394 | c$$$C IRNCT0 = IRNCT0+1 | |
27395 | c$$$ | |
27396 | c$$$ RETURN | |
27397 | c$$$ END | |
27398 | c$$$ | |
27399 | c$$$*$ CREATE DT_RNDMST.FOR | |
27400 | c$$$*COPY DT_RNDMST | |
27401 | c$$$* | |
27402 | c$$$*===rndmst=============================================================* | |
27403 | c$$$* | |
27404 | c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) | |
27405 | c$$$ | |
27406 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27407 | c$$$ SAVE | |
27408 | c$$$ | |
27409 | c$$$* random number generator | |
27410 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27411 | c$$$ | |
27412 | c$$$ MA1 = NA1 | |
27413 | c$$$ MA2 = NA2 | |
27414 | c$$$ MA3 = NA3 | |
27415 | c$$$ MB1 = NB1 | |
27416 | c$$$ I = 97 | |
27417 | c$$$ J = 33 | |
27418 | c$$$ DO 20 II2 = 1,97 | |
27419 | c$$$ S = 0 | |
27420 | c$$$ T = 0.5D0 | |
27421 | c$$$ DO 10 II1 = 1,24 | |
27422 | c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179) | |
27423 | c$$$ MA1 = MA2 | |
27424 | c$$$ MA2 = MA3 | |
27425 | c$$$ MA3 = MAT | |
27426 | c$$$ MB1 = MOD(53*MB1+1,169) | |
27427 | c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T | |
27428 | c$$$ 10 T = 0.5D0*T | |
27429 | c$$$ 20 U(II2) = S | |
27430 | c$$$ C = 362436.0D0/16777216.0D0 | |
27431 | c$$$ CD = 7654321.0D0/16777216.0D0 | |
27432 | c$$$ CM = 16777213.0D0/16777216.0D0 | |
27433 | c$$$ RETURN | |
27434 | c$$$ END | |
27435 | c$$$ | |
27436 | c$$$*$ CREATE DT_RNDMIN.FOR | |
27437 | c$$$*COPY DT_RNDMIN | |
27438 | c$$$* | |
27439 | c$$$*===rndmin=============================================================* | |
27440 | c$$$* | |
27441 | c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) | |
27442 | c$$$ | |
27443 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27444 | c$$$ SAVE | |
27445 | c$$$ | |
27446 | c$$$* random number generator | |
27447 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27448 | c$$$ | |
27449 | c$$$ DIMENSION UIN(97) | |
27450 | c$$$ | |
27451 | c$$$ DO 10 KKK = 1,97 | |
27452 | c$$$ 10 U(KKK) = UIN(KKK) | |
27453 | c$$$ C = CIN | |
27454 | c$$$ CD = CDIN | |
27455 | c$$$ CM = CMIN | |
27456 | c$$$ I = IIN | |
27457 | c$$$ J = JIN | |
27458 | c$$$ | |
27459 | c$$$ RETURN | |
27460 | c$$$ END | |
27461 | c$$$ | |
27462 | c$$$*$ CREATE DT_RNDMOU.FOR | |
27463 | c$$$*COPY DT_RNDMOU | |
27464 | c$$$* | |
27465 | c$$$*===rndmou=============================================================* | |
27466 | c$$$* | |
27467 | c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) | |
27468 | c$$$ | |
27469 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27470 | c$$$ SAVE | |
27471 | c$$$ | |
27472 | c$$$* random number generator | |
27473 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27474 | c$$$ | |
27475 | c$$$ DIMENSION UOUT(97) | |
27476 | c$$$ | |
27477 | c$$$ DO 10 KKK = 1,97 | |
27478 | c$$$ 10 UOUT(KKK) = U(KKK) | |
27479 | c$$$ COUT = C | |
27480 | c$$$ CDOUT = CD | |
27481 | c$$$ CMOUT = CM | |
27482 | c$$$ IOUT = I | |
27483 | c$$$ JOUT = J | |
27484 | c$$$ | |
27485 | c$$$ RETURN | |
27486 | c$$$ END | |
27487 | c$$$ | |
27488 | c$$$*$ CREATE DT_RNDMTE.FOR | |
27489 | c$$$*COPY DT_RNDMTE | |
27490 | c$$$* | |
27491 | c$$$*===rndmte=============================================================* | |
27492 | c$$$* | |
27493 | c$$$ SUBROUTINE DT_RNDMTE(IO) | |
27494 | c$$$ | |
27495 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27496 | c$$$ SAVE | |
27497 | c$$$ | |
27498 | c$$$ DIMENSION UU(97),U(6),X(6),D(6) | |
27499 | c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, | |
27500 | c$$$ +8354498.D0, 10633180.D0/ | |
27501 | c$$$ | |
27502 | c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) | |
27503 | c$$$ CALL DT_RNDMST(12,34,56,78) | |
27504 | c$$$ DO 10 II1 = 1,20000 | |
27505 | c$$$ 10 XX = DT_RNDM(XX) | |
27506 | c$$$ SD = 0.0D0 | |
27507 | c$$$ DO 20 II2 = 1,6 | |
27508 | c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) | |
27509 | c$$$ D(II2) = X(II2)-U(II2) | |
27510 | c$$$ 20 SD = SD+D(II2) | |
27511 | c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) | |
27512 | c$$$**sr 24.01.95 | |
27513 | c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) | |
27514 | c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN | |
27515 | c$$$C WRITE(6,1000) | |
27516 | c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', | |
27517 | c$$$ & ' passed') | |
27518 | c$$$ ENDIF | |
27519 | c$$$** | |
27520 | c$$$ RETURN | |
27521 | c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, | |
27522 | c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. | |
27523 | c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;', | |
27524 | c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') | |
27525 | c$$$ END | |
9aaba0d6 | 27526 | * |
27527 | *$ CREATE PHO_RNDM.FOR | |
27528 | *COPY PHO_RNDM | |
27529 | * | |
27530 | *===pho_rndm===========================================================* | |
27531 | * | |
27532 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) | |
27533 | ||
27534 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27535 | SAVE | |
27536 | ||
27537 | PHO_RNDM = DT_RNDM(DUMMY) | |
27538 | ||
27539 | RETURN | |
27540 | END | |
27541 | ||
27542 | *$ CREATE PYR.FOR | |
27543 | *COPY PYR | |
27544 | * | |
27545 | *===pyr================================================================* | |
27546 | * | |
27547 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) | |
27548 | ||
27549 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27550 | SAVE | |
27551 | ||
27552 | DUMMY = DBLE(IDUMMY) | |
27553 | PYR = DT_RNDM(DUMMY) | |
27554 | ||
27555 | RETURN | |
27556 | END | |
27557 | ||
27558 | *$ CREATE DT_TITLE.FOR | |
27559 | *COPY DT_TITLE | |
27560 | * | |
27561 | *===title==============================================================* | |
27562 | * | |
27563 | SUBROUTINE DT_TITLE | |
27564 | ||
27565 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27566 | SAVE | |
27567 | PARAMETER ( LINP = 10 , | |
27568 | & LOUT = 6 , | |
27569 | & LDAT = 9 ) | |
27570 | ||
27571 | CHARACTER*6 CVERSI | |
27572 | CHARACTER*11 CCHANG | |
27573 | DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/ | |
27574 | ||
27575 | CALL DT_XTIME | |
27576 | WRITE(LOUT,1000) CVERSI,CCHANG | |
27577 | 1000 FORMAT(1X,'+-------------------------------------------------', | |
27578 | & '----------------------+',/, | |
27579 | & 1X,'|',71X,'|',/, | |
27580 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, | |
27581 | & 1X,'|',71X,'|',/, | |
27582 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, | |
27583 | & 1X,'|',71X,'|',/, | |
27584 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, | |
27585 | & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/, | |
27586 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, | |
27587 | & 1X,'|',71X,'|',/, | |
27588 | & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', | |
27589 | & 17X,'|',/, | |
27590 | & 1X,'|',71X,'|',/, | |
27591 | & 1X,'+-------------------------------------------------', | |
27592 | & '----------------------+',/, | |
27593 | & 1X,'| Please send suggestions, bug reports, etc. to: ', | |
27594 | & 'Stefan.Roesler@cern.ch |',/, | |
27595 | & 1X,'+-------------------------------------------------', | |
27596 | & '----------------------+',/) | |
27597 | ||
27598 | RETURN | |
27599 | END | |
27600 | ||
27601 | *$ CREATE DT_EVTINI.FOR | |
27602 | *COPY DT_EVTINI | |
27603 | * | |
27604 | *===evtini=============================================================* | |
27605 | * | |
27606 | SUBROUTINE DT_EVTINI | |
27607 | ||
27608 | ************************************************************************ | |
27609 | * Initialization of DTEVT1. * | |
27610 | * This version dated 15.01.94 is written by S. Roesler * | |
27611 | ************************************************************************ | |
27612 | ||
27613 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27614 | SAVE | |
27615 | PARAMETER ( LINP = 10 , | |
27616 | & LOUT = 6 , | |
27617 | & LDAT = 9 ) | |
27618 | ||
27619 | * event history | |
27620 | PARAMETER (NMXHKK=200000) | |
27621 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27622 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27623 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27624 | * extended event history | |
27625 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27626 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27627 | & IHIST(2,NMXHKK) | |
27628 | * event flag | |
27629 | COMMON /DTEVNO/ NEVENT,ICASCA | |
27630 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
27631 | * emulsion treatment | |
27632 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
27633 | & NCOMPO,IEMUL | |
27634 | ||
27635 | * initialization of DTEVT1/DTEVT2 | |
27636 | NEND = NHKK | |
27637 | IF (NEVENT.EQ.1) NEND = NMXHKK | |
27638 | NHKK = 0 | |
27639 | NEVHKK = NEVENT | |
27640 | DO 1 I=1,NEND | |
27641 | ISTHKK(I) = 0 | |
27642 | IDHKK(I) = 0 | |
27643 | JMOHKK(1,I) = 0 | |
27644 | JMOHKK(2,I) = 0 | |
27645 | JDAHKK(1,I) = 0 | |
27646 | JDAHKK(2,I) = 0 | |
27647 | IDRES(I) = 0 | |
27648 | IDXRES(I) = 0 | |
27649 | NOBAM(I) = 0 | |
27650 | IDCH(I) = 0 | |
27651 | IHIST(1,I) = 0 | |
27652 | IHIST(2,I) = 0 | |
27653 | DO 2 J=1,4 | |
27654 | PHKK(J,I) = 0.0D0 | |
27655 | VHKK(J,I) = 0.0D0 | |
27656 | WHKK(J,I) = 0.0D0 | |
27657 | 2 CONTINUE | |
27658 | PHKK(5,I) = 0.0D0 | |
27659 | 1 CONTINUE | |
27660 | DO 3 I=1,10 | |
27661 | NPOINT(I) = 0 | |
27662 | 3 CONTINUE | |
27663 | CALL DT_CHASTA(-1) | |
27664 | ||
27665 | C* initialization of DTLTRA | |
27666 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) | |
27667 | ||
27668 | RETURN | |
27669 | END | |
27670 | ||
27671 | *$ CREATE DT_STATIS.FOR | |
27672 | *COPY DT_STATIS | |
27673 | * | |
27674 | *===statis=============================================================* | |
27675 | * | |
27676 | SUBROUTINE DT_STATIS(MODE) | |
27677 | ||
27678 | ************************************************************************ | |
27679 | * Initialization and output of run-statistics. * | |
27680 | * MODE = 1 initialization * | |
27681 | * = 2 output * | |
27682 | * This version dated 23.01.94 is written by S. Roesler * | |
27683 | ************************************************************************ | |
27684 | ||
27685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27686 | SAVE | |
27687 | PARAMETER ( LINP = 10 , | |
27688 | & LOUT = 6 , | |
27689 | & LDAT = 9 ) | |
27690 | PARAMETER (TINY3=1.0D-3) | |
27691 | ||
27692 | * statistics | |
27693 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
27694 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
27695 | & ICEVTG(8,0:30) | |
27696 | * rejection counter | |
27697 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27698 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27699 | & IREXCI(3),IRDIFF(2),IRINC | |
27700 | * central particle production, impact parameter biasing | |
27701 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
27702 | * various options for treatment of partons (DTUNUC 1.x) | |
27703 | * (chain recombination, Cronin,..) | |
27704 | LOGICAL LCO2CR,LINTPT | |
27705 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
27706 | & LCO2CR,LINTPT | |
27707 | * nucleon-nucleon event-generator | |
27708 | CHARACTER*8 CMODEL | |
27709 | LOGICAL LPHOIN | |
27710 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
27711 | * flags for particle decays | |
27712 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
27713 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
27714 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
27715 | * diquark-breaking mechanism | |
27716 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
27717 | ||
27718 | DIMENSION PP(4),PT(4) | |
27719 | ||
27720 | GOTO (1,2) MODE | |
27721 | ||
27722 | * initialization | |
27723 | 1 CONTINUE | |
27724 | ||
27725 | * initialize statistics counter | |
27726 | ICREQU = 0 | |
27727 | ICSAMP = 0 | |
27728 | ICCPRO = 0 | |
27729 | ICDPR = 0 | |
27730 | ICDTA = 0 | |
27731 | ICRJSS = 0 | |
27732 | ICVV2S = 0 | |
27733 | DO 10 I=1,9 | |
27734 | ICRES(I) = 0 | |
27735 | ICCHAI(1,I) = 0 | |
27736 | ICCHAI(2,I) = 0 | |
27737 | 10 CONTINUE | |
27738 | * initialize rejection counter | |
27739 | IRPT = 0 | |
27740 | IRHHA = 0 | |
27741 | LOMRES = 0 | |
27742 | LOBRES = 0 | |
27743 | IRFRAG = 0 | |
27744 | IREVT = 0 | |
27745 | IRRES(1) = 0 | |
27746 | IRRES(2) = 0 | |
27747 | IRCHKI(1) = 0 | |
27748 | IRCHKI(2) = 0 | |
27749 | IRCRON(1) = 0 | |
27750 | IRCRON(2) = 0 | |
27751 | IRCRON(3) = 0 | |
27752 | IRDIFF(1) = 0 | |
27753 | IRDIFF(2) = 0 | |
27754 | IRINC = 0 | |
27755 | DO 11 I=1,5 | |
27756 | ICDIFF(I) = 0 | |
27757 | 11 CONTINUE | |
27758 | DO 12 I=1,8 | |
27759 | DO 13 J=0,30 | |
27760 | ICEVTG(I,J) = 0 | |
27761 | 13 CONTINUE | |
27762 | 12 CONTINUE | |
27763 | ||
27764 | RETURN | |
27765 | ||
27766 | * output | |
27767 | 2 CONTINUE | |
27768 | ||
27769 | * statistics counter | |
27770 | WRITE(LOUT,1000) | |
27771 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, | |
27772 | & 28X,'---------------------') | |
be6523b4 | 27773 | IF (ICREQU.GT.0) THEN |
9aaba0d6 | 27774 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) |
27775 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, | |
27776 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', | |
27777 | & 'event',11X,F9.1) | |
be6523b4 | 27778 | ENDIF |
9aaba0d6 | 27779 | IF (ICDIFF(1).NE.0) THEN |
27780 | WRITE(LOUT,1009) ICDIFF | |
27781 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, | |
27782 | & 'low mass high mass',/,24X,'single diffraction', | |
27783 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) | |
27784 | ENDIF | |
be6523b4 | 27785 | IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN |
9aaba0d6 | 27786 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), |
27787 | & DBLE(ICSAMP)/DBLE(ICCPRO) | |
27788 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', | |
27789 | & ' of sampled Glauber-events per event',9X,F9.1,/, | |
27790 | & 2X,'fraction of production cross section',21X,F10.6) | |
27791 | ENDIF | |
be6523b4 | 27792 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27793 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), |
27794 | & DBLE(ICDTA)/DBLE(ICSAMP) | |
27795 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', | |
27796 | & ' nucleons after x-sampling',2(4X,F6.2)) | |
be6523b4 | 27797 | ENDIF |
9aaba0d6 | 27798 | |
27799 | IF (MCGENE.EQ.1) THEN | |
be6523b4 | 27800 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27801 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) |
27802 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', | |
27803 | & ' event',3X,F9.1) | |
27804 | IF (ISICHA.EQ.1) THEN | |
27805 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) | |
27806 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', | |
27807 | & 'of single chains per event',13X,F9.1) | |
27808 | ENDIF | |
be6523b4 | 27809 | ENDIF |
27810 | IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN | |
9aaba0d6 | 27811 | WRITE(LOUT,1006) |
27812 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, | |
27813 | & 23X,'mean number of chains mean number of chains',/, | |
27814 | & 23X,'sampled hadronized having mass of a reso.') | |
27815 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), | |
27816 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), | |
27817 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), | |
27818 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) | |
27819 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27820 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27821 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27822 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27823 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27824 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27825 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27826 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27827 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) | |
27828 | WRITE(LOUT,1008) | |
27829 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), | |
27830 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), | |
27831 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), | |
27832 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), | |
27833 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), | |
27834 | & DBLE(IRHHA)/DBLE(ICREQU), | |
27835 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), | |
27836 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) | |
27837 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, | |
27838 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', | |
27839 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, | |
27840 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, | |
27841 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, | |
27842 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', | |
27843 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, | |
27844 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', | |
27845 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, | |
27846 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, | |
27847 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', | |
27848 | & F7.2,/,1X,'Total no. of rej.', | |
27849 | & ' in chain-systems treatment (GETCSY)',/,43X, | |
27850 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', | |
27851 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, | |
27852 | & 1X,'Total no. of rej. in DPM-treatment of one event', | |
27853 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, | |
27854 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' | |
27855 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, | |
27856 | & 'IREXCI(3) = ',I5,/) | |
be6523b4 | 27857 | ENDIF |
9aaba0d6 | 27858 | ELSEIF (MCGENE.EQ.2) THEN |
27859 | WRITE(LOUT,1010) ELOJET | |
27860 | 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', | |
27861 | & F4.1,' GeV') | |
27862 | WRITE(LOUT,1011) | |
27863 | 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, | |
27864 | & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', | |
27865 | & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') | |
27866 | WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), | |
27867 | & (INT(ICCHAI(2,I)/2.0D0),I=1,8), | |
27868 | & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), | |
27869 | & ((ICEVTG(I,J),I=1,8),J=3,7), | |
27870 | & ((ICEVTG(I,J),I=1,8),J=19,21), | |
27871 | & (ICEVTG(I,8),I=1,8), | |
27872 | & ((ICEVTG(I,J),I=1,8),J=22,24), | |
27873 | & (ICEVTG(I,9),I=1,8), | |
27874 | & ((ICEVTG(I,J),I=1,8),J=25,28), | |
27875 | & ((ICEVTG(I,J),I=1,8),J=10,18) | |
27876 | 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', | |
27877 | & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, | |
27878 | & ' no-dif.',8I8,/, | |
27879 | & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, | |
27880 | & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, | |
27881 | & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, | |
27882 | & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, | |
27883 | & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, | |
27884 | & ' hi-lo ',8I8,/, | |
27885 | & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, | |
27886 | & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, | |
27887 | & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) | |
27888 | WRITE(LOUT,1013) | |
27889 | 1013 FORMAT(/,1X,'2. chain system statistics -', | |
27890 | & ' mean numbers per evt:',/,30X,'---------------------', | |
27891 | & /,/,16X,'s-s',7X,'d-s',7X,'s-d') | |
be6523b4 | 27892 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27893 | WRITE(LOUT,1014) |
27894 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), | |
27895 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), | |
27896 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) | |
27897 | 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, | |
27898 | & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, | |
27899 | & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, | |
27900 | & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, | |
27901 | & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, | |
27902 | & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, | |
27903 | & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, | |
27904 | & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, | |
27905 | & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, | |
27906 | & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) | |
be6523b4 | 27907 | ENDIF |
9aaba0d6 | 27908 | WRITE(LOUT,1015) |
27909 | 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') | |
be6523b4 | 27910 | IF (ICSAMP.GT.0) THEN |
9aaba0d6 | 27911 | WRITE(LOUT,1016) |
27912 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), | |
27913 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), | |
27914 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) | |
27915 | 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, | |
27916 | & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, | |
27917 | & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, | |
27918 | & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, | |
27919 | & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, | |
27920 | & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, | |
27921 | & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, | |
27922 | & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, | |
27923 | & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, | |
27924 | & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) | |
be6523b4 | 27925 | ENDIF |
9aaba0d6 | 27926 | |
27927 | ENDIF | |
27928 | CALL DT_CHASTA(1) | |
27929 | ||
27930 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
27931 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
27932 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', | |
27933 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), | |
27934 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) | |
27935 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', | |
27936 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), | |
27937 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) | |
27938 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', | |
27939 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), | |
27940 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) | |
27941 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', | |
27942 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), | |
27943 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) | |
27944 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', | |
27945 | & DBRKA(3,1),DBRKA(3,2), | |
27946 | & DBRKA(3,3),DBRKA(3,4) | |
27947 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', | |
27948 | & DBRKR(3,1),DBRKR(3,2), | |
27949 | & DBRKR(3,3),DBRKR(3,4) | |
27950 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', | |
27951 | & DBRKA(3,5),DBRKA(3,6), | |
27952 | & DBRKA(3,7),DBRKA(3,8) | |
27953 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', | |
27954 | & DBRKR(3,5),DBRKR(3,6), | |
27955 | & DBRKR(3,7),DBRKR(3,8) | |
27956 | ENDIF | |
27957 | ||
27958 | FAC = 1.0D0 | |
27959 | IF (MCGENE.EQ.2) THEN | |
27960 | C CALL PHO_PHIST(-2,SIGMAX) | |
27961 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) | |
27962 | ENDIF | |
27963 | ||
27964 | CALL DT_XTIME | |
27965 | ||
27966 | RETURN | |
27967 | END | |
27968 | ||
27969 | *$ CREATE DT_EVTOUT.FOR | |
27970 | *COPY DT_EVTOUT | |
27971 | * | |
27972 | *===evtout=============================================================* | |
27973 | * | |
27974 | SUBROUTINE DT_EVTOUT(MODE) | |
27975 | ||
27976 | ************************************************************************ | |
27977 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27978 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27979 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27980 | * This version dated 11.12.94 is written by S. Roesler * | |
27981 | ************************************************************************ | |
27982 | ||
27983 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27984 | SAVE | |
27985 | PARAMETER ( LINP = 10 , | |
27986 | & LOUT = 6 , | |
27987 | & LDAT = 9 ) | |
27988 | * event history | |
27989 | PARAMETER (NMXHKK=200000) | |
27990 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27991 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27992 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27993 | ||
27994 | DIMENSION IRANGE(NMXHKK) | |
27995 | ||
27996 | IF (MODE.EQ.2) RETURN | |
27997 | ||
27998 | CALL DT_EVTPLO(IRANGE,MODE) | |
27999 | ||
28000 | RETURN | |
28001 | END | |
28002 | ||
28003 | *$ CREATE DT_EVTPLO.FOR | |
28004 | *COPY DT_EVTPLO | |
28005 | * | |
28006 | *===evtplo=============================================================* | |
28007 | * | |
28008 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) | |
28009 | ||
28010 | ************************************************************************ | |
28011 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
28012 | * 2 plot entries of DTEVT1 given by IRANGE * | |
28013 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
28014 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
28015 | * 5 plot rejection counter * | |
28016 | * This version dated 11.12.94 is written by S. Roesler * | |
28017 | ************************************************************************ | |
28018 | ||
28019 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28020 | SAVE | |
28021 | PARAMETER ( LINP = 10 , | |
28022 | & LOUT = 6 , | |
28023 | & LDAT = 9 ) | |
28024 | ||
28025 | CHARACTER*16 CHAU | |
28026 | ||
28027 | * event history | |
28028 | PARAMETER (NMXHKK=200000) | |
28029 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28030 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28031 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28032 | * extended event history | |
28033 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28034 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28035 | & IHIST(2,NMXHKK) | |
28036 | * rejection counter | |
28037 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
28038 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
28039 | & IREXCI(3),IRDIFF(2),IRINC | |
28040 | ||
28041 | DIMENSION IRANGE(NMXHKK) | |
28042 | ||
28043 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN | |
28044 | WRITE(LOUT,1000) | |
28045 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, | |
28046 | & 15X,' --------------------------',/,/, | |
28047 | & ' ST ID M1 M2 D1 D2 PX PY', | |
28048 | & ' PZ E M',/) | |
28049 | DO 1 I=1,NHKK | |
28050 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28051 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28052 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28053 | & PHKK(5,I) | |
28054 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28055 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28056 | C & PHKK(3,I),PHKK(4,I) | |
28057 | C WRITE(LOUT,'(4E15.4)') | |
28058 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) | |
28059 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) | |
28060 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) | |
28061 | 1 CONTINUE | |
28062 | WRITE(LOUT,*) | |
28063 | C DO 4 I=1,NHKK | |
28064 | C WRITE(LOUT,1006) I,ISTHKK(I), | |
28065 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), | |
28066 | C & WHKK(2,I),WHKK(3,I) | |
28067 | C1006 FORMAT(1X,I4,I6,6E10.3) | |
28068 | C 4 CONTINUE | |
28069 | ENDIF | |
28070 | ||
28071 | IF (MODE.EQ.2) THEN | |
28072 | WRITE(LOUT,1000) | |
28073 | NC = 0 | |
28074 | 2 CONTINUE | |
28075 | NC = NC+1 | |
28076 | IF (IRANGE(NC).EQ.-100) GOTO 9999 | |
28077 | I = IRANGE(NC) | |
28078 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28079 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28080 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28081 | & PHKK(5,I) | |
28082 | GOTO 2 | |
28083 | ENDIF | |
28084 | ||
28085 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN | |
28086 | WRITE(LOUT,1002) | |
28087 | 1002 FORMAT(/,1X,'EVTPLO:',14X, | |
28088 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, | |
28089 | & 15X,' -----------------------------------',/,/, | |
28090 | & ' ST ID M1 M2 D1 D2 IDR IDXR', | |
28091 | & ' NOBAM IDCH M',/) | |
28092 | DO 3 I=1,NHKK | |
28093 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN | |
28094 | KF = IDHKK(I) | |
28095 | IDCHK = KF/10000 | |
28096 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28097 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 | |
28098 | CALL PYNAME(KF,CHAU) | |
28099 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28100 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28101 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), | |
28102 | & PHKK(5,I),CHAU | |
28103 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) | |
28104 | C ENDIF | |
28105 | 3 CONTINUE | |
28106 | ENDIF | |
28107 | ||
28108 | IF (MODE.EQ.5) THEN | |
28109 | WRITE(LOUT,1004) | |
28110 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, | |
28111 | & 15X,' --------------------------',/) | |
28112 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, | |
28113 | & IRSEA,IRCRON | |
28114 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, | |
28115 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, | |
28116 | & 1X,'IREMC = ',10I5,/, | |
28117 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) | |
28118 | ENDIF | |
28119 | ||
28120 | 9999 RETURN | |
28121 | END | |
28122 | ||
28123 | *$ CREATE DT_EVTPUT.FOR | |
28124 | *COPY DT_EVTPUT | |
28125 | * | |
28126 | *===evtput=============================================================* | |
28127 | * | |
28128 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) | |
28129 | ||
28130 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28131 | SAVE | |
28132 | PARAMETER ( LINP = 10 , | |
28133 | & LOUT = 6 , | |
28134 | & LDAT = 9 ) | |
28135 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, | |
28136 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) | |
28137 | ||
28138 | * event history | |
28139 | PARAMETER (NMXHKK=200000) | |
28140 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28141 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28142 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28143 | * extended event history | |
28144 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28145 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28146 | & IHIST(2,NMXHKK) | |
28147 | * Lorentz-parameters of the current interaction | |
28148 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28149 | & UMO,PPCM,EPROJ,PPROJ | |
28150 | * particle properties (BAMJET index convention) | |
28151 | CHARACTER*8 ANAME | |
28152 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28153 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28154 | ||
28155 | C IF (MODE.GT.100) THEN | |
28156 | C WRITE(LOUT,'(1X,A,I5,A,I5)') | |
28157 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 | |
28158 | C NHKK = NHKK-MODE+100 | |
28159 | C RETURN | |
28160 | C ENDIF | |
28161 | MO1 = M1 | |
28162 | MO2 = M2 | |
28163 | NHKK = NHKK+1 | |
28164 | ||
28165 | IF (NHKK.GT.NMXHKK) THEN | |
28166 | WRITE(LOUT,1000) NHKK | |
28167 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, | |
28168 | & '! program execution stopped..') | |
28169 | STOP | |
28170 | ENDIF | |
28171 | IF (M1.LT.0) MO1 = NHKK+M1 | |
28172 | IF (M2.LT.0) MO2 = NHKK+M2 | |
28173 | ISTHKK(NHKK) = IST | |
28174 | IDHKK(NHKK) = ID | |
28175 | JMOHKK(1,NHKK) = MO1 | |
28176 | JMOHKK(2,NHKK) = MO2 | |
28177 | JDAHKK(1,NHKK) = 0 | |
28178 | JDAHKK(2,NHKK) = 0 | |
28179 | IDRES(NHKK) = IDR | |
28180 | IDXRES(NHKK) = IDXR | |
28181 | IDCH(NHKK) = IDC | |
28182 | ** here we need to do something.. | |
28183 | IF (ID.EQ.88888) THEN | |
28184 | IDMO1 = ABS(IDHKK(MO1)) | |
28185 | IDMO2 = ABS(IDHKK(MO2)) | |
28186 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 | |
28187 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 | |
28188 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 | |
28189 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 | |
28190 | ELSE | |
28191 | NOBAM(NHKK) = 0 | |
28192 | ENDIF | |
28193 | IDBAM(NHKK) = IDT_ICIHAD(ID) | |
28194 | IF (MO1.GT.0) THEN | |
28195 | IF (JDAHKK(1,MO1).NE.0) THEN | |
28196 | JDAHKK(2,MO1) = NHKK | |
28197 | ELSE | |
28198 | JDAHKK(1,MO1) = NHKK | |
28199 | ENDIF | |
28200 | ENDIF | |
28201 | IF (MO2.GT.0) THEN | |
28202 | IF (JDAHKK(1,MO2).NE.0) THEN | |
28203 | JDAHKK(2,MO2) = NHKK | |
28204 | ELSE | |
28205 | JDAHKK(1,MO2) = NHKK | |
28206 | ENDIF | |
28207 | ENDIF | |
28208 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN | |
28209 | C PTOT = SQRT(PX**2+PY**2+PZ**2) | |
28210 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) | |
28211 | C AMRQ = AAM(IDBAM(NHKK)) | |
28212 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
28213 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. | |
28214 | C & (PTOT.GT.ZERO)) THEN | |
28215 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) | |
28216 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) | |
28217 | C E = E+DELTA | |
28218 | C PTOT1 = PTOT-DELTA | |
28219 | C PX = PX*PTOT1/PTOT | |
28220 | C PY = PY*PTOT1/PTOT | |
28221 | C PZ = PZ*PTOT1/PTOT | |
28222 | C ENDIF | |
28223 | C ENDIF | |
28224 | PHKK(1,NHKK) = PX | |
28225 | PHKK(2,NHKK) = PY | |
28226 | PHKK(3,NHKK) = PZ | |
28227 | PHKK(4,NHKK) = E | |
28228 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) | |
28229 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN | |
28230 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 | |
28231 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) | |
28232 | ELSE | |
28233 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) | |
28234 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) | |
28235 | C & WRITE(LOUT,'(1X,A,G10.3)') | |
28236 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) | |
28237 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) | |
28238 | ENDIF | |
28239 | IDCHK = ID/10000 | |
28240 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN | |
28241 | * special treatment for chains: | |
28242 | * z coordinate of chain in Lab = pos. of target nucleon | |
28243 | * time of chain-creation in Lab = time of passage of projectile | |
28244 | * nucleus at pos. of taget nucleus | |
28245 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) | |
28246 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) | |
28247 | VHKK(1,NHKK) = VHKK(1,MO2) | |
28248 | VHKK(2,NHKK) = VHKK(2,MO2) | |
28249 | VHKK(3,NHKK) = VHKK(3,MO2) | |
28250 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
28251 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) | |
28252 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) | |
28253 | WHKK(1,NHKK) = WHKK(1,MO1) | |
28254 | WHKK(2,NHKK) = WHKK(2,MO1) | |
28255 | WHKK(3,NHKK) = WHKK(3,MO1) | |
28256 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
28257 | ELSE | |
28258 | IF (MO1.GT.0) THEN | |
28259 | DO 1 I=1,4 | |
28260 | VHKK(I,NHKK) = VHKK(I,MO1) | |
28261 | WHKK(I,NHKK) = WHKK(I,MO1) | |
28262 | 1 CONTINUE | |
28263 | ELSE | |
28264 | DO 2 I=1,4 | |
28265 | VHKK(I,NHKK) = ZERO | |
28266 | WHKK(I,NHKK) = ZERO | |
28267 | 2 CONTINUE | |
28268 | ENDIF | |
28269 | ENDIF | |
28270 | ||
28271 | RETURN | |
28272 | END | |
28273 | ||
28274 | *$ CREATE DT_CHASTA.FOR | |
28275 | *COPY DT_CHASTA | |
28276 | * | |
28277 | *===chasta=============================================================* | |
28278 | * | |
28279 | SUBROUTINE DT_CHASTA(MODE) | |
28280 | ||
28281 | ************************************************************************ | |
28282 | * This subroutine performs CHAin STAtistics and checks sequence of * | |
28283 | * partons in dtevt1 and sorts them with projectile partons coming * | |
28284 | * first if necessary. * | |
28285 | * * | |
28286 | * This version dated 8.5.00 is written by S. Roesler. * | |
28287 | ************************************************************************ | |
28288 | ||
28289 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28290 | SAVE | |
28291 | PARAMETER ( LINP = 10 , | |
28292 | & LOUT = 6 , | |
28293 | & LDAT = 9 ) | |
28294 | ||
28295 | CHARACTER*5 CCHTYP | |
28296 | ||
28297 | * event history | |
28298 | PARAMETER (NMXHKK=200000) | |
28299 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28300 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28301 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28302 | * extended event history | |
28303 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28304 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28305 | & IHIST(2,NMXHKK) | |
28306 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
28307 | PARAMETER (MAXCHN=10000) | |
28308 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
28309 | ||
28310 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), | |
28311 | & CCHTYP(9),ICHSTA(10),ITOT(10) | |
28312 | DATA ICHCFG /1800*0/ | |
28313 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ | |
28314 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ | |
28315 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ | |
28316 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ | |
28317 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ | |
28318 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ | |
28319 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', | |
28320 | & 'ad aq',' d ad','ad d ',' g g '/ | |
28321 | * | |
28322 | * initialization | |
28323 | * | |
28324 | IF (MODE.EQ.-1) THEN | |
28325 | NCHAIN = 0 | |
28326 | * | |
28327 | * loop over DTEVT1 and analyse chain configurations | |
28328 | * | |
28329 | ELSEIF (MODE.EQ.0) THEN | |
28330 | DO 21 IDX=NPOINT(3),NHKK | |
28331 | IDCHK = IDHKK(IDX)/10000 | |
28332 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28333 | & (IDHKK(IDX).NE.80000).AND. | |
28334 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN | |
28335 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN | |
28336 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', | |
28337 | & ' at entry ',IDX | |
28338 | GOTO 21 | |
28339 | ENDIF | |
28340 | * | |
28341 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28342 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28343 | IMO1 = IST1/10 | |
28344 | IMO1 = IST1-10*IMO1 | |
28345 | IMO2 = IST2/10 | |
28346 | IMO2 = IST2-10*IMO2 | |
28347 | * swop parton entries if necessary since we need projectile partons | |
28348 | * to come first in the common | |
28349 | IF (IMO1.GT.IMO2) THEN | |
28350 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 | |
28351 | DO 22 K=1,NPTN/2 | |
28352 | I0 = JMOHKK(1,IDX)-1+K | |
28353 | I1 = JMOHKK(2,IDX)+1-K | |
28354 | ITMP = ISTHKK(I0) | |
28355 | ISTHKK(I0) = ISTHKK(I1) | |
28356 | ISTHKK(I1) = ITMP | |
28357 | ITMP = IDHKK(I0) | |
28358 | IDHKK(I0) = IDHKK(I1) | |
28359 | IDHKK(I1) = ITMP | |
28360 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) | |
28361 | & JDAHKK(1,JMOHKK(1,I0)) = I1 | |
28362 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) | |
28363 | & JDAHKK(2,JMOHKK(1,I0)) = I1 | |
28364 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) | |
28365 | & JDAHKK(1,JMOHKK(2,I0)) = I1 | |
28366 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) | |
28367 | & JDAHKK(2,JMOHKK(2,I0)) = I1 | |
28368 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) | |
28369 | & JDAHKK(1,JMOHKK(1,I1)) = I0 | |
28370 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) | |
28371 | & JDAHKK(2,JMOHKK(1,I1)) = I0 | |
28372 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) | |
28373 | & JDAHKK(1,JMOHKK(2,I1)) = I0 | |
28374 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) | |
28375 | & JDAHKK(2,JMOHKK(2,I1)) = I0 | |
28376 | ITMP = JMOHKK(1,I0) | |
28377 | JMOHKK(1,I0) = JMOHKK(1,I1) | |
28378 | JMOHKK(1,I1) = ITMP | |
28379 | ITMP = JMOHKK(2,I0) | |
28380 | JMOHKK(2,I0) = JMOHKK(2,I1) | |
28381 | JMOHKK(2,I1) = ITMP | |
28382 | ITMP = JDAHKK(1,I0) | |
28383 | JDAHKK(1,I0) = JDAHKK(1,I1) | |
28384 | JDAHKK(1,I1) = ITMP | |
28385 | ITMP = JDAHKK(2,I0) | |
28386 | JDAHKK(2,I0) = JDAHKK(2,I1) | |
28387 | JDAHKK(2,I1) = ITMP | |
28388 | DO 23 J=1,4 | |
28389 | RTMP1 = PHKK(J,I0) | |
28390 | RTMP2 = VHKK(J,I0) | |
28391 | RTMP3 = WHKK(J,I0) | |
28392 | PHKK(J,I0) = PHKK(J,I1) | |
28393 | VHKK(J,I0) = VHKK(J,I1) | |
28394 | WHKK(J,I0) = WHKK(J,I1) | |
28395 | PHKK(J,I1) = RTMP1 | |
28396 | VHKK(J,I1) = RTMP2 | |
28397 | WHKK(J,I1) = RTMP3 | |
28398 | 23 CONTINUE | |
28399 | RTMP1 = PHKK(5,I0) | |
28400 | PHKK(5,I0) = PHKK(5,I1) | |
28401 | PHKK(5,I1) = RTMP1 | |
28402 | ITMP = IDRES(I0) | |
28403 | IDRES(I0) = IDRES(I1) | |
28404 | IDRES(I1) = ITMP | |
28405 | ITMP = IDXRES(I0) | |
28406 | IDXRES(I0) = IDXRES(I1) | |
28407 | IDXRES(I1) = ITMP | |
28408 | ITMP = NOBAM(I0) | |
28409 | NOBAM(I0) = NOBAM(I1) | |
28410 | NOBAM(I1) = ITMP | |
28411 | ITMP = IDBAM(I0) | |
28412 | IDBAM(I0) = IDBAM(I1) | |
28413 | IDBAM(I1) = ITMP | |
28414 | ITMP = IDCH(I0) | |
28415 | IDCH(I0) = IDCH(I1) | |
28416 | IDCH(I1) = ITMP | |
28417 | ITMP = IHIST(1,I0) | |
28418 | IHIST(1,I0) = IHIST(1,I1) | |
28419 | IHIST(1,I1) = ITMP | |
28420 | ITMP = IHIST(2,I0) | |
28421 | IHIST(2,I0) = IHIST(2,I1) | |
28422 | IHIST(2,I1) = ITMP | |
28423 | 22 CONTINUE | |
28424 | ENDIF | |
28425 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28426 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28427 | * | |
28428 | * parton 1 (projectile side) | |
28429 | IF (IST1.EQ.21) THEN | |
28430 | IDX1 = 1 | |
28431 | ELSEIF (IST1.EQ.22) THEN | |
28432 | IDX1 = 2 | |
28433 | ELSEIF (IST1.EQ.31) THEN | |
28434 | IDX1 = 3 | |
28435 | ELSEIF (IST1.EQ.32) THEN | |
28436 | IDX1 = 4 | |
28437 | ELSEIF (IST1.EQ.41) THEN | |
28438 | IDX1 = 5 | |
28439 | ELSEIF (IST1.EQ.42) THEN | |
28440 | IDX1 = 6 | |
28441 | ELSEIF (IST1.EQ.51) THEN | |
28442 | IDX1 = 7 | |
28443 | ELSEIF (IST1.EQ.52) THEN | |
28444 | IDX1 = 8 | |
28445 | ELSEIF (IST1.EQ.61) THEN | |
28446 | IDX1 = 9 | |
28447 | ELSEIF (IST1.EQ.62) THEN | |
28448 | IDX1 = 10 | |
28449 | ELSE | |
28450 | c WRITE(LOUT,*) | |
28451 | c & ' CHASTA: unknown parton status flag (', | |
28452 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28453 | GOTO 21 | |
28454 | ENDIF | |
28455 | ID = IDHKK(JMOHKK(1,IDX)) | |
28456 | IF (ABS(ID).LE.4) THEN | |
28457 | IF (ID.GT.0) THEN | |
28458 | ITYP1 = 1 | |
28459 | ELSE | |
28460 | ITYP1 = 2 | |
28461 | ENDIF | |
28462 | ELSEIF (ABS(ID).GE.1000) THEN | |
28463 | IF (ID.GT.0) THEN | |
28464 | ITYP1 = 3 | |
28465 | ELSE | |
28466 | ITYP1 = 4 | |
28467 | ENDIF | |
28468 | ELSEIF (ID.EQ.21) THEN | |
28469 | ITYP1 = 5 | |
28470 | ELSE | |
28471 | WRITE(LOUT,*) | |
28472 | & ' CHASTA: inconsistent parton identity (', | |
28473 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28474 | GOTO 21 | |
28475 | ENDIF | |
28476 | * | |
28477 | * parton 2 (target side) | |
28478 | IF (IST2.EQ.21) THEN | |
28479 | IDX2 = 1 | |
28480 | ELSEIF (IST2.EQ.22) THEN | |
28481 | IDX2 = 2 | |
28482 | ELSEIF (IST2.EQ.31) THEN | |
28483 | IDX2 = 3 | |
28484 | ELSEIF (IST2.EQ.32) THEN | |
28485 | IDX2 = 4 | |
28486 | ELSEIF (IST2.EQ.41) THEN | |
28487 | IDX2 = 5 | |
28488 | ELSEIF (IST2.EQ.42) THEN | |
28489 | IDX2 = 6 | |
28490 | ELSEIF (IST2.EQ.51) THEN | |
28491 | IDX2 = 7 | |
28492 | ELSEIF (IST2.EQ.52) THEN | |
28493 | IDX2 = 8 | |
28494 | ELSEIF (IST2.EQ.61) THEN | |
28495 | IDX2 = 9 | |
28496 | ELSEIF (IST2.EQ.62) THEN | |
28497 | IDX2 = 10 | |
28498 | ELSE | |
28499 | c WRITE(LOUT,*) | |
28500 | c & ' CHASTA: unknown parton status flag (', | |
28501 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' | |
28502 | GOTO 21 | |
28503 | ENDIF | |
28504 | ID = IDHKK(JMOHKK(2,IDX)) | |
28505 | IF (ABS(ID).LE.4) THEN | |
28506 | IF (ID.GT.0) THEN | |
28507 | ITYP2 = 1 | |
28508 | ELSE | |
28509 | ITYP2 = 2 | |
28510 | ENDIF | |
28511 | ELSEIF (ABS(ID).GE.1000) THEN | |
28512 | IF (ID.GT.0) THEN | |
28513 | ITYP2 = 3 | |
28514 | ELSE | |
28515 | ITYP2 = 4 | |
28516 | ENDIF | |
28517 | ELSEIF (ID.EQ.21) THEN | |
28518 | ITYP2 = 5 | |
28519 | ELSE | |
28520 | WRITE(LOUT,*) | |
28521 | & ' CHASTA: inconsistent parton identity (', | |
28522 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28523 | GOTO 21 | |
28524 | ENDIF | |
28525 | * | |
28526 | * fill counter | |
28527 | ITYPE = ICHTYP(ITYP1,ITYP2) | |
28528 | IF (ITYPE.NE.0) THEN | |
28529 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 | |
28530 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 | |
28531 | ICHCFG(IDX1,IDX2,ITYPE,2) = | |
28532 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON | |
28533 | ||
28534 | NCHAIN = NCHAIN+1 | |
28535 | IF (NCHAIN.GT.MAXCHN) THEN | |
28536 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', | |
28537 | & NCHAIN,MAXCHN | |
28538 | STOP | |
28539 | ENDIF | |
28540 | IDXCHN(1,NCHAIN) = IDX | |
28541 | IDXCHN(2,NCHAIN) = ITYPE | |
28542 | ELSE | |
28543 | WRITE(LOUT,*) | |
28544 | & ' CHASTA: inconsistent chain at entry ',IDX | |
28545 | GOTO 21 | |
28546 | ENDIF | |
28547 | ENDIF | |
28548 | 21 CONTINUE | |
28549 | * | |
28550 | * write statistics to output unit | |
28551 | * | |
28552 | ELSEIF (MODE.EQ.1) THEN | |
28553 | WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' | |
28554 | DO 31 I=1,10 | |
28555 | WRITE(LOUT,'(/,2A)') | |
28556 | & ' -----------------------------------------', | |
28557 | & '------------------------------------' | |
28558 | WRITE(LOUT,'(2A)') | |
28559 | & ' p\\t 21 22 31 32 41', | |
28560 | & ' 42 51 52 61 62' | |
28561 | WRITE(LOUT,'(2A)') | |
28562 | & ' -----------------------------------------', | |
28563 | & '------------------------------------' | |
28564 | DO 32 J=1,10 | |
28565 | ITOT(J) = 0 | |
28566 | DO 33 K=1,9 | |
28567 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) | |
28568 | 33 CONTINUE | |
28569 | 32 CONTINUE | |
28570 | WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) | |
28571 | DO 34 K=1,9 | |
28572 | ISUM = 0 | |
28573 | DO 35 J=1,10 | |
28574 | ISUM = ISUM+ICHCFG(I,J,K,1) | |
28575 | 35 CONTINUE | |
28576 | IF (ISUM.GT.0) | |
28577 | & WRITE(LOUT,'(1X,A5,2X,10I7)') | |
28578 | & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) | |
28579 | 34 CONTINUE | |
28580 | C WRITE(LOUT,'(2A)') | |
28581 | C & ' -----------------------------------------', | |
28582 | C & '-------------------------------' | |
28583 | 31 CONTINUE | |
28584 | * | |
28585 | ELSE | |
28586 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' | |
28587 | STOP | |
28588 | ENDIF | |
28589 | ||
28590 | RETURN | |
28591 | END | |
28592 | *$ CREATE PHO_PHIST.FOR | |
28593 | *COPY PHO_PHIST | |
28594 | * | |
28595 | *===pohist=============================================================* | |
28596 | * | |
28597 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) | |
28598 | ||
28599 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28600 | SAVE | |
28601 | ||
28602 | PARAMETER ( LINP = 10 , | |
28603 | & LOUT = 6 , | |
28604 | & LDAT = 9 ) | |
28605 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
28606 | * Glauber formalism: cross sections | |
28607 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
28608 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
28609 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
28610 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
28611 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
28612 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
28613 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
28614 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
28615 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
28616 | & BSLOPE,NEBINI,NQBINI | |
28617 | ||
28618 | ILAB = 0 | |
28619 | IF (IMODE.EQ.10) THEN | |
28620 | IMODE = 1 | |
28621 | ILAB = 1 | |
28622 | ENDIF | |
28623 | IF (ABS(IMODE).LT.1000) THEN | |
28624 | * PHOJET-statistics | |
28625 | C CALL POHISX(IMODE,WEIGHT) | |
28626 | IF (IMODE.EQ.-1) THEN | |
28627 | MODE = 1 | |
28628 | XSTOT(1,1,1) = WEIGHT | |
28629 | ENDIF | |
28630 | IF (IMODE.EQ. 1) MODE = 2 | |
28631 | IF (IMODE.EQ.-2) MODE = 3 | |
28632 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) | |
28633 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28634 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28635 | CALL DT_HISTOG(MODE) | |
28636 | CALL DT_USRHIS(MODE) | |
28637 | ELSE | |
28638 | * DTUNUC-statistics | |
28639 | MODE = IMODE/1000 | |
28640 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28641 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28642 | CALL DT_HISTOG(MODE) | |
28643 | CALL DT_USRHIS(MODE) | |
28644 | ENDIF | |
28645 | ||
28646 | RETURN | |
28647 | END | |
28648 | ||
28649 | *$ CREATE DT_SWPPHO.FOR | |
28650 | *COPY DT_SWPPHO | |
28651 | * | |
28652 | *===swppho=============================================================* | |
28653 | * | |
28654 | SUBROUTINE DT_SWPPHO(ILAB) | |
28655 | ||
28656 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28657 | SAVE | |
28658 | PARAMETER ( LINP = 10 , | |
28659 | & LOUT = 6 , | |
28660 | & LDAT = 9 ) | |
28661 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28662 | ||
28663 | LOGICAL LSTART | |
28664 | ||
28665 | * event history | |
28666 | PARAMETER (NMXHKK=200000) | |
28667 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28668 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28669 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28670 | * extended event history | |
28671 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28672 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28673 | & IHIST(2,NMXHKK) | |
28674 | * flags for input different options | |
28675 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28676 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28677 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28678 | * properties of photon/lepton projectiles | |
28679 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
28680 | ||
28681 | **PHOJET105a | |
28682 | C PARAMETER (NMXHEP=2000) | |
28683 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28684 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) | |
28685 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28686 | C COMMON /PLASAV/ PLAB | |
28687 | **PHOJET110 | |
28688 | C standard particle data interface | |
28689 | INTEGER NMXHEP | |
28690 | PARAMETER (NMXHEP=4000) | |
28691 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
28692 | DOUBLE PRECISION PHEP,VHEP | |
28693 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28694 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
09b429a4 | 28695 | & VHEP(4,NMXHEP),NSD1, NSD2, NDD |
9aaba0d6 | 28696 | C extension to standard particle data interface (PHOJET specific) |
28697 | INTEGER IMPART,IPHIST,ICOLOR | |
28698 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
28699 | C global event kinematics and particle IDs | |
28700 | INTEGER IFPAP,IFPAB | |
28701 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
28702 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28703 | ** | |
28704 | DATA ICOUNT/0/ | |
28705 | ||
28706 | DATA LSTART /.TRUE./ | |
28707 | ||
28708 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN | |
28709 | IF ((IFRAME.EQ.1).AND.LSTART) THEN | |
28710 | UMO = ECM | |
28711 | ELA = ZERO | |
28712 | PLA = ZERO | |
28713 | IDP = IDT_ICIHAD(IFPAP(1)) | |
28714 | IDT = IDT_ICIHAD(IFPAP(2)) | |
28715 | VIRT = PVIRT(1) | |
28716 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) | |
28717 | PLAB = PLA | |
28718 | LSTART = .FALSE. | |
28719 | ENDIF | |
28720 | ||
28721 | NHKK = 0 | |
28722 | ICOUNT = ICOUNT+1 | |
28723 | C NEVHKK = NEVHEP | |
28724 | NEVHKK = ICOUNT | |
28725 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT | |
28726 | DO 1 I=3,NHEP | |
28727 | IF (ISTHEP(I).EQ.1) THEN | |
28728 | NHKK = NHKK+1 | |
28729 | ISTHKK(NHKK) = 1 | |
28730 | IDHKK(NHKK) = IDHEP(I) | |
28731 | JMOHKK(1,NHKK) = 0 | |
28732 | JMOHKK(2,NHKK) = 0 | |
28733 | JDAHKK(1,NHKK) = 0 | |
28734 | JDAHKK(2,NHKK) = 0 | |
28735 | DO 2 K=1,4 | |
28736 | PHKK(K,NHKK) = PHEP(K,I) | |
28737 | VHKK(K,NHKK) = ZERO | |
28738 | WHKK(K,NHKK) = ZERO | |
28739 | 2 CONTINUE | |
28740 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) | |
28741 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), | |
28742 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) | |
28743 | PHKK(5,NHKK) = PHEP(5,I) | |
28744 | IDRES(NHKK) = 0 | |
28745 | IDXRES(NHKK) = 0 | |
28746 | NOBAM(NHKK) = 0 | |
28747 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) | |
28748 | IDCH(NHKK) = 0 | |
28749 | ENDIF | |
28750 | 1 CONTINUE | |
28751 | ||
28752 | RETURN | |
28753 | END | |
28754 | ||
28755 | *$ CREATE DT_HISTOG.FOR | |
28756 | *COPY DT_HISTOG | |
28757 | * | |
28758 | *===histog=============================================================* | |
28759 | * | |
28760 | SUBROUTINE DT_HISTOG(MODE) | |
28761 | ||
28762 | ************************************************************************ | |
28763 | * This version dated 25.03.96 is written by S. Roesler * | |
28764 | ************************************************************************ | |
28765 | ||
28766 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28767 | SAVE | |
28768 | PARAMETER ( LINP = 10 , | |
28769 | & LOUT = 6 , | |
28770 | & LDAT = 9 ) | |
28771 | ||
28772 | LOGICAL LFSP,LRNL | |
28773 | ||
28774 | * event history | |
28775 | PARAMETER (NMXHKK=200000) | |
28776 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28777 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28778 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28779 | * extended event history | |
28780 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28781 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28782 | & IHIST(2,NMXHKK) | |
28783 | * event flag used for histograms | |
28784 | COMMON /DTNORM/ ICEVT,IEVHKK | |
28785 | * flags for activated histograms | |
28786 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
28787 | ||
28788 | IEVHKK = NEVHKK | |
28789 | GOTO (1,2,3) MODE | |
28790 | ||
28791 | *------------------------------------------------------------------ | |
28792 | * initialization | |
28793 | 1 CONTINUE | |
28794 | ICEVT = 0 | |
28795 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) | |
28796 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) | |
28797 | ||
28798 | RETURN | |
28799 | *------------------------------------------------------------------ | |
28800 | * filling of histogram with event-record | |
28801 | 2 CONTINUE | |
28802 | ICEVT = ICEVT+1 | |
28803 | ||
28804 | DO 20 I=1,NHKK | |
28805 | CALL DT_SWPFSP(I,LFSP,LRNL) | |
28806 | IF (LFSP) THEN | |
28807 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) | |
28808 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) | |
28809 | ENDIF | |
28810 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) | |
28811 | 20 CONTINUE | |
28812 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) | |
28813 | ||
28814 | RETURN | |
28815 | *------------------------------------------------------------------ | |
28816 | * output | |
28817 | 3 CONTINUE | |
28818 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) | |
28819 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) | |
28820 | ||
28821 | RETURN | |
28822 | END | |
28823 | ||
28824 | *$ CREATE DT_SWPFSP.FOR | |
28825 | *COPY DT_SWPFSP | |
28826 | * | |
28827 | *===swpfsp=============================================================* | |
28828 | * | |
28829 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) | |
28830 | ||
28831 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28832 | SAVE | |
28833 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28834 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, | |
28835 | & PI =TWOPI/TWO, | |
28836 | & BOG =TWOPI/360.0D0) | |
28837 | ||
28838 | * event history | |
28839 | PARAMETER (NMXHKK=200000) | |
28840 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28841 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28842 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28843 | * extended event history | |
28844 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28845 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28846 | & IHIST(2,NMXHKK) | |
28847 | * particle properties (BAMJET index convention) | |
28848 | CHARACTER*8 ANAME | |
28849 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28850 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28851 | * Lorentz-parameters of the current interaction | |
28852 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28853 | & UMO,PPCM,EPROJ,PPROJ | |
28854 | * flags for input different options | |
28855 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28856 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28857 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28858 | * (original name: PAREVT) | |
28859 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
28860 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
28861 | PARAMETER ( NALLWP = 39 ) | |
28862 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
28863 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
28864 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
28865 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
28866 | * temporary storage for one final state particle | |
28867 | LOGICAL LFRAG,LGREY,LBLACK | |
28868 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
28869 | & SINTHE,COSTHE,THETA,THECMS, | |
28870 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
28871 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
28872 | & LFRAG,LGREY,LBLACK | |
28873 | ||
28874 | LOGICAL LFSP,LRNL | |
28875 | ||
28876 | LFSP = .FALSE. | |
28877 | LRNL = .FALSE. | |
28878 | ISTRNL = 1000 | |
28879 | MULDEF = 1 | |
28880 | IF (LEVPRT) ISTRNL = 1001 | |
28881 | ||
28882 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN | |
28883 | IST = ISTHKK(IDX) | |
28884 | IDPDG = IDHKK(IDX) | |
28885 | LFRAG = .FALSE. | |
28886 | IF (IDHKK(IDX).LT.80000) THEN | |
28887 | IDBJT = IDBAM(IDX) | |
28888 | IBARY = IIBAR(IDBJT) | |
28889 | ICHAR = IICH(IDBJT) | |
28890 | AMASS = AAM(IDBJT) | |
28891 | ELSEIF (IDHKK(IDX).EQ.80000) THEN | |
28892 | IDBJT = 0 | |
28893 | IBARY = IDRES(IDX) | |
28894 | ICHAR = IDXRES(IDX) | |
28895 | AMASS = PHKK(5,IDX) | |
28896 | INUT = IBARY-ICHAR | |
28897 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 | |
28898 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 | |
28899 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 | |
28900 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 | |
28901 | IF (IDBJT.EQ.0) LFRAG = .TRUE. | |
28902 | ELSE | |
28903 | GOTO 9999 | |
28904 | ENDIF | |
28905 | PE = PHKK(4,IDX) | |
28906 | PX = PHKK(1,IDX) | |
28907 | PY = PHKK(2,IDX) | |
28908 | PZ = PHKK(3,IDX) | |
28909 | PT2 = PX**2+PY**2 | |
28910 | PT = SQRT(PT2) | |
28911 | PTOT = SQRT(PT2+PZ**2) | |
28912 | SINTHE = PT/MAX(PTOT,TINY14) | |
28913 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28914 | IF (COSTHE.GT.ONE) THEN | |
28915 | THETA = ZERO | |
28916 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28917 | THETA = TWOPI/2.0D0 | |
28918 | ELSE | |
28919 | THETA = ACOS(COSTHE) | |
28920 | ENDIF | |
28921 | EKIN = PE-AMASS | |
28922 | **sr 15.4.96 new E_t-definition | |
28923 | IF (IBARY.GT.0) THEN | |
28924 | ET = EKIN*SINTHE | |
28925 | ELSEIF (IBARY.LT.0) THEN | |
28926 | ET = (EKIN+TWO*AMASS)*SINTHE | |
28927 | ELSE | |
28928 | ET = PE*SINTHE | |
28929 | ENDIF | |
28930 | ** | |
28931 | XLAB = PZ/MAX(PPROJ,TINY14) | |
28932 | C XLAB = PE/MAX(EPROJ,TINY14) | |
28933 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) | |
28934 | & *(ONE+AMASS/MAX(PE,TINY14)) )) | |
28935 | PPLUS = PE+PZ | |
28936 | PMINUS = PE-PZ | |
28937 | IF (PMINUS.GT.TINY14) THEN | |
28938 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28939 | ELSE | |
28940 | YY = 100.0D0 | |
28941 | ENDIF | |
28942 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28943 | ETA = -LOG(TAN(THETA/TWO)) | |
28944 | ELSE | |
28945 | ETA = 100.0D0 | |
28946 | ENDIF | |
28947 | IF (IFRAME.EQ.1) THEN | |
28948 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) | |
28949 | PPLUS = EECMS+PZCMS | |
28950 | PMINUS = EECMS-PZCMS | |
28951 | IF ((PPLUS*PMINUS).GT.TINY14) THEN | |
28952 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28953 | ELSE | |
28954 | YYCMS = 100.0D0 | |
28955 | ENDIF | |
28956 | PTOTCM = SQRT(PT2+PZCMS**2) | |
28957 | COSTH = PZCMS/MAX(PTOTCM,TINY14) | |
28958 | IF (COSTH.GT.ONE) THEN | |
28959 | THECMS = ZERO | |
28960 | ELSEIF (COSTH.LT.-ONE) THEN | |
28961 | THECMS = TWOPI/2.0D0 | |
28962 | ELSE | |
28963 | THECMS = ACOS(COSTH) | |
28964 | ENDIF | |
28965 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN | |
28966 | ETACMS = -LOG(TAN(THECMS/TWO)) | |
28967 | ELSE | |
28968 | ETACMS = 100.0D0 | |
28969 | ENDIF | |
28970 | XF = PZCMS/MAX(PPCM,TINY14) | |
28971 | THECMS = THECMS/BOG | |
28972 | ELSE | |
28973 | PZCMS = PZ | |
28974 | EECMS = PE | |
28975 | YYCMS = YY | |
28976 | ETACMS = ETA | |
28977 | XF = XLAB | |
28978 | THECMS = THETA/BOG | |
28979 | ENDIF | |
28980 | THETA = THETA/BOG | |
28981 | ||
28982 | * set flag for "grey/black" | |
28983 | LGREY = .FALSE. | |
28984 | LBLACK = .FALSE. | |
28985 | EK = EKIN | |
28986 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) | |
28987 | IF (MULDEF.EQ.1) THEN | |
28988 | * EMU01-Def. | |
28989 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. | |
28990 | & (EK.LE.375.0D-3) ).OR. | |
28991 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. | |
28992 | & (EK.LE. 56.0D-3) ).OR. | |
28993 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. | |
28994 | & (EK.LE. 56.0D-3) ).OR. | |
28995 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. | |
28996 | & (EK.LE.198.0D-3) ).OR. | |
28997 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. | |
28998 | & (EK.LE.198.0D-3) ).OR. | |
28999 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
29000 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
29001 | & (IDBJT.NE.16).AND. | |
29002 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) | |
29003 | & LGREY = .TRUE. | |
29004 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. | |
29005 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. | |
29006 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. | |
29007 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. | |
29008 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. | |
29009 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
29010 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
29011 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) | |
29012 | & LBLACK = .TRUE. | |
29013 | ELSE | |
29014 | * common Def. | |
29015 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. | |
29016 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. | |
29017 | ENDIF | |
29018 | LFSP = .TRUE. | |
29019 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN | |
29020 | IST = ISTHKK(IDX) | |
29021 | IDPDG = IDHKK(IDX) | |
29022 | LFRAG = .TRUE. | |
29023 | IDBJT = 0 | |
29024 | IBARY = IDRES(IDX) | |
29025 | ICHAR = IDXRES(IDX) | |
29026 | AMASS = PHKK(5,IDX) | |
29027 | PE = PHKK(4,IDX) | |
29028 | PX = PHKK(1,IDX) | |
29029 | PY = PHKK(2,IDX) | |
29030 | PZ = PHKK(3,IDX) | |
29031 | PT2 = PX**2+PY**2 | |
29032 | PT = SQRT(PT2) | |
29033 | PTOT = SQRT(PT2+PZ**2) | |
29034 | SINTHE = PT/MAX(PTOT,TINY14) | |
29035 | COSTHE = PZ/MAX(PTOT,TINY14) | |
29036 | IF (COSTHE.GT.ONE) THEN | |
29037 | THETA = ZERO | |
29038 | ELSEIF (COSTHE.LT.-ONE) THEN | |
29039 | THETA = TWOPI/2.0D0 | |
29040 | ELSE | |
29041 | THETA = ACOS(COSTHE) | |
29042 | ENDIF | |
29043 | EKIN = PE-AMASS | |
29044 | **sr 15.4.96 new E_t-definition | |
29045 | C ET = PE*SINTHE | |
29046 | ET = EKIN*SINTHE | |
29047 | ** | |
29048 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
29049 | ETA = -LOG(TAN(THETA/TWO)) | |
29050 | ELSE | |
29051 | ETA = 100.0D0 | |
29052 | ENDIF | |
29053 | THETA = THETA/BOG | |
29054 | LRNL = .TRUE. | |
29055 | ENDIF | |
29056 | ||
29057 | 9999 CONTINUE | |
29058 | RETURN | |
29059 | END | |
29060 | ||
29061 | *$ CREATE DT_HIMULT.FOR | |
29062 | *COPY DT_HIMULT | |
29063 | * | |
29064 | *===himult=============================================================* | |
29065 | * | |
29066 | SUBROUTINE DT_HIMULT(MODE) | |
29067 | ||
29068 | ************************************************************************ | |
29069 | * Tables of average energies/multiplicities. * | |
29070 | * This version dated 30.08.2000 is written by S. Roesler * | |
29071 | ************************************************************************ | |
29072 | ||
29073 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29074 | SAVE | |
29075 | PARAMETER ( LINP = 10 , | |
29076 | & LOUT = 6 , | |
29077 | & LDAT = 9 ) | |
29078 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29079 | ||
29080 | PARAMETER (SWMEXP=1.7D0) | |
29081 | ||
29082 | CHARACTER*8 ANAMEH(4) | |
29083 | ||
29084 | * particle properties (BAMJET index convention) | |
29085 | CHARACTER*8 ANAME | |
29086 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29087 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29088 | * temporary storage for one final state particle | |
29089 | LOGICAL LFRAG,LGREY,LBLACK | |
29090 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29091 | & SINTHE,COSTHE,THETA,THECMS, | |
29092 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29093 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29094 | & LFRAG,LGREY,LBLACK | |
29095 | * event flag used for histograms | |
29096 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29097 | * Lorentz-parameters of the current interaction | |
29098 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
29099 | & UMO,PPCM,EPROJ,PPROJ | |
29100 | ||
29101 | PARAMETER (NOPART=210) | |
29102 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), | |
29103 | & AVPT(4,NOPART),IAVPT(4,NOPART) | |
29104 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ | |
29105 | ||
29106 | GOTO (1,2,3) MODE | |
29107 | ||
29108 | *------------------------------------------------------------------ | |
29109 | * initialization | |
29110 | 1 CONTINUE | |
29111 | DO 10 I=1,NOPART | |
29112 | DO 11 J=1,4 | |
29113 | AVMULT(J,I) = ZERO | |
29114 | AVE(J,I) = ZERO | |
29115 | AVSWM(J,I) = ZERO | |
29116 | AVPT(J,I) = ZERO | |
29117 | IAVPT(J,I) = 0 | |
29118 | 11 CONTINUE | |
29119 | 10 CONTINUE | |
29120 | ||
29121 | RETURN | |
29122 | ||
29123 | *------------------------------------------------------------------ | |
29124 | * filling of histogram with event-record | |
29125 | 2 CONTINUE | |
29126 | IF (PE.LT.0.0D0) THEN | |
29127 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE | |
29128 | RETURN | |
29129 | ENDIF | |
29130 | IF (.NOT.LFRAG) THEN | |
29131 | IVEL = 2 | |
29132 | IF (LGREY) IVEL = 3 | |
29133 | IF (LBLACK) IVEL = 4 | |
29134 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE | |
29135 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE | |
29136 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT | |
29137 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT | |
29138 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 | |
29139 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 | |
29140 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP | |
29141 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP | |
29142 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE | |
29143 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE | |
29144 | IF (IDBJT.LT.116) THEN | |
29145 | * total energy, multiplicity | |
29146 | AVE(1,30) = AVE(1,30) +PE | |
29147 | AVE(IVEL,30) = AVE(IVEL,30)+PE | |
29148 | AVPT(1,30) = AVPT(1,30) +PT | |
29149 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT | |
29150 | IAVPT(1,30) = IAVPT(1,30) +1 | |
29151 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 | |
29152 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP | |
29153 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP | |
29154 | AVMULT(1,30) = AVMULT(1,30) +ONE | |
29155 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE | |
29156 | * charged energy, multiplicity | |
29157 | IF (ICHAR.LT.0) THEN | |
29158 | AVE(1,26) = AVE(1,26) +PE | |
29159 | AVE(IVEL,26) = AVE(IVEL,26)+PE | |
29160 | AVPT(1,26) = AVPT(1,26) +PT | |
29161 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT | |
29162 | IAVPT(1,26) = IAVPT(1,26) +1 | |
29163 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 | |
29164 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP | |
29165 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP | |
29166 | AVMULT(1,26) = AVMULT(1,26) +ONE | |
29167 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE | |
29168 | ENDIF | |
29169 | IF (ICHAR.NE.0) THEN | |
29170 | AVE(1,27) = AVE(1,27) +PE | |
29171 | AVE(IVEL,27) = AVE(IVEL,27)+PE | |
29172 | AVPT(1,27) = AVPT(1,27) +PT | |
29173 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT | |
29174 | IAVPT(1,27) = IAVPT(1,27) +1 | |
29175 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 | |
29176 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP | |
29177 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP | |
29178 | AVMULT(1,27) = AVMULT(1,27) +ONE | |
29179 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE | |
29180 | ENDIF | |
29181 | ENDIF | |
29182 | ENDIF | |
29183 | ||
29184 | RETURN | |
29185 | ||
29186 | *------------------------------------------------------------------ | |
29187 | * output | |
29188 | 3 CONTINUE | |
29189 | WRITE(LOUT,3000) | |
29190 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, | |
29191 | & 29X,'---------------------',/) | |
29192 | IF (MULDEF.EQ.1) THEN | |
29193 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' | |
29194 | ELSE | |
29195 | BETGRE = 0.7D0 | |
29196 | BETBLC = 0.23D0 | |
29197 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC | |
29198 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' | |
29199 | & ,F4.2,' black: beta < ',F4.2,/) | |
29200 | ENDIF | |
29201 | WRITE(LOUT,3003) SWMEXP | |
29202 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, | |
29203 | & 13X,'| total fast', | |
29204 | C & ' grey black K f(',F3.1,')',/,1X, | |
29205 | & ' grey black <pt> f(',F3.1,')',/,1X, | |
29206 | & '------------+--------------', | |
29207 | & '-------------------------------------------------') | |
29208 | DO 30 I=1,NOPART | |
29209 | DO 31 J=1,4 | |
29210 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) | |
29211 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ | |
29212 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) | |
29213 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP | |
29214 | 31 CONTINUE | |
29215 | IF (I.LE.115) THEN | |
29216 | WRITE(LOUT,3004) ANAME(I),I, | |
29217 | & AVMULT(1,I),AVMULT(2,I), | |
29218 | & AVMULT(3,I),AVMULT(4,I), | |
29219 | C & AVE(1,I),AVSWM(1,I) | |
29220 | & AVPT(1,I),AVSWM(1,I) | |
29221 | ELSEIF (I.LE.119) THEN | |
29222 | WRITE(LOUT,3004) ANAMEH(I-115),I, | |
29223 | & AVMULT(1,I),AVMULT(2,I), | |
29224 | & AVMULT(3,I),AVMULT(4,I), | |
29225 | C & AVE(1,I),AVSWM(1,I) | |
29226 | & AVPT(1,I),AVSWM(1,I) | |
29227 | ENDIF | |
29228 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) | |
29229 | 30 CONTINUE | |
29230 | **temporary | |
29231 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', | |
29232 | C & AVMULT(3,27)+AVMULT(4,27) | |
29233 | ** | |
29234 | ||
29235 | RETURN | |
29236 | END | |
29237 | ||
29238 | *$ CREATE DT_HISTAT.FOR | |
29239 | *COPY DT_HISTAT | |
29240 | * | |
29241 | *===histat=============================================================* | |
29242 | * | |
29243 | SUBROUTINE DT_HISTAT(IDX,MODE) | |
29244 | ||
29245 | ************************************************************************ | |
29246 | * This version dated 26.02.96 is written by S. Roesler * | |
29247 | * * | |
29248 | * Last change 27.12.2006 by S. Roesler. * | |
29249 | ************************************************************************ | |
29250 | ||
29251 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29252 | SAVE | |
29253 | PARAMETER ( LINP = 10 , | |
29254 | & LOUT = 6 , | |
29255 | & LDAT = 9 ) | |
29256 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29257 | PARAMETER (NDIM=199) | |
29258 | ||
29259 | * event history | |
29260 | PARAMETER (NMXHKK=200000) | |
29261 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
29262 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
29263 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
29264 | * extended event history | |
29265 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
29266 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
29267 | & IHIST(2,NMXHKK) | |
29268 | * particle properties (BAMJET index convention) | |
29269 | CHARACTER*8 ANAME | |
29270 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29271 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29272 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
29273 | * Glauber formalism: cross sections | |
29274 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
29275 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
29276 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
29277 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
29278 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
29279 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
29280 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
29281 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
29282 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
29283 | & BSLOPE,NEBINI,NQBINI | |
29284 | * emulsion treatment | |
29285 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
29286 | & NCOMPO,IEMUL | |
29287 | * properties of interacting particles | |
29288 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
29289 | * rejection counter | |
29290 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
29291 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
29292 | & IREXCI(3),IRDIFF(2),IRINC | |
29293 | * statistics: residual nuclei | |
29294 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
29295 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
29296 | & NINCST(2,4),NINCEV(2), | |
29297 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
29298 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
29299 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
29300 | & NEVAFI(2,2) | |
29301 | * parameter for intranuclear cascade | |
29302 | LOGICAL LPAULI | |
29303 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
29304 | * (original name: PAREVT) | |
29305 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
29306 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
29307 | PARAMETER ( NALLWP = 39 ) | |
29308 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
29309 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
29310 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
29311 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
29312 | * (original name: FRBKCM) | |
29313 | PARAMETER ( MXFFBK = 6 ) | |
29314 | PARAMETER ( MXZFBK = 9 ) | |
29315 | PARAMETER ( MXNFBK = 10 ) | |
29316 | PARAMETER ( MXAFBK = 16 ) | |
29317 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
29318 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
29319 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
29320 | PARAMETER ( MXPSST = 300 ) | |
29321 | PARAMETER ( MXPSFB = 41000 ) | |
29322 | LOGICAL LFRMBK, LNCMSS | |
29323 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
29324 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
29325 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
29326 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
29327 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
29328 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
29329 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
29330 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
29331 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
29332 | * (original name: INPFLG) | |
29333 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
29334 | * temporary storage for one final state particle | |
29335 | LOGICAL LFRAG,LGREY,LBLACK | |
29336 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29337 | & SINTHE,COSTHE,THETA,THECMS, | |
29338 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29339 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29340 | & LFRAG,LGREY,LBLACK | |
29341 | * event flag used for histograms | |
29342 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29343 | * statistics: double-Pomeron exchange | |
29344 | COMMON /DTFLG2/ INTFLG,IPOPO | |
29345 | ||
29346 | DIMENSION EMUSAM(NCOMPX) | |
29347 | ||
29348 | CHARACTER*13 CMSG(3) | |
29349 | DATA CMSG /'not requested','not requested','not requested'/ | |
29350 | ||
29351 | GOTO (1,2,3,4,5) MODE | |
29352 | ||
29353 | *------------------------------------------------------------------ | |
29354 | * initialization | |
29355 | 1 CONTINUE | |
29356 | * emulsion treatment | |
29357 | IF (NCOMPO.GT.0) THEN | |
29358 | DO 10 I=1,NCOMPX | |
29359 | EMUSAM(I) = ZERO | |
29360 | 10 CONTINUE | |
29361 | ENDIF | |
29362 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. | |
29363 | NINCGE = 0 | |
29364 | DO 11 I=1,2 | |
29365 | EXCDPM(I) = ZERO | |
29366 | EXCDPM(I+2) = ZERO | |
29367 | EXCEVA(I) = ZERO | |
29368 | NINCWO(I) = 0 | |
29369 | NINCEV(I) = 0 | |
29370 | NRESTO(I) = 0 | |
29371 | NRESPR(I) = 0 | |
29372 | NRESNU(I) = 0 | |
29373 | NRESBA(I) = 0 | |
29374 | NRESPB(I) = 0 | |
29375 | NRESCH(I) = 0 | |
29376 | NRESEV(I) = 0 | |
29377 | NRESEV(I+2) = 0 | |
29378 | NEVAGA(I) = 0 | |
29379 | NEVAHT(I) = 0 | |
29380 | NEVAFI(1,I) = 0 | |
29381 | NEVAFI(2,I) = 0 | |
29382 | DO 12 J=1,6 | |
29383 | IF (J.LE.2) NINCHR(I,J) = 0 | |
29384 | IF (J.LE.3) NINCCO(I,J) = 0 | |
29385 | IF (J.LE.4) NINCST(I,J) = 0 | |
29386 | NEVA(I,J) = 0 | |
29387 | 12 CONTINUE | |
29388 | DO 13 J=1,210 | |
29389 | NEVAHY(1,I,J) = 0 | |
29390 | NEVAHY(2,I,J) = 0 | |
29391 | 13 CONTINUE | |
29392 | 11 CONTINUE | |
29393 | MAXGEN = 0 | |
29394 | **dble Po statistics. | |
29395 | KPOPO = 0 | |
29396 | ||
29397 | RETURN | |
29398 | *------------------------------------------------------------------ | |
29399 | * filling of histogram with event-record | |
29400 | 2 CONTINUE | |
29401 | IF (IST.EQ.-1) THEN | |
29402 | IF (.NOT.LFRAG) THEN | |
29403 | IF (IDPDG.EQ.2212) THEN | |
29404 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 | |
29405 | ELSEIF (IDPDG.EQ.2112) THEN | |
29406 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 | |
29407 | ELSEIF (IDPDG.EQ.22) THEN | |
29408 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 | |
29409 | ELSEIF (IDPDG.EQ.80000) THEN | |
29410 | IF (IDBJT.EQ.116) THEN | |
29411 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 | |
29412 | ELSEIF (IDBJT.EQ.117) THEN | |
29413 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 | |
29414 | ELSEIF (IDBJT.EQ.118) THEN | |
29415 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 | |
29416 | ELSEIF (IDBJT.EQ.119) THEN | |
29417 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 | |
29418 | ENDIF | |
29419 | ENDIF | |
29420 | ELSE | |
29421 | * heavy fragments (here: fission products only) | |
29422 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 | |
29423 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 | |
29424 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29425 | ENDIF | |
29426 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN | |
29427 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) | |
29428 | ENDIF | |
29429 | ||
29430 | RETURN | |
29431 | *------------------------------------------------------------------ | |
29432 | * output | |
29433 | 3 CONTINUE | |
29434 | ||
29435 | **dble Po statistics. | |
29436 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') | |
29437 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', | |
29438 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) | |
29439 | ||
29440 | * emulsion treatment | |
29441 | IF (NCOMPO.GT.0) THEN | |
29442 | WRITE(LOUT,3000) | |
29443 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, | |
29444 | & 22X,'----------------------------',/,/,19X, | |
29445 | & 'mass charge fraction',/,39X, | |
29446 | & 'input treated',/) | |
29447 | DO 30 I=1,NCOMPO | |
29448 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), | |
29449 | & EMUSAM(I)/DBLE(ICEVT) | |
29450 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) | |
29451 | 30 CONTINUE | |
29452 | ENDIF | |
29453 | ||
29454 | * i.n.c. statistics: output | |
29455 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC | |
29456 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, | |
29457 | & 22X,'---------------------------------',/,/,1X, | |
29458 | & 'no. of events for normalization: (accepted final events,', | |
29459 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, | |
29460 | & /,1X,'no. of rejected events due to intranuclear', | |
29461 | & ' cascade',15X,I6,/) | |
29462 | ICEV = MAX(ICEVT,1) | |
29463 | ICEV1 = ICEV | |
29464 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) | |
29465 | WRITE(LOUT,3002) | |
29466 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), | |
29467 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), | |
29468 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), | |
29469 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29470 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), | |
29471 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29472 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) | |
29473 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', | |
29474 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', | |
29475 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', | |
29476 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, | |
29477 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, | |
29478 | & /,1X,'maximum no. of generations treated (maximum allowed:' | |
29479 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', | |
29480 | & ' interactions in proj./ target (mean per evt1)', | |
29481 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', | |
29482 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', | |
29483 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', | |
29484 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) | |
29485 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, | |
29486 | & IREXCI(1)+IREXCI(2)+IREXCI(3) | |
29487 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', | |
29488 | & 'evaporation',/,22X,'-----------------------------', | |
29489 | & '------------',/,/,1X,'no. of events for normal.: ', | |
29490 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', | |
29491 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', | |
29492 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) | |
29493 | ||
29494 | WRITE(LOUT,3004) | |
29495 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) | |
29496 | ICEV = MAX(NRESEV(2),1) | |
29497 | WRITE(LOUT,3005) | |
29498 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), | |
29499 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), | |
29500 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), | |
29501 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), | |
29502 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), | |
29503 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), | |
29504 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), | |
29505 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) | |
29506 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, | |
29507 | & 'proj. / target',/,/,8X,'total number of particles',15X, | |
29508 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29509 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, | |
29510 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, | |
29511 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, | |
29512 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) | |
29513 | ||
29514 | * evaporation / fission / fragmentation statistics: output | |
29515 | ICEV = MAX(NRESEV(2),1) | |
29516 | ICEV1 = MAX(NRESEV(4),1) | |
29517 | NTEVA1 = | |
29518 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) | |
29519 | NTEVA2 = | |
29520 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) | |
29521 | IF (LEVPRT) THEN | |
29522 | IF (IFISS.EQ.1) CMSG(1) = 'requested ' | |
29523 | IF (LFRMBK) CMSG(2) = 'requested ' | |
29524 | IF (LDEEXG) CMSG(3) = 'requested ' | |
29525 | WRITE(LOUT,3006) | |
29526 | & CMSG, | |
29527 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), | |
29528 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), | |
29529 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), | |
29530 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), | |
29531 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), | |
29532 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), | |
29533 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), | |
29534 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), | |
29535 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) | |
29536 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', | |
29537 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', | |
29538 | & 'deexcitation:',2X,A13,/,/, | |
29539 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', | |
29540 | & 'proj. / target',/,/,8X,'total number of evap. particles', | |
29541 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29542 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, | |
29543 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, | |
29544 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, | |
29545 | & 'heavy fragments',25X,2F9.3,/) | |
29546 | IF (IFISS.EQ.1) THEN | |
29547 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), | |
29548 | & NEVAFI(2,1),NEVAFI(2,2), | |
29549 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, | |
29550 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 | |
29551 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ | |
29552 | & 12X,'out of which fission occured',8X,2I9,/, | |
29553 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) | |
29554 | ENDIF | |
29555 | C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN | |
29556 | C WRITE(LOUT,3008) | |
29557 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', | |
29558 | C & ' proj. / target',/) | |
29559 | C DO 31 I=1,210 | |
29560 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN | |
29561 | C WRITE(LOUT,3009) I, | |
29562 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29563 | C3009 FORMAT(38X,I3,3X,2E12.3) | |
29564 | C ENDIF | |
29565 | C 31 CONTINUE | |
29566 | C WRITE(LOUT,3010) | |
29567 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', | |
29568 | C & ' proj. / target',/) | |
29569 | C DO 32 I=1,210 | |
29570 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN | |
29571 | C WRITE(LOUT,3011) I, | |
29572 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29573 | C3011 FORMAT(38X,I3,3X,2E12.3) | |
29574 | C ENDIF | |
29575 | C 32 CONTINUE | |
29576 | C WRITE(LOUT,*) | |
29577 | C ENDIF | |
29578 | ELSE | |
29579 | WRITE(LOUT,3012) | |
29580 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, | |
29581 | & 'Evaporation: not requested',/) | |
29582 | ENDIF | |
29583 | ||
29584 | RETURN | |
29585 | *------------------------------------------------------------------ | |
29586 | * filling of histogram with event-record | |
29587 | 4 CONTINUE | |
29588 | * emulsion treatment | |
29589 | IF (NCOMPO.GT.0) THEN | |
29590 | DO 40 I=1,NCOMPO | |
29591 | IF (IT.EQ.IEMUMA(I)) THEN | |
29592 | EMUSAM(I) = EMUSAM(I)+ONE | |
29593 | ENDIF | |
29594 | 40 CONTINUE | |
29595 | ENDIF | |
29596 | NINCGE = NINCGE+MAXGEN | |
29597 | MAXGEN = 0 | |
29598 | **dble Po statistics. | |
29599 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 | |
29600 | ||
29601 | RETURN | |
29602 | *------------------------------------------------------------------ | |
29603 | * filling of histogram with event-record | |
29604 | 5 CONTINUE | |
29605 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN | |
29606 | IB = IIBAR(IDBAM(IDX)) | |
29607 | IC = IICH(IDBAM(IDX)) | |
29608 | J = ISTHKK(IDX)-14 | |
29609 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN | |
29610 | NINCST(J,1) = NINCST(J,1)+1 | |
29611 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN | |
29612 | NINCST(J,2) = NINCST(J,2)+1 | |
29613 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN | |
29614 | NINCST(J,3) = NINCST(J,3)+1 | |
29615 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN | |
29616 | NINCST(J,4) = NINCST(J,4)+1 | |
29617 | ENDIF | |
29618 | ELSEIF (ISTHKK(IDX).EQ.17) THEN | |
29619 | NINCWO(1) = NINCWO(1)+1 | |
29620 | ELSEIF (ISTHKK(IDX).EQ.18) THEN | |
29621 | NINCWO(2) = NINCWO(2)+1 | |
29622 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN | |
29623 | IB = IDRES(IDX) | |
29624 | IC = IDXRES(IDX) | |
29625 | IF (IC.GT.0) THEN | |
29626 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 | |
29627 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 | |
29628 | ENDIF | |
29629 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29630 | ENDIF | |
29631 | ||
29632 | RETURN | |
29633 | END | |
29634 | ||
29635 | *$ CREATE DT_NEWHGR.FOR | |
29636 | *COPY DT_NEWHGR | |
29637 | * | |
29638 | *===newhgr=============================================================* | |
29639 | * | |
29640 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) | |
29641 | ||
29642 | ************************************************************************ | |
29643 | * * | |
29644 | * Histogram initialization. * | |
29645 | * * | |
29646 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * | |
29647 | * XLIM3 bin size * | |
29648 | * IBIN > 0 number of bins in equidistant lin. binning * | |
29649 | * = -1 reset histograms * | |
29650 | * < -1 |IBIN| number of bins in equidistant log. * | |
29651 | * binning or log. binning in user def. struc. * | |
29652 | * XLIMB(*) user defined bin structure * | |
29653 | * * | |
29654 | * The bin structure is sensitive to * | |
29655 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * | |
29656 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * | |
29657 | * XLIMB, IBIN if XLIM3 < 0 * | |
29658 | * * | |
29659 | * * | |
29660 | * output: IREFN histogram index * | |
29661 | * (= -1 for inconsistent histogr. request) * | |
29662 | * * | |
29663 | * This subroutine is based on a original version by R. Engel. * | |
29664 | * This version dated 22.4.95 is written by S. Roesler. * | |
29665 | ************************************************************************ | |
29666 | ||
29667 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29668 | SAVE | |
29669 | PARAMETER ( LINP = 10 , | |
29670 | & LOUT = 6 , | |
29671 | & LDAT = 9 ) | |
29672 | ||
29673 | LOGICAL LSTART | |
29674 | ||
29675 | PARAMETER (ZERO = 0.0D0, | |
29676 | & TINY = 1.0D-10) | |
29677 | ||
29678 | DIMENSION XLIMB(*) | |
29679 | ||
29680 | * histograms | |
29681 | PARAMETER (NHIS=150, NDIM=250) | |
29682 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29683 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29684 | * auxiliary common for histograms | |
29685 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29686 | ||
29687 | DATA LSTART /.TRUE./ | |
29688 | ||
29689 | * reset histogram counter | |
29690 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN | |
29691 | IHISL = 0 | |
29692 | IF (IBIN.EQ.-1) RETURN | |
29693 | LSTART = .FALSE. | |
29694 | ENDIF | |
29695 | ||
29696 | IHIS = IHISL+1 | |
29697 | * check for maximum number of allowed histograms | |
29698 | IF (IHIS.GT.NHIS) THEN | |
29699 | WRITE(LOUT,1003) IHIS,NHIS,IHIS | |
29700 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', | |
29701 | & I4,') exceeds array size (',I4,')',/,21X, | |
29702 | & 'histogram',I3,' skipped!') | |
29703 | GOTO 9999 | |
29704 | ENDIF | |
29705 | ||
29706 | IREFN = IHIS | |
29707 | IBINS(IHIS) = ABS(IBIN) | |
29708 | * check requested number of bins | |
29709 | IF (IBINS(IHIS).GE.NDIM) THEN | |
29710 | WRITE(LOUT,1000) IBIN,NDIM,NDIM | |
29711 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', | |
29712 | & I3,') exceeds array size (',I3,')',/,21X, | |
29713 | & 'and will be reset to ',I3) | |
29714 | IBINS(IHIS) = NDIM | |
29715 | ENDIF | |
29716 | IF (IBINS(IHIS).EQ.0) THEN | |
29717 | WRITE(LOUT,1001) IBIN,IHIS | |
29718 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', | |
29719 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') | |
29720 | GOTO 9999 | |
29721 | ENDIF | |
29722 | ||
29723 | * initialize arrays | |
29724 | DO 1 I=1,NDIM | |
29725 | DO 2 K=1,3 | |
29726 | HIST(K,IHIS,I) = ZERO | |
29727 | HIST(K+3,IHIS,I) = ZERO | |
29728 | TMPHIS(K,IHIS,I) = ZERO | |
29729 | 2 CONTINUE | |
29730 | HIST(7,IHIS,I) = ZERO | |
29731 | 1 CONTINUE | |
29732 | DENTRY(1,IHIS)= ZERO | |
29733 | DENTRY(2,IHIS)= ZERO | |
29734 | OVERF(IHIS) = ZERO | |
29735 | UNDERF(IHIS) = ZERO | |
29736 | TMPUFL(IHIS) = ZERO | |
29737 | TMPOFL(IHIS) = ZERO | |
29738 | ||
29739 | * bin str. sensitive to lower edge, bin size, and numb. of bins | |
29740 | IF (XLIM3.GT.ZERO) THEN | |
29741 | DO 3 K=1,IBINS(IHIS)+1 | |
29742 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 | |
29743 | 3 CONTINUE | |
29744 | ISWI(IHIS) = 1 | |
29745 | * bin str. sensitive to lower/upper edge and numb. of bins | |
29746 | ELSEIF (XLIM3.EQ.ZERO) THEN | |
29747 | * linear binning | |
29748 | IF (IBIN.GT.0) THEN | |
29749 | XLOW = XLIM1 | |
29750 | XHI = XLIM2 | |
29751 | IF (XLIM2.LE.XLIM1) THEN | |
29752 | WRITE(LOUT,1002) XLIM1,XLIM2 | |
29753 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29754 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29755 | GOTO 9999 | |
29756 | ENDIF | |
29757 | ISWI(IHIS) = 1 | |
29758 | ELSEIF (IBIN.LT.-1) THEN | |
29759 | * logarithmic binning | |
29760 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN | |
29761 | WRITE(LOUT,1004) XLIM1,XLIM2 | |
29762 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', | |
29763 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29764 | GOTO 9999 | |
29765 | ENDIF | |
29766 | IF (XLIM2.LE.XLIM1) THEN | |
29767 | WRITE(LOUT,1005) XLIM1,XLIM2 | |
29768 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29769 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29770 | GOTO 9999 | |
29771 | ENDIF | |
29772 | XLOW = LOG10(XLIM1) | |
29773 | XHI = LOG10(XLIM2) | |
29774 | ISWI(IHIS) = 3 | |
29775 | ENDIF | |
29776 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) | |
29777 | DO 4 K=1,IBINS(IHIS)+1 | |
29778 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX | |
29779 | 4 CONTINUE | |
29780 | ELSE | |
29781 | * user defined bin structure | |
29782 | DO 5 K=1,IBINS(IHIS)+1 | |
29783 | IF (IBIN.GT.0) THEN | |
29784 | HIST(1,IHIS,K) = XLIMB(K) | |
29785 | ISWI(IHIS) = 2 | |
29786 | ELSEIF (IBIN.LT.-1) THEN | |
29787 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) | |
29788 | ISWI(IHIS) = 4 | |
29789 | ENDIF | |
29790 | 5 CONTINUE | |
29791 | ENDIF | |
29792 | ||
29793 | * histogram accepted | |
29794 | IHISL = IHIS | |
29795 | ||
29796 | RETURN | |
29797 | ||
29798 | 9999 CONTINUE | |
29799 | IREFN = -1 | |
29800 | RETURN | |
29801 | END | |
29802 | ||
29803 | *$ CREATE DT_FILHGR.FOR | |
29804 | *COPY DT_FILHGR | |
29805 | * | |
29806 | *===filhgr=============================================================* | |
29807 | * | |
29808 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) | |
29809 | ||
29810 | ************************************************************************ | |
29811 | * * | |
29812 | * Scoring for histogram IHIS. * | |
29813 | * * | |
29814 | * This subroutine is based on a original version by R. Engel. * | |
29815 | * This version dated 23.4.95 is written by S. Roesler. * | |
29816 | ************************************************************************ | |
29817 | ||
29818 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29819 | SAVE | |
29820 | PARAMETER ( LINP = 10 , | |
29821 | & LOUT = 6 , | |
29822 | & LDAT = 9 ) | |
29823 | ||
29824 | PARAMETER (ZERO = 0.0D0, | |
29825 | & ONE = 1.0D0, | |
29826 | & TINY = 1.0D-10) | |
29827 | ||
29828 | * histograms | |
29829 | PARAMETER (NHIS=150, NDIM=250) | |
29830 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29831 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29832 | * auxiliary common for histograms | |
29833 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29834 | ||
29835 | DATA NCEVT /1/ | |
29836 | ||
29837 | X = XI | |
29838 | Y = YI | |
29839 | ||
29840 | * dump content of temorary arrays into histograms | |
29841 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN | |
29842 | CALL DT_EVTHIS(IDUM) | |
29843 | NCEVT = NEVT | |
29844 | ENDIF | |
29845 | ||
29846 | * check histogram index | |
29847 | IF (IHIS.EQ.-1) RETURN | |
29848 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN | |
29849 | C WRITE(LOUT,1000) IHIS,IHISL | |
29850 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, | |
29851 | & ' out of range (1..',I3,')') | |
29852 | RETURN | |
29853 | ENDIF | |
29854 | ||
29855 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN | |
29856 | * bin structure not explicitly given | |
29857 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) | |
29858 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) | |
29859 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29860 | I1 = 0 | |
29861 | ELSE | |
29862 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 | |
29863 | ENDIF | |
29864 | ||
29865 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN | |
29866 | * user defined bin structure | |
29867 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) | |
29868 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29869 | I1 = 0 | |
29870 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN | |
29871 | I1 = IBINS(IHIS)+1 | |
29872 | ELSE | |
29873 | * binary sort algorithm | |
29874 | KMIN = 0 | |
29875 | KMAX = IBINS(IHIS)+1 | |
29876 | 1 CONTINUE | |
29877 | IF ((KMAX-KMIN).EQ.1) GOTO 2 | |
29878 | KK = (KMAX+KMIN)/2 | |
29879 | IF (X.LE.HIST(1,IHIS,KK)) THEN | |
29880 | KMAX=KK | |
29881 | ELSE | |
29882 | KMIN=KK | |
29883 | ENDIF | |
29884 | GOTO 1 | |
29885 | 2 CONTINUE | |
29886 | I1 = KMIN | |
29887 | ENDIF | |
29888 | ||
29889 | ELSE | |
29890 | WRITE(LOUT,1001) | |
29891 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') | |
29892 | RETURN | |
29893 | ENDIF | |
29894 | ||
29895 | * scoring | |
29896 | IF (I1.LE.0) THEN | |
29897 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE | |
29898 | ELSEIF (I1.LE.IBINS(IHIS)) THEN | |
29899 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE | |
29900 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
29901 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X | |
29902 | ELSE | |
29903 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X | |
29904 | ENDIF | |
29905 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y | |
29906 | ELSE | |
29907 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE | |
29908 | ENDIF | |
29909 | ||
29910 | RETURN | |
29911 | END | |
29912 | ||
29913 | *$ CREATE DT_EVTHIS.FOR | |
29914 | *COPY DT_EVTHIS | |
29915 | * | |
29916 | *===evthis=============================================================* | |
29917 | * | |
29918 | SUBROUTINE DT_EVTHIS(NEVT) | |
29919 | ||
29920 | ************************************************************************ | |
29921 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * | |
29922 | * is called after each event and for the last event before any call * | |
29923 | * to OUTHGR. * | |
29924 | * NEVT number of events dumped, this is only needed to * | |
29925 | * get the normalization after the last event * | |
29926 | * This version dated 23.4.95 is written by S. Roesler. * | |
29927 | ************************************************************************ | |
29928 | ||
29929 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29930 | SAVE | |
29931 | PARAMETER ( LINP = 10 , | |
29932 | & LOUT = 6 , | |
29933 | & LDAT = 9 ) | |
29934 | ||
29935 | LOGICAL LNOETY | |
29936 | ||
29937 | PARAMETER (ZERO = 0.0D0, | |
29938 | & ONE = 1.0D0, | |
29939 | & TINY = 1.0D-10) | |
29940 | ||
29941 | * histograms | |
29942 | PARAMETER (NHIS=150, NDIM=250) | |
29943 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29944 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29945 | * auxiliary common for histograms | |
29946 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29947 | ||
29948 | DATA NCEVT /0/ | |
29949 | ||
29950 | NCEVT = NCEVT+1 | |
29951 | NEVT = NCEVT | |
29952 | ||
29953 | DO 1 I=1,IHISL | |
29954 | LNOETY = .TRUE. | |
29955 | DO 2 J=1,IBINS(I) | |
29956 | IF (TMPHIS(1,I,J).GT.ZERO) THEN | |
29957 | LNOETY = .FALSE. | |
29958 | HIST(2,I,J) = HIST(2,I,J)+ONE | |
29959 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) | |
29960 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) | |
29961 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) | |
29962 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX | |
29963 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 | |
29964 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) | |
29965 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 | |
29966 | TMPHIS(1,I,J) = ZERO | |
29967 | TMPHIS(2,I,J) = ZERO | |
29968 | TMPHIS(3,I,J) = ZERO | |
29969 | ENDIF | |
29970 | 2 CONTINUE | |
29971 | IF (LNOETY) THEN | |
29972 | IF (TMPUFL(I).GT.ZERO) THEN | |
29973 | UNDERF(I) = UNDERF(I)+ONE | |
29974 | TMPUFL(I) = ZERO | |
29975 | ELSEIF (TMPOFL(I).GT.ZERO) THEN | |
29976 | OVERF(I) = OVERF(I)+ONE | |
29977 | TMPOFL(I) = ZERO | |
29978 | ENDIF | |
29979 | ELSE | |
29980 | DENTRY(1,I) = DENTRY(1,I)+ONE | |
29981 | ENDIF | |
29982 | 1 CONTINUE | |
29983 | ||
29984 | RETURN | |
29985 | END | |
29986 | ||
29987 | *$ CREATE DT_OUTHGR.FOR | |
29988 | *COPY DT_OUTHGR | |
29989 | * | |
29990 | *===outhgr=============================================================* | |
29991 | * | |
29992 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, | |
29993 | & ILOGY,INORM,NMODE) | |
29994 | ||
29995 | ************************************************************************ | |
29996 | * * | |
29997 | * Plot histogram(s) to standard output unit * | |
29998 | * * | |
29999 | * I1..6 indices of histograms to be plotted * | |
30000 | * CHEAD,IHEAD header string,integer * | |
30001 | * NEVTS number of events * | |
30002 | * FAC scaling factor * | |
30003 | * ILOGY = 1 logarithmic y-axis * | |
30004 | * INORM normalization * | |
30005 | * = 0 no further normalization (FAC is obsolete) * | |
30006 | * = 1 per event and bin width * | |
30007 | * = 2 per entry and bin width * | |
30008 | * = 3 per bin entry * | |
30009 | * = 4 per event and "bin width" x1^2...x2^2 * | |
30010 | * = 5 per event and "log. bin width" ln x1..ln x2 * | |
30011 | * = 6 per event * | |
30012 | * MODE = 0 no output but normalization applied * | |
30013 | * = 1 all valid histograms separately (small frame) * | |
30014 | * all valid histograms separately (small frame) * | |
30015 | * = -1 and tables as histograms * | |
30016 | * = 2 all valid histograms (one plot, wide frame) * | |
30017 | * all valid histograms (one plot, wide frame) * | |
30018 | * = -2 and tables as histograms * | |
30019 | * * | |
30020 | * * | |
30021 | * Note: All histograms to be plotted with one call to this * | |
30022 | * subroutine and |MODE|=2 must have the same bin structure! * | |
30023 | * There is no test included ensuring this fact. * | |
30024 | * * | |
30025 | * This version dated 23.4.95 is written by S. Roesler. * | |
30026 | ************************************************************************ | |
30027 | ||
30028 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30029 | SAVE | |
30030 | PARAMETER ( LINP = 10 , | |
30031 | & LOUT = 6 , | |
30032 | & LDAT = 9 ) | |
30033 | ||
30034 | CHARACTER*72 CHEAD | |
30035 | ||
30036 | PARAMETER (ZERO = 0.0D0, | |
30037 | & IZERO = 0, | |
30038 | & ONE = 1.0D0, | |
30039 | & TWO = 2.0D0, | |
30040 | & OHALF = 0.5D0, | |
30041 | & EPS = 1.0D-5, | |
30042 | & TINY = 1.0D-8, | |
30043 | & SMALL = -1.0D8, | |
30044 | & RLARGE = 1.0D8 ) | |
30045 | ||
30046 | * histograms | |
30047 | PARAMETER (NHIS=150, NDIM=250) | |
30048 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30049 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30050 | ||
30051 | PARAMETER (NDIM2 = 2*NDIM) | |
30052 | DIMENSION XX(NDIM2),YY(NDIM2) | |
30053 | ||
30054 | PARAMETER (NHISTO = 6) | |
30055 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), | |
30056 | & IDX(NHISTO) | |
30057 | ||
30058 | CHARACTER*43 CNORM(0:8) | |
30059 | DATA CNORM /'no further normalization ', | |
30060 | & 'per event and bin width ', | |
30061 | & 'per entry1 and bin width ', | |
30062 | & 'per bin entry ', | |
30063 | & 'per event and "bin width" x1^2...x2^2 ', | |
30064 | & 'per event and "log. bin width" ln x1..ln x2', | |
30065 | & 'per event ', | |
30066 | & 'per bin entry1 ', | |
30067 | & 'per entry2 and bin width '/ | |
30068 | ||
30069 | IDX1(1) = I1 | |
30070 | IDX1(2) = I2 | |
30071 | IDX1(3) = I3 | |
30072 | IDX1(4) = I4 | |
30073 | IDX1(5) = I5 | |
30074 | IDX1(6) = I6 | |
30075 | ||
30076 | MODE = NMODE | |
30077 | ||
30078 | * initialization if "wide frame" is requested | |
30079 | IF (ABS(MODE).EQ.2) THEN | |
30080 | DO 1 I=1,NHISTO | |
30081 | DO 2 J=1,NDIM | |
30082 | XX1(J,I) = ZERO | |
30083 | YY1(J,I) = ZERO | |
30084 | 2 CONTINUE | |
30085 | 1 CONTINUE | |
30086 | ENDIF | |
30087 | ||
30088 | * plot header | |
30089 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) | |
30090 | ||
30091 | * check histogram indices | |
30092 | NHI = 0 | |
30093 | DO 3 I=1,NHISTO | |
30094 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN | |
30095 | IF (ISWI(IDX1(I)).NE.0) THEN | |
30096 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN | |
30097 | WRITE(LOUT,1000) | |
30098 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) | |
30099 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', | |
30100 | & ' histogram ',I3,/,21X,'underflows:',F10.0, | |
30101 | & ' overflows: ',F10.0) | |
30102 | ELSE | |
30103 | NHI = NHI+1 | |
30104 | IDX(NHI) = IDX1(I) | |
30105 | ENDIF | |
30106 | ENDIF | |
30107 | ENDIF | |
30108 | 3 CONTINUE | |
30109 | IF (NHI.EQ.0) THEN | |
30110 | WRITE(LOUT,1001) | |
30111 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') | |
30112 | RETURN | |
30113 | ENDIF | |
30114 | ||
30115 | * check normalization request | |
30116 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. | |
30117 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. | |
30118 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. | |
30119 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN | |
30120 | WRITE(LOUT,1002) NEVTS,INORM,FAC | |
30121 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', | |
30122 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, | |
30123 | & 'FAC = ',E11.4) | |
30124 | RETURN | |
30125 | ENDIF | |
30126 | ||
30127 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS | |
30128 | ||
30129 | * apply normalization | |
30130 | DO 4 N=1,NHI | |
30131 | ||
30132 | I = IDX(N) | |
30133 | ||
30134 | IF (ISWI(I).EQ.1) THEN | |
30135 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30136 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, | |
30137 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30138 | ELSEIF (ISWI(I).EQ.2) THEN | |
30139 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30140 | WRITE(LOUT,1007) | |
30141 | 1007 FORMAT(1X,'user defined bin structure') | |
30142 | ELSEIF (ISWI(I).EQ.3) THEN | |
30143 | WRITE(LOUT,1004) | |
30144 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30145 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, | |
30146 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30147 | ELSEIF (ISWI(I).EQ.4) THEN | |
30148 | WRITE(LOUT,1004) | |
30149 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30150 | WRITE(LOUT,1007) | |
30151 | ELSE | |
30152 | WRITE(LOUT,1008) ISWI(I) | |
30153 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) | |
30154 | ENDIF | |
30155 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) | |
30156 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, | |
30157 | & ' overfl.:',F8.0) | |
30158 | WRITE(LOUT,1009) CNORM(INORM) | |
30159 | 1009 FORMAT(1X,'normalization: ',A,/) | |
30160 | ||
30161 | DO 5 K=1,IBINS(I) | |
30162 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) | |
30163 | YMEAN = FAC*YMEAN | |
30164 | YERR = FAC*YERR | |
30165 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30166 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30167 | 1006 FORMAT(1X,5E11.3) | |
30168 | * small frame | |
30169 | II = 2*K | |
30170 | XX(II-1) = HIST(1,I,K) | |
30171 | XX(II) = HIST(1,I,K+1) | |
30172 | YY(II-1) = YMEAN | |
30173 | YY(II) = YMEAN | |
30174 | * wide frame | |
30175 | XX1(K,N) = XMEAN | |
30176 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) | |
30177 | & XX1(K,N) = LOG10(XMEAN) | |
30178 | YY1(K,N) = YMEAN | |
30179 | 5 CONTINUE | |
30180 | ||
30181 | * plot small frame | |
30182 | IF (ABS(MODE).EQ.1) THEN | |
30183 | IBIN2 = 2*IBINS(I) | |
30184 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30185 | IF(ILOGY.EQ.1) THEN | |
30186 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30187 | ELSE | |
30188 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30189 | ENDIF | |
30190 | ENDIF | |
30191 | ||
30192 | 4 CONTINUE | |
30193 | ||
30194 | * plot wide frame | |
30195 | IF (ABS(MODE).EQ.2) THEN | |
30196 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30197 | NSIZE = NDIM*NHISTO | |
30198 | DXLOW = HIST(1,IDX(1),1) | |
30199 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) | |
30200 | YLOW = RLARGE | |
30201 | YHI = SMALL | |
30202 | DO 6 I=1,NHISTO | |
30203 | DO 7 J=1,NDIM | |
30204 | IF (YY1(J,I).LT.YLOW) THEN | |
30205 | IF (ILOGY.EQ.1) THEN | |
30206 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) | |
30207 | ELSE | |
30208 | YLOW = YY1(J,I) | |
30209 | ENDIF | |
30210 | ENDIF | |
30211 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) | |
30212 | 7 CONTINUE | |
30213 | 6 CONTINUE | |
30214 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30215 | IF (DY.LE.ZERO) THEN | |
30216 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') | |
30217 | & 'OUTHGR: warning! zero bin width for histograms ', | |
30218 | & IDX,': ',YLOW,YHI | |
30219 | RETURN | |
30220 | ENDIF | |
30221 | IF (ILOGY.EQ.1) THEN | |
30222 | YLOW = LOG10(YLOW) | |
30223 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30224 | DO 8 I=1,NHISTO | |
30225 | DO 9 J=1,NDIM | |
30226 | IF (YY1(J,I).LE.ZERO) THEN | |
30227 | YY1(J,I) = YLOW | |
30228 | ELSE | |
30229 | YY1(J,I) = LOG10(YY1(J,I)) | |
30230 | ENDIF | |
30231 | 9 CONTINUE | |
30232 | 8 CONTINUE | |
30233 | ENDIF | |
30234 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) | |
30235 | ENDIF | |
30236 | ||
30237 | RETURN | |
30238 | END | |
30239 | ||
30240 | *$ CREATE DT_GETBIN.FOR | |
30241 | *COPY DT_GETBIN | |
30242 | * | |
30243 | *===getbin=============================================================* | |
30244 | * | |
30245 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, | |
30246 | & XMEAN,YMEAN,YERR) | |
30247 | ||
30248 | ************************************************************************ | |
30249 | * This version dated 23.4.95 is written by S. Roesler. * | |
30250 | ************************************************************************ | |
30251 | ||
30252 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30253 | SAVE | |
30254 | PARAMETER ( LINP = 10 , | |
30255 | & LOUT = 6 , | |
30256 | & LDAT = 9 ) | |
30257 | ||
30258 | PARAMETER (ZERO = 0.0D0, | |
30259 | & ONE = 1.0D0, | |
30260 | & TINY35 = 1.0D-35) | |
30261 | ||
30262 | * histograms | |
30263 | PARAMETER (NHIS=150, NDIM=250) | |
30264 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30265 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30266 | ||
30267 | XLOW = HIST(1,IHIS,IBIN) | |
30268 | XHI = HIST(1,IHIS,IBIN+1) | |
30269 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
30270 | XLOW = 10**XLOW | |
30271 | XHI = 10**XHI | |
30272 | ENDIF | |
30273 | IF (NORM.EQ.2) THEN | |
30274 | DX = XHI-XLOW | |
30275 | NEVT = INT(DENTRY(1,IHIS)) | |
30276 | ELSEIF (NORM.EQ.3) THEN | |
30277 | DX = ONE | |
30278 | NEVT = INT(HIST(2,IHIS,IBIN)) | |
30279 | ELSEIF (NORM.EQ.4) THEN | |
30280 | DX = XHI**2-XLOW**2 | |
30281 | NEVT = KEVT | |
30282 | ELSEIF (NORM.EQ.5) THEN | |
30283 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) | |
30284 | NEVT = KEVT | |
30285 | ELSEIF (NORM.EQ.6) THEN | |
30286 | DX = ONE | |
30287 | NEVT = KEVT | |
30288 | ELSEIF (NORM.EQ.7) THEN | |
30289 | DX = ONE | |
30290 | NEVT = INT(HIST(7,IHIS,IBIN)) | |
30291 | ELSEIF (NORM.EQ.8) THEN | |
30292 | DX = XHI-XLOW | |
30293 | NEVT = INT(DENTRY(2,IHIS)) | |
30294 | ELSE | |
30295 | DX = ABS(XHI-XLOW) | |
30296 | NEVT = KEVT | |
30297 | ENDIF | |
30298 | IF (ABS(DX).LT.TINY35) DX = ONE | |
30299 | NEVT = MAX(NEVT,1) | |
30300 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) | |
30301 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) | |
30302 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) | |
30303 | YSUM = HIST(5,IHIS,IBIN) | |
30304 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE | |
30305 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) | |
30306 | XMEAN = HIST(3,IHIS,IBIN)/YSUM | |
30307 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW | |
30308 | ||
30309 | RETURN | |
30310 | END | |
30311 | ||
30312 | *$ CREATE DT_JOIHIS.FOR | |
30313 | *COPY DT_JOIHIS | |
30314 | * | |
30315 | *===joihis=============================================================* | |
30316 | * | |
30317 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) | |
30318 | ||
30319 | ************************************************************************ | |
30320 | * * | |
30321 | * Operation on histograms. * | |
30322 | * * | |
30323 | * input: IH1,IH2 histogram indices to be joined * | |
30324 | * COPER character defining the requested operation, * | |
30325 | * i.e. '+', '-', '*', '/' * | |
30326 | * FAC1,FAC2 factors for joining, i.e. * | |
30327 | * FAC1*histo1 COPER FAC2*histo2 * | |
30328 | * * | |
30329 | * This version dated 23.4.95 is written by S. Roesler. * | |
30330 | ************************************************************************ | |
30331 | ||
30332 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30333 | SAVE | |
30334 | PARAMETER ( LINP = 10 , | |
30335 | & LOUT = 6 , | |
30336 | & LDAT = 9 ) | |
30337 | ||
30338 | CHARACTER COPER*1 | |
30339 | ||
30340 | PARAMETER (ZERO = 0.0D0, | |
30341 | & ONE = 1.0D0, | |
30342 | & OHALF = 0.5D0, | |
30343 | & TINY8 = 1.0D-8, | |
30344 | & SMALL = -1.0D8, | |
30345 | & RLARGE = 1.0D8 ) | |
30346 | ||
30347 | * histograms | |
30348 | PARAMETER (NHIS=150, NDIM=250) | |
30349 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30350 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30351 | ||
30352 | PARAMETER (NDIM2 = 2*NDIM) | |
30353 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) | |
30354 | ||
30355 | CHARACTER*43 CNORM(0:6) | |
30356 | DATA CNORM /'no further normalization ', | |
30357 | & 'per event and bin width ', | |
30358 | & 'per entry and bin width ', | |
30359 | & 'per bin entry ', | |
30360 | & 'per event and "bin width" x1^2...x2^2 ', | |
30361 | & 'per event and "log. bin width" ln x1..ln x2', | |
30362 | & 'per event '/ | |
30363 | ||
30364 | * check histogram indices | |
30365 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. | |
30366 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN | |
30367 | WRITE(LOUT,1000) IH1,IH2,IHISL | |
30368 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', | |
30369 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) | |
30370 | GOTO 9999 | |
30371 | ENDIF | |
30372 | ||
30373 | * check bin structure of histograms to be joined | |
30374 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN | |
30375 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) | |
30376 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30377 | & ' and ',I3,' failed',/,21X, | |
30378 | & 'due to different numbers of bins (',I3,',',I3,')') | |
30379 | GOTO 9999 | |
30380 | ENDIF | |
30381 | DO 1 K=1,IBINS(IH1)+1 | |
30382 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN | |
30383 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) | |
30384 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30385 | & ' and ',I3,' failed at bin edge ',I3,/,21X, | |
30386 | & 'X1,X2 = ',2E11.4) | |
30387 | GOTO 9999 | |
30388 | ENDIF | |
30389 | 1 CONTINUE | |
30390 | ||
30391 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 | |
30392 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', | |
30393 | & 'operation ',A,/,11X,'and factors ',2E11.4) | |
30394 | WRITE(LOUT,1004) CNORM(NORM) | |
30395 | 1004 FORMAT(1X,'normalization: ',A,/) | |
30396 | ||
30397 | DO 2 K=1,IBINS(IH1) | |
30398 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) | |
30399 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) | |
30400 | XLOW = XLOW1 | |
30401 | XHI = XHI1 | |
30402 | XMEAN = OHALF*(XMEAN1+XMEAN2) | |
30403 | IF (COPER.EQ.'+') THEN | |
30404 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 | |
30405 | ELSEIF (COPER.EQ.'*') THEN | |
30406 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 | |
30407 | ELSEIF (COPER.EQ.'/') THEN | |
30408 | IF (YMEAN2.EQ.ZERO) THEN | |
30409 | YMEAN = ZERO | |
30410 | ELSE | |
30411 | IF (FAC2.EQ.ZERO) FAC2 = ONE | |
30412 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) | |
30413 | ENDIF | |
30414 | ELSE | |
30415 | GOTO 9998 | |
30416 | ENDIF | |
30417 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30418 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30419 | 1006 FORMAT(1X,5E11.3) | |
30420 | * small frame | |
30421 | II = 2*K | |
30422 | XX(II-1) = HIST(1,IH1,K) | |
30423 | XX(II) = HIST(1,IH1,K+1) | |
30424 | YY(II-1) = YMEAN | |
30425 | YY(II) = YMEAN | |
30426 | * wide frame | |
30427 | XX1(K) = XMEAN | |
30428 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) | |
30429 | YY1(K) = YMEAN | |
30430 | 2 CONTINUE | |
30431 | ||
30432 | * plot small frame | |
30433 | IF (ABS(MODE).EQ.1) THEN | |
30434 | IBIN2 = 2*IBINS(IH1) | |
30435 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30436 | IF(ILOGY.EQ.1) THEN | |
30437 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30438 | ELSE | |
30439 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30440 | ENDIF | |
30441 | ENDIF | |
30442 | ||
30443 | * plot wide frame | |
30444 | IF (ABS(MODE).EQ.2) THEN | |
30445 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30446 | NSIZE = NDIM | |
30447 | DXLOW = HIST(1,IH1,1) | |
30448 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) | |
30449 | YLOW = RLARGE | |
30450 | YHI = SMALL | |
30451 | DO 3 I=1,NDIM | |
30452 | IF (YY1(I).LT.YLOW) THEN | |
30453 | IF (ILOGY.EQ.1) THEN | |
30454 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) | |
30455 | ELSE | |
30456 | YLOW = YY1(I) | |
30457 | ENDIF | |
30458 | ENDIF | |
30459 | IF (YY1(I).GT.YHI) YHI = YY1(I) | |
30460 | 3 CONTINUE | |
30461 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30462 | IF (DY.LE.ZERO) THEN | |
30463 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') | |
30464 | & 'JOIHIS: warning! zero bin width for histograms ', | |
30465 | & IH1,IH2,': ',YLOW,YHI | |
30466 | RETURN | |
30467 | ENDIF | |
30468 | IF (ILOGY.EQ.1) THEN | |
30469 | YLOW = LOG10(YLOW) | |
30470 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30471 | DO 4 I=1,NDIM | |
30472 | IF (YY1(I).LE.ZERO) THEN | |
30473 | YY1(I) = YLOW | |
30474 | ELSE | |
30475 | YY1(I) = LOG10(YY1(I)) | |
30476 | ENDIF | |
30477 | 4 CONTINUE | |
30478 | ENDIF | |
30479 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) | |
30480 | ENDIF | |
30481 | ||
30482 | RETURN | |
30483 | ||
30484 | 9998 CONTINUE | |
30485 | WRITE(LOUT,1005) COPER | |
30486 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) | |
30487 | ||
30488 | 9999 CONTINUE | |
30489 | RETURN | |
30490 | END | |
30491 | ||
30492 | *$ CREATE DT_XGRAPH.FOR | |
30493 | *COPY DT_XGRAPH | |
30494 | * | |
30495 | *===qgraph=============================================================* | |
30496 | * | |
30497 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) | |
30498 | C*********************************************************************** | |
30499 | C | |
30500 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30501 | C ranges will be chosen automatically | |
30502 | C | |
30503 | C input N dimension of input fields | |
30504 | C IARG number of curves (fields) to plot | |
30505 | C X field of X | |
30506 | C Y1 field of Y1 | |
30507 | C Y2 field of Y2 | |
30508 | C | |
30509 | C This subroutine is written by R. Engel. | |
30510 | C*********************************************************************** | |
30511 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30512 | SAVE | |
30513 | ||
30514 | PARAMETER ( LINP = 10 , | |
30515 | & LOUT = 6 , | |
30516 | & LDAT = 9 ) | |
30517 | C | |
30518 | DIMENSION X(N),Y1(N),Y2(N) | |
30519 | PARAMETER (EPS=1.D-30) | |
30520 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30521 | CHARACTER SYMB(5) | |
30522 | CHARACTER COL(0:149,0:49) | |
30523 | C | |
30524 | DATA SYMB /'0','e','z','#','x'/ | |
30525 | C | |
30526 | ISPALT=IBREIT-10 | |
30527 | C | |
30528 | C*** automatic range fitting | |
30529 | C | |
30530 | XMAX=X(1) | |
30531 | XMIN=X(1) | |
30532 | DO 600 I=1,N | |
30533 | XMAX=MAX(X(I),XMAX) | |
30534 | XMIN=MIN(X(I),XMIN) | |
30535 | 600 CONTINUE | |
30536 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30537 | C | |
30538 | ITEST=0 | |
30539 | DO 1100 K=0,IZEIL-1 | |
30540 | ITEST=ITEST+1 | |
30541 | IF (ITEST.EQ.IYRAST) THEN | |
30542 | DO 1010 L=1,ISPALT-1 | |
30543 | COL(L,K)='-' | |
30544 | 1010 CONTINUE | |
30545 | COL(ISPALT,K)='+' | |
30546 | ITEST=0 | |
30547 | DO 1020 L=0,ISPALT-1,IXRAST | |
30548 | COL(L,K)='+' | |
30549 | 1020 CONTINUE | |
30550 | ELSE | |
30551 | DO 1030 L=1,ISPALT-1 | |
30552 | COL(L,K)=' ' | |
30553 | 1030 CONTINUE | |
30554 | DO 1040 L=0,ISPALT-1,IXRAST | |
30555 | COL(L,K)='|' | |
30556 | 1040 CONTINUE | |
30557 | COL(ISPALT,K)='|' | |
30558 | ENDIF | |
30559 | 1100 CONTINUE | |
30560 | C | |
30561 | C*** plot curve Y1 | |
30562 | C | |
30563 | YMAX=Y1(1) | |
30564 | YMIN=Y1(1) | |
30565 | DO 500 I=1,N | |
30566 | YMAX=MAX(Y1(I),YMAX) | |
30567 | YMIN=MIN(Y1(I),YMIN) | |
30568 | 500 CONTINUE | |
30569 | IF(IARG.GT.1) THEN | |
30570 | DO 550 I=1,N | |
30571 | YMAX=MAX(Y2(I),YMAX) | |
30572 | YMIN=MIN(Y2(I),YMIN) | |
30573 | 550 CONTINUE | |
30574 | ENDIF | |
30575 | YMAX=(YMAX-YMIN)/40.0D0+YMAX | |
30576 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 | |
30577 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) | |
30578 | IF(YZOOM.LT.EPS) THEN | |
30579 | WRITE(LOUT,'(1X,A)') | |
30580 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30581 | RETURN | |
30582 | ENDIF | |
30583 | C | |
30584 | C*** plot curve Y1 | |
30585 | C | |
30586 | ILAST=-1 | |
30587 | LLAST=-1 | |
30588 | DO 1200 K=1,N | |
30589 | L=NINT((X(K)-XMIN)/XZOOM) | |
30590 | I=NINT((YMAX-Y1(K))/YZOOM) | |
30591 | IF(ILAST.GE.0) THEN | |
30592 | LD = L-LLAST | |
30593 | ID = I-ILAST | |
30594 | DO 55 II=0,LD,SIGN(1,LD) | |
30595 | DO 66 KK=0,ID,SIGN(1,ID) | |
30596 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30597 | 66 CONTINUE | |
30598 | 55 CONTINUE | |
30599 | ELSE | |
30600 | COL(L,I)=SYMB(1) | |
30601 | ENDIF | |
30602 | ILAST = I | |
30603 | LLAST = L | |
30604 | 1200 CONTINUE | |
30605 | C | |
30606 | IF(IARG.GT.1) THEN | |
30607 | C | |
30608 | C*** plot curve Y2 | |
30609 | C | |
30610 | DO 1250 K=1,N | |
30611 | L=NINT((X(K)-XMIN)/XZOOM) | |
30612 | I=NINT((YMAX-Y2(K))/YZOOM) | |
30613 | COL(L,I)=SYMB(2) | |
30614 | 1250 CONTINUE | |
30615 | ENDIF | |
30616 | C | |
30617 | C*** write it | |
30618 | C | |
30619 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30620 | C | |
30621 | C*** write range of X | |
30622 | C | |
30623 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30624 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30625 | C | |
30626 | DO 1300 K=0,IZEIL-1 | |
30627 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) | |
30628 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30629 | 110 FORMAT(1X,1PE9.2,70A1) | |
30630 | 1300 CONTINUE | |
30631 | C | |
30632 | C*** write range of X | |
30633 | C | |
30634 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30635 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30636 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30637 | 120 FORMAT(6X,7(1PE10.3)) | |
30638 | END | |
30639 | ||
30640 | *$ CREATE DT_XGLOGY.FOR | |
30641 | *COPY DT_XGLOGY | |
30642 | * | |
30643 | *===qglogy=============================================================* | |
30644 | * | |
30645 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) | |
30646 | C*********************************************************************** | |
30647 | C | |
30648 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30649 | C logarithmic y axis | |
30650 | C ranges will be chosen automatically | |
30651 | C | |
30652 | C input N dimension of input fields | |
30653 | C IARG number of curves (fields) to plot | |
30654 | C X field of X | |
30655 | C Y1 field of Y1 | |
30656 | C Y2 field of Y2 | |
30657 | C | |
30658 | C This subroutine is written by R. Engel. | |
30659 | C*********************************************************************** | |
30660 | C | |
30661 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30662 | SAVE | |
30663 | ||
30664 | PARAMETER ( LINP = 10 , | |
30665 | & LOUT = 6 , | |
30666 | & LDAT = 9 ) | |
30667 | DIMENSION X(N),Y1(N),Y2(N) | |
30668 | PARAMETER (EPS=1.D-30) | |
30669 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30670 | CHARACTER SYMB(5) | |
30671 | CHARACTER COL(0:149,0:49) | |
30672 | PARAMETER (DEPS = 1.D-10) | |
30673 | C | |
30674 | DATA SYMB /'0','e','z','#','x'/ | |
30675 | C | |
30676 | ISPALT=IBREIT-10 | |
30677 | C | |
30678 | C*** automatic range fitting | |
30679 | C | |
30680 | XMAX=X(1) | |
30681 | XMIN=X(1) | |
30682 | DO 600 I=1,N | |
30683 | XMAX=MAX(X(I),XMAX) | |
30684 | XMIN=MIN(X(I),XMIN) | |
30685 | 600 CONTINUE | |
30686 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30687 | C | |
30688 | ITEST=0 | |
30689 | DO 1100 K=0,IZEIL-1 | |
30690 | ITEST=ITEST+1 | |
30691 | IF (ITEST.EQ.IYRAST) THEN | |
30692 | DO 1010 L=1,ISPALT-1 | |
30693 | COL(L,K)='-' | |
30694 | 1010 CONTINUE | |
30695 | COL(ISPALT,K)='+' | |
30696 | ITEST=0 | |
30697 | DO 1020 L=0,ISPALT-1,IXRAST | |
30698 | COL(L,K)='+' | |
30699 | 1020 CONTINUE | |
30700 | ELSE | |
30701 | DO 1030 L=1,ISPALT-1 | |
30702 | COL(L,K)=' ' | |
30703 | 1030 CONTINUE | |
30704 | DO 1040 L=0,ISPALT-1,IXRAST | |
30705 | COL(L,K)='|' | |
30706 | 1040 CONTINUE | |
30707 | COL(ISPALT,K)='|' | |
30708 | ENDIF | |
30709 | 1100 CONTINUE | |
30710 | C | |
30711 | C*** plot curve Y1 | |
30712 | C | |
30713 | YMAX=Y1(1) | |
30714 | YMIN=MAX(Y1(1),EPS) | |
30715 | DO 500 I=1,N | |
30716 | YMAX =MAX(Y1(I),YMAX) | |
30717 | IF(Y1(I).GT.EPS) THEN | |
30718 | IF(YMIN.EQ.EPS) THEN | |
30719 | YMIN = Y1(I)/10.D0 | |
30720 | ELSE | |
30721 | YMIN = MIN(Y1(I),YMIN) | |
30722 | ENDIF | |
30723 | ENDIF | |
30724 | 500 CONTINUE | |
30725 | IF(IARG.GT.1) THEN | |
30726 | DO 550 I=1,N | |
30727 | YMAX=MAX(Y2(I),YMAX) | |
30728 | IF(Y2(I).GT.EPS) THEN | |
30729 | IF(YMIN.EQ.EPS) THEN | |
30730 | YMIN = Y2(I) | |
30731 | ELSE | |
30732 | YMIN = MIN(Y2(I),YMIN) | |
30733 | ENDIF | |
30734 | ENDIF | |
30735 | 550 CONTINUE | |
30736 | ENDIF | |
30737 | C | |
30738 | DO 560 I=1,N | |
30739 | Y1(I) = MAX(Y1(I),YMIN) | |
30740 | 560 CONTINUE | |
30741 | IF(IARG.GT.1) THEN | |
30742 | DO 570 I=1,N | |
30743 | Y2(I) = MAX(Y2(I),YMIN) | |
30744 | 570 CONTINUE | |
30745 | ENDIF | |
30746 | C | |
30747 | IF(YMAX.LE.YMIN) THEN | |
30748 | WRITE(LOUT,'(/1X,A,2E12.3,/)') | |
30749 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX | |
30750 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' | |
30751 | RETURN | |
30752 | ENDIF | |
30753 | C | |
30754 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) | |
30755 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 | |
30756 | YZOOM=(YMA-YMI)/DBLE(IZEIL) | |
30757 | IF(YZOOM.LT.EPS) THEN | |
30758 | WRITE(LOUT,'(1X,A)') | |
30759 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30760 | RETURN | |
30761 | ENDIF | |
30762 | C | |
30763 | C*** plot curve Y1 | |
30764 | C | |
30765 | ILAST=-1 | |
30766 | LLAST=-1 | |
30767 | DO 1200 K=1,N | |
30768 | L=NINT((X(K)-XMIN)/XZOOM) | |
30769 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) | |
30770 | IF(ILAST.GE.0) THEN | |
30771 | LD = L-LLAST | |
30772 | ID = I-ILAST | |
30773 | DO 55 II=0,LD,SIGN(1,LD) | |
30774 | DO 66 KK=0,ID,SIGN(1,ID) | |
30775 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30776 | 66 CONTINUE | |
30777 | 55 CONTINUE | |
30778 | ELSE | |
30779 | COL(L,I)=SYMB(1) | |
30780 | ENDIF | |
30781 | ILAST = I | |
30782 | LLAST = L | |
30783 | 1200 CONTINUE | |
30784 | C | |
30785 | IF(IARG.GT.1) THEN | |
30786 | C | |
30787 | C*** plot curve Y2 | |
30788 | C | |
30789 | DO 1250 K=1,N | |
30790 | L=NINT((X(K)-XMIN)/XZOOM) | |
30791 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) | |
30792 | COL(L,I)=SYMB(2) | |
30793 | 1250 CONTINUE | |
30794 | ENDIF | |
30795 | C | |
30796 | C*** write it | |
30797 | C | |
30798 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' | |
30799 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30800 | C | |
30801 | C*** write range of X | |
30802 | C | |
30803 | XZOOM1 = (XMAX-XMIN)/DBLE(7) | |
30804 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30805 | C | |
30806 | DO 1300 K=0,IZEIL-1 | |
30807 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) | |
30808 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30809 | 110 FORMAT(1X,1PE9.2,70A1) | |
30810 | 1300 CONTINUE | |
30811 | C | |
30812 | C*** write range of X | |
30813 | C | |
30814 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30815 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30816 | 120 FORMAT(6X,7(1PE10.3)) | |
30817 | C | |
30818 | END | |
30819 | ||
30820 | *$ CREATE DT_SRPLOT.FOR | |
30821 | *COPY DT_SRPLOT | |
30822 | * | |
30823 | *===plot===============================================================* | |
30824 | * | |
30825 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) | |
30826 | ||
30827 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30828 | SAVE | |
30829 | ||
30830 | PARAMETER ( LINP = 10 , | |
30831 | & LOUT = 6 , | |
30832 | & LDAT = 9 ) | |
30833 | * | |
30834 | * initial version | |
30835 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) | |
30836 | * This is a subroutine of fluka to plot Y across the page | |
30837 | * as a function of X down the page. Up to 37 curves can be | |
30838 | * plotted in the same picture with different plotting characters. | |
30839 | * Output of first 10 overprinted characters addad by FB 88 | |
30840 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
30841 | * | |
30842 | * Input Variables: | |
30843 | * X = array containing the values of X | |
30844 | * Y = array containing the values of Y | |
30845 | * N = number of values in X and in Y | |
30846 | * can exceed the fixed number of lines | |
30847 | * M = number of different curves X,Y are containing | |
30848 | * MM = number of points in each curve i.e. N=M*MM | |
30849 | * XO = smallest value of X to be plotted | |
30850 | * DX = increment of X between subsequent lines | |
30851 | * YO = smallest value of Y to be plotted | |
30852 | * DY = increment of Y between subsequent character spaces | |
30853 | * | |
30854 | * other variables used inside: | |
30855 | * XX = numbers along the X-coordinate axis | |
30856 | * YY = numbers along the Y-coordinate axis | |
30857 | * LL = ten lines temporary storage for the plot | |
30858 | * L = character set used to plot different curves | |
30859 | * LOV = memorizes overprinted symbols | |
30860 | * the first 10 overprinted symbols are printed on | |
30861 | * the end of the line to avoid ambiguities | |
30862 | * (added by FB as considered quite helpful) | |
30863 | * | |
30864 | ********************************************************************* | |
30865 | * | |
30866 | DIMENSION XX(61),YY(61),LL(101,10) | |
30867 | DIMENSION X(N),Y(N),L(40),LOV(40,10) | |
333481d6 | 30868 | INTEGER*4 LL, L, LOV |
9aaba0d6 | 30869 | DATA L/ |
30870 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, | |
30871 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, | |
30872 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, | |
30873 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / | |
30874 | * | |
30875 | * | |
30876 | MN=51 | |
30877 | DO 10 I=1,MN | |
30878 | AI=I-1 | |
30879 | 10 XX(I)=XO+AI*DX | |
30880 | DO 20 I=1,11 | |
30881 | AI=I-1 | |
30882 | 20 YY(I)=YO+10.0D0*AI*DY | |
30883 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30884 | MMN=MN-1 | |
30885 | * | |
30886 | * | |
30887 | DO 90 JJ=1,MMN,10 | |
30888 | JJJ=JJ-1 | |
30889 | DO 30 I=1,101 | |
30890 | DO 30 J=1,10 | |
30891 | 30 LL(I,J)=L(40) | |
30892 | DO 40 I=1,101 | |
30893 | 40 LL(I,1)=L(39) | |
30894 | DO 50 I=1,101,10 | |
30895 | DO 50 J=1,10 | |
30896 | 50 LL(I,J)=L(38) | |
30897 | DO 60 I=1,40 | |
30898 | DO 60 J=1,10 | |
30899 | 60 LOV(I,J)=L(40) | |
30900 | * | |
30901 | * | |
30902 | DO 70 I=1,M | |
30903 | DO 70 J=1,MM | |
30904 | II=J+(I-1)*MM | |
30905 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 | |
30906 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 | |
30907 | AIX=AIX-DBLE(JJJ) | |
30908 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW | |
30909 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND | |
30910 | + . AIY .LT. 102.D0) THEN | |
30911 | IX=INT(AIX) | |
30912 | IY=INT(AIY) | |
30913 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) | |
30914 | + THEN | |
30915 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) | |
30916 | + =LL(IY,IX) | |
30917 | LL(IY,IX)=L(I) | |
30918 | ENDIF | |
30919 | ENDIF | |
30920 | 70 CONTINUE | |
30921 | * | |
30922 | * | |
30923 | DO 80 I=1,10 | |
30924 | II=I+JJJ | |
30925 | III=II+1 | |
30926 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , | |
30927 | & (LOV(J,I),J=1,10) | |
30928 | 80 CONTINUE | |
30929 | 90 CONTINUE | |
30930 | * | |
30931 | * | |
30932 | WRITE(LOUT, 520) | |
30933 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30934 | RETURN | |
30935 | * | |
30936 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) | |
30937 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) | |
30938 | 520 FORMAT(20X,10('1---------'),'1') | |
30939 | END | |
30940 | ||
30941 | *$ CREATE DT_DEFSET.FOR | |
30942 | *COPY DT_DEFSET | |
30943 | * | |
30944 | *===defset=============================================================* | |
30945 | * | |
30946 | BLOCK DATA DT_DEFSET | |
30947 | ||
30948 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30949 | SAVE | |
30950 | ||
30951 | * flags for input different options | |
30952 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
30953 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
30954 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
30955 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
30956 | * emulsion treatment | |
30957 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
30958 | & NCOMPO,IEMUL | |
30959 | ||
30960 | * / DTFLG1 / | |
30961 | DATA IFRAG / 2, 1 / | |
30962 | DATA IRESCO / 1 / | |
30963 | DATA IMSHL / 1 / | |
30964 | DATA IRESRJ / 0 / | |
30965 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / | |
30966 | DATA LEMCCK / .FALSE. / | |
30967 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., | |
30968 | & .TRUE.,.TRUE.,.TRUE./ | |
30969 | DATA LSEADI / .TRUE. / | |
30970 | DATA LEVAPO / .TRUE. / | |
30971 | DATA IFRAME / 1 / | |
30972 | DATA ITRSPT / 0 / | |
30973 | ||
30974 | * / DTCOMP / | |
30975 | DATA EMUFRA / NCOMPX*0.0D0 / | |
30976 | DATA IEMUMA / NCOMPX*1 / | |
30977 | DATA IEMUCH / NCOMPX*1 / | |
30978 | DATA NCOMPO / 0 / | |
30979 | DATA IEMUL / 0 / | |
30980 | ||
30981 | END | |
30982 | ||
30983 | *$ CREATE DT_HADPRP.FOR | |
30984 | *COPY DT_HADPRP | |
30985 | * | |
30986 | *===hadprp=============================================================* | |
30987 | * | |
30988 | BLOCK DATA DT_HADPRP | |
30989 | ||
30990 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30991 | SAVE | |
30992 | ||
30993 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
30994 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
30995 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
30996 | & IQTCHR(-6:6),MQUARK(3,39) | |
30997 | * hadron index conversion (BAMJET <--> PDG) | |
30998 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
30999 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
31000 | & IAMCIN(210) | |
31001 | * names of hadrons used in input-cards | |
31002 | CHARACTER*8 BTYPE | |
31003 | COMMON /DTPAIN/ BTYPE(30) | |
31004 | ||
31005 | * / DTQUAR / | |
31006 | *----------------------------------------------------------------------* | |
31007 | * * | |
31008 | * Quark content of particles: * | |
31009 | * index quark el. charge bar. charge isospin isospin3 * | |
31010 | * 1 = u 2/3 1/3 1/2 1/2 * | |
31011 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * | |
31012 | * 2 = d -1/3 1/3 1/2 -1/2 * | |
31013 | * -2 = dbar 1/3 -1/3 1/2 1/2 * | |
31014 | * 3 = s -1/3 1/3 0 0 * | |
31015 | * -3 = sbar 1/3 -1/3 0 0 * | |
31016 | * 4 = c 2/3 1/3 0 0 * | |
31017 | * -4 = cbar -2/3 -1/3 0 0 * | |
31018 | * 5 = b -1/3 1/3 0 0 * | |
31019 | * -5 = bbar 1/3 -1/3 0 0 * | |
31020 | * 6 = t 2/3 1/3 0 0 * | |
31021 | * -6 = tbar -2/3 -1/3 0 0 * | |
31022 | * * | |
31023 | * Mquark = particle quark composition (Paprop numbering) * | |
31024 | * Iqechr = electric charge ( in 1/3 unit ) * | |
31025 | * Iqbchr = baryonic charge ( in 1/3 unit ) * | |
31026 | * Iqichr = isospin ( in 1/2 unit ), z component * | |
31027 | * Iqschr = strangeness * | |
31028 | * Iqcchr = charm * | |
31029 | * Iquchr = beauty * | |
31030 | * Iqtchr = ...... * | |
31031 | * * | |
31032 | *----------------------------------------------------------------------* | |
31033 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / | |
31034 | DATA IQBCHR / 6*-1, 0, 6*1 / | |
31035 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / | |
31036 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / | |
31037 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / | |
31038 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / | |
31039 | DATA IQTCHR / -1, 11*0, 1 / | |
31040 | DATA MQUARK / | |
31041 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31042 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, | |
31043 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, | |
31044 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, | |
31045 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, | |
31046 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31047 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, | |
31048 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / | |
31049 | ||
31050 | * / DTHAIC / | |
31051 | * (renamed) (HAdron InDex COnversion) | |
31052 | * translation table version filled up by r.e. 25.01.94 * | |
31053 | DATA IAMCIN / | |
31054 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, | |
31055 | &13,130,211,-211,321, -321,3122,-3122,310,3112, | |
31056 | &3222,3212,111,311,-311, 0,0,0,0,0, | |
31057 | &221,213,113,-213,223, 323,313,-323,-313,10323, | |
31058 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, | |
31059 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, | |
31060 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, | |
31061 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, | |
31062 | &5*99999, 5*99999, | |
31063 | &4*99999,331, 333,3322,3312,-3222,-3212, | |
31064 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, | |
31065 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, | |
31066 | &-431,441,423,413,-413, -423,433,-433,20443,443, | |
31067 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, | |
31068 | &4212,4112,3*99999, 3*99999,-4122,-4232, | |
31069 | &-4132,-4222,-4212,-4112,99999, 5*99999, | |
31070 | &5*99999, 5*99999, | |
31071 | &10*99999, | |
31072 | &5*99999 , 20211,20111,-20211,99999,20321, | |
31073 | &-20321,20311,-20311,7*99999 , | |
31074 | &7*99999,12212,12112,99999/ | |
31075 | ||
31076 | * / DTHAIC / | |
31077 | * (HAdron InDex COnversion) | |
31078 | DATA (IPDG2(1,K),K=1,7) | |
31079 | & / -11, -12, -13, -15, -16, -14, 0/ | |
31080 | DATA (IBAM2(1,K),K=1,7) | |
31081 | & / 4, 6, 10, 131, 134, 136, 0/ | |
31082 | DATA (IPDG2(2,K),K=1,7) | |
31083 | & / 11, 12, 22, 13, 15, 16, 14/ | |
31084 | DATA (IBAM2(2,K),K=1,7) | |
31085 | & / 3, 5, 7, 11, 132, 133, 135/ | |
31086 | DATA (IPDG3(1,K),K=1,22) | |
31087 | & / -211, -321, -311, -213, -323, -313, -411, -421, | |
31088 | & -431, -413, -423, -433, 0, 0, 0, 0, | |
31089 | & 0, 0, 0, 0, 0, 0/ | |
31090 | DATA (IBAM3(1,K),K=1,22) | |
31091 | & / 14, 16, 25, 34, 38, 39, 118, 119, | |
31092 | & 121, 125, 126, 128, 0, 0, 0, 0, | |
31093 | & 0, 0, 0, 0, 0, 0/ | |
31094 | DATA (IPDG3(2,K),K=1,22) | |
31095 | & / 130, 211, 321, 310, 111, 311, 221, 213, | |
31096 | & 113, 223, 323, 313, 331, 333, 421, 411, | |
31097 | & 431, 441, 423, 413, 433, 443/ | |
31098 | DATA (IBAM3(2,K),K=1,22) | |
31099 | & / 12, 13, 15, 19, 23, 24, 31, 32, | |
31100 | & 33, 35, 36, 37, 95, 96, 116, 117, | |
31101 | & 120, 122, 123, 124, 127, 130/ | |
31102 | DATA (IPDG4(1,K),K=1,29) | |
31103 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, | |
31104 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, | |
31105 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, | |
31106 | & -4212, -4112, 0, 0, 0/ | |
31107 | DATA (IBAM4(1,K),K=1,29) | |
31108 | & / 2, 9, 18, 67, 68, 69, 70, 75, | |
31109 | & 76, 99, 100, 101, 102, 103, 110, 111, | |
31110 | & 112, 113, 114, 115, 149, 150, 151, 152, | |
31111 | & 153, 154, 0, 0, 0/ | |
31112 | DATA (IPDG4(2,K),K=1,29) | |
31113 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, | |
31114 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, | |
31115 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, | |
31116 | & 4232, 4132, 4222, 4212, 4112/ | |
31117 | DATA (IBAM4(2,K),K=1,29) | |
31118 | & / 1, 8, 17, 20, 21, 22, 48, 49, | |
31119 | & 50, 51, 52, 53, 54, 55, 56, 97, | |
31120 | & 98, 104, 105, 106, 107, 108, 109, 137, | |
31121 | & 138, 139, 140, 141, 142/ | |
31122 | DATA (IPDG5(1,K),K=1,19) | |
31123 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, | |
31124 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, | |
31125 | & 0, 0, 0/ | |
31126 | DATA (IBAM5(1,K),K=1,19) | |
31127 | & / 42, 43, 46, 47, 71, 72, 73, 74, | |
31128 | & 188, 191, 193, 0, 0, 0, 0, 0, | |
31129 | & 0, 0, 0/ | |
31130 | DATA (IPDG5(2,K),K=1,19) | |
31131 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, | |
31132 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, | |
31133 | & 20311, 12212, 12112/ | |
31134 | DATA (IBAM5(2,K),K=1,19) | |
31135 | & / 40, 41, 44, 45, 57, 58, 59, 60, | |
31136 | & 63, 64, 65, 66, 129, 186, 187, 190, | |
31137 | & 192, 208, 209/ | |
31138 | ||
31139 | * / DTPAIN / | |
31140 | * internal particle names | |
31141 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , | |
31142 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , | |
31143 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , | |
31144 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , | |
31145 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , | |
31146 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , | |
31147 | &'BLANK ' / | |
31148 | ||
31149 | END | |
31150 | ||
31151 | *$ CREATE DT_BLKD46.FOR | |
31152 | *COPY DT_BLKD46 | |
31153 | * | |
31154 | *===blkd46=============================================================* | |
31155 | * | |
31156 | BLOCK DATA DT_BLKD46 | |
31157 | ||
31158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31159 | SAVE | |
31160 | ||
31161 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31162 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31163 | ||
31164 | * particle properties (BAMJET index convention) | |
31165 | CHARACTER*8 ANAME | |
31166 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
31167 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
31168 | ||
31169 | * / DTPART / | |
31170 | * Particle masses Engel version JETSET compatible | |
31171 | C DATA (AAM(K),K=1,85) / | |
31172 | C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, | |
31173 | C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , | |
31174 | C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, | |
31175 | C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, | |
31176 | C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, | |
31177 | C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31178 | C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, | |
31179 | C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, | |
31180 | C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, | |
31181 | C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, | |
31182 | C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31183 | C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31184 | C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31185 | C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31186 | C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31187 | C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31188 | C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31189 | C DATA (AAM(K),K=86,183) / | |
31190 | C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31191 | C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, | |
31192 | C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, | |
31193 | C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, | |
31194 | C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, | |
31195 | C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, | |
31196 | C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, | |
31197 | C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, | |
31198 | C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, | |
31199 | C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, | |
31200 | C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, | |
31201 | C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, | |
31202 | C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, | |
31203 | C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, | |
31204 | C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31205 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31206 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31207 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31208 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31209 | C & .1250D+01, .1250D+01, .1250D+01 / | |
31210 | C DATA (AAM ( I ), I = 184,210 ) / | |
31211 | C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31212 | C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31213 | C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31214 | C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31215 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31216 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31217 | C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31218 | C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31219 | C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31220 | * sr 25.1.06: particle masses adjusted to Pythia | |
31221 | DATA (AAM(K),K=1,85) / | |
31222 | & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00, | |
31223 | & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON , | |
31224 | & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00, | |
31225 | & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01, | |
31226 | & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00, | |
31227 | & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00, | |
31228 | & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00, | |
31229 | & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01, | |
31230 | & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01, | |
31231 | & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01, | |
31232 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31233 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31234 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31235 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31236 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31237 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31238 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31239 | DATA (AAM(K),K=86,183) / | |
31240 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31241 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00, | |
31242 | & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01, | |
31243 | & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01, | |
31244 | & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01, | |
31245 | & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01, | |
31246 | & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01, | |
31247 | & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01, | |
31248 | & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01, | |
31249 | & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00, | |
31250 | & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01, | |
31251 | & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01, | |
31252 | & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01, | |
31253 | & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01, | |
31254 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31255 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31256 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31257 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31258 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31259 | & .1250D+01, .1250D+01, .1250D+01 / | |
31260 | DATA (AAM ( I ), I = 184,210 ) / | |
31261 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31262 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31263 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31264 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31265 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31266 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31267 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31268 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31269 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31270 | * Particle mean lives | |
31271 | DATA (TAU(K),K=1,183) / | |
31272 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, | |
31273 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, | |
31274 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, | |
31275 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, | |
31276 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, | |
31277 | & 70*.0000D+00, | |
31278 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, | |
31279 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, | |
31280 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, | |
31281 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, | |
31282 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31283 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31284 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31285 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, | |
31286 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31287 | & 40*.0000D+00, | |
31288 | & .0000D+00, .0000D+00, .0000D+00 / | |
31289 | DATA ( TAU ( I ), I = 184,210 ) / | |
31290 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31291 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31292 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31293 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31294 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31295 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31296 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31297 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31298 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ | |
31299 | * Resonance width Gamma in GeV | |
31300 | DATA (GA(K),K= 1,85) / | |
31301 | & 30*.0000D+00, | |
31302 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, | |
31303 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, | |
31304 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, | |
31305 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, | |
31306 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, | |
31307 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, | |
31308 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, | |
31309 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, | |
31310 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, | |
31311 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, | |
31312 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / | |
31313 | DATA (GA(K),K= 86,183) / | |
31314 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, | |
31315 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, | |
31316 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31317 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, | |
31318 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, | |
31319 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, | |
31320 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31321 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, | |
31322 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, | |
31323 | & 50*.0000D+00, | |
31324 | & .3000D+00, .3000D+00, .3000D+00 / | |
31325 | DATA ( GA ( I ), I = 184,210 ) / | |
31326 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, | |
31327 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, | |
31328 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, | |
31329 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, | |
31330 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31331 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31332 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, | |
31333 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, | |
31334 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ | |
31335 | * Particle names | |
31336 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) | |
31337 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on | |
31338 | * designation N*@@ means N*@1(@2) | |
31339 | DATA (ANAME(K),K=1,85) / | |
31340 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31341 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', | |
31342 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', | |
31343 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', | |
31344 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', | |
31345 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', | |
31346 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', | |
31347 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', | |
31348 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', | |
31349 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', | |
31350 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', | |
31351 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', | |
31352 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', | |
31353 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', | |
31354 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', | |
31355 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', | |
31356 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / | |
31357 | DATA (ANAME(K),K=86,183) / | |
31358 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', | |
31359 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', | |
31360 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', | |
31361 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', | |
31362 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', | |
31363 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', | |
31364 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', | |
31365 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', | |
31366 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', | |
31367 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', | |
31368 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', | |
31369 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', | |
31370 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', | |
31371 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', | |
31372 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', | |
31373 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', | |
31374 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', | |
31375 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', | |
31376 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', | |
31377 | & 'RO ','R+ ','R- ' / | |
31378 | DATA ( ANAME ( I ), I = 184,210 ) / | |
31379 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', | |
31380 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', | |
31381 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', | |
31382 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', | |
31383 | &'N*+14 ','N*014 ','BLANK '/ | |
31384 | * Charge of particles and resonances | |
31385 | DATA (IICH ( I ), I = 1,210 ) / | |
31386 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, | |
31387 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31388 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, | |
31389 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, | |
31390 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, | |
31391 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, | |
31392 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, | |
31393 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, | |
31394 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, | |
31395 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, | |
31396 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, | |
31397 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, | |
31398 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, | |
31399 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ | |
31400 | * Particle baryonic charges | |
31401 | DATA (IIBAR ( I ), I = 1,210 ) / | |
31402 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, | |
31403 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, | |
31404 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31405 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, | |
31406 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31407 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, | |
31408 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, | |
31409 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, | |
31410 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31411 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, | |
31412 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, | |
31413 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31414 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, | |
31415 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ | |
31416 | * First number of decay channels used for resonances | |
31417 | * and decaying particles | |
31418 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, | |
31419 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, | |
31420 | & 2*330, 46, 51, 52, 54, 55, 58, | |
31421 | * 50 | |
31422 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, | |
31423 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, | |
31424 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, | |
31425 | * 85 | |
31426 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, | |
31427 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, | |
31428 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, | |
31429 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, | |
31430 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, | |
31431 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, | |
31432 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, | |
31433 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, | |
31434 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, | |
31435 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, | |
31436 | & 590, 596, 602 / | |
31437 | * Last number of decay channels used for resonances | |
31438 | * and decaying particles | |
31439 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, | |
31440 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, | |
31441 | & 2* 330, 50, 51, 53, 54, 57, | |
31442 | * 50 | |
31443 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, | |
31444 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, | |
31445 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, | |
31446 | * 85 | |
31447 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, | |
31448 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, | |
31449 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, | |
31450 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, | |
31451 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, | |
31452 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, | |
31453 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, | |
31454 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, | |
31455 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, | |
31456 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, | |
31457 | & 589, 595, 601, 602 / | |
31458 | ||
31459 | END | |
31460 | ||
31461 | *$ CREATE DT_BLKD47.FOR | |
31462 | *COPY DT_BLKD47 | |
31463 | * | |
31464 | *===blkd47=============================================================* | |
31465 | * | |
31466 | BLOCK DATA DT_BLKD47 | |
31467 | ||
31468 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31469 | SAVE | |
31470 | ||
31471 | * HADRIN: decay channel information | |
31472 | PARAMETER (IDMAX9=602) | |
31473 | CHARACTER*8 ZKNAME | |
31474 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
31475 | ||
31476 | * Name of decay channel | |
31477 | * Designation N*@ means N*@1(1236) | |
31478 | * @1=# means ++, @1 = = means -- | |
31479 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively | |
31480 | DATA (ZKNAME(K),K= 1, 85) / | |
31481 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31482 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', | |
31483 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', | |
31484 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', | |
31485 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', | |
31486 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', | |
31487 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', | |
31488 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', | |
31489 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', | |
31490 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', | |
31491 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', | |
31492 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', | |
31493 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', | |
31494 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', | |
31495 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', | |
31496 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', | |
31497 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / | |
31498 | DATA (ZKNAME(K),K= 86,170) / | |
31499 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', | |
31500 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', | |
31501 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', | |
31502 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', | |
31503 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', | |
31504 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', | |
31505 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', | |
31506 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', | |
31507 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', | |
31508 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', | |
31509 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', | |
31510 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', | |
31511 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', | |
31512 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31513 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31514 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', | |
31515 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / | |
31516 | DATA (ZKNAME(K),K=171,255) / | |
31517 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', | |
31518 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', | |
31519 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31520 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31521 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', | |
31522 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', | |
31523 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', | |
31524 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', | |
31525 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', | |
31526 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', | |
31527 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', | |
31528 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', | |
31529 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', | |
31530 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', | |
31531 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', | |
31532 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', | |
31533 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / | |
31534 | DATA (ZKNAME(K),K=256,340) / | |
31535 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', | |
31536 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', | |
31537 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', | |
31538 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', | |
31539 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', | |
31540 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', | |
31541 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', | |
31542 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', | |
31543 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', | |
31544 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', | |
31545 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', | |
31546 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31547 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31548 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31549 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31550 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', | |
31551 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / | |
31552 | DATA (ZKNAME(K),K=341,425) / | |
31553 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', | |
31554 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', | |
31555 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', | |
31556 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', | |
31557 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', | |
31558 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', | |
31559 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', | |
31560 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', | |
31561 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', | |
31562 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', | |
31563 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', | |
31564 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', | |
31565 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', | |
31566 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', | |
31567 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', | |
31568 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', | |
31569 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / | |
31570 | DATA (ZKNAME(K),K=426,510) / | |
31571 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', | |
31572 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', | |
31573 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', | |
31574 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', | |
31575 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', | |
31576 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', | |
31577 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', | |
31578 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', | |
31579 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', | |
31580 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', | |
31581 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', | |
31582 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', | |
31583 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', | |
31584 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', | |
31585 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', | |
31586 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', | |
31587 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / | |
31588 | DATA (ZKNAME(K),K=511,540) / | |
31589 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', | |
31590 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', | |
31591 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', | |
31592 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', | |
31593 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', | |
31594 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / | |
31595 | DATA (ZKNAME(I),I=541,602)/ | |
31596 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', | |
31597 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', | |
31598 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', | |
31599 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', | |
31600 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', | |
31601 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', | |
31602 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', | |
31603 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', | |
31604 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ | |
31605 | * Weight of decay channel | |
31606 | DATA (WT(K),K= 1, 85) / | |
31607 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31608 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31609 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, | |
31610 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, | |
31611 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, | |
31612 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, | |
31613 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, | |
31614 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, | |
31615 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, | |
31616 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, | |
31617 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, | |
31618 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, | |
31619 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, | |
31620 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, | |
31621 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, | |
31622 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, | |
31623 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / | |
31624 | DATA (WT(K),K= 86,170) / | |
31625 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, | |
31626 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, | |
31627 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, | |
31628 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, | |
31629 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, | |
31630 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, | |
31631 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, | |
31632 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, | |
31633 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, | |
31634 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, | |
31635 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, | |
31636 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31637 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31638 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31639 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31640 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31641 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / | |
31642 | DATA (WT(K),K=171,255) / | |
31643 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, | |
31644 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, | |
31645 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, | |
31646 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, | |
31647 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, | |
31648 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, | |
31649 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, | |
31650 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, | |
31651 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31652 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31653 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31654 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31655 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31656 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, | |
31657 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, | |
31658 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, | |
31659 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / | |
31660 | DATA (WT(K),K=256,340) / | |
31661 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, | |
31662 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, | |
31663 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, | |
31664 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, | |
31665 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, | |
31666 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, | |
31667 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, | |
31668 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, | |
31669 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, | |
31670 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, | |
31671 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, | |
31672 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31673 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31674 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31675 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31676 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, | |
31677 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / | |
31678 | DATA (WT(K),K=341,425) / | |
31679 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, | |
31680 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, | |
31681 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, | |
31682 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, | |
31683 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, | |
31684 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, | |
31685 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, | |
31686 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, | |
31687 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, | |
31688 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, | |
31689 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, | |
31690 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, | |
31691 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, | |
31692 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, | |
31693 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, | |
31694 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, | |
31695 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / | |
31696 | DATA (WT(K),K=426,510) / | |
31697 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, | |
31698 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, | |
31699 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, | |
31700 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, | |
31701 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, | |
31702 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, | |
31703 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31704 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, | |
31705 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, | |
31706 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, | |
31707 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, | |
31708 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, | |
31709 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, | |
31710 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, | |
31711 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, | |
31712 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, | |
31713 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / | |
31714 | DATA (WT(K),K=511,540) / | |
31715 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31716 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, | |
31717 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31718 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31719 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, | |
31720 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / | |
31721 | C | |
31722 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, | |
31723 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, | |
31724 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, | |
31725 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, | |
31726 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, | |
31727 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, | |
31728 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / | |
31729 | * Particle numbers in decay channel | |
31730 | DATA (NZK(K,1),K= 1,170) / | |
31731 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, | |
31732 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, | |
31733 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, | |
31734 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, | |
31735 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, | |
31736 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, | |
31737 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, | |
31738 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, | |
31739 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, | |
31740 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, | |
31741 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, | |
31742 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, | |
31743 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, | |
31744 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, | |
31745 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, | |
31746 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31747 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / | |
31748 | DATA (NZK(K,1),K=171,340) / | |
31749 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, | |
31750 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31751 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, | |
31752 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, | |
31753 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, | |
31754 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, | |
31755 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, | |
31756 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, | |
31757 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, | |
31758 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, | |
31759 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, | |
31760 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, | |
31761 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, | |
31762 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, | |
31763 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31764 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31765 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / | |
31766 | DATA (NZK(K,1),K=341,510) / | |
31767 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, | |
31768 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, | |
31769 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, | |
31770 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, | |
31771 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, | |
31772 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, | |
31773 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, | |
31774 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, | |
31775 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, | |
31776 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, | |
31777 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, | |
31778 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, | |
31779 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, | |
31780 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, | |
31781 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, | |
31782 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, | |
31783 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / | |
31784 | DATA (NZK(K,1),K=511,540) / | |
31785 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, | |
31786 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, | |
31787 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / | |
31788 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, | |
31789 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, | |
31790 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, | |
31791 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, | |
31792 | & 55, 8, 1, 8, 8, 54, 55, 210/ | |
31793 | DATA (NZK(K,2),K= 1,170) / | |
31794 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, | |
31795 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, | |
31796 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, | |
31797 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, | |
31798 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, | |
31799 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, | |
31800 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, | |
31801 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, | |
31802 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, | |
31803 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, | |
31804 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, | |
31805 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, | |
31806 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, | |
31807 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, | |
31808 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, | |
31809 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31810 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / | |
31811 | DATA (NZK(K,2),K=171,340) / | |
31812 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, | |
31813 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31814 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, | |
31815 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, | |
31816 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, | |
31817 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, | |
31818 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, | |
31819 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, | |
31820 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, | |
31821 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, | |
31822 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, | |
31823 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, | |
31824 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, | |
31825 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, | |
31826 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31827 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31828 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / | |
31829 | DATA (NZK(K,2),K=341,510) / | |
31830 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, | |
31831 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, | |
31832 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, | |
31833 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, | |
31834 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, | |
31835 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, | |
31836 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, | |
31837 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, | |
31838 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, | |
31839 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, | |
31840 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, | |
31841 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, | |
31842 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, | |
31843 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, | |
31844 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, | |
31845 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, | |
31846 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / | |
31847 | DATA (NZK(K,2),K=511,540) / | |
31848 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, | |
31849 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, | |
31850 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / | |
31851 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, | |
31852 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, | |
31853 | & 14, 14, 23, 14, 16, 25, | |
31854 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, | |
31855 | & 23, 13, 14, 23, 0 / | |
31856 | DATA (NZK(K,3),K= 1,170) / | |
31857 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, | |
31858 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, | |
31859 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, | |
31860 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, | |
31861 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, | |
31862 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, | |
31863 | & 110*0 / | |
31864 | DATA (NZK(K,3),K=171,340) / | |
31865 | & 80*0, | |
31866 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, | |
31867 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, | |
31868 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, | |
31869 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, | |
31870 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, | |
31871 | & 30*0, | |
31872 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / | |
31873 | DATA (NZK(K,3),K=341,510) / | |
31874 | & 30*0, | |
31875 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, | |
31876 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, | |
31877 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, | |
31878 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31879 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, | |
31880 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, | |
31881 | & 80*0 / | |
31882 | DATA (NZK(K,3),K=511,540) / | |
31883 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, | |
31884 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31885 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / | |
31886 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, | |
31887 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ | |
31888 | ||
31889 | END | |
31890 | ||
31891 | *$ CREATE DT_BDEVAP.FOR | |
31892 | *COPY DT_BDEVAP | |
31893 | * | |
31894 | *=== bdevap ===========================================================* | |
31895 | * | |
31896 | BLOCK DATA DT_BDEVAP | |
31897 | ||
31898 | C INCLUDE '(DBLPRC)' | |
31899 | * DBLPRC.ADD | |
31900 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31901 | SAVE | |
31902 | * (original name: GLOBAL) | |
31903 | PARAMETER ( KALGNM = 2 ) | |
31904 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
31905 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
31906 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
31907 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
31908 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
31909 | PARAMETER ( AINFNT = 1.0D+30 ) | |
31910 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
31911 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
31912 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
31913 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
31914 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
31915 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
31916 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
31917 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
31918 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
31919 | PARAMETER ( ZERZER = 0.D+00 ) | |
31920 | PARAMETER ( ONEONE = 1.D+00 ) | |
31921 | PARAMETER ( TWOTWO = 2.D+00 ) | |
31922 | PARAMETER ( THRTHR = 3.D+00 ) | |
31923 | PARAMETER ( FOUFOU = 4.D+00 ) | |
31924 | PARAMETER ( FIVFIV = 5.D+00 ) | |
31925 | PARAMETER ( SIXSIX = 6.D+00 ) | |
31926 | PARAMETER ( SEVSEV = 7.D+00 ) | |
31927 | PARAMETER ( EIGEIG = 8.D+00 ) | |
31928 | PARAMETER ( ANINEN = 9.D+00 ) | |
31929 | PARAMETER ( TENTEN = 10.D+00 ) | |
31930 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
31931 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
31932 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
31933 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
31934 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
31935 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
31936 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
31937 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
31938 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
31939 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
31940 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
31941 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
31942 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
31943 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
31944 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
31945 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
31946 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
31947 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
31948 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
31949 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
31950 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
31951 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
31952 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
31953 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
31954 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
31955 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
31956 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
31957 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
31958 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
31959 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
31960 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
31961 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
31962 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
31963 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
31964 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
31965 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
31966 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
31967 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
31968 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
31969 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
31970 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31971 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
31972 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31973 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
31974 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
31975 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
31976 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
31977 | & * 1.D-09 ) | |
31978 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
31979 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
31980 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
31981 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
31982 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
31983 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
31984 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
31985 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
31986 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
31987 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
31988 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
31989 | LOGICAL LGBIAS, LGBANA | |
31990 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
31991 | C INCLUDE '(DIMPAR)' | |
31992 | * DIMPAR.ADD | |
31993 | PARAMETER ( MXXRGN = 5000 ) | |
31994 | PARAMETER ( MXXMDF = 82 ) | |
31995 | PARAMETER ( MXXMDE = 54 ) | |
31996 | PARAMETER ( MFSTCK = 1000 ) | |
31997 | PARAMETER ( MESTCK = 100 ) | |
31998 | PARAMETER ( NELEMX = 80 ) | |
31999 | PARAMETER ( MPDPDX = 8 ) | |
32000 | PARAMETER ( ICOMAX = 180 ) | |
32001 | PARAMETER ( NSTBIS = 304 ) | |
32002 | PARAMETER ( IDMAXP = 220 ) | |
32003 | PARAMETER ( IDMXDC = 640 ) | |
32004 | PARAMETER ( MKBMX1 = 1 ) | |
32005 | PARAMETER ( MKBMX2 = 1 ) | |
32006 | C INCLUDE '(IOUNIT)' | |
32007 | * IOUNIT.ADD | |
32008 | PARAMETER ( LUNIN = 5 ) | |
32009 | PARAMETER ( LUNOUT = 6 ) | |
32010 | **sr 19.5. set error output-unit from 15 to 6 | |
32011 | PARAMETER ( LUNERR = 6 ) | |
32012 | PARAMETER ( LUNBER = 14 ) | |
32013 | PARAMETER ( LUNECH = 8 ) | |
32014 | PARAMETER ( LUNFLU = 13 ) | |
32015 | PARAMETER ( LUNGEO = 16 ) | |
32016 | PARAMETER ( LUNPMF = 12 ) | |
32017 | PARAMETER ( LUNRAN = 2 ) | |
32018 | PARAMETER ( LUNXSC = 9 ) | |
32019 | PARAMETER ( LUNDET = 17 ) | |
32020 | PARAMETER ( LUNRAY = 10 ) | |
32021 | PARAMETER ( LUNRDB = 1 ) | |
32022 | PARAMETER ( LUNPGO = 7 ) | |
32023 | PARAMETER ( LUNPGS = 4 ) | |
32024 | PARAMETER ( LUNSCR = 3 ) | |
32025 | * | |
32026 | *----------------------------------------------------------------------* | |
32027 | * * | |
32028 | * Block Data for the EVAPoration routines: * | |
32029 | * * | |
32030 | * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala * | |
32031 | * Infn - Milan * | |
32032 | * * | |
32033 | * Modified from the original version of J.M.Zazula * | |
32034 | * and, for cookcm, from a LAHET block data kindly provided by * | |
32035 | * R.E.Prael-LANL * | |
32036 | * * | |
32037 | * Last change on 20-feb-95 by Alfredo Ferrari * | |
32038 | * * | |
32039 | * * | |
32040 | *----------------------------------------------------------------------* | |
32041 | * | |
32042 | * (original name: COOKCM) | |
32043 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
32044 | LOGICAL LDEFOZ, LDEFON | |
32045 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
32046 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
32047 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
32048 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
32049 | * (original name: EVA0) | |
32050 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
32051 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
32052 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
32053 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
32054 | * APRIME (250), IA (6), IZ (6) | |
32055 | * (original name: HETTP) | |
32056 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
32057 | * (original name: HETC7) | |
32058 | COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI | |
32059 | * (original name: INPFLG) | |
32060 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
32061 | * | |
32062 | DATA B0 / 8.D+00 /, Y0 / 1.5D+00 / | |
32063 | DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 / | |
32064 | DATA ISTRAG /0/, KEYDK /0/ | |
32065 | DATA NBERTP /LUNBER/ | |
32066 | DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/, | |
32067 | & SINPHI/ZERZER/ | |
32068 | * /cookcm/ | |
32069 | DATA ( PZCOOK(I),I = 1, IZCOOK ) / | |
32070 | & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00, | |
32071 | & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00, | |
32072 | & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00, | |
32073 | & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00, | |
32074 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01, | |
32075 | & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00, | |
32076 | & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00, | |
32077 | & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00, | |
32078 | & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00, | |
32079 | & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00, | |
32080 | &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01, | |
32081 | & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01, | |
32082 | & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01, | |
32083 | & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01, | |
32084 | & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01, | |
32085 | &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01, | |
32086 | & 0.000D+00, 7.700D-01/ | |
32087 | DATA ( PNCOOK(I),I = 1, 90 ) / | |
32088 | & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00, | |
32089 | & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00, | |
32090 | & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00, | |
32091 | & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00, | |
32092 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00, | |
32093 | & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00, | |
32094 | &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00, | |
32095 | & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00, | |
32096 | & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00, | |
32097 | & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00, | |
32098 | &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00, | |
32099 | &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00, | |
32100 | &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01, | |
32101 | &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00, | |
32102 | &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/ | |
32103 | DATA ( PNCOOK(I),I = 91, INCOOK ) / | |
32104 | &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01, | |
32105 | &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00, | |
32106 | & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01, | |
32107 | & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00, | |
32108 | &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01, | |
32109 | & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01, | |
32110 | & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01, | |
32111 | & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01, | |
32112 | & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01, | |
32113 | & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/ | |
32114 | DATA ( SZCOOK(I),I = 1, 98) / | |
32115 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32116 | & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00, | |
32117 | &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01, | |
32118 | &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01, | |
32119 | &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01, | |
32120 | &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01, | |
32121 | &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01, | |
32122 | &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01, | |
32123 | &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01, | |
32124 | &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01, | |
32125 | &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00, | |
32126 | &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00, | |
32127 | &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00, | |
32128 | &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00, | |
32129 | &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00, | |
32130 | &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00, | |
32131 | &-7.200D+00,-7.740D+00/ | |
32132 | DATA ( SNCOOK(I),I = 1, 90 ) / | |
32133 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32134 | & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00, | |
32135 | & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00, | |
32136 | & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01, | |
32137 | & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01, | |
32138 | & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01, | |
32139 | & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01, | |
32140 | & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01, | |
32141 | & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01, | |
32142 | & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01, | |
32143 | & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01, | |
32144 | & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01, | |
32145 | & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01, | |
32146 | & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00, | |
32147 | & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/ | |
32148 | DATA ( SNCOOK(I),I = 91, INCOOK ) / | |
32149 | & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01, | |
32150 | & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00, | |
32151 | & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00, | |
32152 | & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00, | |
32153 | & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00, | |
32154 | & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00, | |
32155 | &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00, | |
32156 | & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00, | |
32157 | & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00, | |
32158 | & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/ | |
32159 | DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. / | |
32160 | DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. / | |
32161 | *=== End of Block Data Bdevap =========================================* | |
32162 | END | |
32163 | ||
32164 | *$ CREATE DT_BDNOPT.FOR | |
32165 | *COPY DT_BDNOPT | |
32166 | * | |
32167 | *=== bdnopt ===========================================================* | |
32168 | *== * | |
32169 | BLOCK DATA DT_BDNOPT | |
32170 | ||
32171 | C INCLUDE '(DBLPRC)' | |
32172 | * DBLPRC.ADD | |
32173 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32174 | SAVE | |
32175 | * (original name: GLOBAL) | |
32176 | PARAMETER ( KALGNM = 2 ) | |
32177 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32178 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32179 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32180 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32181 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32182 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32183 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32184 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32185 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32186 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32187 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32188 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32189 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32190 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32191 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32192 | PARAMETER ( ZERZER = 0.D+00 ) | |
32193 | PARAMETER ( ONEONE = 1.D+00 ) | |
32194 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32195 | PARAMETER ( THRTHR = 3.D+00 ) | |
32196 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32197 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32198 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32199 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32200 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32201 | PARAMETER ( ANINEN = 9.D+00 ) | |
32202 | PARAMETER ( TENTEN = 10.D+00 ) | |
32203 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32204 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32205 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32206 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32207 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32208 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32209 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32210 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32211 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32212 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32213 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32214 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32215 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32216 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32217 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32218 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32219 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32220 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32221 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32222 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32223 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32224 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32225 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32226 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32227 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32228 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32229 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32230 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32231 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32232 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32233 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32234 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32235 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32236 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32237 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32238 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32239 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32240 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32241 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32242 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32243 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32244 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32245 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32246 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32247 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32248 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32249 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32250 | & * 1.D-09 ) | |
32251 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32252 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32253 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32254 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32255 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32256 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32257 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32258 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32259 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32260 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32261 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32262 | LOGICAL LGBIAS, LGBANA | |
32263 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32264 | C INCLUDE '(DIMPAR)' | |
32265 | * DIMPAR.ADD | |
32266 | PARAMETER ( MXXRGN = 5000 ) | |
32267 | PARAMETER ( MXXMDF = 82 ) | |
32268 | PARAMETER ( MXXMDE = 54 ) | |
32269 | PARAMETER ( MFSTCK = 1000 ) | |
32270 | PARAMETER ( MESTCK = 100 ) | |
32271 | PARAMETER ( NELEMX = 80 ) | |
32272 | PARAMETER ( MPDPDX = 8 ) | |
32273 | PARAMETER ( ICOMAX = 180 ) | |
32274 | PARAMETER ( NSTBIS = 304 ) | |
32275 | PARAMETER ( IDMAXP = 220 ) | |
32276 | PARAMETER ( IDMXDC = 640 ) | |
32277 | PARAMETER ( MKBMX1 = 1 ) | |
32278 | PARAMETER ( MKBMX2 = 1 ) | |
32279 | C INCLUDE '(IOUNIT)' | |
32280 | * IOUNIT.ADD | |
32281 | PARAMETER ( LUNIN = 5 ) | |
32282 | PARAMETER ( LUNOUT = 6 ) | |
32283 | **sr 19.5. set error output-unit from 15 to 6 | |
32284 | PARAMETER ( LUNERR = 6 ) | |
32285 | PARAMETER ( LUNBER = 14 ) | |
32286 | PARAMETER ( LUNECH = 8 ) | |
32287 | PARAMETER ( LUNFLU = 13 ) | |
32288 | PARAMETER ( LUNGEO = 16 ) | |
32289 | PARAMETER ( LUNPMF = 12 ) | |
32290 | PARAMETER ( LUNRAN = 2 ) | |
32291 | PARAMETER ( LUNXSC = 9 ) | |
32292 | PARAMETER ( LUNDET = 17 ) | |
32293 | PARAMETER ( LUNRAY = 10 ) | |
32294 | PARAMETER ( LUNRDB = 1 ) | |
32295 | PARAMETER ( LUNPGO = 7 ) | |
32296 | PARAMETER ( LUNPGS = 4 ) | |
32297 | PARAMETER ( LUNSCR = 3 ) | |
32298 | * | |
32299 | *----------------------------------------------------------------------* | |
32300 | * * | |
32301 | * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan * | |
32302 | * * | |
32303 | * Last change on 20-apr-95 by Alfredo Ferrari * | |
32304 | * * | |
32305 | *----------------------------------------------------------------------* | |
32306 | * | |
32307 | C INCLUDE '(BLNKCM)' | |
32308 | * BLNKCM.ADD | |
32309 | **sr 17.5. commented since not used here | |
32310 | C PARAMETER ( NBLNMX = 1100000 ) | |
32311 | C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ), | |
32312 | C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ), | |
32313 | C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX ) | |
32314 | C REAL SIGGTT | |
32315 | C LOGICAL LBSTOR | |
32316 | C COMMON NSTOR ( KALGNM*NBLNMX ) | |
32317 | ** | |
32318 | **sr 18.5. commented since not used for evap. | |
32319 | C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, | |
32320 | C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST, | |
32321 | C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST, | |
32322 | C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST, | |
32323 | C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST, | |
32324 | C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32325 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, | |
32326 | C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, | |
32327 | C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST, | |
32328 | C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST, | |
32329 | C & KTMBGN | |
32330 | ** | |
32331 | ||
32332 | C EQUIVALENCE ( NSTOR (1), GMSTOR (1) ) | |
32333 | C EQUIVALENCE ( NSTOR (1), BRMBRR (1) ) | |
32334 | C EQUIVALENCE ( NSTOR (1), BRMEXP (1) ) | |
32335 | C EQUIVALENCE ( NSTOR (1), BRMSIG (1) ) | |
32336 | C EQUIVALENCE ( NSTOR (1), COMSCO (1) ) | |
32337 | C EQUIVALENCE ( NSTOR (1), SIGGTT (1) ) | |
32338 | C EQUIVALENCE ( NSTOR (1), LBSTOR (1) ) | |
32339 | C INCLUDE '(BLNTMP)' | |
32340 | * BLNTMP.ADD | |
32341 | **sr 18.5. commented since not used for evap. | |
32342 | C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, | |
32343 | C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM, | |
32344 | C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM, | |
32345 | C & KLPBTM, NXXRGN | |
32346 | ** | |
32347 | C INCLUDE '(CMMDNR)' | |
32348 | * CMMDNR.ADD | |
32349 | **sr 18.5. commented since not used for evap. | |
32350 | C LOGICAL LFLDNR | |
32351 | C COMMON / CMMDNR / DDNEAR, LFLDNR | |
32352 | ** | |
32353 | C INCLUDE '(CTITLE)' | |
32354 | * CTITLE.ADD | |
32355 | **sr 18.5. commented since not used for evap. | |
32356 | C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10 | |
32357 | C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY | |
32358 | C COMMON / CEXPCK / ITEXPI, ITEXMX | |
32359 | ** | |
32360 | C INCLUDE '(DETECT)' | |
32361 | * DETECT.ADD | |
32362 | **sr 18.5. commented since not used for evap. | |
32363 | C PARAMETER (NRGNMX = 10) | |
32364 | C PARAMETER (NDTCMX = 10) | |
32365 | C PARAMETER (NSCRMX = 10) | |
32366 | C PARAMETER (NDTBIN = 1024) | |
32367 | C CHARACTER*10 TITDET,TITSCO | |
32368 | C LOGICAL LDTCTR | |
32369 | C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX), | |
32370 | C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX), | |
32371 | C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN), | |
32372 | C & KDTSCD(NSCRMX) | |
32373 | C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX) | |
32374 | ** | |
32375 | C INCLUDE '(DETLOC)' | |
32376 | * DETLOC.ADD | |
32377 | **sr 18.5. commented since not used for evap. | |
32378 | C PARAMETER (NDTCM2 = 10) | |
32379 | C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2), | |
32380 | C & ICOINC(NDTCM2), NCLAS | |
32381 | ** | |
32382 | C INCLUDE '(EMGTRN)' | |
32383 | * EMGTRN.ADD | |
32384 | **sr 18.5. commented since not used for evap. | |
32385 | C LOGICAL LMCSMG | |
32386 | C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG | |
32387 | ** | |
32388 | C INCLUDE '(EMSHO)' | |
32389 | * EMSHO.ADD | |
32390 | **sr 18.5. commented since not used for evap. | |
32391 | C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32392 | C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO, | |
32393 | C & EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32394 | ** | |
32395 | C INCLUDE '(EPISOR)' | |
32396 | * EPISOR.ADD | |
32397 | **sr 18.5. commented since not used for evap. | |
32398 | C LOGICAL LUSSRC | |
32399 | C COMMON/EPISOR/TKESUM,LUSSRC | |
32400 | ** | |
32401 | * (original name: FHEAVY,FHEAVC) | |
32402 | PARAMETER ( MXHEAV = 100 ) | |
32403 | CHARACTER*8 ANHEAV | |
32404 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
32405 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
32406 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
32407 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
32408 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
32409 | & IBHEAV ( 12 ) , NPHEAV | |
32410 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
32411 | * (original name: FINUC) | |
32412 | PARAMETER (MXP=999) | |
32413 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
32414 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
32415 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
32416 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
32417 | & KPART (MXP) | |
32418 | C INCLUDE '(GENTHR)' | |
32419 | * GENTHR.ADD | |
32420 | **sr 18.5. commented since not used for evap. | |
32421 | C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP), | |
32422 | C & PTHDFF (NALLWP), IJNUCR (NALLWP) | |
32423 | ** | |
32424 | C INCLUDE '(LOWNEU)' | |
32425 | * LOWNEU.ADD | |
32426 | **sr 18.5. commented since not used for evap. | |
32427 | C PARAMETER ( MXGTHN = 15 ) | |
32428 | C PARAMETER ( MXGLWN = 200 ) | |
32429 | C PARAMETER ( MXSHPP = 5 ) | |
32430 | C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET | |
32431 | C CHARACTER*10 TITLOW | |
32432 | C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL, | |
32433 | C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL, | |
32434 | C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF), | |
32435 | C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF), | |
32436 | C & TMNMLN (MXXMDF), ICHCPT (MXXMDF), | |
32437 | C & IGTMRT (MXXMDF), NEUMED (MXXMDF), | |
32438 | C & ID1MED (MXXMDF), ID2MED (MXXMDF), | |
32439 | C & ID3MED (MXXMDF), MGTMED (MXXMDF), | |
32440 | C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP, | |
32441 | C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW, | |
32442 | C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN, | |
32443 | C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB, | |
32444 | C & IWWLWT, IPXBGN, NPXSEC | |
32445 | C COMMON / CHLWNT / TITLOW (MXXMDF) | |
32446 | ** | |
32447 | C INCLUDE '(LTCLCM)' | |
32448 | * LTCLCM.ADD | |
32449 | **sr 18.5. commented since not used for evap. | |
32450 | C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 | |
32451 | ** | |
32452 | C INCLUDE '(MULBOU)' | |
32453 | * MULBOU.ADD | |
32454 | **sr 18.5. commented since not used for evap. | |
32455 | C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32456 | C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG , | |
32457 | C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE, | |
32458 | C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN, | |
32459 | C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32460 | ** | |
32461 | C INCLUDE '(MULHD)' | |
32462 | * MULHD.ADD | |
32463 | **sr 18.5. commented since not used for evap. | |
32464 | C PARAMETER ( MXXPT1 = 1 ) | |
32465 | C PARAMETER ( TIMESS = 2.00D+00 ) | |
32466 | C PARAMETER ( TMSRLX = 1.50D+00 ) | |
32467 | C PARAMETER ( EPSINS = 0.15D+00 ) | |
32468 | C PARAMETER ( EPSRLX = 0.50D+00 ) | |
32469 | C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 ) | |
32470 | C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 ) | |
32471 | C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN ) | |
32472 | C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR ) | |
32473 | C PARAMETER ( R0NCMS = 1.20 D+00 ) | |
32474 | C LOGICAL LTOPT, LSRCRH, LNSCRH | |
32475 | C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ), | |
32476 | C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ), | |
32477 | C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ), | |
32478 | C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ), | |
32479 | C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ), | |
32480 | C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ), | |
32481 | C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ), | |
32482 | C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP, | |
32483 | C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ), | |
32484 | C & LTOPT ( MXXMDF ), NFSCAT | |
32485 | ** | |
32486 | * (original name: PAREVT) | |
32487 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
32488 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
32489 | PARAMETER ( NALLWP = 39 ) | |
32490 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
32491 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
32492 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
32493 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
32494 | * (original name: RESNUC) | |
32495 | LOGICAL LRNFSS, LFRAGM | |
32496 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
32497 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
32498 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
32499 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
32500 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
32501 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
32502 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
32503 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
32504 | & LFRAGM | |
32505 | C INCLUDE '(SCOHLP)' | |
32506 | * SCOHLP.ADD | |
32507 | **sr 18.5. commented since not used for evap. | |
32508 | C LOGICAL LSCZER | |
32509 | C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER | |
32510 | ** | |
32511 | C INCLUDE '(TRACKR)' | |
32512 | * TRACKR.ADD | |
32513 | **sr 18.5. commented since not used for evap. | |
32514 | C PARAMETER ( MXTRCK = 2500 ) | |
32515 | C LOGICAL LFSSSC | |
32516 | C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ), | |
32517 | C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ), | |
32518 | C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK, | |
32519 | C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG, | |
32520 | C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK, | |
32521 | C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC | |
32522 | ** | |
32523 | C INCLUDE '(USRBDX)' | |
32524 | * USRBDX.ADD | |
32525 | **sr 18.5. commented since not used for evap. | |
32526 | C PARAMETER ( MXUSBX = 600 ) | |
32527 | C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX | |
32528 | C CHARACTER*10 TITUSX | |
32529 | C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX), | |
32530 | C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX), | |
32531 | C & AUSBDX(MXUSBX), | |
32532 | C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX), | |
32533 | C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX), | |
32534 | C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX), | |
32535 | C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX), | |
32536 | C & NUSRBX, LUSBDX | |
32537 | C COMMON /USXCH/ TITUSX(MXUSBX) | |
32538 | ** | |
32539 | C INCLUDE '(USRBIN)' | |
32540 | * USRBIN.ADD | |
32541 | **sr 18.5. commented since not used for evap. | |
32542 | C PARAMETER ( MXUSBN = 100 ) | |
32543 | C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN | |
32544 | C CHARACTER*10 TITUSB | |
32545 | C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN), | |
32546 | C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN), | |
32547 | C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN), | |
32548 | C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN), | |
32549 | C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN), | |
32550 | C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN), | |
32551 | C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN), | |
32552 | C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB | |
32553 | C COMMON /USRCH/ TITUSB(MXUSBN) | |
32554 | ** | |
32555 | C INCLUDE '(USRSNC)' | |
32556 | * USRSNC.ADD | |
32557 | **sr 18.5. commented since not used for evap. | |
32558 | C PARAMETER ( MXRSNC = 400 ) | |
32559 | C PARAMETER ( NMZMIN = -5 ) | |
32560 | C LOGICAL LURSNC | |
32561 | C CHARACTER*10 TIURSN | |
32562 | C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC), | |
32563 | C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC), | |
32564 | C & IPURSN(MXRSNC), NURSNC, LURSNC | |
32565 | C COMMON /USRSCH/ TIURSN(MXRSNC) | |
32566 | C INCLUDE '(USRTRC)' | |
32567 | * USRTRC.ADD | |
32568 | **sr 18.5. commented since not used for evap. | |
32569 | C PARAMETER ( MXUSTC = 400 ) | |
32570 | C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC | |
32571 | C CHARACTER*10 TITUTC | |
32572 | C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC), | |
32573 | C & VUSRTC(MXUSTC), | |
32574 | C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC), | |
32575 | C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC), | |
32576 | C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC), | |
32577 | C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC, | |
32578 | C & LUSTRK, LUSCLL | |
32579 | C COMMON /USTCH/ TITUTC(MXUSTC) | |
32580 | ** | |
32581 | C INCLUDE '(USRYLD)' | |
32582 | * USRYLD.ADD | |
32583 | **sr 18.5. commented since not used for evap. | |
32584 | C PARAMETER ( MXUSYL = 500 ) | |
32585 | C LOGICAL LUSRYL, LLNUYL, LSCUYL | |
32586 | C CHARACTER*10 TITUYL | |
32587 | C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL), | |
32588 | C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL), | |
32589 | C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL, | |
32590 | C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL, | |
32591 | C & VCMUYL, WCMUYL, IJUSYL, JTUSYL, | |
32592 | C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL), | |
32593 | C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL), | |
32594 | C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL), | |
32595 | C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL), | |
32596 | C & NUSRYL, LUSRYL, LSCUYL | |
32597 | C COMMON /USYCH/ TITUYL(MXUSYL) | |
32598 | ** | |
32599 | C INCLUDE '(WWINDW)' | |
32600 | * WWINDW.ADD | |
32601 | **sr 18.5. commented since not used for evap. | |
32602 | C PARAMETER ( MXWWSP = 3 ) | |
32603 | C PARAMETER ( WWSPMX = 50.D+00 ) | |
32604 | C LOGICAL LWWNDW, LWWPRM | |
32605 | C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP), | |
32606 | C & WWEXWD (NALLWP), EXTWWN (NALLWP), | |
32607 | C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM | |
32608 | ** | |
32609 | ||
32610 | * /blnkcm/ | |
32611 | * *** If blank common dimension has to be superseded substitute in the | |
32612 | * *** following two lines the new dimension in real*8 units to Nblnmx | |
32613 | **sr 18.5. commented since not used for evap. | |
32614 | C PARAMETER (MXDUMM = KALGNM * NBLNMX) | |
32615 | C DATA KTMBGN / NBLNMX / | |
32616 | C DATA MBLNMX / MXDUMM / | |
32617 | C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST, | |
32618 | C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN, | |
32619 | C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST, | |
32620 | C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN, | |
32621 | C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32622 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN, | |
32623 | C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST, | |
32624 | C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, | |
32625 | C & KBRLST / 57*0 / | |
32626 | ||
32627 | * /blntmp/ | |
32628 | **sr 18.5. commented since not used for evap. | |
32629 | C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM, | |
32630 | C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM, | |
32631 | C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 / | |
32632 | ||
32633 | * /cmmdnr/ | |
32634 | **sr 18.5. commented since not used for evap. | |
32635 | C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. / | |
32636 | ||
32637 | * /ctitle/ | |
32638 | **sr 18.5. commented since not used for evap. | |
32639 | C DATA RUNTIT (1:40) / '****************************************' / | |
32640 | C DATA RUNTIT(41:80) / '****************************************' / | |
32641 | C DATA ITEXPI, ITEXMX / 100000000, 150 / | |
32642 | * /detect/ | |
32643 | **sr 18.5. commented since not used for evap. | |
32644 | C PARAMETER (NNN1 = NRGNMX*NDTCMX) | |
32645 | C PARAMETER (NNN2 = NSCRMX*NDTCMX) | |
32646 | C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/ | |
32647 | C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/ | |
32648 | C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/ | |
32649 | C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/ | |
32650 | ||
32651 | * /detloc/ | |
32652 | **sr 18.5. commented since not used for evap. | |
32653 | C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/ | |
32654 | C DATA NCLAS /0/ | |
32655 | ||
32656 | * /emgtrn/ | |
32657 | **sr 18.5. commented since not used for evap. | |
32658 | C DATA LMCSMG / .FALSE. / | |
32659 | ||
32660 | * /emsho/ | |
32661 | **sr 18.5. commented since not used for evap. | |
32662 | C DATA LIMPRE, LEXPTE / 2 * .FALSE. / | |
32663 | ||
32664 | * /episor/ | |
32665 | **sr 18.5. commented since not used for evap. | |
32666 | C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. / | |
32667 | ||
32668 | * /fheavy/ | |
32669 | DATA AMHEAV / 12 * 0.D+00 / | |
32670 | DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ', | |
32671 | & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2', | |
32672 | & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/ | |
32673 | DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /, | |
32674 | & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 / | |
32675 | DATA NPHEAV / 0 / | |
32676 | ||
32677 | * /finuc/ | |
32678 | DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/, | |
32679 | & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 / | |
32680 | ||
32681 | * /genthr/ | |
32682 | * Up to 20-apr-'95 | |
32683 | * DATA PEANCT, PEAPIT / 2*1.D+00 / | |
32684 | * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00, | |
32685 | * & 9*2.5D+00 / | |
32686 | * DATA PTHDFF / 39*5.D+00 / | |
32687 | * & 9*2.5D+00 / | |
32688 | * New values: | |
32689 | **sr 18.5. commented since not used for evap. | |
32690 | C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 / | |
32691 | C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00, | |
32692 | C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00, | |
32693 | C & 9*2.5D+00 / | |
32694 | C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00, | |
32695 | C & 3.5D+00, 13*5.D+00 / | |
32696 | C DATA PLDNCT / 0.26D+00 / | |
32697 | C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 / | |
32698 | ||
32699 | * /lowneu/ | |
32700 | **sr 18.5. commented since not used for evap. | |
32701 | C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 / | |
32702 | C DATA IWWLWB, IWWLWT / 2 * 100000000 / | |
32703 | C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 / | |
32704 | C DATA IGRTHN / 1 / | |
32705 | C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /, | |
32706 | C & LLOWWW / .FALSE. /, LLOWET / .FALSE. / | |
32707 | ||
32708 | * /ltclcm/ | |
32709 | **sr 18.5. commented since not used for evap. | |
32710 | C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 / | |
32711 | ||
32712 | * /mulbou/ | |
32713 | **sr 18.5. commented since not used for evap. | |
32714 | C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR | |
32715 | C & / 7 * .FALSE. / | |
32716 | C DATA TSENSE / AINFNT /, NSSENS / -1 / | |
32717 | C DATA DSMALL / ANGLGB / | |
32718 | ||
32719 | * /mulhd/ | |
32720 | **sr 18.5. commented since not used for evap. | |
32721 | C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 / | |
32722 | C DATA ESTEPF / MXXMDF * 0.1D+00 / | |
32723 | C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. / | |
32724 | C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 / | |
32725 | ||
32726 | * /parevt/ | |
32727 | DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /, | |
32728 | & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 / | |
32729 | DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE., | |
32730 | & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE., | |
32731 | & 4 * .FALSE., 9 * .TRUE./ | |
32732 | **sr 17.5.95 | |
32733 | * default value for LEVPRT changed (reset sr 25.7.97) | |
32734 | * default value for LHEAVY changed 25.7.97 | |
32735 | C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32736 | C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32737 | C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32738 | C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32739 | DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32740 | & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32741 | & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32742 | & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32743 | ** | |
32744 | **sr 27.5.97 | |
32745 | * default value for ILVMOD changed | |
32746 | C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32747 | DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32748 | ** | |
32749 | ||
32750 | * /resnuc/ | |
32751 | DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /, | |
32752 | & IPR4HE / 0 / | |
32753 | DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /, | |
32754 | & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /, | |
32755 | & IDEEXG / 0 / | |
32756 | DATA LRNFSS / .FALSE. / | |
32757 | ||
32758 | * /scohlp/ | |
32759 | **sr 18.5. commented since not used for evap. | |
32760 | C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. / | |
32761 | ||
32762 | * /trackr/ | |
32763 | **sr 18.5. commented since not used for evap. | |
32764 | C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/, | |
32765 | C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/ | |
32766 | ||
32767 | * /usrbin/ | |
32768 | **sr 18.5. commented since not used for evap. | |
32769 | C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/ | |
32770 | ||
32771 | * /usrbdx/ | |
32772 | **sr 18.5. commented since not used for evap. | |
32773 | C DATA LUSBDX /.FALSE./, NUSRBX /0/ | |
32774 | ||
32775 | * /usrsnc/ | |
32776 | **sr 18.5. commented since not used for evap. | |
32777 | C DATA LURSNC /.FALSE./, NURSNC /0/ | |
32778 | ||
32779 | * /usrtrc/ | |
32780 | **sr 18.5. commented since not used for evap. | |
32781 | C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. / | |
32782 | C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 / | |
32783 | ||
32784 | * /usryld/ | |
32785 | **sr 18.5. commented since not used for evap. | |
32786 | C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/, | |
32787 | C & IJUSYL /0/, JTUSYL /0/ | |
32788 | C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER / | |
32789 | ||
32790 | * /wwindw/ | |
32791 | **sr 18.5. commented since not used for evap. | |
32792 | C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 / | |
32793 | C DATA LWWPRM / .TRUE. / | |
32794 | ||
32795 | *= end*block.bdnopt * | |
32796 | END | |
32797 | ||
32798 | *$ CREATE DT_BDPREE.FOR | |
32799 | *COPY DT_BDPREE | |
32800 | * | |
32801 | *=== bdpree ===========================================================* | |
32802 | * | |
32803 | BLOCK DATA DT_BDPREE | |
32804 | ||
32805 | C INCLUDE '(DBLPRC)' | |
32806 | * DBLPRC.ADD | |
32807 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32808 | SAVE | |
32809 | * (original name: GLOBAL) | |
32810 | PARAMETER ( KALGNM = 2 ) | |
32811 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32812 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32813 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32814 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32815 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32816 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32817 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32818 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32819 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32820 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32821 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32822 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32823 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32824 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32825 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32826 | PARAMETER ( ZERZER = 0.D+00 ) | |
32827 | PARAMETER ( ONEONE = 1.D+00 ) | |
32828 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32829 | PARAMETER ( THRTHR = 3.D+00 ) | |
32830 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32831 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32832 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32833 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32834 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32835 | PARAMETER ( ANINEN = 9.D+00 ) | |
32836 | PARAMETER ( TENTEN = 10.D+00 ) | |
32837 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32838 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32839 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32840 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32841 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32842 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32843 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32844 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32845 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32846 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32847 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32848 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32849 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32850 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32851 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32852 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32853 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32854 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32855 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32856 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32857 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32858 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32859 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32860 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32861 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32862 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32863 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32864 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32865 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32866 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32867 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32868 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32869 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32870 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32871 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32872 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32873 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32874 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32875 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32876 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32877 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32878 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32879 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32880 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32881 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32882 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32883 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32884 | & * 1.D-09 ) | |
32885 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32886 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32887 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32888 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32889 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32890 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32891 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32892 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32893 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32894 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32895 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32896 | LOGICAL LGBIAS, LGBANA | |
32897 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32898 | C INCLUDE '(DIMPAR)' | |
32899 | * DIMPAR.ADD | |
32900 | PARAMETER ( MXXRGN = 5000 ) | |
32901 | PARAMETER ( MXXMDF = 82 ) | |
32902 | PARAMETER ( MXXMDE = 54 ) | |
32903 | PARAMETER ( MFSTCK = 1000 ) | |
32904 | PARAMETER ( MESTCK = 100 ) | |
32905 | PARAMETER ( NALLWP = 39 ) | |
32906 | PARAMETER ( NELEMX = 80 ) | |
32907 | PARAMETER ( MPDPDX = 8 ) | |
32908 | PARAMETER ( ICOMAX = 180 ) | |
32909 | PARAMETER ( NSTBIS = 304 ) | |
32910 | PARAMETER ( IDMAXP = 220 ) | |
32911 | PARAMETER ( IDMXDC = 640 ) | |
32912 | PARAMETER ( MKBMX1 = 1 ) | |
32913 | PARAMETER ( MKBMX2 = 1 ) | |
32914 | C INCLUDE '(IOUNIT)' | |
32915 | * IOUNIT.ADD | |
32916 | PARAMETER ( LUNIN = 5 ) | |
32917 | PARAMETER ( LUNOUT = 6 ) | |
32918 | **sr 19.5. set error output-unit from 15 to 6 | |
32919 | PARAMETER ( LUNERR = 6 ) | |
32920 | PARAMETER ( LUNBER = 14 ) | |
32921 | PARAMETER ( LUNECH = 8 ) | |
32922 | PARAMETER ( LUNFLU = 13 ) | |
32923 | PARAMETER ( LUNGEO = 16 ) | |
32924 | PARAMETER ( LUNPMF = 12 ) | |
32925 | PARAMETER ( LUNRAN = 2 ) | |
32926 | PARAMETER ( LUNXSC = 9 ) | |
32927 | PARAMETER ( LUNDET = 17 ) | |
32928 | PARAMETER ( LUNRAY = 10 ) | |
32929 | PARAMETER ( LUNRDB = 1 ) | |
32930 | PARAMETER ( LUNPGO = 7 ) | |
32931 | PARAMETER ( LUNPGS = 4 ) | |
32932 | PARAMETER ( LUNSCR = 3 ) | |
32933 | * | |
32934 | *----------------------------------------------------------------------* | |
32935 | * * | |
32936 | * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala * | |
32937 | * Infn - Milan * | |
32938 | * * | |
32939 | * Last change on 03-feb-94 by Alfredo Ferrari * | |
32940 | * * | |
32941 | * * | |
32942 | *----------------------------------------------------------------------* | |
32943 | * | |
32944 | * (original name: CMPISG,CHPISG) | |
32945 | PARAMETER ( TPPPI0 = 0.279656044337515D+00 ) | |
32946 | PARAMETER ( TNNPI0 = 0.279642680857450D+00 ) | |
32947 | PARAMETER ( TPPPIP = 0.292295207182790D+00 ) | |
32948 | PARAMETER ( TPPDEP = 0.287514778898469D+00 ) | |
32949 | PARAMETER ( TNNPIM = 0.286723140900975D+00 ) | |
32950 | PARAMETER ( TNNDEM = 0.281949292916434D+00 ) | |
32951 | PARAMETER ( TPNPI0 = 0.279456888147740D+00 ) | |
32952 | PARAMETER ( TPNDE0 = 0.274693916135245D+00 ) | |
32953 | PARAMETER ( TPNPIP = 0.292086756473890D+00 ) | |
32954 | PARAMETER ( TNPPI0 = 0.279842093144975D+00 ) | |
32955 | PARAMETER ( TNPDE0 = 0.275072555824202D+00 ) | |
32956 | PARAMETER ( TNPPIP = 0.292489370554958D+00 ) | |
32957 | PARAMETER ( PIRSMX = 1.2D+00 ) | |
32958 | PARAMETER ( NPIREA = 10 ) | |
32959 | PARAMETER ( NPIRTA = 68 ) | |
32960 | PARAMETER ( NPIRLN = 21 ) | |
32961 | PARAMETER ( NPIRLG = NPIRTA - NPIRLN ) | |
32962 | PARAMETER ( NPISIS = NPIRLN + 20 ) | |
32963 | PARAMETER ( NPISEX = NPIRLN + 21 ) | |
32964 | PARAMETER ( NPIIMN = 14 ) | |
32965 | PARAMETER ( NPIIRC = 6 ) | |
32966 | PARAMETER ( DELWLL = 0.035D+00 ) | |
32967 | CHARACTER CHPIRE*8 | |
32968 | LOGICAL LDLRES | |
32969 | COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG, | |
32970 | & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS, | |
32971 | & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA), | |
32972 | & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA), | |
32973 | & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA), | |
32974 | & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) , | |
32975 | & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA), | |
32976 | & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA), | |
32977 | & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA), | |
32978 | & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2), | |
32979 | & SGABSR (2,2,4) , PRRSDL, | |
32980 | & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR , | |
32981 | & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) , | |
32982 | & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES | |
32983 | COMMON /FKCHPI/ CHPIRE (NPIREA) | |
32984 | DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2) | |
32985 | EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) ) | |
32986 | EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) ) | |
32987 | EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) ) | |
32988 | * (original name: FRBKCM) | |
32989 | PARAMETER ( MXFFBK = 6 ) | |
32990 | PARAMETER ( MXZFBK = 9 ) | |
32991 | PARAMETER ( MXNFBK = 10 ) | |
32992 | PARAMETER ( MXAFBK = 16 ) | |
32993 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
32994 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
32995 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
32996 | PARAMETER ( MXPSST = 300 ) | |
32997 | PARAMETER ( MXPSFB = 41000 ) | |
32998 | LOGICAL LFRMBK, LNCMSS | |
32999 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
33000 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
33001 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
33002 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
33003 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
33004 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
33005 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
33006 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
33007 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
33008 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
33009 | PARAMETER ( PI = PIPIPI ) | |
33010 | PARAMETER ( PISQ = PIPISQ ) | |
33011 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
33012 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
33013 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
33014 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
33015 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
33016 | & / R0PROT ) | |
33017 | PARAMETER ( RLLE04 = RZNUCL ) | |
33018 | PARAMETER ( RLLE16 = RZNUCL ) | |
33019 | PARAMETER ( RLGT16 = RZNUCL ) | |
33020 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
33021 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
33022 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
33023 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
33024 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
33025 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
33026 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
33027 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
33028 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
33029 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
33030 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
33031 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
33032 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
33033 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
33034 | PARAMETER ( POTBA0 = 1.D+00 ) | |
33035 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
33036 | PARAMETER ( RADPIM = 0.035D+00 ) | |
33037 | PARAMETER ( RDPMHL = 14.D+00 ) | |
33038 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
33039 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
33040 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
33041 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
33042 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
33043 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
33044 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
33045 | PARAMETER ( MXSCIN = 50 ) | |
33046 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
33047 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
33048 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
33049 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
33050 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
33051 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
33052 | & PFRTAB (2:260) | |
33053 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
33054 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
33055 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
33056 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
33057 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
33058 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
33059 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
33060 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
33061 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
33062 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
33063 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
33064 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
33065 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
33066 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
33067 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
33068 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
33069 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
33070 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
33071 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
33072 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
33073 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
33074 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
33075 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
33076 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
33077 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
33078 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
33079 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
33080 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
33081 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
33082 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
33083 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
33084 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
33085 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
33086 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
33087 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
33088 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
33089 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
33090 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
33091 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
33092 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
33093 | & LNCDCY, LNUSCT | |
33094 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
33095 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
33096 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
33097 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
33098 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
33099 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
33100 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
33101 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
33102 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
33103 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
33104 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
33105 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
33106 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
33107 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
33108 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
33109 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
33110 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
33111 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
33112 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
33113 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
33114 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
33115 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
33116 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
33117 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
33118 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
33119 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
33120 | * (original name: NUCLEV) | |
33121 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
33122 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
33123 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
33124 | & CUMRAD (0:160,2), RUSNUC (2), | |
33125 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
33126 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
33127 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
33128 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
33129 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
33130 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
33131 | & LFLVSL, LRLVSL, LEQSBL | |
33132 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
33133 | & MGSSPR (19) , MGSSNE (25) | |
33134 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
33135 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
33136 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
33137 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
33138 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
33139 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
33140 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
33141 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
33142 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
33143 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
33144 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
33145 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
33146 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
33147 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
33148 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
33149 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
33150 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
33151 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
33152 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
33153 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
33154 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
33155 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
33156 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
33157 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
33158 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
33159 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
33160 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
33161 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
33162 | * (original name: PARNUC) | |
33163 | PARAMETER ( PIGRK = PIPIPI ) | |
33164 | PARAMETER ( ALEVEL = 8.D-03 ) | |
33165 | PARAMETER ( RCNUCL = 1.12D+00 ) | |
33166 | PARAMETER ( R0SIG = 1.3D+00 ) | |
33167 | PARAMETER ( R0SIGK = 1.5D+00 ) | |
33168 | PARAMETER ( RCOULB = 1.5D+00 ) | |
33169 | PARAMETER ( COULBH = 0.88235D-03 ) | |
33170 | PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL ) | |
33171 | PARAMETER ( TAUFO0 = 10.0D+00 ) | |
33172 | PARAMETER ( EKEEXP = 0.03D+00 ) | |
33173 | PARAMETER ( EKREXP = 0.05D+00 ) | |
33174 | PARAMETER ( EKEMNM = 0.01D+00 ) | |
33175 | PARAMETER ( NCPMX = 120 ) | |
33176 | COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR, | |
33177 | & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX), | |
33178 | & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX), | |
33179 | & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX), | |
33180 | & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX), | |
33181 | & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX), | |
33182 | & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN, | |
33183 | & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX), | |
33184 | & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI , | |
33185 | & IBNUCL, NPNUC , NNUCTS | |
33186 | * | |
33187 | DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. / | |
33188 | DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 / | |
33189 | DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 / | |
33190 | DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 / | |
33191 | DATA LPREEQ / .FALSE. / | |
33192 | * /cmpisg/ | |
33193 | DATA JSTOKP / 1, 8, 13, 14, 23 / | |
33194 | DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 / | |
33195 | DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P', | |
33196 | & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P', | |
33197 | & 'PI0NPI0N','PI0NPI-P' / | |
33198 | DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8, | |
33199 | & 13, 8, 13, 8, 23, 8, 23, 8 / | |
33200 | DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8, | |
33201 | & 13, 8, 23, 1, 23, 8, 14, 1 / | |
33202 | DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 / | |
33203 | DATA IPIINE / 1, 2, 3, 4, 5, 6 / | |
33204 | * /frbkcm/ | |
33205 | DATA LFRMBK / .FALSE. / | |
33206 | DATA NBUFBK / 500 / | |
33207 | DATA EXMXFB / 80.0 D+00 / | |
33208 | DATA R0FRBK / 1.18 D+00 / | |
33209 | DATA R0CFBK / 2.173D+00 / | |
33210 | DATA C1CFBK / 6.103D-03 / | |
33211 | DATA C2CFBK / 9.443D-03 / | |
33212 | * /parnuc/ | |
33213 | DATA TAUFOR / TAUFO0 / | |
33214 | *=== End of Block Data Bdpree =========================================* | |
33215 | END | |
33216 | ||
33217 | *$ CREATE DT_XHOINI.FOR | |
33218 | *COPY DT_XHOINI | |
33219 | * | |
33220 | *====phoini============================================================* | |
33221 | * | |
33222 | SUBROUTINE DT_XHOINI | |
33223 | C SUBROUTINE DT_PHOINI | |
33224 | ||
33225 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33226 | SAVE | |
33227 | PARAMETER ( LINP = 10 , | |
33228 | & LOUT = 6 , | |
33229 | & LDAT = 9 ) | |
33230 | ||
33231 | RETURN | |
33232 | END | |
33233 | ||
33234 | *$ CREATE DT_XVENTB.FOR | |
33235 | *COPY DT_XVENTB | |
33236 | * | |
33237 | *====eventb============================================================* | |
33238 | * | |
33239 | SUBROUTINE DT_XVENTB(NCSY,IREJ) | |
33240 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
33241 | ||
33242 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33243 | SAVE | |
33244 | PARAMETER ( LINP = 10 , | |
33245 | & LOUT = 6 , | |
33246 | & LDAT = 9 ) | |
33247 | ||
33248 | WRITE(LOUT,1000) | |
33249 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') | |
33250 | STOP | |
33251 | ||
33252 | END | |
33253 | ||
33254 | *$ CREATE DT_XVENT.FOR | |
33255 | *COPY DT_XVENT | |
33256 | * | |
33257 | *===event==============================================================* | |
33258 | * | |
33259 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) | |
33260 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) | |
33261 | ||
33262 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33263 | SAVE | |
33264 | ||
33265 | DIMENSION PP(4),PT(4) | |
33266 | ||
33267 | RETURN | |
33268 | END | |
33269 | ||
33270 | *$ CREATE DT_XOHISX.FOR | |
33271 | *COPY DT_XOHISX | |
33272 | * | |
33273 | *===pohisx=============================================================* | |
33274 | * | |
33275 | SUBROUTINE DT_XOHISX(I,X) | |
33276 | C SUBROUTINE POHISX(I,X) | |
33277 | ||
33278 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33279 | SAVE | |
33280 | ||
33281 | RETURN | |
33282 | END | |
33283 | ||
33284 | *$ CREATE PHO_LHIST.FOR | |
33285 | *COPY PHO_LHIST | |
33286 | * | |
33287 | *===poluhi=============================================================* | |
33288 | * | |
33289 | SUBROUTINE PHO_LHIST(I,X) | |
33290 | ** | |
33291 | ||
33292 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33293 | SAVE | |
33294 | ||
33295 | RETURN | |
33296 | END | |
33297 | ||
33298 | *$ CREATE PDFSET.FOR | |
33299 | *COPY PDFSET | |
33300 | * | |
33301 | C********************************************************************** | |
33302 | C | |
33303 | C dummy subroutines, remove to link PDFLIB | |
33304 | C | |
33305 | C********************************************************************** | |
33306 | SUBROUTINE PDFSET(PARAM,VALUE) | |
33307 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33308 | DIMENSION PARAM(20),VALUE(20) | |
33309 | CHARACTER*20 PARAM | |
33310 | END | |
33311 | ||
33312 | *$ CREATE STRUCTM.FOR | |
33313 | *COPY STRUCTM | |
33314 | * | |
33315 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33316 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33317 | END | |
33318 | ||
33319 | *$ CREATE STRUCTP.FOR | |
33320 | *COPY STRUCTP | |
33321 | * | |
33322 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33323 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33324 | END | |
33325 | ||
33326 | *$ CREATE DT_DIQBRK.FOR | |
33327 | *COPY DT_DIQBRK | |
33328 | * | |
33329 | *===diqbrk=============================================================* | |
33330 | * | |
33331 | SUBROUTINE DT_XIQBRK | |
33332 | C SUBROUTINE DT_DIQBRK | |
33333 | ||
33334 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33335 | SAVE | |
33336 | ||
33337 | STOP 'diquark-breaking not implemeted !' | |
33338 | ||
33339 | RETURN | |
33340 | END | |
33341 | ||
33342 | *$ CREATE DT_ELHAIN.FOR | |
33343 | *COPY DT_ELHAIN | |
33344 | * | |
33345 | *===elhain=============================================================* | |
33346 | * | |
33347 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) | |
33348 | ||
33349 | ************************************************************************ | |
33350 | * Elastic hadron-hadron scattering. * | |
33351 | * This is a revised version of the original. * | |
33352 | * This version dated 03.04.98 is written by S. Roesler * | |
33353 | ************************************************************************ | |
33354 | ||
33355 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33356 | SAVE | |
33357 | PARAMETER ( LINP = 10 , | |
33358 | & LOUT = 6 , | |
33359 | & LDAT = 9 ) | |
33360 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33361 | & TINY10=1.0D-10) | |
33362 | ||
33363 | PARAMETER (ENNTHR = 3.5D0) | |
33364 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, | |
33365 | & BLOWB=0.05D0,BHIB=0.2D0, | |
33366 | & BLOWM=0.1D0, BHIM=2.0D0) | |
33367 | ||
33368 | * particle properties (BAMJET index convention) | |
33369 | CHARACTER*8 ANAME | |
33370 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33371 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33372 | * final state from HADRIN interaction | |
33373 | PARAMETER (MAXFIN=10) | |
33374 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33375 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33376 | ||
33377 | C DATA TSLOPE /10.0D0/ | |
33378 | ||
33379 | IREJ = 0 | |
33380 | ||
33381 | 1 CONTINUE | |
33382 | ||
33383 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) | |
33384 | EKIN = ELAB-AAM(IP) | |
33385 | * kinematical quantities in cms of the hadrons | |
33386 | AMP2 = AAM(IP)**2 | |
33387 | AMT2 = AAM(IT)**2 | |
33388 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) | |
33389 | ECM = SQRT(S) | |
33390 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) | |
33391 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) | |
33392 | ||
33393 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) | |
33394 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. | |
33395 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN | |
33396 | * TSAMCS treats pp and np only, therefore change pn into np and | |
33397 | * nn into pp | |
33398 | IF (IT.EQ.1) THEN | |
33399 | KPROJ = IP | |
33400 | ELSE | |
33401 | KPROJ = 8 | |
33402 | IF (IP.EQ.8) KPROJ = 1 | |
33403 | ENDIF | |
33404 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) | |
33405 | T = TWO*PCM**2*(CTCMS-ONE) | |
33406 | ||
33407 | * very crude treatment otherwise: sample t from exponential dist. | |
33408 | ELSE | |
33409 | * momentum transfer t | |
33410 | TMAX = TWO*TWO*PCM**2 | |
33411 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) | |
33412 | IF (IIBAR(IP).NE.0) THEN | |
33413 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) | |
33414 | ELSE | |
33415 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) | |
33416 | ENDIF | |
33417 | FMAX = EXP(-TSLOPE*TMAX)-ONE | |
33418 | R = DT_RNDM(RR) | |
33419 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE | |
33420 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE | |
33421 | ENDIF | |
33422 | ||
33423 | * target hadron in Lab after scattering | |
33424 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) | |
33425 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) | |
33426 | IF (PLRH(2).LE.TINY10) THEN | |
33427 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) | |
33428 | GOTO 1 | |
33429 | ENDIF | |
33430 | * projectile hadron in Lab after scattering | |
33431 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) | |
33432 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) | |
33433 | * scattering angle of projectile in Lab | |
33434 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) | |
33435 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) | |
33436 | CALL DT_DSFECF(SPLABP,CPLABP) | |
33437 | * direction cosines of projectile in Lab | |
33438 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, | |
33439 | & CXRH(1),CYRH(1),CZRH(1)) | |
33440 | * scattering angle of target in Lab | |
33441 | PLLABT = PLAB-CTLABP*PLRH(1) | |
33442 | CTLABT = PLLABT/PLRH(2) | |
33443 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) | |
33444 | * direction cosines of target in Lab | |
33445 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, | |
33446 | & CXRH(2),CYRH(2),CZRH(2)) | |
33447 | * fill /HNFSPA/ | |
33448 | IRH = 2 | |
33449 | ITRH(1) = IP | |
33450 | ITRH(2) = IT | |
33451 | ||
33452 | RETURN | |
33453 | END | |
33454 | ||
33455 | *$ CREATE DT_TSAMCS.FOR | |
33456 | *COPY DT_TSAMCS | |
33457 | * | |
33458 | *===tsamcs=============================================================* | |
33459 | * | |
33460 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) | |
33461 | ||
33462 | ************************************************************************ | |
33463 | * Sampling of cos(theta) for nucleon-proton scattering according to * | |
33464 | * hetkfa2/bertini parametrization. * | |
33465 | * This is a revised version of the original (HJM 24/10/88) * | |
33466 | * This version dated 28.10.95 is written by S. Roesler * | |
33467 | ************************************************************************ | |
33468 | ||
33469 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33470 | SAVE | |
33471 | PARAMETER ( LINP = 10 , | |
33472 | & LOUT = 6 , | |
33473 | & LDAT = 9 ) | |
33474 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33475 | & TINY10=1.0D-10) | |
33476 | ||
33477 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) | |
33478 | DIMENSION PDCI(60),PDCH(55) | |
33479 | ||
33480 | DATA (DCLIN(I),I=1,80) / | |
33481 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, | |
33482 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, | |
33483 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, | |
33484 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, | |
33485 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, | |
33486 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, | |
33487 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, | |
33488 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, | |
33489 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, | |
33490 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, | |
33491 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, | |
33492 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, | |
33493 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, | |
33494 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, | |
33495 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, | |
33496 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ | |
33497 | DATA (DCLIN(I),I=81,160) / | |
33498 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, | |
33499 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, | |
33500 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, | |
33501 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, | |
33502 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, | |
33503 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, | |
33504 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, | |
33505 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, | |
33506 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, | |
33507 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, | |
33508 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, | |
33509 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, | |
33510 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, | |
33511 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, | |
33512 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, | |
33513 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ | |
33514 | DATA (DCLIN(I),I=161,195) / | |
33515 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, | |
33516 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, | |
33517 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, | |
33518 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, | |
33519 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, | |
33520 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, | |
33521 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ | |
33522 | ||
33523 | DATA PDCI / | |
33524 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, | |
33525 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, | |
33526 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, | |
33527 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, | |
33528 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, | |
33529 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, | |
33530 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, | |
33531 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, | |
33532 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, | |
33533 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, | |
33534 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, | |
33535 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ | |
33536 | ||
33537 | DATA PDCH / | |
33538 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, | |
33539 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, | |
33540 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, | |
33541 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, | |
33542 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, | |
33543 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, | |
33544 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, | |
33545 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, | |
33546 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, | |
33547 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, | |
33548 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ | |
33549 | ||
33550 | DATA (DCHN(I),I=1,90) / | |
33551 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, | |
33552 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, | |
33553 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, | |
33554 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, | |
33555 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, | |
33556 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, | |
33557 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, | |
33558 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, | |
33559 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, | |
33560 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, | |
33561 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, | |
33562 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, | |
33563 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, | |
33564 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, | |
33565 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, | |
33566 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, | |
33567 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, | |
33568 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ | |
33569 | DATA (DCHN(I),I=91,143) / | |
33570 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, | |
33571 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, | |
33572 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, | |
33573 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, | |
33574 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, | |
33575 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, | |
33576 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, | |
33577 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, | |
33578 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, | |
33579 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, | |
33580 | & 6.488D-02, 6.485D-02, 6.480D-02/ | |
33581 | ||
33582 | DATA DCHNA / | |
33583 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, | |
33584 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, | |
33585 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, | |
33586 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, | |
33587 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, | |
33588 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, | |
33589 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, | |
33590 | & 1.000D+00/ | |
33591 | ||
33592 | DATA DCHNB / | |
33593 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, | |
33594 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, | |
33595 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, | |
33596 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, | |
33597 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, | |
33598 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, | |
33599 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33600 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, | |
33601 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33602 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, | |
33603 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33604 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ | |
33605 | ||
33606 | CST = ONE | |
33607 | IF (EKIN.GT.3.5D0) RETURN | |
33608 | C | |
33609 | IF(KPROJ.EQ.8) GOTO 101 | |
33610 | IF(KPROJ.EQ.1) GOTO 102 | |
33611 | C* INVALID REACTION | |
33612 | WRITE(LOUT,'(A,I5/A)') | |
33613 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, | |
33614 | & ' COS(THETA) = 1D0 RETURNED' | |
33615 | RETURN | |
33616 | C-------------------------------- NP ELASTIC SCATTERING---------- | |
33617 | 101 CONTINUE | |
33618 | IF (EKIN.GT.0.740D0)GOTO 1000 | |
33619 | IF (EKIN.LT.0.300D0)THEN | |
33620 | C EKIN .LT. 300 MEV | |
33621 | IDAT=1 | |
33622 | ELSE | |
33623 | C 300 MEV < EKIN < 740 MEV | |
33624 | IDAT=6 | |
33625 | END IF | |
33626 | C | |
33627 | ENER=EKIN | |
33628 | IE=INT(ABS(ENER/0.020D0)) | |
33629 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33630 | C FORWARD/BACKWARD DECISION | |
33631 | K=IDAT+5*IE | |
33632 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33633 | IF (DT_RNDM(CST).LT.BWFW)THEN | |
33634 | VALUE2=-1D0 | |
33635 | K=K+1 | |
33636 | ELSE | |
33637 | VALUE2=1D0 | |
33638 | K=K+3 | |
33639 | END IF | |
33640 | C | |
33641 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33642 | RND=DT_RNDM(COEF) | |
33643 | C | |
33644 | IF(RND.LT.COEF)THEN | |
33645 | CST=DT_RNDM(RND) | |
33646 | CST=CST*VALUE2 | |
33647 | ELSE | |
33648 | R1=DT_RNDM(CST) | |
33649 | R2=DT_RNDM(R1) | |
33650 | R3=DT_RNDM(R2) | |
33651 | R4=DT_RNDM(R3) | |
33652 | C | |
33653 | IF(VALUE2.GT.0.0)THEN | |
33654 | CST=MAX(R1,R2,R3,R4) | |
33655 | GOTO 1500 | |
33656 | ELSE | |
33657 | R5=DT_RNDM(R4) | |
33658 | C | |
33659 | IF (IDAT.EQ.1)THEN | |
33660 | CST=-MAX(R1,R2,R3,R4,R5) | |
33661 | ELSE | |
33662 | R6=DT_RNDM(R5) | |
33663 | R7=DT_RNDM(R6) | |
33664 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) | |
33665 | END IF | |
33666 | C | |
33667 | END IF | |
33668 | C | |
33669 | END IF | |
33670 | C | |
33671 | GOTO 1500 | |
33672 | C | |
33673 | C******** EKIN .GT. 0.74 GEV | |
33674 | C | |
33675 | 1000 ENER=EKIN - 0.66D0 | |
33676 | C IE=ABS(ENER/0.02) | |
33677 | IE=INT(ENER/0.02D0) | |
33678 | EMEV=EKIN*1D3 | |
33679 | C | |
33680 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33681 | K=IE | |
33682 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) | |
33683 | RND=DT_RNDM(BWFW) | |
33684 | C FORWARD NEUTRON | |
33685 | IF (RND.GE.BWFW)THEN | |
33686 | DO 1200 K=10,36,9 | |
33687 | IF (DCHNA(K).GT.EMEV) THEN | |
33688 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) | |
33689 | UNIV=DT_RNDM(UNIVE) | |
33690 | DO 1100 I=1,8 | |
33691 | II=K+I | |
33692 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) | |
33693 | C | |
33694 | IF (P.GT.UNIV)THEN | |
33695 | UNIV=DT_RNDM(UNIVE) | |
33696 | FLTI=DBLE(I)-UNIV | |
33697 | GOTO(290,290,290,290,330,340,350,360) I | |
33698 | END IF | |
33699 | 1100 CONTINUE | |
33700 | END IF | |
33701 | 1200 CONTINUE | |
33702 | C | |
33703 | ELSE | |
33704 | C BACKWARD NEUTRON | |
33705 | DO 1400 K=13,60,12 | |
33706 | IF (DCHNB(K).GT.EMEV) THEN | |
33707 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) | |
33708 | UNIV=DT_RNDM(UNIVE) | |
33709 | DO 1300 I=1,11 | |
33710 | II=K+I | |
33711 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) | |
33712 | C | |
33713 | IF (P.GT.UNIV)THEN | |
33714 | UNIV=DT_RNDM(P) | |
33715 | FLTI=DBLE(I)-UNIV | |
33716 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I | |
33717 | END IF | |
33718 | 1300 CONTINUE | |
33719 | END IF | |
33720 | 1400 CONTINUE | |
33721 | END IF | |
33722 | C | |
33723 | 120 CST=1.0D-2*FLTI-1.0D0 | |
33724 | GOTO 1500 | |
33725 | 140 CST=2.0D-2*UNIV-0.98D0 | |
33726 | GOTO 1500 | |
33727 | 150 CST=4.0D-2*UNIV-0.96D0 | |
33728 | GOTO 1500 | |
33729 | 160 CST=6.0D-2*FLTI-1.16D0 | |
33730 | GOTO 1500 | |
33731 | 180 CST=8.0D-2*UNIV-0.80D0 | |
33732 | GOTO 1500 | |
33733 | 190 CST=1.0D-1*UNIV-0.72D0 | |
33734 | GOTO 1500 | |
33735 | 200 CST=1.2D-1*UNIV-0.62D0 | |
33736 | GOTO 1500 | |
33737 | 210 CST=2.0D-1*UNIV-0.50D0 | |
33738 | GOTO 1500 | |
33739 | 220 CST=3.0D-1*(UNIV-1.0D0) | |
33740 | GOTO 1500 | |
33741 | C | |
33742 | 290 CST=1.0D0-2.5d-2*FLTI | |
33743 | GOTO 1500 | |
33744 | 330 CST=0.85D0+0.5D-1*UNIV | |
33745 | GOTO 1500 | |
33746 | 340 CST=0.70D0+1.5D-1*UNIV | |
33747 | GOTO 1500 | |
33748 | 350 CST=0.50D0+2.0D-1*UNIV | |
33749 | GOTO 1500 | |
33750 | 360 CST=0.50D0*UNIV | |
33751 | C | |
33752 | 1500 RETURN | |
33753 | C | |
33754 | C----------------------------------- PP ELASTIC SCATTERING ------- | |
33755 | C | |
33756 | 102 CONTINUE | |
33757 | EMEV=EKIN*1D3 | |
33758 | C | |
33759 | IF (EKIN.LE.0.500D0) THEN | |
33760 | RND=DT_RNDM(EMEV) | |
33761 | CST=2.0D0*RND-1.0D0 | |
33762 | RETURN | |
33763 | C | |
33764 | ELSEIF (EKIN.LT.1.0D0) THEN | |
33765 | DO 2200 K=13,60,12 | |
33766 | IF (PDCI(K).GT.EMEV) THEN | |
33767 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) | |
33768 | UNIV=DT_RNDM(UNIVE) | |
33769 | SUM=0 | |
33770 | DO 2100 I=1,11 | |
33771 | II=K+I | |
33772 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) | |
33773 | C | |
33774 | IF (UNIV.LT.SUM)THEN | |
33775 | UNIV=DT_RNDM(SUM) | |
33776 | FLTI=DBLE(I)-UNIV | |
33777 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I | |
33778 | END IF | |
33779 | 2100 CONTINUE | |
33780 | END IF | |
33781 | 2200 CONTINUE | |
33782 | ELSE | |
33783 | DO 2400 K=12,55,11 | |
33784 | IF (PDCH(K).GT.EMEV) THEN | |
33785 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) | |
33786 | UNIV=DT_RNDM(UNIVE) | |
33787 | SUM=0.0D0 | |
33788 | DO 2300 I=1,10 | |
33789 | II=K+I | |
33790 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) | |
33791 | C | |
33792 | IF (UNIV.LT.SUM)THEN | |
33793 | UNIV=DT_RNDM(SUM) | |
33794 | FLTI=UNIV+DBLE(I) | |
33795 | GOTO(50,55,60,60,65,65,65,65,70,70) I | |
33796 | END IF | |
33797 | 2300 CONTINUE | |
33798 | END IF | |
33799 | 2400 CONTINUE | |
33800 | END IF | |
33801 | C | |
33802 | 50 CST=0.4D0*UNIV | |
33803 | GOTO 2500 | |
33804 | 55 CST=0.2D0*FLTI | |
33805 | GOTO 2500 | |
33806 | 60 CST=0.3D0+0.1D0*FLTI | |
33807 | GOTO 2500 | |
33808 | 65 CST=0.6D0+0.04D0*FLTI | |
33809 | GOTO 2500 | |
33810 | 70 CST=0.78D0+0.02D0*FLTI | |
33811 | C | |
33812 | 2500 CONTINUE | |
33813 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST | |
33814 | C | |
33815 | RETURN | |
33816 | END | |
33817 | ||
33818 | *$ CREATE DT_DHADRI.FOR | |
33819 | *COPY DT_DHADRI | |
33820 | * | |
33821 | *===dhadri=============================================================* | |
33822 | * | |
33823 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) | |
33824 | ||
33825 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33826 | SAVE | |
33827 | ||
33828 | PARAMETER ( LINP = 10 , | |
33829 | & LOUT = 6 , | |
33830 | & LDAT = 9 ) | |
33831 | C | |
33832 | C----------------------------- | |
33833 | C*** INPUT VARIABLES LIST: | |
33834 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 | |
33835 | C*** GEV/C LABORATORY MOMENTUM REGION | |
33836 | C*** N - PROJECTILE HADRON INDEX | |
33837 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) | |
33838 | C*** ELAB - LABORATORY ENERGY OF N (GEV) | |
33839 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM | |
33840 | C*** ITTA - TARGET NUCLEON INDEX | |
33841 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ | |
33842 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES | |
33843 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) | |
33844 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE | |
33845 | C*** RESPECT., UNITS (GEV/C AND GEV) | |
33846 | C---------------------------- | |
33847 | ||
33848 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
33849 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33850 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33851 | & NRK(2,268),NURE(30,2) | |
33852 | * particle properties (BAMJET index convention), | |
33853 | * (dublicate of DTPART for HADRIN) | |
33854 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33855 | & K1H(110),K2H(110) | |
33856 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
33857 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), | |
33858 | & ITS(149),IS | |
33859 | COMMON /HNDRUN/ RUNTES,EFTES | |
33860 | * particle properties (BAMJET index convention) | |
33861 | CHARACTER*8 ANAME | |
33862 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33863 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33864 | * final state from HADRIN interaction | |
33865 | PARAMETER (MAXFIN=10) | |
33866 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33867 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33868 | ||
33869 | DIMENSION ITPRF(110) | |
33870 | DATA NNN/0/ | |
33871 | DATA UMODA/0./ | |
33872 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ | |
33873 | LOWP=0 | |
33874 | IF (N.LE.0.OR.N.GE.111)N=1 | |
33875 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN | |
33876 | GOTO 280 | |
33877 | * WRITE (6,1000) | |
33878 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA | |
33879 | * STOP | |
33880 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) | |
33881 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) | |
33882 | ENDIF | |
33883 | IATMPT=0 | |
33884 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 | |
33885 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB | |
33886 | C STOP | |
33887 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE | |
33888 | + ALLOWED REGION, PLAB=',1E15.5) | |
33889 | ||
33890 | 20 CONTINUE | |
33891 | UMODAT=N*1.11111D0+ITTA*2.19291D0 | |
33892 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) | |
33893 | UMODA=UMODAT | |
33894 | 30 IATMPT=0 | |
33895 | LOWP=LOWP+1 | |
33896 | 40 CONTINUE | |
33897 | IMACH=0 | |
33898 | REDU=2.0D0 | |
33899 | IF (LOWP.GT.20) THEN | |
33900 | C WRITE(LOUT,*) ' jump 1' | |
33901 | GO TO 280 | |
33902 | ENDIF | |
33903 | NNN=N | |
33904 | IF (NNN.EQ.N) GO TO 50 | |
33905 | RUNTES=0.0D0 | |
33906 | EFTES=0.0D0 | |
33907 | 50 CONTINUE | |
33908 | IS=1 | |
33909 | IRH=0 | |
33910 | IST=1 | |
33911 | NSTAB=23 | |
33912 | IRE=NURE(N,1) | |
33913 | IF(ITTA.GT.1) IRE=NURE(N,2) | |
33914 | C | |
33915 | C----------------------------- | |
33916 | C*** IE,AMT,ECM,SI DETERMINATION | |
33917 | C---------------------------- | |
33918 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) | |
33919 | IANTH=-1 | |
33920 | **sr | |
33921 | C IF (AMH(1).NE.0.93828D0) IANTH=1 | |
33922 | IF (AMH(1).NE.0.9383D0) IANTH=1 | |
33923 | ** | |
33924 | IF (IANTH.GE.0) SI=1.0D0 | |
33925 | ECMMH=ECM | |
33926 | C | |
33927 | C----------------------------- | |
33928 | C ENERGY INDEX | |
33929 | C IRE CHARACTERIZES THE REACTION | |
33930 | C IE IS THE ENERGY INDEX | |
33931 | C---------------------------- | |
33932 | IF (SI.LT.1.D-6) THEN | |
33933 | C WRITE(LOUT,*) ' jump 2' | |
33934 | GO TO 280 | |
33935 | ENDIF | |
33936 | IF (N.LE.NSTAB) GO TO 60 | |
33937 | RUNTES=RUNTES+1.0D0 | |
33938 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N | |
33939 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) | |
33940 | IF(IBARH(N).EQ.1) N=8 | |
33941 | IF(IBARH(N).EQ.-1) N=9 | |
33942 | 60 CONTINUE | |
33943 | IMACH=IMACH+1 | |
33944 | **sr 19.2.97: loop for direct channel suppression | |
33945 | C IF (IMACH.GT.10) THEN | |
33946 | IF (IMACH.GT.1000) THEN | |
33947 | ** | |
33948 | C WRITE(LOUT,*) ' jump 3' | |
33949 | GO TO 280 | |
33950 | ENDIF | |
33951 | ECM =ECMMH | |
33952 | AMN2=AMN**2 | |
33953 | AMT2=AMT**2 | |
33954 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) | |
33955 | IF(ECMN.LE.AMN) ECMN=AMN | |
33956 | PCMN=SQRT(ECMN**2-AMN2) | |
33957 | GAM=(ELAB+AMT)/ECM | |
33958 | BGAM=PLAB/ECM | |
33959 | IF (IANTH.GE.0) ECM=2.1D0 | |
33960 | C | |
33961 | C----------------------------- | |
33962 | C*** RANDOM CHOICE OF REACTION CHANNEL | |
33963 | C---------------------------- | |
33964 | IST=0 | |
33965 | VV=DT_RNDM(AMN2) | |
33966 | VV=VV-1.D-17 | |
33967 | C | |
33968 | C----------------------------- | |
33969 | C*** PLACE REDUCED VERSION | |
33970 | C---------------------------- | |
33971 | IIEI=IEII(IRE) | |
33972 | IDWK=IEII(IRE+1)-IIEI | |
33973 | IIWK=IRII(IRE) | |
33974 | IIKI=IKII(IRE) | |
33975 | C | |
33976 | C----------------------------- | |
33977 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS | |
33978 | C---------------------------- | |
33979 | HECM=ECM | |
33980 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) | |
33981 | IF (HUMO.LT.ECM) ECM=HUMO | |
33982 | C | |
33983 | C----------------------------- | |
33984 | C*** INTERPOLATION PREPARATION | |
33985 | C---------------------------- | |
33986 | ECMO=UMO(IE) | |
33987 | ECM1=UMO(IE-1) | |
33988 | DECM=ECMO-ECM1 | |
33989 | DEC=ECMO-ECM | |
33990 | C | |
33991 | C----------------------------- | |
33992 | C*** RANDOM LOOP | |
33993 | C---------------------------- | |
33994 | IK=0 | |
33995 | WKK=0.0D0 | |
33996 | WICOR=0.0D0 | |
33997 | 70 IK=IK+1 | |
33998 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI | |
33999 | WOK=WK(IWK) | |
34000 | WDK=WOK-WK(IWK-1) | |
34001 | C | |
34002 | C----------------------------- | |
34003 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK | |
34004 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT | |
34005 | C CONTRIBUTE | |
34006 | C---------------------------- | |
34007 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 | |
34008 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 | |
34009 | IF (WICO.EQ.WICOR) GO TO 70 | |
34010 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 | |
34011 | WICOR=WICO | |
34012 | C | |
34013 | C----------------------------- | |
34014 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
34015 | C---------------------------- | |
34016 | EKLIM=-THRESH(IIKI+IK) | |
34017 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
34018 | DELIM=UMO(IELIM)+EKLIM | |
34019 | *+1.D-16 | |
34020 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
34021 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 | |
34022 | 80 DECC=DELIM | |
34023 | GO TO 100 | |
34024 | 90 DECC=DECM | |
34025 | 100 CONTINUE | |
34026 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
34027 | C | |
34028 | C----------------------------- | |
34029 | C*** RANDOM CHOICE | |
34030 | C---------------------------- | |
34031 | C | |
34032 | IF (VV.GT.WKK) GO TO 70 | |
34033 | C | |
34034 | C***IK IS THE REACTION CHANNEL | |
34035 | C---------------------------- | |
34036 | INRK=IKII(IRE)+IK | |
34037 | ECM=HECM | |
34038 | I1001 =0 | |
34039 | C | |
34040 | 110 CONTINUE | |
34041 | IT1=NRK(1,INRK) | |
34042 | AM1=DT_DAMG(IT1) | |
34043 | IT2=NRK(2,INRK) | |
34044 | AM2=DT_DAMG(IT2) | |
34045 | AMS=AM1+AM2 | |
34046 | I1001=I1001+1 | |
34047 | IF (I1001.GT.50) GO TO 60 | |
34048 | C | |
34049 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 | |
34050 | IT11=IT1 | |
34051 | IT22=IT2 | |
34052 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 | |
34053 | AM11=AM1 | |
34054 | AM22=AM2 | |
34055 | IF (IT2.GT.0) GO TO 120 | |
34056 | **sr 19.2.97: supress direct channel for pp-collisions | |
34057 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN | |
34058 | RR = DT_RNDM(AM11) | |
34059 | IF (RR.LE.0.75D0) GOTO 60 | |
34060 | ENDIF | |
34061 | ** | |
34062 | C | |
34063 | C----------------------------- | |
34064 | C INCLUSION OF DIRECT RESONANCES | |
34065 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 | |
34066 | C------------------------ | |
34067 | KZ1=K1H(IT1) | |
34068 | IST=IST+1 | |
34069 | IECO=0 | |
34070 | ECO=ECM | |
34071 | GAM=(ELAB+AMT)/ECO | |
34072 | BGAM=PLAB/ECO | |
34073 | CXS(1)=CX | |
34074 | CYS(1)=CY | |
34075 | CZS(1)=CZ | |
34076 | GO TO 170 | |
34077 | 120 CONTINUE | |
34078 | WW=DT_RNDM(ECO) | |
34079 | IF(WW.LT. 0.5D0) GO TO 130 | |
34080 | IT1=IT22 | |
34081 | IT2=IT11 | |
34082 | AM1=AM22 | |
34083 | AM2=AM11 | |
34084 | 130 CONTINUE | |
34085 | C | |
34086 | C----------------------------- | |
34087 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T | |
34088 | IBN=IBARH(N) | |
34089 | IB1=IBARH(IT1) | |
34090 | IT11=IT1 | |
34091 | IT22=IT2 | |
34092 | AM11=AM1 | |
34093 | AM22=AM2 | |
34094 | IF(IB1.EQ.IBN) GO TO 140 | |
34095 | IT1=IT22 | |
34096 | IT2=IT11 | |
34097 | AM1=AM22 | |
34098 | AM2=AM11 | |
34099 | 140 CONTINUE | |
34100 | C----------------------------- | |
34101 | C***IT1,IT2 ARE THE CREATED PARTICLES | |
34102 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM | |
34103 | C------------------------ | |
34104 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34105 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) | |
34106 | IST=IST+1 | |
34107 | ITS(IST)=IT1 | |
34108 | AMM(IST)=AM1 | |
34109 | C | |
34110 | C----------------------------- | |
34111 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION | |
34112 | C---------------------------- | |
34113 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, | |
34114 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34115 | IST=IST+1 | |
34116 | ITS(IST)=IT2 | |
34117 | AMM(IST)=AM2 | |
34118 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, | |
34119 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34120 | 150 CONTINUE | |
34121 | C | |
34122 | C----------------------------- | |
34123 | C***TEST STABLE OR UNSTABLE | |
34124 | C---------------------------- | |
34125 | IF(ITS(IST).GT.NSTAB) GO TO 160 | |
34126 | IRH=IRH+1 | |
34127 | C | |
34128 | C----------------------------- | |
34129 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE | |
34130 | C---------------------------- | |
34131 | C* IF (REDU.LT.0.D0) GO TO 1009 | |
34132 | ITRH(IRH)=ITS(IST) | |
34133 | PLRH(IRH)=PLS(IST) | |
34134 | CXRH(IRH)=CXS(IST) | |
34135 | CYRH(IRH)=CYS(IST) | |
34136 | CZRH(IRH)=CZS(IST) | |
34137 | ELRH(IRH)=ELS(IST) | |
34138 | IST=IST-1 | |
34139 | IF(IST.GE.1) GO TO 150 | |
34140 | GO TO 260 | |
34141 | 160 CONTINUE | |
34142 | C | |
34143 | C RANDOM CHOICE OF DECAY CHANNELS | |
34144 | C---------------------------- | |
34145 | C | |
34146 | IT=ITS(IST) | |
34147 | ECO=AMM(IST) | |
34148 | GAM=ELS(IST)/ECO | |
34149 | BGAM=PLS(IST)/ECO | |
34150 | IECO=0 | |
34151 | KZ1=K1H(IT) | |
34152 | 170 CONTINUE | |
34153 | IECO=IECO+1 | |
34154 | VV=DT_RNDM(GAM) | |
34155 | VV=VV-1.D-17 | |
34156 | IIK=KZ1-1 | |
34157 | 180 IIK=IIK+1 | |
34158 | IF (VV.GT.WTI(IIK)) GO TO 180 | |
34159 | C | |
34160 | C IIK IS THE DECAY CHANNEL | |
34161 | C---------------------------- | |
34162 | IT1=NZKI(IIK,1) | |
34163 | I310=0 | |
34164 | 190 CONTINUE | |
34165 | I310=I310+1 | |
34166 | AM1=DT_DAMG(IT1) | |
34167 | IT2=NZKI(IIK,2) | |
34168 | AM2=DT_DAMG(IT2) | |
34169 | IF (IT2-1.LT.0) GO TO 240 | |
34170 | IT3=NZKI(IIK,3) | |
34171 | AM3=DT_DAMG(IT3) | |
34172 | AMS=AM1+AM2+AM3 | |
34173 | C | |
34174 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE | |
34175 | C---------------------------- | |
34176 | IF (IECO.LE.10) GO TO 200 | |
34177 | IATMPT=IATMPT+1 | |
34178 | IF(IATMPT.GT.3) THEN | |
34179 | C WRITE(LOUT,*) ' jump 4' | |
34180 | GO TO 280 | |
34181 | ENDIF | |
34182 | GO TO 40 | |
34183 | 200 CONTINUE | |
34184 | IF (I310.GT.50) GO TO 170 | |
34185 | IF (AMS.GT.ECO) GO TO 190 | |
34186 | C | |
34187 | C FOR THE DECAY CHANNEL | |
34188 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT | |
34189 | C---------------------------- | |
34190 | IF (REDU.LT.0.D0) GO TO 30 | |
34191 | ITWTHC=0 | |
34192 | REDU=2.0D0 | |
34193 | IF(IT3.EQ.0) GO TO 220 | |
34194 | 210 CONTINUE | |
34195 | ITWTH=1 | |
34196 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, | |
34197 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
34198 | GO TO 230 | |
34199 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, | |
34200 | &COD2,COF2,SIF2,AM1,AM2) | |
34201 | ITWTH=-1 | |
34202 | IT3=0 | |
34203 | 230 CONTINUE | |
34204 | ITWTHC=ITWTHC+1 | |
34205 | IF (REDU.GT.0.D0) GO TO 240 | |
34206 | REDU=2.0D0 | |
34207 | IF (ITWTHC.GT.100) GO TO 30 | |
34208 | IF (ITWTH) 220,220,210 | |
34209 | 240 CONTINUE | |
34210 | ITS(IST )=IT1 | |
34211 | IF (IT2-1.LT.0) GO TO 250 | |
34212 | ITS(IST+1) =IT2 | |
34213 | ITS(IST+2)=IT3 | |
34214 | RX=CXS(IST) | |
34215 | RY=CYS(IST) | |
34216 | RZ=CZS(IST) | |
34217 | AMM(IST)=AM1 | |
34218 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, | |
34219 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34220 | IST=IST+1 | |
34221 | AMM(IST)=AM2 | |
34222 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, | |
34223 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34224 | IF (IT3.LE.0) GO TO 250 | |
34225 | IST=IST+1 | |
34226 | AMM(IST)=AM3 | |
34227 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, | |
34228 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34229 | 250 CONTINUE | |
34230 | GO TO 150 | |
34231 | 260 CONTINUE | |
34232 | 270 CONTINUE | |
34233 | RETURN | |
34234 | 280 CONTINUE | |
34235 | C | |
34236 | C---------------------------- | |
34237 | C | |
34238 | C ZERO CROSS SECTION CASE | |
34239 | C---------------------------- | |
34240 | C | |
34241 | IRH=1 | |
34242 | ITRH(1)=N | |
34243 | CXRH(1)=CX | |
34244 | CYRH(1)=CY | |
34245 | CZRH(1)=CZ | |
34246 | ELRH(1)=ELAB | |
34247 | PLRH(1)=PLAB | |
34248 | RETURN | |
34249 | END | |
34250 | ||
34251 | *$ CREATE DT_RUNTT.FOR | |
34252 | *COPY DT_RUNTT | |
34253 | * | |
34254 | *===runtt==============================================================* | |
34255 | * | |
34256 | BLOCK DATA DT_RUNTT | |
34257 | ||
34258 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34259 | SAVE | |
34260 | ||
34261 | COMMON /HNDRUN/ RUNTES,EFTES | |
34262 | ||
34263 | DATA RUNTES,EFTES /100.D0,100.D0/ | |
34264 | ||
34265 | END | |
34266 | ||
34267 | *$ CREATE DT_NONAME.FOR | |
34268 | *COPY DT_NONAME | |
34269 | * | |
34270 | *===noname=============================================================* | |
34271 | * | |
34272 | BLOCK DATA DT_NONAME | |
34273 | ||
34274 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34275 | SAVE | |
34276 | ||
34277 | * slope parameters for HADRIN interactions | |
34278 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34279 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34280 | ||
34281 | C DATAS DATAS DATAS DATAS DATAS | |
34282 | C****** ********* | |
34283 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, | |
34284 | & 207, 224, 241, 252, 268 / | |
34285 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, | |
34286 | & 220, 241, 262, 279, 296 / | |
34287 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, | |
34288 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ | |
34289 | ||
34290 | C | |
34291 | C MASSES FOR THE SLOPE B(M) IN GEV | |
34292 | C SLOPE B(M) FOR AN MESONIC SYSTEM | |
34293 | C SLOPE B(M) FOR A BARYONIC SYSTEM | |
34294 | ||
34295 | * | |
34296 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, | |
34297 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, | |
34298 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, | |
34299 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, | |
34300 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, | |
34301 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, | |
34302 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, | |
34303 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, | |
34304 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, | |
34305 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, | |
34306 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, | |
34307 | & 14.2D0, 13.4D0, 12.6D0, | |
34308 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, | |
34309 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / | |
34310 | * | |
34311 | END | |
34312 | ||
34313 | *$ CREATE DT_DAMG.FOR | |
34314 | *COPY DT_DAMG | |
34315 | * | |
34316 | *===damg===============================================================* | |
34317 | * | |
34318 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) | |
34319 | ||
34320 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34321 | SAVE | |
34322 | ||
34323 | * particle properties (BAMJET index convention), | |
34324 | * (dublicate of DTPART for HADRIN) | |
34325 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34326 | & K1H(110),K2H(110) | |
34327 | ||
34328 | DIMENSION GASUNI(14) | |
34329 | DATA GASUNI/ | |
34330 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, | |
34331 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ | |
34332 | DATA GAUNO/2.352D0/ | |
34333 | DATA GAUNON/2.4D0/ | |
34334 | DATA IO/14/ | |
34335 | DATA NSTAB/23/ | |
34336 | ||
34337 | I=1 | |
34338 | IF (IT.LE.0) GO TO 30 | |
34339 | IF (IT.LE.NSTAB) GO TO 20 | |
34340 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) | |
34341 | VV=DT_RNDM(DGAUNI) | |
34342 | VV=VV*2.0D0-1.0D0+1.D-16 | |
34343 | 10 CONTINUE | |
34344 | VO=GASUNI(I) | |
34345 | I=I+1 | |
34346 | V1=GASUNI(I) | |
34347 | IF (VV.GT.V1) GO TO 10 | |
34348 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ | |
34349 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) | |
34350 | DAM=GAH(IT)*UNIGA/GAUNO | |
34351 | AAM=AMH(IT)+DAM | |
34352 | DT_DAMG=AAM | |
34353 | RETURN | |
34354 | 20 CONTINUE | |
34355 | DT_DAMG=AMH(IT) | |
34356 | RETURN | |
34357 | 30 CONTINUE | |
34358 | DT_DAMG=0.0D0 | |
34359 | RETURN | |
34360 | END | |
34361 | ||
34362 | *$ CREATE DT_DCALUM.FOR | |
34363 | *COPY DT_DCALUM | |
34364 | * | |
34365 | *===dcalum=============================================================* | |
34366 | * | |
34367 | SUBROUTINE DT_DCALUM(N,ITTA) | |
34368 | ||
34369 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34370 | SAVE | |
34371 | ||
34372 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION | |
34373 | ||
34374 | * particle properties (BAMJET index convention), | |
34375 | * (dublicate of DTPART for HADRIN) | |
34376 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34377 | & K1H(110),K2H(110) | |
34378 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34379 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34380 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34381 | & NRK(2,268),NURE(30,2) | |
34382 | ||
34383 | IRE=NURE(N,ITTA/8+1) | |
34384 | IEO=IEII(IRE)+1 | |
34385 | IEE=IEII(IRE +1) | |
34386 | AM1=AMH(N ) | |
34387 | AM12=AM1**2 | |
34388 | AM2=AMH(ITTA) | |
34389 | AM22=AM2**2 | |
34390 | DO 10 IE=IEO,IEE | |
34391 | PLAB2=PLABF(IE)**2 | |
34392 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) | |
34393 | UMO(IE)=ELAB | |
34394 | 10 CONTINUE | |
34395 | IKO=IKII(IRE)+1 | |
34396 | IKE=IKII(IRE +1) | |
34397 | UMOO=UMO(IEO) | |
34398 | DO 30 IK=IKO,IKE | |
34399 | IF(NRK(2,IK).GT.0) GO TO 30 | |
34400 | IKI=NRK(1,IK) | |
34401 | AMSS=5.0D0 | |
34402 | K11=K1H(IKI) | |
34403 | K22=K2H(IKI) | |
34404 | DO 20 IK1=K11,K22 | |
34405 | IN=NZKI(IK1,1) | |
34406 | AMS=AMH(IN) | |
34407 | IN=NZKI(IK1,2) | |
34408 | IF(IN.GT.0)AMS=AMS+AMH(IN) | |
34409 | IN=NZKI(IK1,3) | |
34410 | IF(IN.GT.0) AMS=AMS+AMH(IN) | |
34411 | IF (AMS.LT.AMSS) AMSS=AMS | |
34412 | 20 CONTINUE | |
34413 | IF(UMOO.LT.AMSS) UMOO=AMSS | |
34414 | THRESH(IK)=UMOO | |
34415 | 30 CONTINUE | |
34416 | RETURN | |
34417 | END | |
34418 | ||
34419 | *$ CREATE DT_DCHANH.FOR | |
34420 | *COPY DT_DCHANH | |
34421 | * | |
34422 | *===dchanh=============================================================* | |
34423 | * | |
34424 | SUBROUTINE DT_DCHANH | |
34425 | ||
34426 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34427 | SAVE | |
34428 | ||
34429 | PARAMETER ( LINP = 10 , | |
34430 | & LOUT = 6 , | |
34431 | & LDAT = 9 ) | |
34432 | * particle properties (BAMJET index convention), | |
34433 | * (dublicate of DTPART for HADRIN) | |
34434 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34435 | & K1H(110),K2H(110) | |
34436 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34437 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34438 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34439 | & NRK(2,268),NURE(30,2) | |
34440 | ||
34441 | DIMENSION HWT(460),HWK(40),SI(5184) | |
34442 | EQUIVALENCE (WK(1),SI(1)) | |
34443 | C-------------------- | |
34444 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN | |
34445 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, | |
34446 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. | |
34447 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE | |
34448 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) | |
34449 | C-------------------------- | |
34450 | IREG=16 | |
34451 | DO 90 IRE=1,IREG | |
34452 | IWKO=IRII(IRE) | |
34453 | IEE=IEII(IRE+1)-IEII(IRE) | |
34454 | IKE=IKII(IRE+1)-IKII(IRE) | |
34455 | IEO=IEII(IRE)+1 | |
34456 | IIKA=IKII(IRE) | |
34457 | * modifications to suppress elestic scattering 24/07/91 | |
34458 | DO 80 IE=1,IEE | |
34459 | SIS=1.D-14 | |
34460 | SINORC=0.0D0 | |
34461 | DO 10 IK=1,IKE | |
34462 | IWK=IWKO+IEE*(IK-1)+IE | |
34463 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34464 | SIS=SIS+SI(IWK)*SINORC | |
34465 | 10 CONTINUE | |
34466 | SIIN(IEO+IE-1)=SIS | |
34467 | SIO=0.D0 | |
34468 | IF (SIS.GE.1.D-12) GO TO 20 | |
34469 | SIS=1.D0 | |
34470 | SIO=1.D0 | |
34471 | 20 CONTINUE | |
34472 | SINORC=0.0D0 | |
34473 | DO 30 IK=1,IKE | |
34474 | IWK=IWKO+IEE*(IK-1)+IE | |
34475 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34476 | SIO=SIO+SI(IWK)*SINORC/SIS | |
34477 | HWK(IK)=SIO | |
34478 | 30 CONTINUE | |
34479 | DO 40 IK=1,IKE | |
34480 | IWK=IWKO+IEE*(IK-1)+IE | |
34481 | 40 WK(IWK)=HWK(IK) | |
34482 | IIKI=IKII(IRE) | |
34483 | DO 70 IK=1,IKE | |
34484 | AM111=0.D0 | |
34485 | INRK1=NRK(1,IIKI+IK) | |
34486 | IF (INRK1.GT.0) AM111=AMH(INRK1) | |
34487 | AM222=0.D0 | |
34488 | INRK2=NRK(2,IIKI+IK) | |
34489 | IF (INRK2.GT.0) AM222=AMH(INRK2) | |
34490 | THRESH(IIKI+IK)=AM111 +AM222 | |
34491 | IF (INRK2-1.GE.0) GO TO 60 | |
34492 | INRKK=K1H(INRK1) | |
34493 | AMSS=5.D0 | |
34494 | INRKO=K2H(INRK1) | |
34495 | DO 50 INRK1=INRKK,INRKO | |
34496 | INZK1=NZKI(INRK1,1) | |
34497 | INZK2=NZKI(INRK1,2) | |
34498 | INZK3=NZKI(INRK1,3) | |
34499 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 | |
34500 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 | |
34501 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 | |
34502 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 | |
34503 | 1000 FORMAT (4I10) | |
34504 | AMS=AMH(INZK1)+AMH(INZK2) | |
34505 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) | |
34506 | IF (AMSS.GT.AMS) AMSS=AMS | |
34507 | 50 CONTINUE | |
34508 | AMS=AMSS | |
34509 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) | |
34510 | THRESH(IIKI+IK)=AMS | |
34511 | 60 CONTINUE | |
34512 | 70 CONTINUE | |
34513 | 80 CONTINUE | |
34514 | 90 CONTINUE | |
34515 | DO 100 J=1,460 | |
34516 | 100 HWT(J)=0.D0 | |
34517 | DO 120 I=1,110 | |
34518 | IK1=K1H(I) | |
34519 | IK2=K2H(I) | |
34520 | HV=0.D0 | |
34521 | IF (IK2.GT.460)IK2=460 | |
34522 | IF (IK1.LE.0)IK1=1 | |
34523 | DO 110 J=IK1,IK2 | |
34524 | HV=HV+WTI(J) | |
34525 | HWT(J)=HV | |
34526 | JI=J | |
34527 | 110 CONTINUE | |
34528 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV | |
34529 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) | |
34530 | 120 CONTINUE | |
34531 | DO 130 J=1,460 | |
34532 | 130 WTI(J)=HWT(J) | |
34533 | RETURN | |
34534 | END | |
34535 | ||
34536 | *$ CREATE DT_DHADDE.FOR | |
34537 | *COPY DT_DHADDE | |
34538 | * | |
34539 | *===dhadde=============================================================* | |
34540 | * | |
34541 | SUBROUTINE DT_DHADDE | |
34542 | ||
34543 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34544 | SAVE | |
34545 | ||
34546 | * particle properties (BAMJET index convention) | |
34547 | CHARACTER*8 ANAME | |
34548 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
34549 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
34550 | * HADRIN: decay channel information | |
34551 | PARAMETER (IDMAX9=602) | |
34552 | CHARACTER*8 ZKNAME | |
34553 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
34554 | * particle properties (BAMJET index convention), | |
34555 | * (dublicate of DTPART for HADRIN) | |
34556 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34557 | & K1H(110),K2H(110) | |
34558 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34559 | * decay channel information for HADRIN | |
34560 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34561 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34562 | & NZK1(153),NZK2(153),NZK3(153) | |
34563 | ||
34564 | DATA IRETUR/0/ | |
34565 | ||
34566 | IRETUR=IRETUR+1 | |
34567 | AMH(31)=0.48D0 | |
34568 | IF (IRETUR.GT.1) RETURN | |
34569 | DO 10 I=1,94 | |
34570 | AMH(I) = AAM(I) | |
34571 | GAH(I) = GA(I) | |
34572 | TAUH(I) = TAU(I) | |
34573 | ICHH(I) = IICH(I) | |
34574 | IBARH(I) = IIBAR(I) | |
34575 | K1H(I) = K1(I) | |
34576 | K2H(I) = K2(I) | |
34577 | 10 CONTINUE | |
34578 | **sr | |
34579 | C AMH(1)=0.93828D0 | |
34580 | AMH(1)=0.9383D0 | |
34581 | ** | |
34582 | AMH(2)=AMH(1) | |
34583 | DO 20 I=26,30 | |
34584 | K1H(I)=452 | |
34585 | K2H(I)=452 | |
34586 | 20 CONTINUE | |
34587 | DO 30 I=1,307 | |
34588 | WTI(I) = WT(I) | |
34589 | NZKI(I,1) = NZK(I,1) | |
34590 | NZKI(I,2) = NZK(I,2) | |
34591 | NZKI(I,3) = NZK(I,3) | |
34592 | 30 CONTINUE | |
34593 | DO 40 I=1,16 | |
34594 | L=I+94 | |
34595 | AMH(L)=AMZ(I) | |
34596 | GAH( L)=GAZ(I) | |
34597 | TAUH( L)=TAUZ(I) | |
34598 | ICHH( L)=ICHZ(I) | |
34599 | IBARH( L)=IBARZ(I) | |
34600 | K1H( L)=K1Z(I) | |
34601 | K2H( L)=K2Z(I) | |
34602 | 40 CONTINUE | |
34603 | DO 50 I=1,153 | |
34604 | L=I+307 | |
34605 | WTI(L) = WTZ(I) | |
34606 | NZKI(L,3) = NZK3(I) | |
34607 | NZKI(L,2) = NZK2(I) | |
34608 | NZKI(L,1) = NZK1(I) | |
34609 | 50 CONTINUE | |
34610 | RETURN | |
34611 | END | |
34612 | ||
34613 | *$ CREATE IDT_IEFUND.FOR | |
34614 | *COPY IDT_IEFUND | |
34615 | * | |
34616 | *===iefund=============================================================* | |
34617 | * | |
34618 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) | |
34619 | ||
34620 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34621 | SAVE | |
34622 | ||
34623 | C*****IEFUN CALCULATES A MOMENTUM INDEX | |
34624 | ||
34625 | PARAMETER ( LINP = 10 , | |
34626 | & LOUT = 6 , | |
34627 | & LDAT = 9 ) | |
34628 | COMMON /HNDRUN/ RUNTES,EFTES | |
34629 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34630 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34631 | & NRK(2,268),NURE(30,2) | |
34632 | ||
34633 | IPLA=IEII(IRE)+1 | |
34634 | *+1 | |
34635 | IPLE=IEII(IRE+1) | |
34636 | IF (PL.LT.0.) GO TO 30 | |
34637 | DO 10 I=IPLA,IPLE | |
34638 | J=I-IPLA+1 | |
34639 | IF (PL.LE.PLABF(I)) GO TO 60 | |
34640 | 10 CONTINUE | |
34641 | I=IPLE | |
34642 | IF ( EFTES.GT.40.D0) GO TO 20 | |
34643 | EFTES=EFTES+1.0D0 | |
34644 | WRITE(LOUT,1000)PL,J | |
34645 | 20 CONTINUE | |
34646 | GO TO 70 | |
34647 | 30 CONTINUE | |
34648 | DO 40 I=IPLA,IPLE | |
34649 | J=I-IPLA+1 | |
34650 | IF (-PL.LE.UMO(I)) GO TO 60 | |
34651 | 40 CONTINUE | |
34652 | I=IPLE | |
34653 | IF ( EFTES.GT.40.D0) GO TO 50 | |
34654 | EFTES=EFTES+1.0D0 | |
34655 | WRITE(LOUT,1000)PL,I | |
34656 | 50 CONTINUE | |
34657 | 60 CONTINUE | |
34658 | 70 CONTINUE | |
34659 | IDT_IEFUND=I | |
34660 | RETURN | |
34661 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , | |
34662 | +7H IEFUN=,I5) | |
34663 | END | |
34664 | ||
34665 | *$ CREATE DT_DSIGIN.FOR | |
34666 | *COPY DT_DSIGIN | |
34667 | * | |
34668 | *===dsigin=============================================================* | |
34669 | * | |
34670 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) | |
34671 | ||
34672 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34673 | SAVE | |
34674 | ||
34675 | * particle properties (BAMJET index convention), | |
34676 | * (dublicate of DTPART for HADRIN) | |
34677 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34678 | & K1H(110),K2H(110) | |
34679 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34680 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34681 | & NRK(2,268),NURE(30,2) | |
34682 | ||
34683 | IE=IDT_IEFUND(PLAB,IRE) | |
34684 | IF (IE.LE.IEII(IRE)) IE=IE+1 | |
34685 | AMT=AMH(ITAR) | |
34686 | AMN=AMH(N) | |
34687 | AMN2=AMN*AMN | |
34688 | AMT2=AMT*AMT | |
34689 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) | |
34690 | C*** INTERPOLATION PREPARATION | |
34691 | ECMO=UMO(IE) | |
34692 | ECM1=UMO(IE-1) | |
34693 | DECM=ECMO-ECM1 | |
34694 | DEC=ECMO-ECM | |
34695 | IIKI=IKII(IRE)+1 | |
34696 | EKLIM=-THRESH(IIKI) | |
34697 | WOK=SIIN(IE) | |
34698 | WDK=WOK-SIIN(IE-1) | |
34699 | IF (ECM.GT.ECMO) WDK=0.0D0 | |
34700 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
34701 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
34702 | DELIM=UMO(IELIM)+EKLIM | |
34703 | *+1.D-16 | |
34704 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
34705 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 | |
34706 | 10 DECC=DELIM | |
34707 | GO TO 30 | |
34708 | 20 DECC=DECM | |
34709 | 30 CONTINUE | |
34710 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
34711 | IF (WKK.LT.0.0D0) WKK=0.0D0 | |
34712 | SI=WKK+1.D-12 | |
34713 | IF (-EKLIM.GT.ECM) SI=1.D-14 | |
34714 | RETURN | |
34715 | END | |
34716 | ||
34717 | *$ CREATE DT_DTCHOI.FOR | |
34718 | *COPY DT_DTCHOI | |
34719 | * | |
34720 | *===dtchoi=============================================================* | |
34721 | * | |
34722 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) | |
34723 | ||
34724 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34725 | SAVE | |
34726 | ||
34727 | C **************************** | |
34728 | C TCHOIC CALCULATES A RANDOM VALUE | |
34729 | C FOR THE FOUR-MOMENTUM-TRANSFER T | |
34730 | C **************************** | |
34731 | ||
34732 | * particle properties (BAMJET index convention), | |
34733 | * (dublicate of DTPART for HADRIN) | |
34734 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34735 | & K1H(110),K2H(110) | |
34736 | * slope parameters for HADRIN interactions | |
34737 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34738 | ||
34739 | AMA=AM1 | |
34740 | AMB=AM2 | |
34741 | IF (I.GT.30.AND.II.GT.30) GO TO 20 | |
34742 | III=II | |
34743 | AM3=AM2 | |
34744 | IF (I.LE.30) GO TO 10 | |
34745 | III=I | |
34746 | AM3=AM1 | |
34747 | 10 CONTINUE | |
34748 | GO TO 30 | |
34749 | 20 CONTINUE | |
34750 | III=II | |
34751 | AM3=AM2 | |
34752 | IF (AMA.LE.AMB) GO TO 30 | |
34753 | III=I | |
34754 | AM3=AM1 | |
34755 | 30 CONTINUE | |
34756 | IB=IBARH(III) | |
34757 | AMA=AM3 | |
34758 | K=INT((AMA-0.75D0)/0.05D0) | |
34759 | IF (K-2.LT.0) K=1 | |
34760 | IF (K-26.GE.0) K=25 | |
34761 | IF (IB)50,40,50 | |
34762 | 40 BM=BBM(K) | |
34763 | GO TO 60 | |
34764 | 50 BM=BBB(K) | |
34765 | 60 CONTINUE | |
34766 | C NORMALIZATION | |
34767 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 | |
34768 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 | |
34769 | VB=DT_RNDM(TMIN) | |
34770 | **sr test | |
34771 | C IF (VB.LT.0.2D0) BM=BM*0.1 | |
34772 | C **0.5 | |
34773 | BM = BM*5.05D0 | |
34774 | ** | |
34775 | TMI=BM*TMIN | |
34776 | TMA=BM*TMAX | |
34777 | ETMA=0.D0 | |
34778 | IF (ABS(TMA).GT.120.D0) GO TO 70 | |
34779 | ETMA=EXP(TMA) | |
34780 | 70 CONTINUE | |
34781 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) | |
34782 | C*** RANDOM CHOICE OF THE T - VALUE | |
34783 | R=DT_RNDM(TMI) | |
34784 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) | |
34785 | RETURN | |
34786 | END | |
34787 | ||
34788 | *$ CREATE DT_DTWOPA.FOR | |
34789 | *COPY DT_DTWOPA | |
34790 | * | |
34791 | *===dtwopa=============================================================* | |
34792 | * | |
34793 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34794 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) | |
34795 | ||
34796 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34797 | SAVE | |
34798 | ||
34799 | C ****************************************************** | |
34800 | C QUASI TWO PARTICLE PRODUCTION | |
34801 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA | |
34802 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 | |
34803 | C IN THE CM - SYSTEM | |
34804 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR | |
34805 | C SPHERICAL COORDINATES | |
34806 | C ****************************************************** | |
34807 | ||
34808 | * particle properties (BAMJET index convention), | |
34809 | * (dublicate of DTPART for HADRIN) | |
34810 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34811 | & K1H(110),K2H(110) | |
34812 | ||
34813 | AMA=AM1 | |
34814 | AMB=AM2 | |
34815 | AMA2=AMA*AMA | |
34816 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) | |
34817 | E2=UMOO - E1 | |
34818 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 | |
34819 | AMTE=(E1-AMA)*(E1+AMA) | |
34820 | AMTE=AMTE+1.D-18 | |
34821 | P1=SQRT(AMTE) | |
34822 | P2=P1 | |
34823 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS | |
34824 | C DETERMINATION OF THE ANGLES | |
34825 | C COS(THETA1)=COD1 COS(THETA2)=COD2 | |
34826 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 | |
34827 | C COS(PHI1)=COF1 COS(PHI2)=COF2 | |
34828 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) | |
34829 | CALL DT_DSFECF(COF1,SIF1) | |
34830 | COF2=-COF1 | |
34831 | SIF2=-SIF1 | |
34832 | C CALCULATION OF THETA1 | |
34833 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) | |
34834 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) | |
34835 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 | |
34836 | COD2=-COD1 | |
34837 | RETURN | |
34838 | END | |
34839 | ||
34840 | *$ CREATE DT_ZK.FOR | |
34841 | *COPY DT_ZK | |
34842 | * | |
34843 | *===zk=================================================================* | |
34844 | * | |
34845 | BLOCK DATA DT_ZK | |
34846 | ||
34847 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34848 | SAVE | |
34849 | ||
34850 | * decay channel information for HADRIN | |
34851 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34852 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34853 | & NZK1(153),NZK2(153),NZK3(153) | |
34854 | * decay channel information for HADRIN | |
34855 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 | |
34856 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) | |
34857 | ||
34858 | * Particle masses in GeV * | |
34859 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, | |
34860 | & 2*1.7D0, 3*0.D0/ | |
34861 | * Resonance width Gamma in GeV * | |
34862 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / | |
34863 | * Mean life time in seconds * | |
34864 | DATA TAUZ / 16*0.D0 / | |
34865 | * Charge of particles and resonances * | |
34866 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / | |
34867 | * Baryonic charge * | |
34868 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / | |
34869 | * First number of decay channels used for resonances * | |
34870 | * and decaying particles * | |
34871 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, | |
34872 | & 3*460/ | |
34873 | * Last number of decay channels used for resonances * | |
34874 | * and decaying particles * | |
34875 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, | |
34876 | & 3*460/ | |
34877 | * Weight of decay channel * | |
34878 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, | |
34879 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, | |
34880 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, | |
34881 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, | |
34882 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, | |
34883 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, | |
34884 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, | |
34885 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, | |
34886 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, | |
34887 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, | |
34888 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, | |
34889 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, | |
34890 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, | |
34891 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, | |
34892 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, | |
34893 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, | |
34894 | & .05D0, .65D0, 9*1.D0 / | |
34895 | * Particle numbers in decay channel * | |
34896 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, | |
34897 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, | |
34898 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, | |
34899 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, | |
34900 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, | |
34901 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, | |
34902 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, | |
34903 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ | |
34904 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, | |
34905 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, | |
34906 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, | |
34907 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, | |
34908 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, | |
34909 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, | |
34910 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, | |
34911 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, | |
34912 | & 1, 8, 1, 8, 1, 9*0 / | |
34913 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, | |
34914 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, | |
34915 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, | |
34916 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, | |
34917 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, | |
34918 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / | |
34919 | * Particle names * | |
34920 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', | |
34921 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', | |
34922 | & 3*'BLANK' / | |
34923 | * Name of decay channel * | |
34924 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', | |
34925 | & 'ANNPI0','APPPI0','ANPPI-'/ | |
34926 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', | |
34927 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', | |
34928 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', | |
34929 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', | |
34930 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', | |
34931 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', | |
34932 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', | |
34933 | & 'OMOMOM', | |
34934 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', | |
34935 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', | |
34936 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', | |
34937 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', | |
34938 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', | |
34939 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ | |
34940 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', | |
34941 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', | |
34942 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', | |
34943 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', | |
34944 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', | |
34945 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', | |
34946 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', | |
34947 | & 9*'BLANK'/ | |
34948 | *= end*block.zk * | |
34949 | END | |
34950 | ||
34951 | *$ CREATE DT_BLKD43.FOR | |
34952 | *COPY DT_BLKD43 | |
34953 | * | |
34954 | *===blkd43=============================================================* | |
34955 | * | |
34956 | BLOCK DATA DT_BLKD43 | |
34957 | ||
34958 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34959 | SAVE | |
34960 | ||
34961 | * | |
34962 | *=== reac =============================================================* | |
34963 | * | |
34964 | *----------------------------------------------------------------------* | |
34965 | * * | |
34966 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * | |
34967 | * Infn - Milan * | |
34968 | * * | |
34969 | * Last change on 10-dec-91 by Alfredo Ferrari * | |
34970 | * * | |
34971 | * This is the original common reac of Hadrin * | |
34972 | * * | |
34973 | *----------------------------------------------------------------------* | |
34974 | * | |
34975 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34976 | & NRK(2,268),NURE(30,2) | |
34977 | ||
34978 | DIMENSION | |
34979 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), | |
34980 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), | |
34981 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), | |
34982 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), | |
34983 | & SPIKP5(187), SPIKP6(289), | |
34984 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), | |
34985 | & SPIKP9(143), SPIKP0(169), SPKPV(143), | |
34986 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), | |
34987 | & SANPEL(84) , SPIKPF(273), | |
34988 | & SPKP15(187), SPKP16(272), | |
34989 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), | |
34990 | & NURELN(60) | |
34991 | * | |
34992 | DIMENSION NRKLIN(532) | |
34993 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
34994 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) | |
34995 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) | |
34996 | EQUIVALENCE ( UMO(263), UMOK0(1)) | |
34997 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) | |
34998 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) | |
34999 | EQUIVALENCE ( PLABF(263), PLAK0(1)) | |
35000 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) | |
35001 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) | |
35002 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) | |
35003 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) | |
35004 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) | |
35005 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) | |
35006 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) | |
35007 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) | |
35008 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) | |
35009 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) | |
35010 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) | |
35011 | EQUIVALENCE ( WK(4913), SPKP16(1)) | |
35012 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
35013 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) | |
35014 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) | |
35015 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) | |
35016 | EQUIVALENCE (NURE(1,1), NURELN(1)) | |
35017 | * | |
35018 | **** pi- p data * | |
35019 | **** pi+ n data * | |
35020 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, | |
35021 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, | |
35022 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, | |
35023 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, | |
35024 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, | |
35025 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, | |
35026 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, | |
35027 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, | |
35028 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, | |
35029 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / | |
35030 | DATA PLAKC / | |
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 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35038 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35039 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35040 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35041 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35042 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
35043 | DATA PLAK0 / | |
35044 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35045 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35046 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
35047 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
35048 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
35049 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
35050 | * pp pn np nn * | |
35051 | DATA PLAP / | |
35052 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35053 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35054 | & 0.D0, 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 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35057 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35058 | * app apn anp ann * | |
35059 | DATA PLAN / | |
35060 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35061 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35062 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35063 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35064 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35065 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35066 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35067 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35068 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35069 | DATA SIIN / 296*0.D0 / | |
35070 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35071 | & 1.557D0,1.615D0,1.6435D0, | |
35072 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35073 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35074 | & 2.735D0,2.90D0, | |
35075 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35076 | & 1.496D0,1.527D0,1.557D0, | |
35077 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35078 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35079 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35080 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35081 | & 1.496D0,1.527D0,1.557D0, | |
35082 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35083 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35084 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35085 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35086 | & 1.557D0,1.615D0,1.6435D0, | |
35087 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35088 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35089 | & 2.735D0, 2.90D0/ | |
35090 | DATA UMOKC/ 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,1.44D0, | |
35097 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35098 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35099 | & 3.1D0,1.44D0, | |
35100 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35101 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35102 | & 3.1D0/ | |
35103 | DATA UMOK0/ 1.44D0, | |
35104 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35105 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35106 | & 3.1D0,1.44D0, | |
35107 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35108 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35109 | & 3.1D0/ | |
35110 | * pp pn np nn * | |
35111 | DATA UMOP/ | |
35112 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35113 | & 3.D0,3.1D0,3.2D0, | |
35114 | & 1.88D0,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 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35117 | & 3.D0,3.1D0,3.2D0/ | |
35118 | * app apn anp ann * | |
35119 | DATA UMON / | |
35120 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35121 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35122 | & 3.D0,3.1D0,3.2D0, | |
35123 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35124 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35125 | & 3.D0,3.1D0,3.2D0, | |
35126 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35127 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35128 | & 3.D0,3.1D0,3.2D0/ | |
35129 | **** reaction channel state particles * | |
35130 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, | |
35131 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, | |
35132 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, | |
35133 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, | |
35134 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, | |
35135 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, | |
35136 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, | |
35137 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, | |
35138 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, | |
35139 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ | |
35140 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, | |
35141 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, | |
35142 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, | |
35143 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, | |
35144 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, | |
35145 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, | |
35146 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, | |
35147 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / | |
35148 | * * | |
35149 | * k0 p k0 n ak0 p ak/ n * | |
35150 | * * | |
35151 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, | |
35152 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, | |
35153 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, | |
35154 | & 53, 47, 1, 103, 0, 93, 0/ | |
35155 | * pp pn np nn * | |
35156 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, | |
35157 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, | |
35158 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, | |
35159 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / | |
35160 | * app apn anp ann * | |
35161 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, | |
35162 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, | |
35163 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, | |
35164 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, | |
35165 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, | |
35166 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, | |
35167 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / | |
35168 | **** channel cross section * | |
35169 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, | |
35170 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, | |
35171 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, | |
35172 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, | |
35173 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, | |
35174 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, | |
35175 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, | |
35176 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, | |
35177 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, | |
35178 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, | |
35179 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, | |
35180 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, | |
35181 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, | |
35182 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, | |
35183 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, | |
35184 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, | |
35185 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, | |
35186 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, | |
35187 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, | |
35188 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / | |
35189 | **** pi+ n data * | |
35190 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, | |
35191 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35192 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35193 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35194 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, | |
35195 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, | |
35196 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, | |
35197 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, | |
35198 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, | |
35199 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, | |
35200 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, | |
35201 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, | |
35202 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, | |
35203 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, | |
35204 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, | |
35205 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, | |
35206 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, | |
35207 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, | |
35208 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, | |
35209 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35210 | * | |
35211 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35212 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, | |
35213 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, | |
35214 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, | |
35215 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, | |
35216 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, | |
35217 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, | |
35218 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, | |
35219 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, | |
35220 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, | |
35221 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, | |
35222 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, | |
35223 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, | |
35224 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, | |
35225 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, | |
35226 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35227 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, | |
35228 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, | |
35229 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, | |
35230 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / | |
35231 | **** pi- p data * | |
35232 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, | |
35233 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35234 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35235 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35236 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, | |
35237 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, | |
35238 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, | |
35239 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, | |
35240 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, | |
35241 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, | |
35242 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, | |
35243 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, | |
35244 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, | |
35245 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, | |
35246 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, | |
35247 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, | |
35248 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, | |
35249 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, | |
35250 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35251 | * | |
35252 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35253 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, | |
35254 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, | |
35255 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, | |
35256 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, | |
35257 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, | |
35258 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, | |
35259 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, | |
35260 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, | |
35261 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, | |
35262 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, | |
35263 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, | |
35264 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, | |
35265 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35266 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, | |
35267 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, | |
35268 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, | |
35269 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, | |
35270 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, | |
35271 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / | |
35272 | **** pi- n data * | |
35273 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, | |
35274 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, | |
35275 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, | |
35276 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, | |
35277 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, | |
35278 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, | |
35279 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, | |
35280 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, | |
35281 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, | |
35282 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, | |
35283 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, | |
35284 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, | |
35285 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, | |
35286 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, | |
35287 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, | |
35288 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, | |
35289 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, | |
35290 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, | |
35291 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, | |
35292 | & 3.3D0, 5.4D0, 7.D0 / | |
35293 | **** k+ p data * | |
35294 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, | |
35295 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35296 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, | |
35297 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, | |
35298 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35299 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35300 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, | |
35301 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, | |
35302 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, | |
35303 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35304 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, | |
35305 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, | |
35306 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / | |
35307 | **** k+ n data * | |
35308 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, | |
35309 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, | |
35310 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, | |
35311 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, | |
35312 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35313 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, | |
35314 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, | |
35315 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, | |
35316 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, | |
35317 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, | |
35318 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, | |
35319 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, | |
35320 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, | |
35321 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35322 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, | |
35323 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, | |
35324 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, | |
35325 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, | |
35326 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / | |
35327 | **** k- p data * | |
35328 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, | |
35329 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, | |
35330 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, | |
35331 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, | |
35332 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, | |
35333 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, | |
35334 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, | |
35335 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, | |
35336 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, | |
35337 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, | |
35338 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, | |
35339 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ | |
35340 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, | |
35341 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35342 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, | |
35343 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, | |
35344 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, | |
35345 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, | |
35346 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, | |
35347 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, | |
35348 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35349 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, | |
35350 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, | |
35351 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, | |
35352 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35353 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, | |
35354 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, | |
35355 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, | |
35356 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, | |
35357 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, | |
35358 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, | |
35359 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, | |
35360 | & 10*0.D0/ | |
35361 | ***** k- n data * | |
35362 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35363 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, | |
35364 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, | |
35365 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, | |
35366 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, | |
35367 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, | |
35368 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, | |
35369 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ | |
35370 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35371 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35372 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, | |
35373 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35374 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35375 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35376 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35377 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, | |
35378 | & .39D0, .22D0, .07D0, 0.D0, | |
35379 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35380 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, | |
35381 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, | |
35382 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35383 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35384 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, | |
35385 | & 5.10D0, 5.44D0, 5.3D0, | |
35386 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ | |
35387 | ***** p p data * | |
35388 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35389 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35390 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, | |
35391 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35392 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35393 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35394 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35395 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35396 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, | |
35397 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35398 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35399 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35400 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35401 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35402 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35403 | ***** p n data * | |
35404 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35405 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35406 | & 0.D0, 1.8D0, .2D0, 12*0.D0, | |
35407 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35408 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35409 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35410 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35411 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35412 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35413 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35414 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35415 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35416 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35417 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35418 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35419 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, | |
35420 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, | |
35421 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ | |
35422 | * nn - data * | |
35423 | * * | |
35424 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35425 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35426 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, | |
35427 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35428 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35429 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35430 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35431 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, | |
35432 | & 11.D0, 5.5D0, 3.5D0, | |
35433 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35434 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35435 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35436 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35437 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35438 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35439 | **************** ap - p - data * | |
35440 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35441 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35442 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35443 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35444 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35445 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35446 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, | |
35447 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, | |
35448 | & 1.55D0, 1.3D0, .95D0, .75D0, | |
35449 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35450 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35451 | & .01D0, .008D0, .006D0, .005D0/ | |
35452 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35453 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35454 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, | |
35455 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, | |
35456 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, | |
35457 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, | |
35458 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, | |
35459 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, | |
35460 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, | |
35461 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, | |
35462 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35463 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35464 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35465 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, | |
35466 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, | |
35467 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, | |
35468 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, | |
35469 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, | |
35470 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, | |
35471 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / | |
35472 | **************** ap - n - data * | |
35473 | DATA SAPNEL/ | |
35474 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35475 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35476 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35477 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, | |
35478 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, | |
35479 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35480 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35481 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35482 | & .01D0, .008D0, .006D0, .005D0 / | |
35483 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35484 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35485 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35486 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35487 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35488 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35489 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35490 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35491 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35492 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35493 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35494 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35495 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35496 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35497 | * * | |
35498 | * * | |
35499 | **************** an - p - data * | |
35500 | * * | |
35501 | DATA SANPEL/ | |
35502 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, | |
35503 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35504 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, | |
35505 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35506 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35507 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35508 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, | |
35509 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35510 | & .01D0, .008D0, .006D0, .005D0 / | |
35511 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35512 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35513 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35514 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35515 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35516 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35517 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35518 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35519 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35520 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35521 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35522 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35523 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35524 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35525 | **** ko - n - data * | |
35526 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, | |
35527 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35528 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, | |
35529 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35530 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35531 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35532 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35533 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, | |
35534 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, | |
35535 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, | |
35536 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, | |
35537 | & 4.85D0, 4.9D0, | |
35538 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, | |
35539 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, | |
35540 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, | |
35541 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, | |
35542 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / | |
35543 | **** ako - p - data * | |
35544 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35545 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, | |
35546 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, | |
35547 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, | |
35548 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, | |
35549 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, | |
35550 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, | |
35551 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35552 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, | |
35553 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, | |
35554 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, | |
35555 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, | |
35556 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, | |
35557 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35558 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, | |
35559 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, | |
35560 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, | |
35561 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, | |
35562 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, | |
35563 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, | |
35564 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / | |
35565 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, | |
35566 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / | |
35567 | *= end*block.blkdt3 * | |
35568 | END | |
35569 | ||
35570 | *$ CREATE DT_QEL_POL.FOR | |
35571 | *COPY DT_QEL_POL | |
35572 | * | |
35573 | *===qel_pol============================================================* | |
35574 | * | |
35575 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35576 | ||
35577 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35578 | SAVE | |
35579 | ||
35580 | CALL DT_MASS_INI | |
35581 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35582 | ||
35583 | RETURN | |
35584 | END | |
35585 | ||
35586 | *$ CREATE DT_GEN_QEL.FOR | |
35587 | *COPY DT_GEN_QEL | |
35588 | C================================================================== | |
35589 | C Generation of a Quasi-Elastic neutrino scattering | |
35590 | C================================================================== | |
35591 | * | |
35592 | *===gen_qel============================================================* | |
35593 | * | |
35594 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35595 | ||
35596 | C...Generate a quasi-elastic neutrino/antineutrino | |
35597 | C. Interaction on a nuclear target | |
35598 | C. INPUT : LTYP = neutrino type (1,...,6) | |
35599 | C. ENU (GeV) = neutrino energy | |
35600 | C---------------------------------------------------- | |
35601 | ||
35602 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35603 | SAVE | |
35604 | ||
35605 | PARAMETER ( LINP = 10 , | |
35606 | & LOUT = 6 , | |
35607 | & LDAT = 9 ) | |
35608 | PARAMETER (MAXLND=4000) | |
35609 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
35610 | * nuclear potential | |
35611 | LOGICAL LFERMI | |
35612 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
35613 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
35614 | & ETACOU(2),ICOUL,LFERMI | |
35615 | * steering flags for qel neutrino scattering modules | |
35616 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
35617 | **sr - removed (not needed) | |
35618 | C COMMON /CBAD/ LBAD, NBAD | |
35619 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 | |
35620 | ** | |
35621 | ||
35622 | DIMENSION PI(3),PO(3) | |
35623 | CJR+ | |
35624 | DATA ININU/0/ | |
35625 | CJR- | |
35626 | C REAL*8 DBETA(3) | |
35627 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 | |
35628 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) | |
35629 | DATA AMN /0.93827231D0, 0.93956563D0/ | |
35630 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ | |
35631 | DATA INIPRI/0/ | |
35632 | ||
35633 | C DATA PFERMI/0.22D0/ | |
35634 | CGB+...Binding Energy | |
35635 | DATA EBIND/0.008D0/ | |
35636 | CGB-... | |
35637 | ||
35638 | ININU=ININU+1 | |
35639 | IF(ININU.EQ.1)NDSIG=0 | |
35640 | LBAD = 0 | |
35641 | enu0=enu | |
35642 | c write(*,*) enu0 | |
35643 | C...Lepton mass | |
35644 | AML = AML0(LTYP) ! massa leptoni | |
35645 | AML2 = AML**2 ! massa leptoni **2 | |
35646 | C...Particle labels (LUND) | |
35647 | N = 5 | |
35648 | K(1,1) = 21 | |
35649 | K(2,1) = 21 | |
35650 | K(3,1) = 21 | |
35651 | K(3,3) = 1 | |
35652 | K(4,1) = 1 | |
35653 | K(4,3) = 1 | |
35654 | K(5,1) = 1 | |
35655 | K(5,3) = 2 | |
35656 | K0 = (LTYP-1)/2 ! 2 | |
35657 | K1 = LTYP/2 ! 2 | |
35658 | KA = 12 + 2*K0 ! 16 | |
35659 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 | |
35660 | K(1,2) = IS*KA | |
35661 | K(4,2) = IS*(KA-1) | |
35662 | K(3,2) = IS*24 | |
35663 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 | |
35664 | IF (LNU .EQ. 2) THEN | |
35665 | K(2,2) = 2212 | |
35666 | K(5,2) = 2112 | |
35667 | AMI = AMN(1) | |
35668 | AMF = AMN(2) | |
35669 | CJR+ | |
35670 | PFERMI=PFERMN(2) | |
35671 | CJR- | |
35672 | ELSE | |
35673 | K(2,2) = 2112 | |
35674 | K(5,2) = 2212 | |
35675 | AMI = AMN(2) | |
35676 | AMF = AMN(1) | |
35677 | CJR+ | |
35678 | PFERMI=PFERMP(2) | |
35679 | CJR- | |
35680 | ENDIF | |
35681 | AMI2 = AMI**2 | |
35682 | AMF2 = AMF**2 | |
35683 | ||
35684 | DO IGB=1,5 | |
35685 | P(3,IGB) = 0. | |
35686 | P(4,IGB) = 0. | |
35687 | P(5,IGB) = 0. | |
35688 | END DO | |
35689 | ||
35690 | NTRY = 0 | |
35691 | CGB+... | |
35692 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy | |
35693 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well | |
35694 | CGB-... | |
35695 | ||
35696 | 100 CONTINUE | |
35697 | ||
35698 | C...4-momentum initial lepton | |
35699 | P(1,5) = 0. ! massa | |
35700 | P(1,4) = ENU0 ! energia | |
35701 | P(1,1) = 0. ! px | |
35702 | P(1,2) = 0. ! py | |
35703 | P(1,3) = ENU0 ! pz | |
35704 | ||
35705 | C PF = PFERMI*PYR(0)**(1./3.) | |
35706 | c write(23,*) PYR(0) | |
35707 | c write(*,*) 'Pfermi=',PF | |
35708 | c PF = 0. | |
35709 | NTRY=NTRY+1 | |
35710 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 | |
35711 | IF (NTRY .GT. 500) THEN | |
35712 | LBAD = 1 | |
35713 | WRITE (LOUT,1001) NBAD, ENU | |
35714 | RETURN | |
35715 | ENDIF | |
35716 | C CT = -1. + 2.*PYR(0) | |
35717 | c CT = -1. | |
35718 | C ST = SQRT(1.-CT*CT) | |
35719 | C F = 2.*3.1415926*PYR(0) | |
35720 | c F = 0. | |
35721 | ||
35722 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia | |
35723 | C P(2,1) = PF*ST*COS(F) ! px | |
35724 | C P(2,2) = PF*ST*SIN(F) ! py | |
35725 | C P(2,3) = PF*CT ! pz | |
35726 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa | |
35727 | P(2,1) = P21 | |
35728 | P(2,2) = P22 | |
35729 | P(2,3) = P23 | |
35730 | P(2,4) = P24 | |
35731 | P(2,5) = P25 | |
35732 | beta1=-p(2,1)/p(2,4) | |
35733 | beta2=-p(2,2)/p(2,4) | |
35734 | beta3=-p(2,3)/p(2,4) | |
35735 | N=2 | |
35736 | C WRITE(6,*)' before transforming into target rest frame' | |
35737 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
35738 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
35739 | N=5 | |
35740 | ||
35741 | phi11=atan(p(1,2)/p(1,3)) | |
35742 | pi(1)=p(1,1) | |
35743 | pi(2)=p(1,2) | |
35744 | pi(3)=p(1,3) | |
35745 | ||
35746 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
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 | phi12=atan(p(1,1)/p(1,3)) | |
35755 | ||
35756 | pi(1)=p(1,1) | |
35757 | pi(2)=p(1,2) | |
35758 | pi(3)=p(1,3) | |
35759 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
35760 | DO ll=1,3 | |
35761 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35762 | END DO | |
35763 | c WRITE(*,*) po | |
35764 | p(1,1)=po(1) | |
35765 | p(1,2)=po(2) | |
35766 | p(1,3)=po(3) | |
35767 | ||
35768 | enu=p(1,4) | |
35769 | ||
35770 | C...Kinematical limits in Q**2 | |
35771 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? | |
35772 | S = P(2,5)**2 + 2.*ENU*P(2,5) | |
35773 | SQS = SQRT(S) ! E centro massa | |
35774 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 | |
35775 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p | |
35776 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. | |
35777 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale | |
35778 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - | |
35779 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) | |
35780 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico | |
35781 | ||
35782 | C...Generate Q**2 | |
35783 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) | |
35784 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
35785 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) | |
35786 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
35787 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) | |
35788 | NDSIG=NDSIG+1 | |
35789 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', | |
35790 | C &Q2,Q2min,Q2MAX,DSIGEV | |
35791 | ||
35792 | C...c.m. frame. Neutrino along z axis | |
35793 | DETOT = (P(1,4)) + (P(2,4)) ! e totale | |
35794 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x | |
35795 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! | |
35796 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! | |
35797 | c WRITE(*,*) | |
35798 | c WRITE(*,*) | |
35799 | C WRITE(*,*) 'Input values laboratory frame' | |
35800 | N=2 | |
35801 | ||
35802 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) | |
35803 | ||
35804 | N=5 | |
35805 | c STHETA = ULANGL(P(1,3),P(1,1)) | |
35806 | c write(*,*) 'stheta' ,stheta | |
35807 | c stheta=0. | |
35808 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) | |
35809 | c WRITE(*,*) | |
35810 | c WRITE(*,*) | |
35811 | C WRITE(*,*) 'Output values cm frame' | |
35812 | C...Kinematic in c.m. frame | |
35813 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm | |
35814 | STSTAR = SQRT(1.-CTSTAR**2) | |
35815 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi | |
35816 | P(4,5) = AML ! massa leptone | |
35817 | P(4,4) = ELF ! e leptone | |
35818 | P(4,3) = PLF*CTSTAR ! px | |
35819 | P(4,1) = PLF*STSTAR*COS(PHI) ! py | |
35820 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz | |
35821 | ||
35822 | P(5,5) = AMF ! barione | |
35823 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione | |
35824 | P(5,3) = -P(4,3) ! px | |
35825 | P(5,1) = -P(4,1) ! py | |
35826 | P(5,2) = -P(4,2) ! pz | |
35827 | ||
35828 | P(3,5) = -Q2 | |
35829 | P(3,1) = P(1,1)-P(4,1) | |
35830 | P(3,2) = P(1,2)-P(4,2) | |
35831 | P(3,3) = P(1,3)-P(4,3) | |
35832 | P(3,4) = P(1,4)-P(4,4) | |
35833 | ||
35834 | C...Transform back to laboratory frame | |
35835 | C WRITE(*,*) 'before going back to nucl rest frame' | |
35836 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) | |
35837 | N=5 | |
35838 | ||
35839 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) | |
35840 | ||
35841 | C WRITE(*,*) 'Now back in nucl rest frame' | |
35842 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) | |
35843 | ||
35844 | c******************************************** | |
35845 | ||
35846 | DO kw=1,5 | |
35847 | pi(1)=p(kw,1) | |
35848 | pi(2)=p(kw,2) | |
35849 | pi(3)=p(kw,3) | |
35850 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
35851 | DO ll=1,3 | |
35852 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35853 | END DO | |
35854 | p(kw,1)=po(1) | |
35855 | p(kw,2)=po(2) | |
35856 | p(kw,3)=po(3) | |
35857 | END DO | |
35858 | c******************************************** | |
35859 | ||
35860 | DO kw=1,5 | |
35861 | pi(1)=p(kw,1) | |
35862 | pi(2)=p(kw,2) | |
35863 | pi(3)=p(kw,3) | |
35864 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
35865 | DO ll=1,3 | |
35866 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35867 | END DO | |
35868 | p(kw,1)=po(1) | |
35869 | p(kw,2)=po(2) | |
35870 | p(kw,3)=po(3) | |
35871 | END DO | |
35872 | ||
35873 | c******************************************** | |
35874 | ||
35875 | C WRITE(*,*) 'Now back in lab frame' | |
35876 | ||
35877 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
35878 | ||
35879 | CGB+... | |
35880 | C...test (on final momentum of nucleon) if Fermi-blocking | |
35881 | C...is operating | |
35882 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) | |
35883 | & - P(5,5) | |
35884 | IF (ENUCL.LT. EFMAX) THEN | |
35885 | IF(INIPRI.LT.10)THEN | |
35886 | INIPRI=INIPRI+1 | |
35887 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX | |
35888 | C...the interaction is not possible due to Pauli-Blocking and | |
35889 | C...it must be resampled | |
35890 | ENDIF | |
35891 | GOTO 100 | |
35892 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN | |
35893 | IF(INIPRI.LT.10)THEN | |
35894 | INIPRI=INIPRI+1 | |
35895 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL | |
35896 | ENDIF | |
35897 | C Reject (J:R) here all these events | |
35898 | C are otherwise rejected in dpmjet | |
35899 | GOTO 100 | |
35900 | C...the interaction is possible, but the nucleon remains inside | |
35901 | C...the nucleus. The nucleus is therefore left excited. | |
35902 | C...We treat this case as a nucleon with 0 kinetic energy. | |
35903 | C P(5,5) = AMF | |
35904 | C P(5,4) = AMF | |
35905 | C P(5,1) = 0. | |
35906 | C P(5,2) = 0. | |
35907 | C P(5,3) = 0. | |
35908 | ELSE IF (ENUCL.GE.ENWELL) THEN | |
35909 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL | |
35910 | C...the interaction is possible, the nucleon can exit the nucleus | |
35911 | C...but the nuclear well depth must be subtracted. The nucleus could be | |
35912 | C...left in an excited state. | |
35913 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) | |
35914 | C P(5,4) = ENUCL-ENWELL + AMF | |
35915 | Pnucl = SQRT(P(5,4)**2-AMF**2) | |
35916 | C...The 3-momentum is scaled assuming that the direction remains | |
35917 | C...unaffected | |
35918 | P(5,1) = P(5,1) * Pnucl/Pstart | |
35919 | P(5,2) = P(5,2) * Pnucl/Pstart | |
35920 | P(5,3) = P(5,3) * Pnucl/Pstart | |
35921 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) | |
35922 | ENDIF | |
35923 | CGB-... | |
35924 | DSIGSU=DSIGSU+DSIGEV | |
35925 | ||
35926 | GA=P(4,4)/P(4,5) | |
35927 | BGX=P(4,1)/P(4,5) | |
35928 | BGY=P(4,2)/P(4,5) | |
35929 | BGZ=P(4,3)/P(4,5) | |
35930 | * | |
35931 | DBETB(1)=BGX/GA | |
35932 | DBETB(2)=BGY/GA | |
35933 | DBETB(3)=BGZ/GA | |
35934 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN | |
35935 | ||
35936 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) | |
35937 | ||
35938 | ENDIF | |
35939 | c | |
35940 | C PRINT*,' FINE EVENTO ' | |
35941 | enu=enu0 | |
35942 | RETURN | |
35943 | ||
35944 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) | |
35945 | END | |
35946 | ||
35947 | *$ CREATE DT_MASS_INI.FOR | |
35948 | *COPY DT_MASS_INI | |
35949 | C==================================================================== | |
35950 | C. Masses | |
35951 | C==================================================================== | |
35952 | * | |
35953 | *===mass_ini===========================================================* | |
35954 | * | |
35955 | SUBROUTINE DT_MASS_INI | |
35956 | C...Initialize the kinematics for the quasi-elastic cross section | |
35957 | ||
35958 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35959 | SAVE | |
35960 | ||
35961 | * particle masses used in qel neutrino scattering modules | |
35962 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
35963 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
35964 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
35965 | ||
35966 | EML(1) = 0.51100D-03 ! e- | |
35967 | EML(2) = EML(1) ! e+ | |
35968 | EML(3) = 0.105659D0 ! mu- | |
35969 | EML(4) = EML(3) ! mu+ | |
35970 | EML(5) = 1.7777D0 ! tau- | |
35971 | EML(6) = EML(5) ! tau+ | |
35972 | EMPROT = 0.93827231D0 ! p | |
35973 | EMNEUT = 0.93956563D0 ! n | |
35974 | EMPROTSQ = EMPROT**2 | |
35975 | EMNEUTSQ = EMNEUT**2 | |
35976 | EMN = (EMPROT + EMNEUT)/2. | |
35977 | EMNSQ = EMN**2 | |
35978 | DO J=1,3 | |
35979 | J0 = 2*(J-1) | |
35980 | EMN1(J0+1) = EMNEUT | |
35981 | EMN1(J0+2) = EMPROT | |
35982 | EMN2(J0+1) = EMPROT | |
35983 | EMN2(J0+2) = EMNEUT | |
35984 | ENDDO | |
35985 | DO J=1,6 | |
35986 | EMLSQ(J) = EML(J)**2 | |
35987 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) | |
35988 | ENDDO | |
35989 | RETURN | |
35990 | END | |
35991 | ||
35992 | *$ CREATE DT_DSQEL_Q2.FOR | |
35993 | *COPY DT_DSQEL_Q2 | |
35994 | * | |
35995 | *===dsqel_q2===========================================================* | |
35996 | * | |
35997 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) | |
35998 | ||
35999 | C...differential cross section for Quasi-Elastic scattering | |
36000 | C. nu + N -> l + N' | |
36001 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). | |
36002 | C. | |
36003 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau | |
36004 | C. ENU (GeV) = Neutrino energy | |
36005 | C. Q2 (GeV**2) = (Transfer momentum)**2 | |
36006 | C. | |
36007 | C. OUTPUT : DSQEL_Q2 = differential cross section : | |
36008 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) | |
36009 | C------------------------------------------------------------------ | |
36010 | ||
36011 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36012 | SAVE | |
36013 | ||
36014 | * particle masses used in qel neutrino scattering modules | |
36015 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
36016 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
36017 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
36018 | **sr - removed (not needed) | |
36019 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
36020 | ** | |
36021 | ||
36022 | DIMENSION SS(6) | |
36023 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
36024 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
36025 | DATA AXIAL2 /1.03D0/ ! to be checked | |
36026 | ||
36027 | FA0=-1.253D0 | |
36028 | CSI = 3.71D0 ! ??? | |
36029 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) | |
36030 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
36031 | X = Q2/(EMN*EMN) ! emn=massa barione | |
36032 | XA = X/4.D0 | |
36033 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
36034 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
36035 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 | |
36036 | FFA = FA*FA | |
36037 | FFV1 = FV1*FV1 | |
36038 | FFV2 = FV2*FV2 | |
36039 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
36040 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 | |
36041 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
36042 | AA = (XA+0.25D0*RM)*(A1 + A2) | |
36043 | BB = -X*FA*(FV1 + FV2) | |
36044 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) | |
36045 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
36046 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! | |
36047 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 | |
36048 | ||
36049 | RETURN | |
36050 | END | |
36051 | ||
36052 | *$ CREATE DT_PREPOLA.FOR | |
36053 | *COPY DT_PREPOLA | |
36054 | * | |
36055 | *===prepola============================================================* | |
36056 | * | |
36057 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) | |
36058 | ||
36059 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36060 | SAVE | |
36061 | c | |
36062 | c By G. Battistoni and E. Scapparone (sept. 1997) | |
36063 | c According to: | |
36064 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 | |
36065 | c | |
36066 | c | |
36067 | PARAMETER (MAXLND=4000) | |
36068 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36069 | COMMON /QNPOL/ POLARX(4),PMODUL | |
36070 | * particle masses used in qel neutrino scattering modules | |
36071 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
36072 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
36073 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
36074 | * steering flags for qel neutrino scattering modules | |
36075 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
36076 | **sr - removed (not needed) | |
36077 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
36078 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, | |
36079 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN | |
36080 | ** | |
36081 | REAL*8 POL(4,4),BB2(3) | |
36082 | DIMENSION SS(6) | |
36083 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
36084 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
36085 | **sr uncommented since common block CAXIAL is now commented | |
36086 | DATA AXIAL2 /1.03D0/ ! to be checked | |
36087 | ** | |
36088 | ||
36089 | RML=P(4,5) | |
36090 | RMM=0.93960D+00 | |
36091 | FM2 = RMM**2 | |
36092 | MPI = 0.135D+00 | |
36093 | OLDQ2=Q2 | |
36094 | FA0=-1.253D+00 | |
36095 | CSI = 3.71D+00 ! | |
36096 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) | |
36097 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
36098 | X = Q2/(EMN*EMN) ! emn=massa barione | |
36099 | XA = X/4.D0 | |
36100 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
36101 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
36102 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 | |
36103 | FFA = FA*FA | |
36104 | FFV1 = FV1*FV1 | |
36105 | FFV2 = FV2*FV2 | |
36106 | FP=2.D0*FA*RMM/(MPI**2 + Q2) | |
36107 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
36108 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 | |
36109 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
36110 | AA = (XA+0.25D+00*RM)*(A1 + A2) | |
36111 | BB = -X*FA*(FV1 + FV2) | |
36112 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) | |
36113 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
36114 | ||
36115 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith | |
36116 | OMEGA2=4.D+00*CC | |
36117 | OMEGA3=2.D+00*FA*(FV1+FV2) | |
36118 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ | |
36119 | 1 (Q2/FM2))*FP**2) | |
36120 | OMEGA5=OMEGA2 | |
36121 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 | |
36122 | WW1=2.D+00*OMEGA1*EMN**2 | |
36123 | WW2=2.D+00*OMEGA2*EMN**2 | |
36124 | WW3=2.D+00*OMEGA3*EMN**2 | |
36125 | WW4=2.D+00*OMEGA4*EMN**2 | |
36126 | WW5=2.D+00*OMEGA5*EMN**2 | |
36127 | ||
36128 | DO I=1,3 | |
36129 | BB2(I)=-P(4,I)/P(4,4) | |
36130 | END DO | |
36131 | c WRITE(*,*) | |
36132 | c WRITE(*,*) | |
36133 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' | |
36134 | N=5 | |
36135 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) | |
36136 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME | |
36137 | c WRITE(*,*) | |
36138 | c WRITE(*,*) | |
36139 | c WRITE(*,*) 'Prepola: now in lepton rest frame' | |
36140 | EE=ENU | |
36141 | QM2=Q2+RML**2 | |
36142 | U=Q2/(2.*RMM) | |
36143 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* | |
36144 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + | |
36145 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! | |
36146 | ||
36147 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 | |
36148 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! | |
36149 | ||
36150 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) | |
36151 | ||
36152 | DO I=1,3 | |
36153 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC | |
36154 | POLARX(I)=POL(4,I) | |
36155 | END DO | |
36156 | ||
36157 | PMODUL=0.D0 | |
36158 | DO I=1,3 | |
36159 | PMODUL=PMODUL+POL(4,I)**2 | |
36160 | END DO | |
36161 | ||
36162 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN | |
36163 | IF(NEUDEC.EQ.1) THEN | |
36164 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), | |
36165 | + ETL,PXL,PYL,PZL, | |
36166 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36167 | c | |
36168 | c Tau has decayed in muon | |
36169 | c | |
36170 | ENDIF | |
36171 | IF(NEUDEC.EQ.2) THEN | |
36172 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), | |
36173 | + ETL,PXL,PYL,PZL, | |
36174 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36175 | c | |
36176 | c Tau has decayed in electron | |
36177 | c | |
36178 | ENDIF | |
36179 | K(4,1)=15 | |
36180 | K(4,4) = 6 | |
36181 | K(4,5) = 8 | |
36182 | N=N+3 | |
36183 | c | |
36184 | c fill common for muon(electron) | |
36185 | c | |
36186 | P(6,1)=PXL | |
36187 | P(6,2)=PYL | |
36188 | P(6,3)=PZL | |
36189 | P(6,4)=ETL | |
36190 | K(6,1)=1 | |
36191 | IF(JTYP.EQ.5) THEN | |
36192 | IF(NEUDEC.EQ.1) THEN | |
36193 | P(6,5)=EML(JTYP-2) | |
36194 | K(6,2)=13 | |
36195 | ELSEIF(NEUDEC.EQ.2) THEN | |
36196 | P(6,5)=EML(JTYP-4) | |
36197 | K(6,2)=11 | |
36198 | ENDIF | |
36199 | ELSEIF(JTYP.EQ.6) THEN | |
36200 | IF(NEUDEC.EQ.1) THEN | |
36201 | K(6,2)=-13 | |
36202 | ELSEIF(NEUDEC.EQ.2) THEN | |
36203 | K(6,2)=-11 | |
36204 | ENDIF | |
36205 | END IF | |
36206 | K(6,3)=4 | |
36207 | K(6,4)=0 | |
36208 | K(6,5)=0 | |
36209 | c | |
36210 | c fill common for tau_(anti)neutrino | |
36211 | c | |
36212 | P(7,1)=PXB | |
36213 | P(7,2)=PYB | |
36214 | P(7,3)=PZB | |
36215 | P(7,4)=ETB | |
36216 | P(7,5)=0. | |
36217 | K(7,1)=1 | |
36218 | IF(JTYP.EQ.5) THEN | |
36219 | K(7,2)=16 | |
36220 | ELSEIF(JTYP.EQ.6) THEN | |
36221 | K(7,2)=-16 | |
36222 | END IF | |
36223 | K(7,3)=4 | |
36224 | K(7,4)=0 | |
36225 | K(7,5)=0 | |
36226 | c | |
36227 | c Fill common for muon(electron)_(anti)neutrino | |
36228 | c | |
36229 | P(8,1)=PXN | |
36230 | P(8,2)=PYN | |
36231 | P(8,3)=PZN | |
36232 | P(8,4)=ETN | |
36233 | P(8,5)=0. | |
36234 | K(8,1)=1 | |
36235 | IF(JTYP.EQ.5) THEN | |
36236 | IF(NEUDEC.EQ.1) THEN | |
36237 | K(8,2)=-14 | |
36238 | ELSEIF(NEUDEC.EQ.2) THEN | |
36239 | K(8,2)=-12 | |
36240 | ENDIF | |
36241 | ELSEIF(JTYP.EQ.6) THEN | |
36242 | IF(NEUDEC.EQ.1) THEN | |
36243 | K(8,2)=14 | |
36244 | ELSEIF(NEUDEC.EQ.2) THEN | |
36245 | K(8,2)=12 | |
36246 | ENDIF | |
36247 | END IF | |
36248 | K(8,3)=4 | |
36249 | K(8,4)=0 | |
36250 | K(8,5)=0 | |
36251 | ENDIF | |
36252 | c WRITE(*,*) | |
36253 | c WRITE(*,*) | |
36254 | ||
36255 | c IF(PMODUL.GE.1.D+00) THEN | |
36256 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36257 | c write(*,*) pmodul | |
36258 | c DO I=1,3 | |
36259 | c POL(4,I)=POL(4,I)/PMODUL | |
36260 | c POLARX(I)=POL(4,I) | |
36261 | c END DO | |
36262 | c PMODUL=0. | |
36263 | c DO I=1,3 | |
36264 | c PMODUL=PMODUL+POL(4,I)**2 | |
36265 | c END DO | |
36266 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36267 | c | |
36268 | c ENDIF | |
36269 | ||
36270 | c WRITE(*,*) 'PMODUL = ',PMODUL | |
36271 | ||
36272 | c WRITE(*,*) | |
36273 | c WRITE(*,*) | |
36274 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' | |
36275 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) | |
36276 | ||
36277 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) | |
36278 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) | |
36279 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) | |
36280 | DO NDC =6,8 | |
36281 | V(NDC,1) = XDC | |
36282 | V(NDC,2) = YDC | |
36283 | V(NDC,3) = ZDC | |
36284 | END DO | |
36285 | ||
36286 | RETURN | |
36287 | END | |
36288 | ||
36289 | *$ CREATE DT_TESTROT.FOR | |
36290 | *COPY DT_TESTROT | |
36291 | * | |
36292 | *===testrot============================================================* | |
36293 | * | |
36294 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) | |
36295 | ||
36296 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36297 | SAVE | |
36298 | ||
36299 | DIMENSION ROT(3,3),PI(3),PO(3) | |
36300 | ||
36301 | IF (MODE.EQ.1) THEN | |
36302 | ROT(1,1) = 1.D0 | |
36303 | ROT(1,2) = 0.D0 | |
36304 | ROT(1,3) = 0.D0 | |
36305 | ROT(2,1) = 0.D0 | |
36306 | ROT(2,2) = COS(PHI) | |
36307 | ROT(2,3) = -SIN(PHI) | |
36308 | ROT(3,1) = 0.D0 | |
36309 | ROT(3,2) = SIN(PHI) | |
36310 | ROT(3,3) = COS(PHI) | |
36311 | ELSEIF (MODE.EQ.2) THEN | |
36312 | ROT(1,1) = 0.D0 | |
36313 | ROT(1,2) = 1.D0 | |
36314 | ROT(1,3) = 0.D0 | |
36315 | ROT(2,1) = COS(PHI) | |
36316 | ROT(2,2) = 0.D0 | |
36317 | ROT(2,3) = -SIN(PHI) | |
36318 | ROT(3,1) = SIN(PHI) | |
36319 | ROT(3,2) = 0.D0 | |
36320 | ROT(3,3) = COS(PHI) | |
36321 | ELSEIF (MODE.EQ.3) THEN | |
36322 | ROT(1,1) = 0.D0 | |
36323 | ROT(2,1) = 1.D0 | |
36324 | ROT(3,1) = 0.D0 | |
36325 | ROT(1,2) = COS(PHI) | |
36326 | ROT(2,2) = 0.D0 | |
36327 | ROT(3,2) = -SIN(PHI) | |
36328 | ROT(1,3) = SIN(PHI) | |
36329 | ROT(2,3) = 0.D0 | |
36330 | ROT(3,3) = COS(PHI) | |
36331 | ELSEIF (MODE.EQ.4) THEN | |
36332 | ROT(1,1) = 1.D0 | |
36333 | ROT(2,1) = 0.D0 | |
36334 | ROT(3,1) = 0.D0 | |
36335 | ROT(1,2) = 0.D0 | |
36336 | ROT(2,2) = COS(PHI) | |
36337 | ROT(3,2) = -SIN(PHI) | |
36338 | ROT(1,3) = 0.D0 | |
36339 | ROT(2,3) = SIN(PHI) | |
36340 | ROT(3,3) = COS(PHI) | |
36341 | ELSE | |
36342 | STOP ' TESTROT: mode not supported!' | |
36343 | ENDIF | |
36344 | DO 1 J=1,3 | |
36345 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) | |
36346 | 1 CONTINUE | |
36347 | ||
36348 | RETURN | |
36349 | END | |
36350 | ||
36351 | *$ CREATE DT_LEPDCYP.FOR | |
36352 | *COPY DT_LEPDCYP | |
36353 | * | |
36354 | *===lepdcyp============================================================* | |
36355 | * | |
36356 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, | |
36357 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36358 | C | |
36359 | C----------------------------------------------------------------- | |
36360 | C | |
36361 | C Author :- G. Battistoni 10-NOV-1995 | |
36362 | C | |
36363 | C================================================================= | |
36364 | C | |
36365 | C Purpose : performs decay of polarized lepton in | |
36366 | C its rest frame: a => b + l + anti-nu | |
36367 | C (Example: mu- => nu-mu + e- + anti-nu-e) | |
36368 | C Polarization is assumed along Z-axis | |
36369 | C WARNING: | |
36370 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS | |
36371 | C OF NEGLIGIBLE MASS | |
36372 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED | |
36373 | C IN THIS VERSION | |
36374 | C | |
36375 | C Method : modifies phase space distribution obtained | |
36376 | C by routine EXPLOD using a rejection against the | |
36377 | C matrix element for unpolarized lepton decay | |
36378 | C | |
36379 | C Inputs : Mass of a : AMA | |
36380 | C Mass of l : AML | |
36381 | C Polar. of a: POL | |
36382 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, | |
36383 | C POL = -1) | |
36384 | C | |
36385 | C Outputs : kinematic variables in the rest frame of decaying lepton | |
36386 | C ETL,PXL,PYL,PZL 4-moment of l | |
36387 | C ETB,PXB,PYB,PZB 4-moment of b | |
36388 | C ETN,PXN,PYN,PZN 4-moment of anti-nu | |
36389 | C | |
36390 | C============================================================ | |
36391 | C + | |
36392 | C Declarations. | |
36393 | C - | |
36394 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36395 | SAVE | |
36396 | ||
36397 | PARAMETER ( LINP = 10 , | |
36398 | & LOUT = 6 , | |
36399 | & LDAT = 9 ) | |
36400 | PARAMETER ( KALGNM = 2 ) | |
36401 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
36402 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
36403 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
36404 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
36405 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
36406 | PARAMETER ( AINFNT = 1.0D+30 ) | |
36407 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
36408 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
36409 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
36410 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
36411 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
36412 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
36413 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
36414 | PARAMETER ( ZERZER = 0.D+00 ) | |
36415 | PARAMETER ( ONEONE = 1.D+00 ) | |
36416 | PARAMETER ( TWOTWO = 2.D+00 ) | |
36417 | PARAMETER ( THRTHR = 3.D+00 ) | |
36418 | PARAMETER ( FOUFOU = 4.D+00 ) | |
36419 | PARAMETER ( FIVFIV = 5.D+00 ) | |
36420 | PARAMETER ( SIXSIX = 6.D+00 ) | |
36421 | PARAMETER ( SEVSEV = 7.D+00 ) | |
36422 | PARAMETER ( EIGEIG = 8.D+00 ) | |
36423 | PARAMETER ( ANINEN = 9.D+00 ) | |
36424 | PARAMETER ( TENTEN = 10.D+00 ) | |
36425 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
36426 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
36427 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
36428 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
36429 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) | |
36430 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) | |
36431 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
36432 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
36433 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
36434 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
36435 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
36436 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
36437 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
36438 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
36439 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
36440 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
36441 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
36442 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
36443 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
36444 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
36445 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
36446 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
36447 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
36448 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
36449 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
36450 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
36451 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
36452 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
36453 | C + | |
36454 | C variables for EXPLOD | |
36455 | C - | |
36456 | PARAMETER ( KPMX = 10 ) | |
36457 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), | |
36458 | & PZEXPL (KPMX), ETEXPL (KPMX) | |
36459 | C + | |
36460 | C test variables | |
36461 | C - | |
36462 | **sr - removed (not needed) | |
36463 | C COMMON /GBATNU/ ELERAT,NTRY | |
36464 | ** | |
36465 | C + | |
36466 | C Initializes test variables | |
36467 | C - | |
36468 | NTRY = 0 | |
36469 | ELERAT = 0.D+00 | |
36470 | C + | |
36471 | C Maximum value for matrix element | |
36472 | C - | |
36473 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + | |
36474 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) | |
36475 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | |
36476 | C Inputs for EXPLOD | |
36477 | C part. no. 1 is l (e- in mu- decay) | |
36478 | C part. no. 2 is b (nu-mu in mu- decay) | |
36479 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) | |
36480 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
36481 | NPEXPL = 3 | |
36482 | ETOTEX = AMA | |
36483 | AMEXPL(1) = AML | |
36484 | AMEXPL(2) = 0.D+00 | |
36485 | AMEXPL(3) = 0.D+00 | |
36486 | C + | |
36487 | C phase space distribution | |
36488 | C - | |
36489 | 100 CONTINUE | |
36490 | NTRY = NTRY + 1 | |
36491 | ||
36492 | CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
36493 | & PYEXPL, PZEXPL ) | |
36494 | ||
36495 | C + | |
36496 | C Calculates matrix element: | |
36497 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} | |
36498 | C Here CTH is the cosine of the angle between anti-nu and Z axis | |
36499 | C - | |
36500 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + | |
36501 | & PZEXPL(3)**2 ) | |
36502 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) | |
36503 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - | |
36504 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) | |
36505 | ELEMAT = 16.D+00 * PROD1 * PROD2 | |
36506 | IF(ELEMAT.GT.ELEMAX) THEN | |
36507 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT | |
36508 | STOP | |
36509 | ENDIF | |
36510 | C + | |
36511 | C Here performs the rejection | |
36512 | C - | |
36513 | TEST = DT_RNDM(ETOTEX) * ELEMAX | |
36514 | IF ( TEST .GT. ELEMAT ) GO TO 100 | |
36515 | C + | |
36516 | C final assignment of variables | |
36517 | C - | |
36518 | ELERAT = ELEMAT/ELEMAX | |
36519 | ETL = ETEXPL(1) | |
36520 | PXL = PXEXPL(1) | |
36521 | PYL = PYEXPL(1) | |
36522 | PZL = PZEXPL(1) | |
36523 | ETB = ETEXPL(2) | |
36524 | PXB = PXEXPL(2) | |
36525 | PYB = PYEXPL(2) | |
36526 | PZB = PZEXPL(2) | |
36527 | ETN = ETEXPL(3) | |
36528 | PXN = PXEXPL(3) | |
36529 | PYN = PYEXPL(3) | |
36530 | PZN = PZEXPL(3) | |
36531 | 999 RETURN | |
36532 | END | |
36533 | ||
36534 | *$ CREATE DT_GEN_DELTA.FOR | |
36535 | *COPY DT_GEN_DELTA | |
36536 | C================================================================== | |
36537 | C. Generation of Delta resonance events | |
36538 | C================================================================== | |
36539 | * | |
36540 | *===gen_delta==========================================================* | |
36541 | * | |
36542 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) | |
36543 | ||
36544 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36545 | SAVE | |
36546 | ||
36547 | PARAMETER ( LINP = 10 , | |
36548 | & LOUT = 6 , | |
36549 | & LDAT = 9 ) | |
36550 | C...Generate a Delta-production neutrino/antineutrino | |
36551 | C. CC-interaction on a nucleon | |
36552 | C | |
36553 | C. INPUT ENU (GeV) = Neutrino Energy | |
36554 | C. LLEP = neutrino type | |
36555 | C. LTARG = nucleon target type 1=p, 2=n. | |
36556 | C. JINT = 1:CC, 2::NC | |
36557 | C. | |
36558 | C. OUTPUT PPL(4) 4-monentum of final lepton | |
36559 | C---------------------------------------------------- | |
36560 | PARAMETER (MAXLND=4000) | |
36561 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36562 | **sr - removed (not needed) | |
36563 | C COMMON /CBAD/ LBAD, NBAD | |
36564 | ** | |
36565 | ||
36566 | DIMENSION PI(3),PO(3) | |
36567 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN | |
36568 | DIMENSION AML0(6),AMN(2) | |
36569 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ | |
36570 | DATA AMN /0.93827231, 0.93956563/ | |
36571 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ | |
36572 | ||
36573 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 | |
36574 | LBAD = 0 | |
36575 | C...Final lepton mass | |
36576 | IF (JINT.EQ.1) THEN | |
36577 | AML = AML0(LLEP) | |
36578 | ELSE | |
36579 | AML = 0. | |
36580 | ENDIF | |
36581 | AML2 = AML**2 | |
36582 | ||
36583 | C...Particle labels (LUND) | |
36584 | N = 5 | |
36585 | K(1,1) = 21 | |
36586 | K(2,1) = 21 | |
36587 | K(3,1) = 21 | |
36588 | K(4,1) = 1 | |
36589 | K(3,3) = 1 | |
36590 | K(4,3) = 1 | |
36591 | IF (LTARG .EQ. 1) THEN | |
36592 | K(2,2) = 2212 | |
36593 | ELSE | |
36594 | K(2,2) = 2112 | |
36595 | ENDIF | |
36596 | K0 = (LLEP-1)/2 | |
36597 | K1 = LLEP/2 | |
36598 | KA = 12 + 2*K0 | |
36599 | IS = -1 + 2*LLEP - 4*K1 | |
36600 | LNU = 2 - LLEP + 2*K1 | |
36601 | K(1,2) = IS*KA | |
36602 | K(5,1) = 1 | |
36603 | K(5,3) = 2 | |
36604 | IF (JINT .EQ. 1) THEN ! CC interactions | |
36605 | K(3,2) = IS*24 | |
36606 | K(4,2) = IS*(KA-1) | |
36607 | IF(LNU.EQ.1) THEN | |
36608 | IF (LTARG .EQ. 1) THEN | |
36609 | K(5,2) = 2224 | |
36610 | ELSE | |
36611 | K(5,2) = 2214 | |
36612 | ENDIF | |
36613 | ELSE | |
36614 | IF (LTARG .EQ. 1) THEN | |
36615 | K(5,2) = 2114 | |
36616 | ELSE | |
36617 | K(5,2) = 1114 | |
36618 | ENDIF | |
36619 | ENDIF | |
36620 | ELSE | |
36621 | K(3,2) = 23 ! NC (Z0) interactions | |
36622 | K(4,2) = K(1,2) | |
36623 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), | |
36624 | * Delta0 for neutron (LTARG=2) | |
36625 | C IF (LTARG .EQ. 1) THEN | |
36626 | C K(5,2) = 2114 | |
36627 | C ELSE | |
36628 | C K(5,2) = 2214 | |
36629 | C ENDIF | |
36630 | IF (LTARG .EQ. 1) THEN | |
36631 | K(5,2) = 2214 | |
36632 | ELSE | |
36633 | K(5,2) = 2114 | |
36634 | ENDIF | |
36635 | ** | |
36636 | ENDIF | |
36637 | ||
36638 | C...4-momentum initial lepton | |
36639 | P(1,5) = 0. | |
36640 | P(1,4) = ENU | |
36641 | P(1,1) = 0. | |
36642 | P(1,2) = 0. | |
36643 | P(1,3) = ENU | |
36644 | C...4-momentum initial nucleon | |
36645 | P(2,5) = AMN(LTARG) | |
36646 | C P(2,4) = P(2,5) | |
36647 | C P(2,1) = 0. | |
36648 | C P(2,2) = 0. | |
36649 | C P(2,3) = 0. | |
36650 | P(2,1) = P21 | |
36651 | P(2,2) = P22 | |
36652 | P(2,3) = P23 | |
36653 | P(2,4) = P24 | |
36654 | P(2,5) = P25 | |
36655 | N=2 | |
36656 | beta1=-p(2,1)/p(2,4) | |
36657 | beta2=-p(2,2)/p(2,4) | |
36658 | beta3=-p(2,3)/p(2,4) | |
36659 | N=2 | |
36660 | ||
36661 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
36662 | ||
36663 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
36664 | ||
36665 | phi11=atan(p(1,2)/p(1,3)) | |
36666 | pi(1)=p(1,1) | |
36667 | pi(2)=p(1,2) | |
36668 | pi(3)=p(1,3) | |
36669 | ||
36670 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
36671 | DO ll=1,3 | |
36672 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36673 | END DO | |
36674 | p(1,1)=po(1) | |
36675 | p(1,2)=po(2) | |
36676 | p(1,3)=po(3) | |
36677 | phi12=atan(p(1,1)/p(1,3)) | |
36678 | ||
36679 | pi(1)=p(1,1) | |
36680 | pi(2)=p(1,2) | |
36681 | pi(3)=p(1,3) | |
36682 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
36683 | DO ll=1,3 | |
36684 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36685 | END DO | |
36686 | p(1,1)=po(1) | |
36687 | p(1,2)=po(2) | |
36688 | p(1,3)=po(3) | |
36689 | ||
36690 | ENUU=P(1,4) | |
36691 | ||
36692 | C...Generate the Mass of the Delta | |
36693 | NTRY = 0 | |
36694 | 100 R = PYR(0) | |
36695 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) | |
36696 | NTRY = NTRY + 1 | |
36697 | IF (NTRY .GT. 1000) THEN | |
36698 | LBAD = 1 | |
36699 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET | |
36700 | RETURN | |
36701 | ENDIF | |
36702 | IF (AMD .LT. AMDMIN) GOTO 100 | |
36703 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) | |
36704 | IF (ENUU .LT. ET) GOTO 100 | |
36705 | ||
36706 | C...Kinematical limits in Q**2 | |
36707 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU | |
36708 | SQS = SQRT(S) | |
36709 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) | |
36710 | ELF = (S - AMD**2 + AML2)/(2.*SQS) | |
36711 | PLF = SQRT(ELF**2 - AML2) | |
36712 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) | |
36713 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) | |
36714 | IF (Q2MIN .LT. 0.) Q2MIN = 0. | |
36715 | ||
36716 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) | |
36717 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
36718 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) | |
36719 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
36720 | ||
36721 | C...Generate the kinematics of the final particles | |
36722 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) | |
36723 | GAM = EISTAR/AMN(LTARG) | |
36724 | BET = PSTAR/EISTAR | |
36725 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) | |
36726 | EL = GAM*(ELF + BET*PLF*CTSTAR) | |
36727 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) | |
36728 | PL = SQRT(EL**2 - AML2) | |
36729 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) | |
36730 | PHI = 6.28319*PYR(0) | |
36731 | P(4,1) = PLT*COS(PHI) | |
36732 | P(4,2) = PLT*SIN(PHI) | |
36733 | P(4,3) = PLZ | |
36734 | P(4,4) = EL | |
36735 | P(4,5) = AML | |
36736 | ||
36737 | C...4-momentum of Delta | |
36738 | P(5,1) = -P(4,1) | |
36739 | P(5,2) = -P(4,2) | |
36740 | P(5,3) = ENUU-P(4,3) | |
36741 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) | |
36742 | P(5,5) = AMD | |
36743 | ||
36744 | C...4-momentum of intermediate boson | |
36745 | P(3,5) = -Q2 | |
36746 | P(3,4) = P(1,4)-P(4,4) | |
36747 | P(3,1) = P(1,1)-P(4,1) | |
36748 | P(3,2) = P(1,2)-P(4,2) | |
36749 | P(3,3) = P(1,3)-P(4,3) | |
36750 | N=5 | |
36751 | ||
36752 | DO kw=1,5 | |
36753 | pi(1)=p(kw,1) | |
36754 | pi(2)=p(kw,2) | |
36755 | pi(3)=p(kw,3) | |
36756 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
36757 | DO ll=1,3 | |
36758 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36759 | END DO | |
36760 | p(kw,1)=po(1) | |
36761 | p(kw,2)=po(2) | |
36762 | p(kw,3)=po(3) | |
36763 | END DO | |
36764 | ||
36765 | c******************************************** | |
36766 | ||
36767 | DO kw=1,5 | |
36768 | pi(1)=p(kw,1) | |
36769 | pi(2)=p(kw,2) | |
36770 | pi(3)=p(kw,3) | |
36771 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
36772 | DO ll=1,3 | |
36773 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36774 | END DO | |
36775 | p(kw,1)=po(1) | |
36776 | p(kw,2)=po(2) | |
36777 | p(kw,3)=po(3) | |
36778 | END DO | |
36779 | c******************************************** | |
36780 | C transform back into Lab. | |
36781 | ||
36782 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
36783 | ||
36784 | C WRITE(6,*)' Lab fram ( fermi incl.) ' | |
36785 | N=5 | |
36786 | CALL PYEXEC | |
36787 | ||
36788 | RETURN | |
36789 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) | |
36790 | END | |
36791 | ||
36792 | *$ CREATE DT_DSIGMA_DELTA.FOR | |
36793 | *COPY DT_DSIGMA_DELTA | |
36794 | * | |
36795 | *===dsigma_delta=======================================================* | |
36796 | * | |
36797 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) | |
36798 | ||
36799 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36800 | SAVE | |
36801 | ||
36802 | C...Reaction nu + N -> lepton + Delta | |
36803 | C. returns the cross section | |
36804 | C. dsigma/dt | |
36805 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) | |
36806 | C. QQ = t (always negative) GeV**2 | |
36807 | C. S = (c.m energy)**2 GeV**2 | |
36808 | C. OUTPUT = 10**-38 cm+2/GeV**2 | |
36809 | C----------------------------------------------------- | |
36810 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 | |
36811 | DATA MN /0.938/ | |
36812 | DATA PI /3.1415926/ | |
36813 | ||
36814 | GF = (1.1664 * 1.97) | |
36815 | GF2 = GF*GF | |
36816 | MN2 = MN*MN | |
36817 | MN4 = MN2*MN2 | |
36818 | MD2 = MD*MD | |
36819 | MD4 = MD2*MD2 | |
36820 | AML2 = AML*AML | |
36821 | AML4 = AML2*AML2 | |
36822 | VQ = (MN2 - MD2 - QQ)/2. | |
36823 | VPI = (MN2 + MD2 - QQ)/2. | |
36824 | VK = (S + QQ - MN2 - AML2)/2. | |
36825 | PIK = (S - MN2)/2. | |
36826 | QK = (AML2 - QQ)/2. | |
36827 | PIQ = (QQ + MN2 - MD2)/2. | |
36828 | Q = SQRT(-QQ) | |
36829 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) | |
36830 | C3 = SQRT(3.)*C3V/MN | |
36831 | C4 = -C3/MD ! attenzione al segno | |
36832 | C5A = 1.18/(1.-QQ/0.4225)**2 | |
36833 | C32 = C3**2 | |
36834 | C42 = C4**2 | |
36835 | C5A2 = C5A**2 | |
36836 | ||
36837 | IF (LNU .EQ. 1) THEN | |
36838 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36839 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36840 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36841 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36842 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36843 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36844 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36845 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36846 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36847 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- | |
36848 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36849 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36850 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36851 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36852 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* | |
36853 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A | |
36854 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* | |
36855 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* | |
36856 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 | |
36857 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36858 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36859 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36860 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36861 | ELSE | |
36862 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36863 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36864 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36865 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36866 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36867 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36868 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36869 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36870 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36871 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ | |
36872 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36873 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36874 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36875 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36876 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* | |
36877 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A | |
36878 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* | |
36879 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* | |
36880 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 | |
36881 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36882 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36883 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36884 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36885 | ENDIF | |
36886 | ANS1=32.*ANS2 | |
36887 | ANS=ANS1/(3.*MD2) | |
36888 | P1CM = (S-MN2)/(2.*SQRT(S)) | |
36889 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) | |
36890 | ||
36891 | RETURN | |
36892 | END | |
36893 | ||
36894 | *$ CREATE DT_QGAUS.FOR | |
36895 | *COPY DT_QGAUS | |
36896 | * | |
36897 | *===qgaus==============================================================* | |
36898 | * | |
36899 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) | |
36900 | ||
36901 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36902 | SAVE | |
36903 | ||
36904 | DIMENSION X(5),W(5) | |
36905 | DATA X/.1488743389D0,.4333953941D0, | |
36906 | & .6794095682D0,.8650633666D0,.9739065285D0 | |
36907 | */ | |
36908 | DATA W/.2955242247D0,.2692667193D0, | |
36909 | & .2190863625D0,.1494513491D0,.0666713443D0 | |
36910 | */ | |
36911 | XM=0.5D0*(B+A) | |
36912 | XR=0.5D0*(B-A) | |
36913 | SS=0 | |
36914 | DO 11 J=1,5 | |
36915 | DX=XR*X(J) | |
36916 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ | |
36917 | * DT_DSQEL_Q2(LTYP,ENU,XM-DX)) | |
36918 | 11 CONTINUE | |
36919 | SS=XR*SS | |
36920 | ||
36921 | RETURN | |
36922 | END | |
36923 | ||
36924 | *$ CREATE DT_DIQBRK.FOR | |
36925 | *COPY DT_DIQBRK | |
36926 | * | |
36927 | *===diqbrk=============================================================* | |
36928 | * | |
36929 | SUBROUTINE DT_DIQBRK | |
36930 | ||
36931 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36932 | SAVE | |
36933 | ||
36934 | * event history | |
36935 | PARAMETER (NMXHKK=200000) | |
36936 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36937 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36938 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36939 | * extended event history | |
36940 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36941 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
36942 | & IHIST(2,NMXHKK) | |
36943 | * event flag | |
36944 | COMMON /DTEVNO/ NEVENT,ICASCA | |
36945 | ||
36946 | C IF(DT_RNDM(VV).LE.0.5D0)THEN | |
36947 | C CALL GSQBS1(NHKK) | |
36948 | C CALL GSQBS2(NHKK) | |
36949 | C CALL USQBS1(NHKK) | |
36950 | C CALL USQBS2(NHKK) | |
36951 | C CALL GSABS1(NHKK) | |
36952 | C CALL GSABS2(NHKK) | |
36953 | C CALL USABS1(NHKK) | |
36954 | C CALL USABS2(NHKK) | |
36955 | C ELSE | |
36956 | C CALL GSQBS2(NHKK) | |
36957 | C CALL GSQBS1(NHKK) | |
36958 | C CALL USQBS2(NHKK) | |
36959 | C CALL USQBS1(NHKK) | |
36960 | C CALL GSABS2(NHKK) | |
36961 | C CALL GSABS1(NHKK) | |
36962 | C CALL USABS2(NHKK) | |
36963 | C CALL USABS1(NHKK) | |
36964 | C ENDIF | |
36965 | ||
36966 | IF(DT_RNDM(VV).LE.0.5D0) THEN | |
36967 | CALL DT_DBREAK(1) | |
36968 | CALL DT_DBREAK(2) | |
36969 | CALL DT_DBREAK(3) | |
36970 | CALL DT_DBREAK(4) | |
36971 | CALL DT_DBREAK(5) | |
36972 | CALL DT_DBREAK(6) | |
36973 | CALL DT_DBREAK(7) | |
36974 | CALL DT_DBREAK(8) | |
36975 | ELSE | |
36976 | CALL DT_DBREAK(2) | |
36977 | CALL DT_DBREAK(1) | |
36978 | CALL DT_DBREAK(4) | |
36979 | CALL DT_DBREAK(3) | |
36980 | CALL DT_DBREAK(6) | |
36981 | CALL DT_DBREAK(5) | |
36982 | CALL DT_DBREAK(8) | |
36983 | CALL DT_DBREAK(7) | |
36984 | ENDIF | |
36985 | ||
36986 | RETURN | |
36987 | END | |
36988 | ||
36989 | *$ CREATE MUSQBS2.FOR | |
36990 | *COPY MUSQBS2 | |
36991 | C | |
36992 | C | |
36993 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
36994 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36995 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
36996 | C | |
36997 | C USQBS-2 diagram (split target diquark) | |
36998 | C | |
36999 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37000 | SAVE | |
37001 | ||
37002 | PARAMETER ( LINP = 10 , | |
37003 | & LOUT = 6 , | |
37004 | & LDAT = 9 ) | |
37005 | * event history | |
37006 | PARAMETER (NMXHKK=200000) | |
37007 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37008 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37009 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37010 | * extended event history | |
37011 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37012 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37013 | & IHIST(2,NMXHKK) | |
37014 | * Lorentz-parameters of the current interaction | |
37015 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37016 | & UMO,PPCM,EPROJ,PPROJ | |
37017 | * diquark-breaking mechanism | |
37018 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37019 | ||
37020 | C | |
37021 | PARAMETER (NTMHKK= 300) | |
37022 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37023 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37024 | +(4,NTMHKK) | |
37025 | *KEEP,XSEADI. | |
37026 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37027 | +SSMIMQ,VVMTHR | |
37028 | *KEEP,DPRIN. | |
37029 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37030 | COMMON /EVFLAG/ NUMEV | |
37031 | C | |
37032 | C USQBS-2 diagram (split target diquark) | |
37033 | C | |
37034 | C | |
37035 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
37036 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) | |
37037 | C | |
37038 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
37039 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37040 | C | |
37041 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37042 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37043 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37044 | C | |
37045 | C | |
37046 | C Put new chains into COMMON /HKKTMP/ | |
37047 | C | |
37048 | IIGLU1=NC1T-NC1P-1 | |
37049 | IIGLU2=NC2T-NC2P-1 | |
37050 | IGCOUN=0 | |
37051 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37052 | CVQ=1.D0 | |
37053 | IREJ=0 | |
37054 | IF(IPIP.EQ.2)THEN | |
37055 | C IF(NUMEV.EQ.-324)THEN | |
37056 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37057 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', | |
37058 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37059 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN | |
37060 | ENDIF | |
37061 | C | |
37062 | C | |
37063 | C | |
37064 | C determine x-values of NC1T diquark | |
37065 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37066 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37067 | C | |
37068 | C determine x-values of sea quark pair | |
37069 | C | |
37070 | IPCO=1 | |
37071 | ICOU=0 | |
37072 | 2234 CONTINUE | |
37073 | ICOU=ICOU+1 | |
37074 | IF(ICOU.GE.500)THEN | |
37075 | IREJ=1 | |
37076 | IF(ISQ.EQ.3)IREJ=3 | |
37077 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' | |
37078 | IPCO=0 | |
37079 | RETURN | |
37080 | ENDIF | |
37081 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37082 | * UMO, XDIQT,XVQP | |
37083 | XSQ=0.D0 | |
37084 | XSAQ=0.D0 | |
37085 | **NEW | |
37086 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37087 | IF (IPIP.EQ.1) THEN | |
37088 | XQMAX = XDIQT/2.0D0 | |
37089 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37090 | ELSE | |
37091 | XQMAX = 2.D0*XVQP/3.0D0 | |
37092 | XAQMAX = XDIQT/2.0D0 | |
37093 | ENDIF | |
37094 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37095 | ISAQ = 6+ISQ | |
37096 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37097 | ** | |
37098 | IF(IPCO.GE.3) | |
37099 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37100 | IF(IREJ.GE.1)THEN | |
37101 | IF(IPCO.GE.3) | |
37102 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37103 | IPCO=0 | |
37104 | RETURN | |
37105 | ENDIF | |
37106 | IF(IPIP.EQ.1)THEN | |
37107 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37108 | ELSEIF(IPIP.EQ.2)THEN | |
37109 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37110 | ENDIF | |
37111 | IF(IPCO.GE.3)THEN | |
37112 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37113 | * XDIQT,XVQP,XSQ,XSAQ | |
37114 | ENDIF | |
37115 | C | |
37116 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37117 | C | |
37118 | C XSQ=0.D0 | |
37119 | IF(IPIP.EQ.1)THEN | |
37120 | XDIQT=XDIQT-XSQ | |
37121 | XVQP =XVQP -XSAQ | |
37122 | ELSEIF(IPIP.EQ.2)THEN | |
37123 | XDIQT=XDIQT-XSAQ | |
37124 | XVQP =XVQP -XSQ | |
37125 | ENDIF | |
37126 | IF(IPCO.GE.3) | |
37127 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37128 | C | |
37129 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37130 | C | |
37131 | XVTHRO=CVQ/UMO | |
37132 | IVTHR=0 | |
37133 | 3466 CONTINUE | |
37134 | IF(IVTHR.EQ.10)THEN | |
37135 | IREJ=1 | |
37136 | IF(ISQ.EQ.3)IREJ=3 | |
37137 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' | |
37138 | IPCO=0 | |
37139 | RETURN | |
37140 | ENDIF | |
37141 | IVTHR=IVTHR+1 | |
37142 | XVTHR=XVTHRO/(201-IVTHR) | |
37143 | UNOPRV=UNON | |
37144 | 380 CONTINUE | |
37145 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37146 | IREJ=1 | |
37147 | IF(ISQ.EQ.3)IREJ=3 | |
37148 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ', | |
37149 | * XVTHR | |
37150 | IPCO=0 | |
37151 | RETURN | |
37152 | ENDIF | |
37153 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37154 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37155 | XVTQII=XDIQT-XVTQI | |
37156 | ELSE | |
37157 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37158 | XVTQI=XDIQT-XVTQII | |
37159 | ENDIF | |
37160 | IF(IPCO.GE.3)THEN | |
37161 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37162 | ENDIF | |
37163 | C | |
37164 | C Prepare 4 momenta of new chains and chain ends | |
37165 | C | |
37166 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37167 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37168 | C +(4,NTMHKK) | |
37169 | C | |
37170 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37171 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37172 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37173 | C | |
37174 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37175 | C * IP1,IP21,IP22,IPP1,IPP2) | |
37176 | C | |
37177 | IF(IPIP.EQ.1)THEN | |
37178 | XSQ1=XSQ | |
37179 | XSAQ1=XSAQ | |
37180 | ISQ1=ISQ | |
37181 | ISAQ1=ISAQ | |
37182 | ELSEIF(IPIP.EQ.2)THEN | |
37183 | XSQ1=XSAQ | |
37184 | XSAQ1=XSQ | |
37185 | ISQ1=ISAQ | |
37186 | ISAQ1=ISQ | |
37187 | ENDIF | |
37188 | IDHKT(1) =IPP1 | |
37189 | ISTHKT(1) =951 | |
37190 | JMOHKT(1,1)=NC2P | |
37191 | JMOHKT(2,1)=0 | |
37192 | JDAHKT(1,1)=3+IIGLU1 | |
37193 | JDAHKT(2,1)=0 | |
37194 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37195 | PHKT(1,1) =PHKK(1,NC2P) | |
37196 | PHKT(2,1) =PHKK(2,NC2P) | |
37197 | PHKT(3,1) =PHKK(3,NC2P) | |
37198 | PHKT(4,1) =PHKK(4,NC2P) | |
37199 | C PHKT(5,1) =PHKK(5,NC2P) | |
37200 | XMIST =(PHKT(4,1)**2- | |
37201 | * PHKT(3,1)**2-PHKT(2,1)**2- | |
37202 | *PHKT(1,1)**2) | |
37203 | IF(XMIST.GT.0.D0)THEN | |
37204 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37205 | *PHKT(1,1)**2) | |
37206 | ELSE | |
37207 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
37208 | PHKT(5,1)=0.D0 | |
37209 | ENDIF | |
37210 | VHKT(1,1) =VHKK(1,NC2P) | |
37211 | VHKT(2,1) =VHKK(2,NC2P) | |
37212 | VHKT(3,1) =VHKK(3,NC2P) | |
37213 | VHKT(4,1) =VHKK(4,NC2P) | |
37214 | WHKT(1,1) =WHKK(1,NC2P) | |
37215 | WHKT(2,1) =WHKK(2,NC2P) | |
37216 | WHKT(3,1) =WHKK(3,NC2P) | |
37217 | WHKT(4,1) =WHKK(4,NC2P) | |
37218 | C Add here IIGLU1 gluons to this chaina | |
37219 | PG1=0.D0 | |
37220 | PG2=0.D0 | |
37221 | PG3=0.D0 | |
37222 | PG4=0.D0 | |
37223 | IF(IIGLU1.GE.1)THEN | |
37224 | JJG=NC1P | |
37225 | DO 61 IIG=2,2+IIGLU1-1 | |
37226 | KKG=JJG+IIG-1 | |
37227 | IDHKT(IIG) =IDHKK(KKG) | |
37228 | ISTHKT(IIG) =921 | |
37229 | JMOHKT(1,IIG)=KKG | |
37230 | JMOHKT(2,IIG)=0 | |
37231 | JDAHKT(1,IIG)=3+IIGLU1 | |
37232 | JDAHKT(2,IIG)=0 | |
37233 | PHKT(1,IIG)=PHKK(1,KKG) | |
37234 | PG1=PG1+ PHKT(1,IIG) | |
37235 | PHKT(2,IIG)=PHKK(2,KKG) | |
37236 | PG2=PG2+ PHKT(2,IIG) | |
37237 | PHKT(3,IIG)=PHKK(3,KKG) | |
37238 | PG3=PG3+ PHKT(3,IIG) | |
37239 | PHKT(4,IIG)=PHKK(4,KKG) | |
37240 | PG4=PG4+ PHKT(4,IIG) | |
37241 | PHKT(5,IIG)=PHKK(5,KKG) | |
37242 | VHKT(1,IIG) =VHKK(1,KKG) | |
37243 | VHKT(2,IIG) =VHKK(2,KKG) | |
37244 | VHKT(3,IIG) =VHKK(3,KKG) | |
37245 | VHKT(4,IIG) =VHKK(4,KKG) | |
37246 | WHKT(1,IIG) =WHKK(1,KKG) | |
37247 | WHKT(2,IIG) =WHKK(2,KKG) | |
37248 | WHKT(3,IIG) =WHKK(3,KKG) | |
37249 | WHKT(4,IIG) =WHKK(4,KKG) | |
37250 | 61 CONTINUE | |
37251 | ENDIF | |
37252 | IDHKT(2+IIGLU1) =IP21 | |
37253 | ISTHKT(2+IIGLU1) =952 | |
37254 | JMOHKT(1,2+IIGLU1)=NC1T | |
37255 | JMOHKT(2,2+IIGLU1)=0 | |
37256 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
37257 | JDAHKT(2,2+IIGLU1)=0 | |
37258 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37259 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37260 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37261 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37262 | C PHKT(5,2) =PHKK(5,NC1T) | |
37263 | XMIST =(PHKT(4,2+IIGLU1)**2- | |
37264 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37265 | *PHKT(1,2+IIGLU1)**2) | |
37266 | IF(XMIST.GT.0.D0)THEN | |
37267 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
37268 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37269 | *PHKT(1,2+IIGLU1)**2) | |
37270 | ELSE | |
37271 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37272 | PHKT(5,5+IIGLU1)=0.D0 | |
37273 | ENDIF | |
37274 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
37275 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
37276 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
37277 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
37278 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
37279 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
37280 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
37281 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
37282 | IDHKT(3+IIGLU1) =88888 | |
37283 | ISTHKT(3+IIGLU1) =95 | |
37284 | JMOHKT(1,3+IIGLU1)=1 | |
37285 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
37286 | JDAHKT(1,3+IIGLU1)=0 | |
37287 | JDAHKT(2,3+IIGLU1)=0 | |
37288 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
37289 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
37290 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
37291 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
37292 | XMIST | |
37293 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37294 | * -PHKT(3,3+IIGLU1)**2) | |
37295 | IF(XMIST.GT.0.D0)THEN | |
37296 | PHKT(5,3+IIGLU1) | |
37297 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37298 | * -PHKT(3,3+IIGLU1)**2) | |
37299 | ELSE | |
37300 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37301 | PHKT(5,5+IIGLU1)=0.D0 | |
37302 | ENDIF | |
37303 | IF(IPIP.GE.2)THEN | |
37304 | C IF(NUMEV.EQ.-324)THEN | |
37305 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
37306 | C * JDAHKT(1,1), | |
37307 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
37308 | DO 71 IIG=2,2+IIGLU1-1 | |
37309 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
37310 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37311 | C * JDAHKT(1,IIG), | |
37312 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37313 | 71 CONTINUE | |
37314 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
37315 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
37316 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
37317 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
37318 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
37319 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
37320 | ENDIF | |
37321 | CHAMAL=CHAM1 | |
37322 | IF(IPIP.EQ.1)THEN | |
37323 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 | |
37324 | ELSEIF(IPIP.EQ.2)THEN | |
37325 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 | |
37326 | ENDIF | |
37327 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
37328 | C IREJ=1 | |
37329 | IPCO=0 | |
37330 | C RETURN | |
37331 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' | |
37332 | GO TO 3466 | |
37333 | ENDIF | |
37334 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
37335 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
37336 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
37337 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
37338 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
37339 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
37340 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
37341 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
37342 | IF(IPIP.EQ.1)THEN | |
37343 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37344 | ELSEIF(IPIP.EQ.2)THEN | |
37345 | IDHKT(4+IIGLU1) =ISAQ1 | |
37346 | ENDIF | |
37347 | ISTHKT(4+IIGLU1) =951 | |
37348 | JMOHKT(1,4+IIGLU1)=NC1P | |
37349 | JMOHKT(2,4+IIGLU1)=0 | |
37350 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37351 | JDAHKT(2,4+IIGLU1)=0 | |
37352 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37353 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37354 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37355 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37356 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37357 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37358 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
37359 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37360 | *PHKT(1,4+IIGLU1)**2) | |
37361 | IF(XMIST.GT.0.D0)THEN | |
37362 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
37363 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37364 | *PHKT(1,4+IIGLU1)**2) | |
37365 | ELSE | |
37366 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST | |
37367 | PHKT(5,4+IIGLU1)=0.D0 | |
37368 | ENDIF | |
37369 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37370 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37371 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37372 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37373 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37374 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37375 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37376 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37377 | IDHKT(5+IIGLU1) =IP22 | |
37378 | ISTHKT(5+IIGLU1) =952 | |
37379 | JMOHKT(1,5+IIGLU1)=NC1T | |
37380 | JMOHKT(2,5+IIGLU1)=0 | |
37381 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37382 | JDAHKT(2,5+IIGLU1)=0 | |
37383 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37384 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37385 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37386 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37387 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37388 | XMIST =(PHKT(4,5+IIGLU1)**2- | |
37389 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37390 | *PHKT(1,5+IIGLU1)**2) | |
37391 | IF(XMIST.GT.0.D0)THEN | |
37392 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
37393 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37394 | *PHKT(1,5+IIGLU1)**2) | |
37395 | ELSE | |
37396 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37397 | PHKT(5,5+IIGLU1)=0.D0 | |
37398 | ENDIF | |
37399 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37400 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37401 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37402 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37403 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37404 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37405 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37406 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37407 | IDHKT(6+IIGLU1) =88888 | |
37408 | ISTHKT(6+IIGLU1) =95 | |
37409 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37410 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37411 | JDAHKT(1,6+IIGLU1)=0 | |
37412 | JDAHKT(2,6+IIGLU1)=0 | |
37413 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37414 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37415 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37416 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37417 | XMIST | |
37418 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37419 | * -PHKT(3,6+IIGLU1)**2) | |
37420 | IF(XMIST.GT.0.D0)THEN | |
37421 | PHKT(5,6+IIGLU1) | |
37422 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37423 | * -PHKT(3,6+IIGLU1)**2) | |
37424 | ELSE | |
37425 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37426 | PHKT(5,5+IIGLU1)=0.D0 | |
37427 | ENDIF | |
37428 | C IF(IPIP.GE.2)THEN | |
37429 | C IF(NUMEV.EQ.-324)THEN | |
37430 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37431 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37432 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37433 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37434 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37435 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37436 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37437 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37438 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37439 | C ENDIF | |
37440 | CHAMAL=CHAM1 | |
37441 | IF(IPIP.EQ.1)THEN | |
37442 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37443 | ELSEIF(IPIP.EQ.2)THEN | |
37444 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37445 | ENDIF | |
37446 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37447 | C IREJ=1 | |
37448 | IPCO=0 | |
37449 | C RETURN | |
37450 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', | |
37451 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
37452 | GO TO 3466 | |
37453 | ENDIF | |
37454 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37455 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37456 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37457 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
37458 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
37459 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
37460 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
37461 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
37462 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
37463 | IDHKT(7+IIGLU1) =IP1 | |
37464 | ISTHKT(7+IIGLU1) =951 | |
37465 | JMOHKT(1,7+IIGLU1)=NC1P | |
37466 | JMOHKT(2,7+IIGLU1)=0 | |
37467 | **NEW | |
37468 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 | |
37469 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
37470 | ** | |
37471 | JDAHKT(2,7+IIGLU1)=0 | |
37472 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
37473 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
37474 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
37475 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
37476 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
37477 | XMIST =(PHKT(4,7+IIGLU1)**2- | |
37478 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37479 | *PHKT(1,7+IIGLU1)**2) | |
37480 | IF(XMIST.GT.0.D0)THEN | |
37481 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
37482 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37483 | *PHKT(1,7+IIGLU1)**2) | |
37484 | ELSE | |
37485 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST | |
37486 | PHKT(5,7+IIGLU1)=0.D0 | |
37487 | ENDIF | |
37488 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
37489 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
37490 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
37491 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
37492 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
37493 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
37494 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
37495 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
37496 | C Insert here the IIGLU2 gluons | |
37497 | PG1=0.D0 | |
37498 | PG2=0.D0 | |
37499 | PG3=0.D0 | |
37500 | PG4=0.D0 | |
37501 | IF(IIGLU2.GE.1)THEN | |
37502 | JJG=NC2P | |
37503 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37504 | KKG=JJG+IIG-7-IIGLU1 | |
37505 | IDHKT(IIG) =IDHKK(KKG) | |
37506 | ISTHKT(IIG) =921 | |
37507 | JMOHKT(1,IIG)=KKG | |
37508 | JMOHKT(2,IIG)=0 | |
37509 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
37510 | JDAHKT(2,IIG)=0 | |
37511 | PHKT(1,IIG)=PHKK(1,KKG) | |
37512 | PG1=PG1+ PHKT(1,IIG) | |
37513 | PHKT(2,IIG)=PHKK(2,KKG) | |
37514 | PG2=PG2+ PHKT(2,IIG) | |
37515 | PHKT(3,IIG)=PHKK(3,KKG) | |
37516 | PG3=PG3+ PHKT(3,IIG) | |
37517 | PHKT(4,IIG)=PHKK(4,KKG) | |
37518 | PG4=PG4+ PHKT(4,IIG) | |
37519 | PHKT(5,IIG)=PHKK(5,KKG) | |
37520 | VHKT(1,IIG) =VHKK(1,KKG) | |
37521 | VHKT(2,IIG) =VHKK(2,KKG) | |
37522 | VHKT(3,IIG) =VHKK(3,KKG) | |
37523 | VHKT(4,IIG) =VHKK(4,KKG) | |
37524 | WHKT(1,IIG) =WHKK(1,KKG) | |
37525 | WHKT(2,IIG) =WHKK(2,KKG) | |
37526 | WHKT(3,IIG) =WHKK(3,KKG) | |
37527 | WHKT(4,IIG) =WHKK(4,KKG) | |
37528 | 81 CONTINUE | |
37529 | ENDIF | |
37530 | IF(IPIP.EQ.1)THEN | |
37531 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
37532 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
37533 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
37534 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
37535 | ELSEIF(IPIP.EQ.2)THEN | |
37536 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
37537 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
37538 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
37539 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
37540 | ENDIF | |
37541 | ISTHKT(8+IIGLU1+IIGLU2) =952 | |
37542 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
37543 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
37544 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
37545 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
37546 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ | |
37547 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37548 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ | |
37549 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37550 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ | |
37551 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37552 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ | |
37553 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37554 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
37555 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
37556 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
37557 | C IREJ=1 | |
37558 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
37559 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T | |
37560 | IPCO=0 | |
37561 | C RETURN | |
37562 | GO TO 3466 | |
37563 | ENDIF | |
37564 | C PHKT(5,8) =PHKK(5,NC2T) | |
37565 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37566 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37567 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37568 | IF(XMIST.GT.0.D0)THEN | |
37569 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37570 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37571 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37572 | ELSE | |
37573 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37574 | PHKT(5,5+IIGLU1)=0.D0 | |
37575 | ENDIF | |
37576 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
37577 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
37578 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
37579 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
37580 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
37581 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
37582 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
37583 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
37584 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
37585 | ISTHKT(9+IIGLU1+IIGLU2) =95 | |
37586 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
37587 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
37588 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
37589 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
37590 | **NEW | |
37591 | C PHKT(1,9+IIGLU1+IIGLU2) | |
37592 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37593 | C PHKT(2,9+IIGLU1+IIGLU2) | |
37594 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37595 | C PHKT(3,9+IIGLU1+IIGLU2) | |
37596 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37597 | C PHKT(4,9+IIGLU1+IIGLU2) | |
37598 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37599 | PHKT(1,9+IIGLU1+IIGLU2) | |
37600 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37601 | PHKT(2,9+IIGLU1+IIGLU2) | |
37602 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37603 | PHKT(3,9+IIGLU1+IIGLU2) | |
37604 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37605 | PHKT(4,9+IIGLU1+IIGLU2) | |
37606 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37607 | ** | |
37608 | XMIST | |
37609 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37610 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37611 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37612 | IF(XMIST.GT.0.D0)THEN | |
37613 | PHKT(5,9+IIGLU1+IIGLU2) | |
37614 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37615 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37616 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37617 | ELSE | |
37618 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37619 | PHKT(5,5+IIGLU1)=0.D0 | |
37620 | ENDIF | |
37621 | IF(IPIP.GE.2)THEN | |
37622 | C IF(NUMEV.EQ.-324)THEN | |
37623 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
37624 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
37625 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
37626 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37627 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37628 | C * JDAHKT(1,IIG), | |
37629 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37630 | C 91 CONTINUE | |
37631 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
37632 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
37633 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
37634 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
37635 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
37636 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
37637 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
37638 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
37639 | ENDIF | |
37640 | CHAMAL=CHAB1 | |
37641 | IF(IPIP.EQ.1)THEN | |
37642 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
37643 | ELSEIF(IPIP.EQ.2)THEN | |
37644 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
37645 | ENDIF | |
37646 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
37647 | C IREJ=1 | |
37648 | IPCO=0 | |
37649 | C RETURN | |
37650 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', | |
37651 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
37652 | GO TO 3466 | |
37653 | ENDIF | |
37654 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
37655 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
37656 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
37657 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
37658 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
37659 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
37660 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
37661 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
37662 | C | |
37663 | IPCO=0 | |
37664 | IGCOUN=9+IIGLU1+IIGLU2 | |
37665 | RETURN | |
37666 | END | |
37667 | ||
37668 | *$ CREATE MGSQBS2.FOR | |
37669 | *COPY MGSQBS2 | |
37670 | C | |
37671 | C | |
37672 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
37673 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37674 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) | |
37675 | C | |
37676 | C GSQBS-2 diagram (split target diquark) | |
37677 | C | |
37678 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37679 | SAVE | |
37680 | ||
37681 | PARAMETER ( LINP = 10 , | |
37682 | & LOUT = 6 , | |
37683 | & LDAT = 9 ) | |
37684 | * event history | |
37685 | PARAMETER (NMXHKK=200000) | |
37686 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37687 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37688 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37689 | * extended event history | |
37690 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37691 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37692 | & IHIST(2,NMXHKK) | |
37693 | * Lorentz-parameters of the current interaction | |
37694 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37695 | & UMO,PPCM,EPROJ,PPROJ | |
37696 | * diquark-breaking mechanism | |
37697 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37698 | ||
37699 | C | |
37700 | PARAMETER (NTMHKK= 300) | |
37701 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37702 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37703 | +(4,NTMHKK) | |
37704 | ||
37705 | *KEEP,XSEADI. | |
37706 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37707 | +SSMIMQ,VVMTHR | |
37708 | *KEEP,DPRIN. | |
37709 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37710 | C | |
37711 | C GSQBS-2 diagram (split target diquark) | |
37712 | C | |
37713 | C | |
37714 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
37715 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) | |
37716 | C | |
37717 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
37718 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37719 | C | |
37720 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37721 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37722 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37723 | C | |
37724 | C | |
37725 | C | |
37726 | C Put new chains into COMMON /HKKTMP/ | |
37727 | C | |
37728 | IIGLU1=NC1T-NC1P-1 | |
37729 | IIGLU2=NC2T-NC2P-1 | |
37730 | IGCOUN=0 | |
37731 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37732 | CVQ=1.D0 | |
37733 | IREJ=0 | |
37734 | C IF(IPIP.EQ.2)THEN | |
37735 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37736 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', | |
37737 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37738 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN | |
37739 | C ENDIF | |
37740 | C | |
37741 | C | |
37742 | C | |
37743 | C determine x-values of NC1T diquark | |
37744 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37745 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37746 | C | |
37747 | C determine x-values of sea quark pair | |
37748 | C | |
37749 | IPCO=1 | |
37750 | ICOU=0 | |
37751 | 2234 CONTINUE | |
37752 | ICOU=ICOU+1 | |
37753 | IF(ICOU.GE.500)THEN | |
37754 | IREJ=1 | |
37755 | IF(ISQ.EQ.3)IREJ=3 | |
37756 | IF(IPCO.GE.3) | |
37757 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' | |
37758 | IPCO=0 | |
37759 | RETURN | |
37760 | ENDIF | |
37761 | IF(IPCO.GE.3) | |
37762 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37763 | * UMO, XDIQT,XVQP | |
37764 | XSQ=0.D0 | |
37765 | XSAQ=0.D0 | |
37766 | **NEW | |
37767 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37768 | IF (IPIP.EQ.1) THEN | |
37769 | XQMAX = XDIQT/2.0D0 | |
37770 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37771 | ELSE | |
37772 | XQMAX = 2.D0*XVQP/3.0D0 | |
37773 | XAQMAX = XDIQT/2.0D0 | |
37774 | ENDIF | |
37775 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37776 | ISAQ = 6+ISQ | |
37777 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37778 | ** | |
37779 | IF(IPCO.GE.3) | |
37780 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37781 | IF(IREJ.GE.1)THEN | |
37782 | IF(IPCO.GE.3) | |
37783 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37784 | IPCO=0 | |
37785 | RETURN | |
37786 | ENDIF | |
37787 | IF(IPIP.EQ.1)THEN | |
37788 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37789 | ELSEIF(IPIP.EQ.2)THEN | |
37790 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37791 | ENDIF | |
37792 | IF(IPCO.GE.3)THEN | |
37793 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37794 | * XDIQT,XVQP,XSQ,XSAQ | |
37795 | ENDIF | |
37796 | C | |
37797 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37798 | C | |
37799 | C XSQ=0.D0 | |
37800 | IF(IPIP.EQ.1)THEN | |
37801 | XDIQT=XDIQT-XSQ | |
37802 | XVQP =XVQP -XSAQ | |
37803 | ELSEIF(IPIP.EQ.2)THEN | |
37804 | XDIQT=XDIQT-XSAQ | |
37805 | XVQP =XVQP -XSQ | |
37806 | ENDIF | |
37807 | IF(IPCO.GE.3) | |
37808 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37809 | C | |
37810 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37811 | C | |
37812 | XVTHRO=CVQ/UMO | |
37813 | IVTHR=0 | |
37814 | 3466 CONTINUE | |
37815 | IF(IVTHR.EQ.10)THEN | |
37816 | IREJ=1 | |
37817 | IF(ISQ.EQ.3)IREJ=3 | |
37818 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' | |
37819 | IPCO=0 | |
37820 | RETURN | |
37821 | ENDIF | |
37822 | IVTHR=IVTHR+1 | |
37823 | XVTHR=XVTHRO/(201-IVTHR) | |
37824 | UNOPRV=UNON | |
37825 | 380 CONTINUE | |
37826 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37827 | IREJ=1 | |
37828 | IF(ISQ.EQ.3)IREJ=3 | |
37829 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ', | |
37830 | * XVTHR | |
37831 | IPCO=0 | |
37832 | RETURN | |
37833 | ENDIF | |
37834 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37835 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37836 | XVTQII=XDIQT-XVTQI | |
37837 | ELSE | |
37838 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37839 | XVTQI=XDIQT-XVTQII | |
37840 | ENDIF | |
37841 | IF(IPCO.GE.3)THEN | |
37842 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37843 | ENDIF | |
37844 | C | |
37845 | C Prepare 4 momenta of new chains and chain ends | |
37846 | C | |
37847 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37848 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37849 | C +(4,NTMHKK) | |
37850 | C | |
37851 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37852 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37853 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37854 | C | |
37855 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37856 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) | |
37857 | C | |
37858 | IF(IPIP.EQ.1)THEN | |
37859 | XSQ1=XSQ | |
37860 | XSAQ1=XSAQ | |
37861 | ISQ1=ISQ | |
37862 | ISAQ1=ISAQ | |
37863 | ELSEIF(IPIP.EQ.2)THEN | |
37864 | XSQ1=XSAQ | |
37865 | XSAQ1=XSQ | |
37866 | ISQ1=ISAQ | |
37867 | ISAQ1=ISQ | |
37868 | ENDIF | |
37869 | KK11=IP21 | |
37870 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37871 | KK21=IPP11 | |
37872 | KK22=IPP12 | |
37873 | XGIVE=0.D0 | |
37874 | IF(IPIP.EQ.1)THEN | |
37875 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37876 | ELSEIF(IPIP.EQ.2)THEN | |
37877 | IDHKT(4+IIGLU1) =ISAQ1 | |
37878 | ENDIF | |
37879 | ISTHKT(4+IIGLU1) =961 | |
37880 | JMOHKT(1,4+IIGLU1)=NC1P | |
37881 | JMOHKT(2,4+IIGLU1)=0 | |
37882 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37883 | JDAHKT(2,4+IIGLU1)=0 | |
37884 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37885 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37886 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37887 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37888 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37889 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37890 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
37891 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37892 | *PHKT(1,4+IIGLU1)**2) | |
37893 | IF(XXMIST.GT.0.D0)THEN | |
37894 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37895 | ELSE | |
37896 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
37897 | XXMIST=ABS(XXMIST) | |
37898 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37899 | ENDIF | |
37900 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37901 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37902 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37903 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37904 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37905 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37906 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37907 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37908 | IDHKT(5+IIGLU1) =IP22 | |
37909 | ISTHKT(5+IIGLU1) =962 | |
37910 | JMOHKT(1,5+IIGLU1)=NC1T | |
37911 | JMOHKT(2,5+IIGLU1)=0 | |
37912 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37913 | JDAHKT(2,5+IIGLU1)=0 | |
37914 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37915 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37916 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37917 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37918 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37919 | XXMIST=(PHKT(4,5+IIGLU1)**2- | |
37920 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37921 | *PHKT(1,5+IIGLU1)**2) | |
37922 | IF(XXMIST.GT.0.D0)THEN | |
37923 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37924 | ELSE | |
37925 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST | |
37926 | XXMIST=ABS(XXMIST) | |
37927 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37928 | ENDIF | |
37929 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37930 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37931 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37932 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37933 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37934 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37935 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37936 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37937 | IDHKT(6+IIGLU1) =88888 | |
37938 | ISTHKT(6+IIGLU1) =96 | |
37939 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37940 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37941 | JDAHKT(1,6+IIGLU1)=0 | |
37942 | JDAHKT(2,6+IIGLU1)=0 | |
37943 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37944 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37945 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37946 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37947 | PHKT(5,6+IIGLU1) | |
37948 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37949 | * -PHKT(3,6+IIGLU1)**2) | |
37950 | CHAMAL=CHAM1 | |
37951 | IF(IPIP.EQ.1)THEN | |
37952 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37953 | ELSEIF(IPIP.EQ.2)THEN | |
37954 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37955 | ENDIF | |
37956 | C--------------------------------------------------- | |
37957 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37958 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
37959 | C we drop chain 6 and give the energy to chain 3 | |
37960 | IDHKT(6+IIGLU1)=22888 | |
37961 | XGIVE=1.D0 | |
37962 | C WRITE(6,*)' drop chain 6 xgive=1' | |
37963 | GO TO 7788 | |
37964 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN | |
37965 | C we drop chain 6 and give the energy to chain 3 | |
37966 | C and change KK11 to IDHKT(5) | |
37967 | IDHKT(6+IIGLU1)=22888 | |
37968 | XGIVE=1.D0 | |
37969 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' | |
37970 | KK11=IDHKT(5+IIGLU1) | |
37971 | GO TO 7788 | |
37972 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN | |
37973 | C we drop chain 6 and give the energy to chain 3 | |
37974 | C and change KK21 to IDHKT(5+IIGLU1) | |
37975 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37976 | IDHKT(6+IIGLU1)=22888 | |
37977 | XGIVE=1.D0 | |
37978 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' | |
37979 | KK21=IDHKT(5+IIGLU1) | |
37980 | GO TO 7788 | |
37981 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN | |
37982 | C we drop chain 6 and give the energy to chain 3 | |
37983 | C and change KK22 to IDHKT(5) | |
37984 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37985 | IDHKT(6+IIGLU1)=22888 | |
37986 | XGIVE=1.D0 | |
37987 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' | |
37988 | KK22=IDHKT(5+IIGLU1) | |
37989 | GO TO 7788 | |
37990 | ENDIF | |
37991 | C IREJ=1 | |
37992 | IPCO=0 | |
37993 | C RETURN | |
37994 | GO TO 3466 | |
37995 | ENDIF | |
37996 | 7788 CONTINUE | |
37997 | C--------------------------------------------------- | |
37998 | IF(IPIP.GE.3)THEN | |
37999 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
38000 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
38001 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
38002 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
38003 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
38004 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
38005 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
38006 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
38007 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
38008 | ENDIF | |
38009 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
38010 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
38011 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
38012 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38013 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38014 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38015 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38016 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38017 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
38018 | IF(IPIP.EQ.1)THEN | |
38019 | IDHKT(1) =1000*KK21+100*KK22+3 | |
38020 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 | |
38021 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 | |
38022 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 | |
38023 | ELSEIF(IPIP.EQ.2)THEN | |
38024 | IDHKT(1) =1000*KK21+100*KK22-3 | |
38025 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 | |
38026 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 | |
38027 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 | |
38028 | ENDIF | |
38029 | ISTHKT(1) =961 | |
38030 | JMOHKT(1,1)=NC2P | |
38031 | JMOHKT(2,1)=0 | |
38032 | JDAHKT(1,1)=3+IIGLU1 | |
38033 | JDAHKT(2,1)=0 | |
38034 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
38035 | PHKT(1,1) =PHKK(1,NC2P) | |
38036 | *+XGIVE*PHKT(1,4+IIGLU1) | |
38037 | PHKT(2,1) =PHKK(2,NC2P) | |
38038 | *+XGIVE*PHKT(2,4+IIGLU1) | |
38039 | PHKT(3,1) =PHKK(3,NC2P) | |
38040 | *+XGIVE*PHKT(3,4+IIGLU1) | |
38041 | PHKT(4,1) =PHKK(4,NC2P) | |
38042 | *+XGIVE*PHKT(4,4+IIGLU1) | |
38043 | C PHKT(5,1) =PHKK(5,NC2P) | |
38044 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38045 | *PHKT(1,1)**2 | |
38046 | IF(XXMIST.GT.0.D0)THEN | |
38047 | PHKT(5,1) =SQRT(XXMIST) | |
38048 | ELSE | |
38049 | WRITE(LOUT,*)'MGSQBS2',XXMIST | |
38050 | XXMIST=ABS(XXMIST) | |
38051 | PHKT(5,1) =SQRT(XXMIST) | |
38052 | ENDIF | |
38053 | VHKT(1,1) =VHKK(1,NC2P) | |
38054 | VHKT(2,1) =VHKK(2,NC2P) | |
38055 | VHKT(3,1) =VHKK(3,NC2P) | |
38056 | VHKT(4,1) =VHKK(4,NC2P) | |
38057 | WHKT(1,1) =WHKK(1,NC2P) | |
38058 | WHKT(2,1) =WHKK(2,NC2P) | |
38059 | WHKT(3,1) =WHKK(3,NC2P) | |
38060 | WHKT(4,1) =WHKK(4,NC2P) | |
38061 | C Add here IIGLU1 gluons to this chaina | |
38062 | PG1=0.D0 | |
38063 | PG2=0.D0 | |
38064 | PG3=0.D0 | |
38065 | PG4=0.D0 | |
38066 | IF(IIGLU1.GE.1)THEN | |
38067 | JJG=NC1P | |
38068 | DO 61 IIG=2,2+IIGLU1-1 | |
38069 | KKG=JJG+IIG-1 | |
38070 | IDHKT(IIG) =IDHKK(KKG) | |
38071 | ISTHKT(IIG) =921 | |
38072 | JMOHKT(1,IIG)=KKG | |
38073 | JMOHKT(2,IIG)=0 | |
38074 | JDAHKT(1,IIG)=3+IIGLU1 | |
38075 | JDAHKT(2,IIG)=0 | |
38076 | PHKT(1,IIG)=PHKK(1,KKG) | |
38077 | PG1=PG1+ PHKT(1,IIG) | |
38078 | PHKT(2,IIG)=PHKK(2,KKG) | |
38079 | PG2=PG2+ PHKT(2,IIG) | |
38080 | PHKT(3,IIG)=PHKK(3,KKG) | |
38081 | PG3=PG3+ PHKT(3,IIG) | |
38082 | PHKT(4,IIG)=PHKK(4,KKG) | |
38083 | PG4=PG4+ PHKT(4,IIG) | |
38084 | PHKT(5,IIG)=PHKK(5,KKG) | |
38085 | VHKT(1,IIG) =VHKK(1,KKG) | |
38086 | VHKT(2,IIG) =VHKK(2,KKG) | |
38087 | VHKT(3,IIG) =VHKK(3,KKG) | |
38088 | VHKT(4,IIG) =VHKK(4,KKG) | |
38089 | WHKT(1,IIG) =WHKK(1,KKG) | |
38090 | WHKT(2,IIG) =WHKK(2,KKG) | |
38091 | WHKT(3,IIG) =WHKK(3,KKG) | |
38092 | WHKT(4,IIG) =WHKK(4,KKG) | |
38093 | 61 CONTINUE | |
38094 | ENDIF | |
38095 | C IDHKT(2) =IP21 | |
38096 | IDHKT(2+IIGLU1) =KK11 | |
38097 | ISTHKT(2+IIGLU1) =962 | |
38098 | JMOHKT(1,2+IIGLU1)=NC1T | |
38099 | JMOHKT(2,2+IIGLU1)=0 | |
38100 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38101 | JDAHKT(2,2+IIGLU1)=0 | |
38102 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38103 | C * +0.5D0*PHKK(1,NC2T) | |
38104 | *+XGIVE*PHKT(1,5+IIGLU1) | |
38105 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38106 | C *+0.5D0*PHKK(2,NC2T) | |
38107 | *+XGIVE*PHKT(2,5+IIGLU1) | |
38108 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38109 | C *+0.5D0*PHKK(3,NC2T) | |
38110 | *+XGIVE*PHKT(3,5+IIGLU1) | |
38111 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38112 | C *+0.5D0*PHKK(4,NC2T) | |
38113 | *+XGIVE*PHKT(4,5+IIGLU1) | |
38114 | C PHKT(5,2) =PHKK(5,NC1T) | |
38115 | XXMIST=(PHKT(4,2+IIGLU1)**2- | |
38116 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38117 | *PHKT(1,2+IIGLU1)**2) | |
38118 | IF(XXMIST.GT.0.D0)THEN | |
38119 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38120 | ELSE | |
38121 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
38122 | XXMIST=ABS(XXMIST) | |
38123 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38124 | ENDIF | |
38125 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
38126 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
38127 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
38128 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
38129 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
38130 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
38131 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
38132 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
38133 | IDHKT(3+IIGLU1) =88888 | |
38134 | ISTHKT(3+IIGLU1) =96 | |
38135 | JMOHKT(1,3+IIGLU1)=1 | |
38136 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38137 | JDAHKT(1,3+IIGLU1)=0 | |
38138 | JDAHKT(2,3+IIGLU1)=0 | |
38139 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38140 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38141 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38142 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38143 | PHKT(5,3+IIGLU1) | |
38144 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38145 | * -PHKT(3,3+IIGLU1)**2) | |
38146 | IF(IPIP.EQ.3)THEN | |
38147 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
38148 | * JDAHKT(1,1), | |
38149 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38150 | DO 71 IIG=2,2+IIGLU1-1 | |
38151 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38152 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38153 | * JDAHKT(1,IIG), | |
38154 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38155 | 71 CONTINUE | |
38156 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38157 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38158 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38159 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38160 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38161 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38162 | ENDIF | |
38163 | CHAMAL=CHAB1 | |
38164 | IF(IPIP.EQ.1)THEN | |
38165 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 | |
38166 | ELSEIF(IPIP.EQ.2)THEN | |
38167 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 | |
38168 | ENDIF | |
38169 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38170 | C IREJ=1 | |
38171 | IPCO=0 | |
38172 | C RETURN | |
38173 | GO TO 3466 | |
38174 | ENDIF | |
38175 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38176 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38177 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38178 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38179 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38180 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38181 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38182 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38183 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 | |
38184 | IDHKT(7+IIGLU1) =IP1 | |
38185 | ISTHKT(7+IIGLU1) =961 | |
38186 | JMOHKT(1,7+IIGLU1)=NC1P | |
38187 | JMOHKT(2,7+IIGLU1)=0 | |
38188 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38189 | JDAHKT(2,7+IIGLU1)=0 | |
38190 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
38191 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
38192 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
38193 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
38194 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
38195 | XXMIST=(PHKT(4,7+IIGLU1)**2- | |
38196 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38197 | *PHKT(1,7+IIGLU1)**2) | |
38198 | IF(XXMIST.GT.0.D0)THEN | |
38199 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38200 | ELSE | |
38201 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST | |
38202 | XXMIST=ABS(XXMIST) | |
38203 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38204 | ENDIF | |
38205 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
38206 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
38207 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
38208 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
38209 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
38210 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
38211 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
38212 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38213 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
38214 | C Insert here the IIGLU2 gluons | |
38215 | PG1=0.D0 | |
38216 | PG2=0.D0 | |
38217 | PG3=0.D0 | |
38218 | PG4=0.D0 | |
38219 | IF(IIGLU2.GE.1)THEN | |
38220 | JJG=NC2P | |
38221 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38222 | KKG=JJG+IIG-7-IIGLU1 | |
38223 | IDHKT(IIG) =IDHKK(KKG) | |
38224 | ISTHKT(IIG) =921 | |
38225 | JMOHKT(1,IIG)=KKG | |
38226 | JMOHKT(2,IIG)=0 | |
38227 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38228 | JDAHKT(2,IIG)=0 | |
38229 | PHKT(1,IIG)=PHKK(1,KKG) | |
38230 | PG1=PG1+ PHKT(1,IIG) | |
38231 | PHKT(2,IIG)=PHKK(2,KKG) | |
38232 | PG2=PG2+ PHKT(2,IIG) | |
38233 | PHKT(3,IIG)=PHKK(3,KKG) | |
38234 | PG3=PG3+ PHKT(3,IIG) | |
38235 | PHKT(4,IIG)=PHKK(4,KKG) | |
38236 | PG4=PG4+ PHKT(4,IIG) | |
38237 | PHKT(5,IIG)=PHKK(5,KKG) | |
38238 | VHKT(1,IIG) =VHKK(1,KKG) | |
38239 | VHKT(2,IIG) =VHKK(2,KKG) | |
38240 | VHKT(3,IIG) =VHKK(3,KKG) | |
38241 | VHKT(4,IIG) =VHKK(4,KKG) | |
38242 | WHKT(1,IIG) =WHKK(1,KKG) | |
38243 | WHKT(2,IIG) =WHKK(2,KKG) | |
38244 | WHKT(3,IIG) =WHKK(3,KKG) | |
38245 | WHKT(4,IIG) =WHKK(4,KKG) | |
38246 | 81 CONTINUE | |
38247 | ENDIF | |
38248 | IF(IPIP.EQ.1)THEN | |
38249 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
38250 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
38251 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
38252 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
38253 | ELSEIF(IPIP.EQ.2)THEN | |
38254 | **NEW | |
38255 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 | |
38256 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
38257 | ** | |
38258 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
38259 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
38260 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
38261 | ENDIF | |
38262 | ISTHKT(8+IIGLU1+IIGLU2) =962 | |
38263 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
38264 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38265 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38266 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38267 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) | |
38268 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) | |
38269 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) | |
38270 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) | |
38271 | PHKT(1,8+IIGLU1+IIGLU2) = | |
38272 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38273 | PHKT(2,8+IIGLU1+IIGLU2) = | |
38274 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38275 | PHKT(3,8+IIGLU1+IIGLU2) = | |
38276 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38277 | PHKT(4,8+IIGLU1+IIGLU2) = | |
38278 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38279 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
38280 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
38281 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
38282 | C IREJ=1 | |
38283 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
38284 | IPCO=0 | |
38285 | C RETURN | |
38286 | GO TO 3466 | |
38287 | ENDIF | |
38288 | C PHKT(5,8) =PHKK(5,NC2T) | |
38289 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38290 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38291 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38292 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
38293 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
38294 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
38295 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
38296 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
38297 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
38298 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
38299 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
38300 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38301 | ISTHKT(9+IIGLU1+IIGLU2) =96 | |
38302 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38303 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38304 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38305 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38306 | PHKT(1,9+IIGLU1+IIGLU2) | |
38307 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38308 | PHKT(2,9+IIGLU1+IIGLU2) | |
38309 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38310 | PHKT(3,9+IIGLU1+IIGLU2) | |
38311 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38312 | PHKT(4,9+IIGLU1+IIGLU2) | |
38313 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38314 | PHKT(5,9+IIGLU1+IIGLU2) | |
38315 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
38316 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38317 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38318 | IF(IPIP.GE.3)THEN | |
38319 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38320 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38321 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38322 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38323 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38324 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38325 | * JDAHKT(1,IIG), | |
38326 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38327 | 91 CONTINUE | |
38328 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
38329 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
38330 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
38331 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38332 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38333 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38334 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38335 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38336 | ENDIF | |
38337 | CHAMAL=CHAB1 | |
38338 | IF(IPIP.EQ.1)THEN | |
38339 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38340 | ELSEIF(IPIP.EQ.2)THEN | |
38341 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38342 | ENDIF | |
38343 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38344 | C IREJ=1 | |
38345 | IPCO=0 | |
38346 | C RETURN | |
38347 | GO TO 3466 | |
38348 | ENDIF | |
38349 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38350 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38351 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38352 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38353 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38354 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38355 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38356 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38357 | C | |
38358 | IPCO=0 | |
38359 | IGCOUN=9+IIGLU1+IIGLU2 | |
38360 | RETURN | |
38361 | END | |
38362 | ||
38363 | *$ CREATE MUSQBS1.FOR | |
38364 | *COPY MUSQBS1 | |
38365 | C | |
38366 | C | |
38367 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
38368 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38369 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
38370 | C | |
38371 | C USQBS-1 diagram (split projectile diquark) | |
38372 | C | |
38373 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38374 | SAVE | |
38375 | ||
38376 | PARAMETER ( LINP = 10 , | |
38377 | & LOUT = 6 , | |
38378 | & LDAT = 9 ) | |
38379 | * event history | |
38380 | PARAMETER (NMXHKK=200000) | |
38381 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38382 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38383 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38384 | * extended event history | |
38385 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38386 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38387 | & IHIST(2,NMXHKK) | |
38388 | * Lorentz-parameters of the current interaction | |
38389 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
38390 | & UMO,PPCM,EPROJ,PPROJ | |
38391 | * diquark-breaking mechanism | |
38392 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
38393 | ||
38394 | C | |
38395 | PARAMETER (NTMHKK= 300) | |
38396 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38397 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38398 | +(4,NTMHKK) | |
38399 | *KEEP,XSEADI. | |
38400 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
38401 | +SSMIMQ,VVMTHR | |
38402 | *KEEP,DPRIN. | |
38403 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
38404 | COMMON /EVFLAG/ NUMEV | |
38405 | C | |
38406 | C USQBS-1 diagram (split projectile diquark) | |
38407 | C | |
38408 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
38409 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) | |
38410 | C | |
38411 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T | |
38412 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38413 | C | |
38414 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38415 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38416 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38417 | C | |
38418 | C Put new chains into COMMON /HKKTMP/ | |
38419 | C | |
38420 | IIGLU1=NC1T-NC1P-1 | |
38421 | IIGLU2=NC2T-NC2P-1 | |
38422 | IGCOUN=0 | |
38423 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP | |
38424 | CVQ=1.D0 | |
38425 | IREJ=0 | |
38426 | IF(IPIP.EQ.3)THEN | |
38427 | C IF(NUMEV.EQ.-324)THEN | |
38428 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
38429 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', | |
38430 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38431 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN | |
38432 | ENDIF | |
38433 | C | |
38434 | C | |
38435 | C | |
38436 | C determine x-values of NC1P diquark | |
38437 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
38438 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
38439 | C | |
38440 | C determine x-values of sea quark pair | |
38441 | C | |
38442 | IPCO=1 | |
38443 | ICOU=0 | |
38444 | 2234 CONTINUE | |
38445 | ICOU=ICOU+1 | |
38446 | IF(ICOU.GE.500)THEN | |
38447 | IREJ=1 | |
38448 | IF(ISQ.EQ.3)IREJ=3 | |
38449 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' | |
38450 | IPCO=0 | |
38451 | RETURN | |
38452 | ENDIF | |
38453 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
38454 | * UMO, XDIQP,XVQT | |
38455 | XSQ=0.D0 | |
38456 | XSAQ=0.D0 | |
38457 | **NEW | |
38458 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
38459 | IF (IPIP.EQ.1) THEN | |
38460 | XQMAX = XDIQP/2.0D0 | |
38461 | XAQMAX = 2.D0*XVQT/3.0D0 | |
38462 | ELSE | |
38463 | XQMAX = 2.D0*XVQT/3.0D0 | |
38464 | XAQMAX = XDIQP/2.0D0 | |
38465 | ENDIF | |
38466 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
38467 | ISAQ = 6+ISQ | |
38468 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
38469 | ** | |
38470 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38471 | IF(IREJ.GE.1)THEN | |
38472 | IF(IPCO.GE.3) | |
38473 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38474 | IPCO=0 | |
38475 | RETURN | |
38476 | ENDIF | |
38477 | IF(IPIP.EQ.1)THEN | |
38478 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38479 | ELSEIF(IPIP.EQ.2)THEN | |
38480 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38481 | ENDIF | |
38482 | IF(IPCO.GE.3)THEN | |
38483 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
38484 | * XDIQP,XVQT,XSQ,XSAQ | |
38485 | ENDIF | |
38486 | C | |
38487 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
38488 | C | |
38489 | C XSQ=0.D0 | |
38490 | IF(IPIP.EQ.1)THEN | |
38491 | XDIQP=XDIQP-XSQ | |
38492 | XVQT =XVQT -XSAQ | |
38493 | ELSEIF(IPIP.EQ.2)THEN | |
38494 | XDIQP=XDIQP-XSAQ | |
38495 | XVQT =XVQT -XSQ | |
38496 | ENDIF | |
38497 | IF(IPCO.GE.3) | |
38498 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
38499 | C | |
38500 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38501 | C | |
38502 | XVTHRO=CVQ/UMO | |
38503 | IVTHR=0 | |
38504 | 3466 CONTINUE | |
38505 | IF(IVTHR.EQ.10)THEN | |
38506 | IREJ=1 | |
38507 | IF(ISQ.EQ.3)IREJ=3 | |
38508 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' | |
38509 | IPCO=0 | |
38510 | RETURN | |
38511 | ENDIF | |
38512 | IVTHR=IVTHR+1 | |
38513 | XVTHR=XVTHRO/(201-IVTHR) | |
38514 | UNOPRV=UNON | |
38515 | 380 CONTINUE | |
38516 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
38517 | IREJ=1 | |
38518 | IF(ISQ.EQ.3)IREJ=3 | |
38519 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ', | |
38520 | * XVTHR | |
38521 | IPCO=0 | |
38522 | RETURN | |
38523 | ENDIF | |
38524 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
38525 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38526 | XVPQII=XDIQP-XVPQI | |
38527 | ELSE | |
38528 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38529 | XVPQI=XDIQP-XVPQII | |
38530 | ENDIF | |
38531 | IF(IPCO.GE.3)THEN | |
38532 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII | |
38533 | ENDIF | |
38534 | C | |
38535 | C Prepare 4 momenta of new chains and chain ends | |
38536 | C | |
38537 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38538 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38539 | C +(4,NTMHKK) | |
38540 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38541 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38542 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38543 | IF(IPIP.EQ.1)THEN | |
38544 | XSQ1=XSQ | |
38545 | XSAQ1=XSAQ | |
38546 | ISQ1=ISQ | |
38547 | ISAQ1=ISAQ | |
38548 | ELSEIF(IPIP.EQ.2)THEN | |
38549 | XSQ1=XSAQ | |
38550 | XSAQ1=XSQ | |
38551 | ISQ1=ISAQ | |
38552 | ISAQ1=ISQ | |
38553 | ENDIF | |
38554 | IDHKT(1) =IP11 | |
38555 | ISTHKT(1) =931 | |
38556 | JMOHKT(1,1)=NC1P | |
38557 | JMOHKT(2,1)=0 | |
38558 | JDAHKT(1,1)=3+IIGLU1 | |
38559 | JDAHKT(2,1)=0 | |
38560 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38561 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38562 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38563 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38564 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38565 | C PHKT(5,1) =PHKK(5,NC1P) | |
38566 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38567 | *PHKT(1,1)**2) | |
38568 | IF(XMIST.GE.0.D0)THEN | |
38569 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38570 | *PHKT(1,1)**2) | |
38571 | ELSE | |
38572 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38573 | PHKT(5,1)=0.D0 | |
38574 | ENDIF | |
38575 | VHKT(1,1) =VHKK(1,NC1P) | |
38576 | VHKT(2,1) =VHKK(2,NC1P) | |
38577 | VHKT(3,1) =VHKK(3,NC1P) | |
38578 | VHKT(4,1) =VHKK(4,NC1P) | |
38579 | WHKT(1,1) =WHKK(1,NC1P) | |
38580 | WHKT(2,1) =WHKK(2,NC1P) | |
38581 | WHKT(3,1) =WHKK(3,NC1P) | |
38582 | WHKT(4,1) =WHKK(4,NC1P) | |
38583 | C Add here IIGLU1 gluons to this chaina | |
38584 | PG1=0.D0 | |
38585 | PG2=0.D0 | |
38586 | PG3=0.D0 | |
38587 | PG4=0.D0 | |
38588 | IF(IIGLU1.GE.1)THEN | |
38589 | JJG=NC1P | |
38590 | DO 61 IIG=2,2+IIGLU1-1 | |
38591 | KKG=JJG+IIG-1 | |
38592 | IDHKT(IIG) =IDHKK(KKG) | |
38593 | ISTHKT(IIG) =921 | |
38594 | JMOHKT(1,IIG)=KKG | |
38595 | JMOHKT(2,IIG)=0 | |
38596 | JDAHKT(1,IIG)=3+IIGLU1 | |
38597 | JDAHKT(2,IIG)=0 | |
38598 | PHKT(1,IIG)=PHKK(1,KKG) | |
38599 | PG1=PG1+ PHKT(1,IIG) | |
38600 | PHKT(2,IIG)=PHKK(2,KKG) | |
38601 | PG2=PG2+ PHKT(2,IIG) | |
38602 | PHKT(3,IIG)=PHKK(3,KKG) | |
38603 | PG3=PG3+ PHKT(3,IIG) | |
38604 | PHKT(4,IIG)=PHKK(4,KKG) | |
38605 | PG4=PG4+ PHKT(4,IIG) | |
38606 | PHKT(5,IIG)=PHKK(5,KKG) | |
38607 | VHKT(1,IIG) =VHKK(1,KKG) | |
38608 | VHKT(2,IIG) =VHKK(2,KKG) | |
38609 | VHKT(3,IIG) =VHKK(3,KKG) | |
38610 | VHKT(4,IIG) =VHKK(4,KKG) | |
38611 | WHKT(1,IIG) =WHKK(1,KKG) | |
38612 | WHKT(2,IIG) =WHKK(2,KKG) | |
38613 | WHKT(3,IIG) =WHKK(3,KKG) | |
38614 | WHKT(4,IIG) =WHKK(4,KKG) | |
38615 | 61 CONTINUE | |
38616 | ENDIF | |
38617 | IDHKT(2+IIGLU1) =IPP2 | |
38618 | ISTHKT(2+IIGLU1) =932 | |
38619 | JMOHKT(1,2+IIGLU1)=NC2T | |
38620 | JMOHKT(2,2+IIGLU1)=0 | |
38621 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38622 | JDAHKT(2,2+IIGLU1)=0 | |
38623 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
38624 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
38625 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
38626 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
38627 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) | |
38628 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
38629 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38630 | *PHKT(1,2+IIGLU1)**2) | |
38631 | IF(XMIST.GT.0.D0)THEN | |
38632 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
38633 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38634 | *PHKT(1,2+IIGLU1)**2) | |
38635 | ELSE | |
38636 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38637 | PHKT(5,2+IIGLU1)=0.D0 | |
38638 | ENDIF | |
38639 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
38640 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
38641 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
38642 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
38643 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
38644 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
38645 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
38646 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
38647 | IDHKT(3+IIGLU1) =88888 | |
38648 | ISTHKT(3+IIGLU1) =94 | |
38649 | JMOHKT(1,3+IIGLU1)=1 | |
38650 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38651 | JDAHKT(1,3+IIGLU1)=0 | |
38652 | JDAHKT(2,3+IIGLU1)=0 | |
38653 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38654 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38655 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38656 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38657 | XMIST | |
38658 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38659 | * -PHKT(3,3+IIGLU1)**2) | |
38660 | IF(XMIST.GE.0.D0)THEN | |
38661 | PHKT(5,3+IIGLU1) | |
38662 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38663 | * -PHKT(3,3+IIGLU1)**2) | |
38664 | ELSE | |
38665 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38666 | PHKT(5,1)=0.D0 | |
38667 | ENDIF | |
38668 | IF(IPIP.GE.3)THEN | |
38669 | C IF(NUMEV.EQ.-324)THEN | |
38670 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), | |
38671 | * JMOHKT(2,1),JDAHKT(1,1), | |
38672 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38673 | DO 71 IIG=2,2+IIGLU1-1 | |
38674 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38675 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38676 | * JDAHKT(1,IIG), | |
38677 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38678 | 71 CONTINUE | |
38679 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38680 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38681 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38682 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38683 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38684 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38685 | ENDIF | |
38686 | CHAMAL=CHAM1 | |
38687 | IF(IPIP.EQ.1)THEN | |
38688 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 | |
38689 | ELSEIF(IPIP.EQ.2)THEN | |
38690 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 | |
38691 | ENDIF | |
38692 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38693 | C IREJ=1 | |
38694 | IPCO=0 | |
38695 | C RETURN | |
38696 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' | |
38697 | GO TO 3466 | |
38698 | ENDIF | |
38699 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38700 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38701 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38702 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38703 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38704 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38705 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38706 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38707 | IDHKT(4+IIGLU1) =IP12 | |
38708 | ISTHKT(4+IIGLU1) =931 | |
38709 | JMOHKT(1,4+IIGLU1)=NC1P | |
38710 | JMOHKT(2,4+IIGLU1)=0 | |
38711 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
38712 | JDAHKT(2,4+IIGLU1)=0 | |
38713 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38714 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38715 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38716 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38717 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38718 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
38719 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
38720 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38721 | *PHKT(1,4+IIGLU1)**2) | |
38722 | IF(XMIST.GT.0.D0)THEN | |
38723 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
38724 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38725 | *PHKT(1,4+IIGLU1)**2) | |
38726 | ELSE | |
38727 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38728 | PHKT(5,4+IIGLU1)=0.D0 | |
38729 | ENDIF | |
38730 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
38731 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
38732 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
38733 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
38734 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
38735 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
38736 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
38737 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
38738 | IF(IPIP.EQ.1)THEN | |
38739 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
38740 | ELSEIF(IPIP.EQ.2)THEN | |
38741 | IDHKT(5+IIGLU1) =ISAQ1 | |
38742 | ENDIF | |
38743 | ISTHKT(5+IIGLU1) =932 | |
38744 | JMOHKT(1,5+IIGLU1)=NC1T | |
38745 | JMOHKT(2,5+IIGLU1)=0 | |
38746 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
38747 | JDAHKT(2,5+IIGLU1)=0 | |
38748 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38749 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38750 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38751 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38752 | C IF( PHKT(4,5).EQ.0.D0)THEN | |
38753 | C IREJ=1 | |
38754 | CIPCO=0 | |
38755 | CRETURN | |
38756 | C ENDIF | |
38757 | C PHKT(5,5) =PHKK(5,NC1T) | |
38758 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
38759 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38760 | *PHKT(1,5+IIGLU1)**2) | |
38761 | IF(XMIST.GT.0.D0)THEN | |
38762 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
38763 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38764 | *PHKT(1,5+IIGLU1)**2) | |
38765 | ELSE | |
38766 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38767 | PHKT(5,5+IIGLU1)=0.D0 | |
38768 | ENDIF | |
38769 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
38770 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
38771 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
38772 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
38773 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
38774 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
38775 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
38776 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
38777 | IDHKT(6+IIGLU1) =88888 | |
38778 | ISTHKT(6+IIGLU1) =94 | |
38779 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
38780 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
38781 | JDAHKT(1,6+IIGLU1)=0 | |
38782 | JDAHKT(2,6+IIGLU1)=0 | |
38783 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
38784 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
38785 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
38786 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
38787 | XMIST | |
38788 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38789 | * -PHKT(3,6+IIGLU1)**2) | |
38790 | IF(XMIST.GE.0.D0)THEN | |
38791 | PHKT(5,6+IIGLU1) | |
38792 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38793 | * -PHKT(3,6+IIGLU1)**2) | |
38794 | ELSE | |
38795 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38796 | PHKT(5,1)=0.D0 | |
38797 | ENDIF | |
38798 | C IF(IPIP.EQ.3)THEN | |
38799 | CHAMAL=CHAM1 | |
38800 | IF(IPIP.EQ.1)THEN | |
38801 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
38802 | ELSEIF(IPIP.EQ.2)THEN | |
38803 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
38804 | ENDIF | |
38805 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
38806 | C IREJ=1 | |
38807 | IPCO=0 | |
38808 | C RETURN | |
38809 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', | |
38810 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
38811 | GO TO 3466 | |
38812 | ENDIF | |
38813 | IF(IPIP.GE.3)THEN | |
38814 | C IF(NUMEV.EQ.-324)THEN | |
38815 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
38816 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
38817 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
38818 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
38819 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
38820 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
38821 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
38822 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
38823 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
38824 | ENDIF | |
38825 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
38826 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
38827 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
38828 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38829 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38830 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38831 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38832 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38833 | IF(IPIP.EQ.1)THEN | |
38834 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 | |
38835 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
38836 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
38837 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
38838 | ELSEIF(IPIP.EQ.2)THEN | |
38839 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
38840 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
38841 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
38842 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
38843 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 | |
38844 | ENDIF | |
38845 | ISTHKT(7+IIGLU1) =931 | |
38846 | JMOHKT(1,7+IIGLU1)=NC2P | |
38847 | JMOHKT(2,7+IIGLU1)=0 | |
38848 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38849 | JDAHKT(2,7+IIGLU1)=0 | |
38850 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38851 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38852 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38853 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38854 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38855 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
38856 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
38857 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
38858 | C IREJ=1 | |
38859 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' | |
38860 | IPCO=0 | |
38861 | C RETURN | |
38862 | GO TO 3466 | |
38863 | ENDIF | |
38864 | C PHKT(5,7) =PHKK(5,NC2P) | |
38865 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
38866 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38867 | *PHKT(1,7+IIGLU1)**2) | |
38868 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
38869 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
38870 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
38871 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
38872 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
38873 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
38874 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
38875 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38876 | C Insert here the IIGLU2 gluons | |
38877 | PG1=0.D0 | |
38878 | PG2=0.D0 | |
38879 | PG3=0.D0 | |
38880 | PG4=0.D0 | |
38881 | IF(IIGLU2.GE.1)THEN | |
38882 | JJG=NC2P | |
38883 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38884 | KKG=JJG+IIG-7-IIGLU1 | |
38885 | IDHKT(IIG) =IDHKK(KKG) | |
38886 | ISTHKT(IIG) =921 | |
38887 | JMOHKT(1,IIG)=KKG | |
38888 | JMOHKT(2,IIG)=0 | |
38889 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38890 | JDAHKT(2,IIG)=0 | |
38891 | PHKT(1,IIG)=PHKK(1,KKG) | |
38892 | PG1=PG1+ PHKT(1,IIG) | |
38893 | PHKT(2,IIG)=PHKK(2,KKG) | |
38894 | PG2=PG2+ PHKT(2,IIG) | |
38895 | PHKT(3,IIG)=PHKK(3,KKG) | |
38896 | PG3=PG3+ PHKT(3,IIG) | |
38897 | PHKT(4,IIG)=PHKK(4,KKG) | |
38898 | PG4=PG4+ PHKT(4,IIG) | |
38899 | PHKT(5,IIG)=PHKK(5,KKG) | |
38900 | VHKT(1,IIG) =VHKK(1,KKG) | |
38901 | VHKT(2,IIG) =VHKK(2,KKG) | |
38902 | VHKT(3,IIG) =VHKK(3,KKG) | |
38903 | VHKT(4,IIG) =VHKK(4,KKG) | |
38904 | WHKT(1,IIG) =WHKK(1,KKG) | |
38905 | WHKT(2,IIG) =WHKK(2,KKG) | |
38906 | WHKT(3,IIG) =WHKK(3,KKG) | |
38907 | WHKT(4,IIG) =WHKK(4,KKG) | |
38908 | 81 CONTINUE | |
38909 | ENDIF | |
38910 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
38911 | ISTHKT(8+IIGLU1+IIGLU2) =932 | |
38912 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
38913 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38914 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38915 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38916 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
38917 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
38918 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
38919 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
38920 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
38921 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38922 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38923 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38924 | IF(XMIST.GT.0.D0)THEN | |
38925 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38926 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38927 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38928 | ELSE | |
38929 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38930 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
38931 | ENDIF | |
38932 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
38933 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
38934 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
38935 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
38936 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
38937 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
38938 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
38939 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
38940 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38941 | ISTHKT(9+IIGLU1+IIGLU2) =94 | |
38942 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38943 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38944 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38945 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38946 | PHKT(1,9+IIGLU1+IIGLU2) | |
38947 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38948 | PHKT(2,9+IIGLU1+IIGLU2) | |
38949 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38950 | PHKT(3,9+IIGLU1+IIGLU2) | |
38951 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38952 | PHKT(4,9+IIGLU1+IIGLU2) | |
38953 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38954 | XMIST | |
38955 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38956 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38957 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38958 | IF(XMIST.GE.0.D0)THEN | |
38959 | PHKT(5,9+IIGLU1+IIGLU2) | |
38960 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38961 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38962 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38963 | ELSE | |
38964 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38965 | PHKT(5,1)=0.D0 | |
38966 | ENDIF | |
38967 | IF(IPIP.GE.3)THEN | |
38968 | C IF(NUMEV.EQ.-324)THEN | |
38969 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38970 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38971 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38972 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38973 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38974 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38975 | * JDAHKT(1,IIG), | |
38976 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38977 | 91 CONTINUE | |
38978 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, | |
38979 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), | |
38980 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
38981 | *JDAHKT(1,8+IIGLU1+IIGLU2), | |
38982 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38983 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38984 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38985 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38986 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38987 | ENDIF | |
38988 | CHAMAL=CHAB1 | |
38989 | IF(IPIP.EQ.1)THEN | |
38990 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38991 | ELSEIF(IPIP.EQ.2)THEN | |
38992 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38993 | ENDIF | |
38994 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38995 | C IREJ=1 | |
38996 | IPCO=0 | |
38997 | C RETURN | |
38998 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
38999 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
39000 | GO TO 3466 | |
39001 | ENDIF | |
39002 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
39003 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
39004 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
39005 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
39006 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
39007 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
39008 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
39009 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
39010 | C | |
39011 | IPCO=0 | |
39012 | IGCOUN=9+IIGLU1+IIGLU2 | |
39013 | RETURN | |
39014 | END | |
39015 | ||
39016 | *$ CREATE MGSQBS1.FOR | |
39017 | *COPY MGSQBS1 | |
39018 | C | |
39019 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
39020 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
39021 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) | |
39022 | C | |
39023 | C GSQBS-1 diagram (split projectile diquark) | |
39024 | C | |
39025 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39026 | SAVE | |
39027 | ||
39028 | PARAMETER ( LINP = 10 , | |
39029 | & LOUT = 6 , | |
39030 | & LDAT = 9 ) | |
39031 | * event history | |
39032 | PARAMETER (NMXHKK=200000) | |
39033 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39034 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39035 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39036 | * extended event history | |
39037 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39038 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39039 | & IHIST(2,NMXHKK) | |
39040 | * Lorentz-parameters of the current interaction | |
39041 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
39042 | & UMO,PPCM,EPROJ,PPROJ | |
39043 | * diquark-breaking mechanism | |
39044 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
39045 | ||
39046 | C | |
39047 | PARAMETER (NTMHKK= 300) | |
39048 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39049 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39050 | +(4,NTMHKK) | |
39051 | *KEEP,XSEADI. | |
39052 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
39053 | +SSMIMQ,VVMTHR | |
39054 | *KEEP,DPRIN. | |
39055 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
39056 | C | |
39057 | C GSQBS-1 diagram (split projectile diquark) | |
39058 | C | |
39059 | C | |
39060 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
39061 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) | |
39062 | C | |
39063 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T | |
39064 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39065 | C | |
39066 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39067 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39068 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39069 | C | |
39070 | C Put new chains into COMMON /HKKTMP/ | |
39071 | C | |
39072 | IIGLU1=NC1T-NC1P-1 | |
39073 | IIGLU2=NC2T-NC2P-1 | |
39074 | IGCOUN=0 | |
39075 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
39076 | CVQ=1.D0 | |
39077 | NNNC1=IDHKK(NC1)/1000 | |
39078 | MMMC1=IDHKK(NC1)-NNNC1*1000 | |
39079 | KKKC1=ISTHKK(NC1) | |
39080 | NNNC2=IDHKK(NC2)/1000 | |
39081 | MMMC2=IDHKK(NC2)-NNNC2*1000 | |
39082 | KKKC2=ISTHKK(NC2) | |
39083 | IREJ=0 | |
39084 | IF(IPIP.EQ.3)THEN | |
39085 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
39086 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', | |
39087 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
39088 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN | |
39089 | ENDIF | |
39090 | C | |
39091 | C | |
39092 | C | |
39093 | C determine x-values of NC1P diquark | |
39094 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
39095 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
39096 | C | |
39097 | C determine x-values of sea quark pair | |
39098 | C | |
39099 | IPCO=1 | |
39100 | ICOU=0 | |
39101 | 2234 CONTINUE | |
39102 | ICOU=ICOU+1 | |
39103 | IF(ICOU.GE.500)THEN | |
39104 | IREJ=1 | |
39105 | IF(ISQ.EQ.3)IREJ=3 | |
39106 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' | |
39107 | IPCO=0 | |
39108 | RETURN | |
39109 | ENDIF | |
39110 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
39111 | * UMO, XDIQP,XVQT | |
39112 | XSQ=0.D0 | |
39113 | XSAQ=0.D0 | |
39114 | **NEW | |
39115 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
39116 | IF (IPIP.EQ.1) THEN | |
39117 | XQMAX = XDIQP/2.0D0 | |
39118 | XAQMAX = 2.D0*XVQT/3.0D0 | |
39119 | ELSE | |
39120 | XQMAX = 2.D0*XVQT/3.0D0 | |
39121 | XAQMAX = XDIQP/2.0D0 | |
39122 | ENDIF | |
39123 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
39124 | ISAQ = 6+ISQ | |
39125 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
39126 | ** | |
39127 | IF(IPCO.GE.3) | |
39128 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39129 | IF(IREJ.GE.1)THEN | |
39130 | IF(IPCO.GE.3) | |
39131 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39132 | IPCO=0 | |
39133 | RETURN | |
39134 | ENDIF | |
39135 | IF(IPIP.EQ.1)THEN | |
39136 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39137 | ELSEIF(IPIP.EQ.2)THEN | |
39138 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39139 | ENDIF | |
39140 | IF(IPCO.GE.3)THEN | |
39141 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
39142 | * XDIQP,XVQT,XSQ,XSAQ | |
39143 | ENDIF | |
39144 | C | |
39145 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
39146 | C | |
39147 | C XSQ=0.D0 | |
39148 | IF(IPIP.EQ.1)THEN | |
39149 | XDIQP=XDIQP-XSQ | |
39150 | **NEW | |
39151 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP | |
39152 | ** | |
39153 | XVQT =XVQT -XSAQ | |
39154 | ELSEIF(IPIP.EQ.2)THEN | |
39155 | XDIQP=XDIQP-XSAQ | |
39156 | XVQT =XVQT -XSQ | |
39157 | ENDIF | |
39158 | IF(IPCO.GE.3) | |
39159 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
39160 | C | |
39161 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39162 | C | |
39163 | XVTHRO=CVQ/UMO | |
39164 | IVTHR=0 | |
39165 | 3466 CONTINUE | |
39166 | IF(IVTHR.EQ.10)THEN | |
39167 | IREJ=1 | |
39168 | IF(ISQ.EQ.3)IREJ=3 | |
39169 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' | |
39170 | IPCO=0 | |
39171 | RETURN | |
39172 | ENDIF | |
39173 | IVTHR=IVTHR+1 | |
39174 | XVTHR=XVTHRO/(201-IVTHR) | |
39175 | UNOPRV=UNON | |
39176 | 380 CONTINUE | |
39177 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
39178 | IREJ=1 | |
39179 | IF(ISQ.EQ.3)IREJ=3 | |
39180 | IF(IPCO.GE.3) | |
39181 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ', | |
39182 | * XVTHR | |
39183 | IPCO=0 | |
39184 | RETURN | |
39185 | ENDIF | |
39186 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
39187 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39188 | XVPQII=XDIQP-XVPQI | |
39189 | ELSE | |
39190 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39191 | XVPQI=XDIQP-XVPQII | |
39192 | ENDIF | |
39193 | IF(IPCO.GE.3)THEN | |
39194 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', | |
39195 | * XVTHR,XDIQP,XVPQI,XVPQII | |
39196 | ENDIF | |
39197 | C | |
39198 | C Prepare 4 momenta of new chains and chain ends | |
39199 | C | |
39200 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39201 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39202 | C +(4,NTMHKK) | |
39203 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39204 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39205 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39206 | IF(IPIP.EQ.1)THEN | |
39207 | XSQ1=XSQ | |
39208 | XSAQ1=XSAQ | |
39209 | ISQ1=ISQ | |
39210 | ISAQ1=ISAQ | |
39211 | ELSEIF(IPIP.EQ.2)THEN | |
39212 | XSQ1=XSAQ | |
39213 | XSAQ1=XSQ | |
39214 | ISQ1=ISAQ | |
39215 | ISAQ1=ISQ | |
39216 | ENDIF | |
39217 | KK11=IP11 | |
39218 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39219 | KK21= IPP21 | |
39220 | KK22= IPP22 | |
39221 | XGIVE=0.D0 | |
39222 | IDHKT(4+IIGLU1) =IP12 | |
39223 | ISTHKT(4+IIGLU1) =921 | |
39224 | JMOHKT(1,4+IIGLU1)=NC1P | |
39225 | JMOHKT(2,4+IIGLU1)=0 | |
39226 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
39227 | JDAHKT(2,4+IIGLU1)=0 | |
39228 | **NEW | |
39229 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. | |
39230 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 | |
39231 | ** | |
39232 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39233 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39234 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39235 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39236 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
39237 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
39238 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
39239 | * PHKT(1,4+IIGLU1)**2) | |
39240 | IF(XXMIST.GT.0.D0)THEN | |
39241 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39242 | ELSE | |
39243 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST | |
39244 | XXMIST=ABS(XXMIST) | |
39245 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39246 | ENDIF | |
39247 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
39248 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
39249 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
39250 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
39251 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
39252 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
39253 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
39254 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
39255 | IF(IPIP.EQ.1)THEN | |
39256 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
39257 | ELSEIF(IPIP.EQ.2)THEN | |
39258 | IDHKT(5+IIGLU1) =ISAQ1 | |
39259 | ENDIF | |
39260 | ISTHKT(5+IIGLU1) =922 | |
39261 | JMOHKT(1,5+IIGLU1)=NC1T | |
39262 | JMOHKT(2,5+IIGLU1)=0 | |
39263 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
39264 | JDAHKT(2,5+IIGLU1)=0 | |
39265 | **NEW | |
39266 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) | |
39267 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT | |
39268 | ** | |
39269 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39270 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39271 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39272 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39273 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
39274 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
39275 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39276 | *PHKT(1,5+IIGLU1)**2) | |
39277 | IF(XMIST.GT.0.D0)THEN | |
39278 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
39279 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39280 | *PHKT(1,5+IIGLU1)**2) | |
39281 | ELSE | |
39282 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
39283 | PHKT(5,5+IIGLU1)=0.D0 | |
39284 | ENDIF | |
39285 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
39286 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
39287 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
39288 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
39289 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
39290 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
39291 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
39292 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
39293 | IDHKT(6+IIGLU1) =88888 | |
39294 | C IDHKT(6) =1000*NNNC1+MMMC1 | |
39295 | ISTHKT(6+IIGLU1) =93 | |
39296 | C ISTHKT(6) =KKKC1 | |
39297 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
39298 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
39299 | JDAHKT(1,6+IIGLU1)=0 | |
39300 | JDAHKT(2,6+IIGLU1)=0 | |
39301 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
39302 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
39303 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
39304 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
39305 | PHKT(5,6+IIGLU1) | |
39306 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
39307 | * -PHKT(3,6+IIGLU1)**2) | |
39308 | CHAMAL=CHAM1 | |
39309 | IF(IPIP.EQ.1)THEN | |
39310 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 | |
39311 | ELSEIF(IPIP.EQ.2)THEN | |
39312 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 | |
39313 | ENDIF | |
39314 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
39315 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
39316 | C we drop chain 6 and give the energy to chain 3 | |
39317 | IDHKT(6+IIGLU1)=33888 | |
39318 | XGIVE=1.D0 | |
39319 | C WRITE(6,*)' drop chain 6 xgive=1' | |
39320 | GO TO 7788 | |
39321 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN | |
39322 | C we drop chain 6 and give the energy to chain 3 | |
39323 | C and change KK11 to IDHKT(4) | |
39324 | IDHKT(6+IIGLU1)=33888 | |
39325 | XGIVE=1.D0 | |
39326 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' | |
39327 | KK11=IDHKT(4+IIGLU1) | |
39328 | GO TO 7788 | |
39329 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN | |
39330 | C we drop chain 6 and give the energy to chain 3 | |
39331 | C and change KK21 to IDHKT(4) | |
39332 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39333 | IDHKT(6+IIGLU1)=33888 | |
39334 | XGIVE=1.D0 | |
39335 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' | |
39336 | KK21=IDHKT(4+IIGLU1) | |
39337 | GO TO 7788 | |
39338 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN | |
39339 | C we drop chain 6 and give the energy to chain 3 | |
39340 | C and change KK22 to IDHKT(4) | |
39341 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39342 | IDHKT(6+IIGLU1)=33888 | |
39343 | XGIVE=1.D0 | |
39344 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' | |
39345 | KK22=IDHKT(4+IIGLU1) | |
39346 | GO TO 7788 | |
39347 | ENDIF | |
39348 | C IREJ=1 | |
39349 | IPCO=0 | |
39350 | C RETURN | |
39351 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' | |
39352 | GO TO 3466 | |
39353 | ENDIF | |
39354 | 7788 CONTINUE | |
39355 | IF(IPIP.GE.3)THEN | |
39356 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
39357 | * JMOHKT(1,4+IIGLU1), | |
39358 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
39359 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
39360 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
39361 | * JMOHKT(1,5+IIGLU1), | |
39362 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
39363 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
39364 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
39365 | * JMOHKT(1,6+IIGLU1), | |
39366 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
39367 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
39368 | ENDIF | |
39369 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
39370 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
39371 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
39372 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
39373 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
39374 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
39375 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
39376 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
39377 | C IDHKT(1) =IP11 | |
39378 | IDHKT(1) =KK11 | |
39379 | ISTHKT(1) =921 | |
39380 | JMOHKT(1,1)=NC1P | |
39381 | JMOHKT(2,1)=0 | |
39382 | JDAHKT(1,1)=3+IIGLU1 | |
39383 | JDAHKT(2,1)=0 | |
39384 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39385 | C * +0.5D0*PHKK(1,NC2P) | |
39386 | *+XGIVE*PHKT(1,4+IIGLU1) | |
39387 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39388 | C * +0.5D0*PHKK(2,NC2P) | |
39389 | *+XGIVE*PHKT(2,4+IIGLU1) | |
39390 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39391 | C * +0.5D0*PHKK(3,NC2P) | |
39392 | *+XGIVE*PHKT(3,4+IIGLU1) | |
39393 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39394 | C * +0.5D0*PHKK(4,NC2P) | |
39395 | *+XGIVE*PHKT(4,4+IIGLU1) | |
39396 | C PHKT(5,1) =PHKK(5,NC1P) | |
39397 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39398 | *PHKT(1,1)**2) | |
39399 | IF(XMIST.GE.0.D0)THEN | |
39400 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39401 | *PHKT(1,1)**2) | |
39402 | ELSE | |
39403 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST | |
39404 | PHKT(5,1)=0.D0 | |
39405 | ENDIF | |
39406 | VHKT(1,1) =VHKK(1,NC1P) | |
39407 | VHKT(2,1) =VHKK(2,NC1P) | |
39408 | VHKT(3,1) =VHKK(3,NC1P) | |
39409 | VHKT(4,1) =VHKK(4,NC1P) | |
39410 | WHKT(1,1) =WHKK(1,NC1P) | |
39411 | WHKT(2,1) =WHKK(2,NC1P) | |
39412 | WHKT(3,1) =WHKK(3,NC1P) | |
39413 | WHKT(4,1) =WHKK(4,NC1P) | |
39414 | C Add here IIGLU1 gluons to this chaina | |
39415 | PG1=0.D0 | |
39416 | PG2=0.D0 | |
39417 | PG3=0.D0 | |
39418 | PG4=0.D0 | |
39419 | IF(IIGLU1.GE.1)THEN | |
39420 | JJG=NC1P | |
39421 | DO 61 IIG=2,2+IIGLU1-1 | |
39422 | KKG=JJG+IIG-1 | |
39423 | IDHKT(IIG) =IDHKK(KKG) | |
39424 | ISTHKT(IIG) =921 | |
39425 | JMOHKT(1,IIG)=KKG | |
39426 | JMOHKT(2,IIG)=0 | |
39427 | JDAHKT(1,IIG)=3+IIGLU1 | |
39428 | JDAHKT(2,IIG)=0 | |
39429 | PHKT(1,IIG)=PHKK(1,KKG) | |
39430 | PG1=PG1+ PHKT(1,IIG) | |
39431 | PHKT(2,IIG)=PHKK(2,KKG) | |
39432 | PG2=PG2+ PHKT(2,IIG) | |
39433 | PHKT(3,IIG)=PHKK(3,KKG) | |
39434 | PG3=PG3+ PHKT(3,IIG) | |
39435 | PHKT(4,IIG)=PHKK(4,KKG) | |
39436 | PG4=PG4+ PHKT(4,IIG) | |
39437 | PHKT(5,IIG)=PHKK(5,KKG) | |
39438 | VHKT(1,IIG) =VHKK(1,KKG) | |
39439 | VHKT(2,IIG) =VHKK(2,KKG) | |
39440 | VHKT(3,IIG) =VHKK(3,KKG) | |
39441 | VHKT(4,IIG) =VHKK(4,KKG) | |
39442 | WHKT(1,IIG) =WHKK(1,KKG) | |
39443 | WHKT(2,IIG) =WHKK(2,KKG) | |
39444 | WHKT(3,IIG) =WHKK(3,KKG) | |
39445 | WHKT(4,IIG) =WHKK(4,KKG) | |
39446 | 61 CONTINUE | |
39447 | ENDIF | |
39448 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39449 | IF(IPIP.EQ.1)THEN | |
39450 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 | |
39451 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 | |
39452 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 | |
39453 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 | |
39454 | ELSEIF(IPIP.EQ.2)THEN | |
39455 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 | |
39456 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 | |
39457 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 | |
39458 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 | |
39459 | ENDIF | |
39460 | ISTHKT(2+IIGLU1) =922 | |
39461 | JMOHKT(1,2+IIGLU1)=NC2T | |
39462 | JMOHKT(2,2+IIGLU1)=0 | |
39463 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
39464 | JDAHKT(2,2+IIGLU1)=0 | |
39465 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
39466 | *+XGIVE*PHKT(1,5+IIGLU1) | |
39467 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
39468 | *+XGIVE*PHKT(2,5+IIGLU1) | |
39469 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
39470 | *+XGIVE*PHKT(3,5+IIGLU1) | |
39471 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
39472 | *+XGIVE*PHKT(4,5+IIGLU1) | |
39473 | C PHKT(5,2) =PHKK(5,NC2T) | |
39474 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
39475 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39476 | *PHKT(1,2+IIGLU1)**2) | |
39477 | IF(XMIST.GT.0.D0)THEN | |
39478 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
39479 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39480 | *PHKT(1,2+IIGLU1)**2) | |
39481 | ELSE | |
39482 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39483 | PHKT(5,2+IIGLU1)=0.D0 | |
39484 | ENDIF | |
39485 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
39486 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
39487 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
39488 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
39489 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
39490 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
39491 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
39492 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
39493 | IDHKT(3+IIGLU1) =88888 | |
39494 | C IDHKT(3) =1000*NNNC1+MMMC1+10 | |
39495 | ISTHKT(3+IIGLU1) =93 | |
39496 | C ISTHKT(3) =KKKC1 | |
39497 | JMOHKT(1,3+IIGLU1)=1 | |
39498 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
39499 | JDAHKT(1,3+IIGLU1)=0 | |
39500 | JDAHKT(2,3+IIGLU1)=0 | |
39501 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
39502 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
39503 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
39504 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
39505 | PHKT(5,3+IIGLU1) | |
39506 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
39507 | * -PHKT(3,3+IIGLU1)**2) | |
39508 | IF(IPIP.GE.3)THEN | |
39509 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
39510 | * JDAHKT(1,1), | |
39511 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
39512 | DO 71 IIG=2,2+IIGLU1-1 | |
39513 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39514 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39515 | * JDAHKT(1,IIG), | |
39516 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39517 | 71 CONTINUE | |
39518 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), | |
39519 | & IDHKT(2),JMOHKT(1,2+IIGLU1), | |
39520 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
39521 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
39522 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
39523 | * JMOHKT(1,3+IIGLU1), | |
39524 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
39525 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
39526 | ENDIF | |
39527 | CHAMAL=CHAB1 | |
39528 | **NEW | |
39529 | C IF(IPIP.EQ.1)THEN | |
39530 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 | |
39531 | C ELSEIF(IPIP.EQ.2)THEN | |
39532 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 | |
39533 | C ENDIF | |
39534 | IF(IPIP.EQ.1)THEN | |
39535 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 | |
39536 | ELSEIF(IPIP.EQ.2)THEN | |
39537 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 | |
39538 | ENDIF | |
39539 | ** | |
39540 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
39541 | C IREJ=1 | |
39542 | IPCO=0 | |
39543 | C RETURN | |
39544 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' | |
39545 | GO TO 3466 | |
39546 | ENDIF | |
39547 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
39548 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
39549 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
39550 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
39551 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
39552 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
39553 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
39554 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
39555 | IF(IPIP.EQ.1)THEN | |
39556 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 | |
39557 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
39558 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
39559 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
39560 | ELSEIF(IPIP.EQ.2)THEN | |
39561 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
39562 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
39563 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
39564 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
39565 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 | |
39566 | ENDIF | |
39567 | ISTHKT(7+IIGLU1) =921 | |
39568 | JMOHKT(1,7+IIGLU1)=NC2P | |
39569 | JMOHKT(2,7+IIGLU1)=0 | |
39570 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
39571 | JDAHKT(2,7+IIGLU1)=0 | |
39572 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) | |
39573 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) | |
39574 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) | |
39575 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) | |
39576 | **NEW | |
39577 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) | |
39578 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP | |
39579 | ** | |
39580 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39581 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39582 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39583 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39584 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
39585 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
39586 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
39587 | C IREJ=1 | |
39588 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' | |
39589 | IPCO=0 | |
39590 | C RETURN | |
39591 | GO TO 3466 | |
39592 | ENDIF | |
39593 | C PHKT(5,7) =PHKK(5,NC2P) | |
39594 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
39595 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
39596 | *PHKT(1,7+IIGLU1)**2) | |
39597 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
39598 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
39599 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
39600 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
39601 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
39602 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
39603 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
39604 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
39605 | C Insert here the IIGLU2 gluons | |
39606 | PG1=0.D0 | |
39607 | PG2=0.D0 | |
39608 | PG3=0.D0 | |
39609 | PG4=0.D0 | |
39610 | IF(IIGLU2.GE.1)THEN | |
39611 | JJG=NC2P | |
39612 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39613 | KKG=JJG+IIG-7-IIGLU1 | |
39614 | IDHKT(IIG) =IDHKK(KKG) | |
39615 | ISTHKT(IIG) =921 | |
39616 | JMOHKT(1,IIG)=KKG | |
39617 | JMOHKT(2,IIG)=0 | |
39618 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
39619 | JDAHKT(2,IIG)=0 | |
39620 | PHKT(1,IIG)=PHKK(1,KKG) | |
39621 | PG1=PG1+ PHKT(1,IIG) | |
39622 | PHKT(2,IIG)=PHKK(2,KKG) | |
39623 | PG2=PG2+ PHKT(2,IIG) | |
39624 | PHKT(3,IIG)=PHKK(3,KKG) | |
39625 | PG3=PG3+ PHKT(3,IIG) | |
39626 | PHKT(4,IIG)=PHKK(4,KKG) | |
39627 | PG4=PG4+ PHKT(4,IIG) | |
39628 | PHKT(5,IIG)=PHKK(5,KKG) | |
39629 | VHKT(1,IIG) =VHKK(1,KKG) | |
39630 | VHKT(2,IIG) =VHKK(2,KKG) | |
39631 | VHKT(3,IIG) =VHKK(3,KKG) | |
39632 | VHKT(4,IIG) =VHKK(4,KKG) | |
39633 | WHKT(1,IIG) =WHKK(1,KKG) | |
39634 | WHKT(2,IIG) =WHKK(2,KKG) | |
39635 | WHKT(3,IIG) =WHKK(3,KKG) | |
39636 | WHKT(4,IIG) =WHKK(4,KKG) | |
39637 | 81 CONTINUE | |
39638 | ENDIF | |
39639 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
39640 | ISTHKT(8+IIGLU1+IIGLU2) =922 | |
39641 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
39642 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
39643 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
39644 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
39645 | **NEW | |
39646 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) | |
39647 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 | |
39648 | ** | |
39649 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
39650 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
39651 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
39652 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
39653 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
39654 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39655 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39656 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39657 | IF(XMIST.GT.0.D0)THEN | |
39658 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39659 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39660 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39661 | ELSE | |
39662 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39663 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
39664 | ENDIF | |
39665 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
39666 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
39667 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
39668 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
39669 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
39670 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
39671 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
39672 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
39673 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
39674 | C IDHKT(9) =1000*NNNC2+MMMC2+10 | |
39675 | ISTHKT(9+IIGLU1+IIGLU2) =93 | |
39676 | C ISTHKT(9) =KKKC2 | |
39677 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
39678 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
39679 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
39680 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
39681 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) | |
39682 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
39683 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) | |
39684 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
39685 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) | |
39686 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
39687 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) | |
39688 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
39689 | PHKT(5,9+IIGLU1+IIGLU2) | |
39690 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
39691 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
39692 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
39693 | IF(IPIP.GE.3)THEN | |
39694 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
39695 | * JMOHKT(1,7+IIGLU1), | |
39696 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
39697 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
39698 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39699 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39700 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39701 | * JDAHKT(1,IIG), | |
39702 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39703 | 91 CONTINUE | |
39704 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
39705 | * IDHKT(8+IIGLU1+IIGLU2), | |
39706 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
39707 | * JDAHKT(1,8+IIGLU1+IIGLU2), | |
39708 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
39709 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
39710 | * IDHKT(9+IIGLU1+IIGLU2), | |
39711 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), | |
39712 | * JDAHKT(1,9+IIGLU1+IIGLU2), | |
39713 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
39714 | ENDIF | |
39715 | CHAMAL=CHAB1 | |
39716 | IF(IPIP.EQ.1)THEN | |
39717 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
39718 | ELSEIF(IPIP.EQ.2)THEN | |
39719 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
39720 | ENDIF | |
39721 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
39722 | C IREJ=1 | |
39723 | IPCO=0 | |
39724 | C RETURN | |
39725 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
39726 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
39727 | GO TO 3466 | |
39728 | ENDIF | |
39729 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
39730 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
39731 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
39732 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
39733 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
39734 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
39735 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
39736 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
39737 | C | |
39738 | IGCOUN=9+IIGLU1+IIGLU2 | |
39739 | IPCO=0 | |
39740 | RETURN | |
39741 | END | |
39742 | ||
39743 | *$ CREATE HKKHKT.FOR | |
39744 | *COPY HKKHKT | |
39745 | C | |
39746 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
39747 | C | |
39748 | SUBROUTINE HKKHKT(I,J) | |
39749 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39750 | SAVE | |
39751 | ||
39752 | * event history | |
39753 | PARAMETER (NMXHKK=200000) | |
39754 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39755 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39756 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39757 | * extended event history | |
39758 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39759 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39760 | & IHIST(2,NMXHKK) | |
39761 | ||
39762 | PARAMETER (NTMHKK= 300) | |
39763 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39764 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39765 | +(4,NTMHKK) | |
39766 | C | |
39767 | ISTHKK(I) =ISTHKT(J) | |
39768 | IDHKK(I) =IDHKT(J) | |
39769 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN | |
39770 | IF(IDHKK(I).EQ.88888)THEN | |
39771 | C JMOHKK(1,I)=I-2 | |
39772 | C JMOHKK(2,I)=I-1 | |
39773 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) | |
39774 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) | |
39775 | ELSE | |
39776 | JMOHKK(1,I)=JMOHKT(1,J) | |
39777 | JMOHKK(2,I)=JMOHKT(2,J) | |
39778 | ENDIF | |
39779 | JDAHKK(1,I)=JDAHKT(1,J) | |
39780 | JDAHKK(2,I)=JDAHKT(2,J) | |
39781 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN | |
39782 | C JDAHKK(1,I)=I+2 | |
39783 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN | |
39784 | C JDAHKK(1,I)=I+1 | |
39785 | C ENDIF | |
39786 | IF(JDAHKT(1,J).GT.0)THEN | |
39787 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) | |
39788 | ENDIF | |
39789 | PHKK(1,I) =PHKT(1,J) | |
39790 | PHKK(2,I) =PHKT(2,J) | |
39791 | PHKK(3,I) =PHKT(3,J) | |
39792 | PHKK(4,I) =PHKT(4,J) | |
39793 | PHKK(5,I) =PHKT(5,J) | |
39794 | VHKK(1,I) =VHKT(1,J) | |
39795 | VHKK(2,I) =VHKT(2,J) | |
39796 | VHKK(3,I) =VHKT(3,J) | |
39797 | VHKK(4,I) =VHKT(4,J) | |
39798 | WHKK(1,I) =WHKT(1,J) | |
39799 | WHKK(2,I) =WHKT(2,J) | |
39800 | WHKK(3,I) =WHKT(3,J) | |
39801 | WHKK(4,I) =WHKT(4,J) | |
39802 | RETURN | |
39803 | END | |
39804 | ||
39805 | *$ CREATE DT_DBREAK.FOR | |
39806 | *COPY DT_DBREAK | |
39807 | * | |
39808 | *===dbreak=============================================================* | |
39809 | * | |
39810 | SUBROUTINE DT_DBREAK(MODE) | |
39811 | ||
39812 | ************************************************************************ | |
39813 | * This is the steering subroutine for the different diquark breaking * | |
39814 | * mechanisms. * | |
39815 | * * | |
39816 | * MODE = 1 breaking of projectile diquark in qq-q chain using * | |
39817 | * a sea quark (q-qq chain) of the same projectile * | |
39818 | * = 2 breaking of target diquark in q-qq chain using * | |
39819 | * a sea quark (qq-q chain) of the same target * | |
39820 | * = 3 breaking of projectile diquark in qq-q chain using * | |
39821 | * a sea quark (q-aq chain) of the same projectile * | |
39822 | * = 4 breaking of target diquark in q-qq chain using * | |
39823 | * a sea quark (aq-q chain) of the same target * | |
39824 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39825 | * a sea anti-quark (aq-aqaq chain) of the same projectile * | |
39826 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * | |
39827 | * a sea anti-quark (aqaq-aq chain) of the same target * | |
39828 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39829 | * a sea anti-quark (aq-q chain) of the same projectile * | |
39830 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * | |
39831 | * a sea anti-quark (q-aq chain) of the same target * | |
39832 | * * | |
39833 | * Original version by J. Ranft. * | |
39834 | * This version dated 17.5.00 is written by S. Roesler. * | |
39835 | ************************************************************************ | |
39836 | ||
39837 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39838 | SAVE | |
39839 | PARAMETER ( LINP = 10 , | |
39840 | & LOUT = 6 , | |
39841 | & LDAT = 9 ) | |
39842 | ||
39843 | * event history | |
39844 | PARAMETER (NMXHKK=200000) | |
39845 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39846 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39847 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39848 | * extended event history | |
39849 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39850 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39851 | & IHIST(2,NMXHKK) | |
39852 | * flags for input different options | |
39853 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
39854 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
39855 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
39856 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
39857 | PARAMETER (MAXCHN=10000) | |
39858 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
39859 | * diquark-breaking mechanism | |
39860 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
39861 | * flags for particle decays | |
39862 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
39863 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
39864 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
39865 | ||
39866 | * | |
39867 | * chain identifiers | |
39868 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, | |
39869 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) | |
39870 | DIMENSION IDCHN1(8),IDCHN2(8) | |
39871 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ | |
39872 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ | |
39873 | * | |
39874 | * parton identifiers | |
39875 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), | |
39876 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) | |
39877 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) | |
39878 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, | |
39879 | & 31, 31, 31, 31, 31, 31, 31, 31, | |
39880 | & 41, 41, 41, 41, 51, 51, 51, 51/ | |
39881 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, | |
39882 | & 32, 32, 32, 32, 32, 32, 32, 32, | |
39883 | & 42, 42, 42, 42, 52, 52, 52, 52/ | |
39884 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, | |
39885 | & 51, 31, 41, 41, 31, 31, 31, 31, | |
39886 | & 0, 41, 51, 51, 51, 51, 51, 51/ | |
39887 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, | |
39888 | & 32, 52, 42, 42, 32, 32, 32, 32, | |
39889 | & 42, 0, 52, 52, 52, 52, 52, 52/ | |
39890 | ||
39891 | IF (NCHAIN.LE.0) RETURN | |
39892 | DO 1 I=1,NCHAIN | |
39893 | IDX1 = IDXCHN(1,I) | |
39894 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) | |
39895 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) | |
39896 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) | |
39897 | & .AND. | |
39898 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. | |
39899 | & (IS1P.EQ.ISP1P(MODE,3))) | |
39900 | & .AND. | |
39901 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. | |
39902 | & (IS1T.EQ.ISP1T(MODE,3))) | |
39903 | & ) THEN | |
39904 | DO 2 J=1,NCHAIN | |
39905 | IDX2 = IDXCHN(1,J) | |
39906 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) | |
39907 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) | |
39908 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) | |
39909 | & .AND. | |
39910 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) | |
39911 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) | |
39912 | & .AND. | |
39913 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) | |
39914 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) | |
39915 | & ) THEN | |
39916 | * find mother nucleons of the diquark to be splitted and of the | |
39917 | * sea-quark and reject this combination if it is not the same | |
39918 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. | |
39919 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN | |
39920 | IANCES = 1 | |
39921 | ELSE | |
39922 | IANCES = 2 | |
39923 | ENDIF | |
39924 | IDXMO1 = JMOHKK(IANCES,IDX1) | |
39925 | 4 CONTINUE | |
39926 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. | |
39927 | & (JMOHKK(2,IDXMO1).NE.0)) THEN | |
39928 | IANC = IANCES | |
39929 | ELSE | |
39930 | IANC = 1 | |
39931 | ENDIF | |
39932 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN | |
39933 | IDXMO1 = JMOHKK(IANC,IDXMO1) | |
39934 | GOTO 4 | |
39935 | ENDIF | |
39936 | IDXMO2 = JMOHKK(IANCES,IDX2) | |
39937 | 5 CONTINUE | |
39938 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. | |
39939 | & (JMOHKK(2,IDXMO2).NE.0)) THEN | |
39940 | IANC = IANCES | |
39941 | ELSE | |
39942 | IANC = 1 | |
39943 | ENDIF | |
39944 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN | |
39945 | IDXMO2 = JMOHKK(IANC,IDXMO2) | |
39946 | GOTO 5 | |
39947 | ENDIF | |
39948 | IF (IDXMO1.NE.IDXMO2) GOTO 2 | |
39949 | * quark content of projectile parton | |
39950 | IP1 = IDHKK(JMOHKK(1,IDX1)) | |
39951 | IP11 = IP1/1000 | |
39952 | IP12 = (IP1-1000*IP11)/100 | |
39953 | IP2 = IDHKK(JMOHKK(2,IDX1)) | |
39954 | IP21 = IP2/1000 | |
39955 | IP22 = (IP2-1000*IP21)/100 | |
39956 | * quark content of target parton | |
39957 | IT1 = IDHKK(JMOHKK(1,IDX2)) | |
39958 | IT11 = IT1/1000 | |
39959 | IT12 = (IT1-1000*IT11)/100 | |
39960 | IT2 = IDHKK(JMOHKK(2,IDX2)) | |
39961 | IT21 = IT2/1000 | |
39962 | IT22 = (IT2-1000*IT21)/100 | |
39963 | * split diquark and form new chains | |
39964 | IF (MODE.EQ.1) THEN | |
39965 | IF (IT1.EQ.4) GOTO 2 | |
39966 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39967 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39968 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) | |
39969 | ELSEIF (MODE.EQ.2) THEN | |
39970 | IF (IT2.EQ.4) GOTO 2 | |
39971 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39972 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39973 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) | |
39974 | ELSEIF (MODE.EQ.3) THEN | |
39975 | IF (IT1.EQ.4) GOTO 2 | |
39976 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39977 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39978 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) | |
39979 | ELSEIF (MODE.EQ.4) THEN | |
39980 | IF (IT2.EQ.4) GOTO 2 | |
39981 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39982 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39983 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) | |
39984 | ELSEIF (MODE.EQ.5) THEN | |
39985 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39986 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39987 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) | |
39988 | ELSEIF (MODE.EQ.6) THEN | |
39989 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39990 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39991 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) | |
39992 | ELSEIF (MODE.EQ.7) THEN | |
39993 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39994 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39995 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) | |
39996 | ELSEIF (MODE.EQ.8) THEN | |
39997 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39998 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39999 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) | |
40000 | ENDIF | |
40001 | IF (IREJ.GE.1) THEN | |
40002 | if ((ipq.lt.0).or.(ipq.ge.4)) | |
40003 | & write(LOUT,*) 'ipq !!!',ipq,mode | |
40004 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
40005 | * accept or reject new chains corresponding to PDBSEA | |
40006 | ELSE | |
40007 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN | |
40008 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) | |
40009 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) | |
40010 | ELSEIF (IPQ.EQ.3) THEN | |
40011 | ACC = DBRKA(3,MODE) | |
40012 | REJ = DBRKR(3,MODE) | |
40013 | ELSE | |
40014 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ | |
40015 | STOP | |
40016 | ENDIF | |
40017 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN | |
40018 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 | |
40019 | IACC = 1 | |
40020 | ELSE | |
40021 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
40022 | IACC = 0 | |
40023 | ENDIF | |
40024 | * new chains have been accepted and are now copied into HKKEVT | |
40025 | IF (IACC.EQ.1) THEN | |
40026 | IF (LEMCCK) THEN | |
40027 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), | |
40028 | & PHKK(3,IDX1),PHKK(4,IDX1), | |
40029 | & 1,IDUM1,IDUM2) | |
40030 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), | |
40031 | & PHKK(3,IDX2),PHKK(4,IDX2), | |
40032 | & 2,IDUM1,IDUM2) | |
40033 | ENDIF | |
40034 | IDHKK(IDX1) = 99888 | |
40035 | IDHKK(IDX2) = 99888 | |
40036 | IDXCHN(2,I) = -1 | |
40037 | IDXCHN(2,J) = -1 | |
40038 | DO 3 K=1,IGCOUN | |
40039 | NHKK = NHKK+1 | |
40040 | CALL HKKHKT(NHKK,K) | |
40041 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN | |
40042 | PX = -PHKK(1,NHKK) | |
40043 | PY = -PHKK(2,NHKK) | |
40044 | PZ = -PHKK(3,NHKK) | |
40045 | PE = -PHKK(4,NHKK) | |
40046 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
40047 | ENDIF | |
40048 | 3 CONTINUE | |
40049 | IF (LEMCCK) THEN | |
40050 | CHKLEV = 0.1D0 | |
40051 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, | |
40052 | & IREJ) | |
40053 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) | |
40054 | ENDIF | |
40055 | GOTO 1 | |
40056 | ENDIF | |
40057 | ENDIF | |
40058 | ENDIF | |
40059 | 2 CONTINUE | |
40060 | ENDIF | |
40061 | 1 CONTINUE | |
40062 | RETURN | |
40063 | END | |
40064 | ||
40065 | *$ CREATE DT_CQPAIR.FOR | |
40066 | *COPY DT_CQPAIR | |
40067 | * | |
40068 | *===cqpair=============================================================* | |
40069 | * | |
40070 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) | |
40071 | ||
40072 | ************************************************************************ | |
40073 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * | |
40074 | * * | |
40075 | * XQMAX maxium energy fraction of quark (input) * | |
40076 | * XAQMAX maxium energy fraction of antiquark (input) * | |
40077 | * XQ energy fraction of quark (output) * | |
40078 | * XAQ energy fraction of antiquark (output) * | |
40079 | * IFLV quark flavour (- antiquark flavor) (output) * | |
40080 | * * | |
40081 | * This version dated 14.5.00 is written by S. Roesler. * | |
40082 | ************************************************************************ | |
40083 | ||
40084 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
40085 | SAVE | |
40086 | PARAMETER ( LINP = 10 , | |
40087 | & LOUT = 6 , | |
40088 | & LDAT = 9 ) | |
40089 | ||
40090 | * Lorentz-parameters of the current interaction | |
40091 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
40092 | & UMO,PPCM,EPROJ,PPROJ | |
40093 | ||
40094 | * | |
40095 | IREJ = 0 | |
40096 | XQ = 0.0D0 | |
40097 | XAQ = 0.0D0 | |
40098 | * | |
40099 | * sample quark flavour | |
40100 | * | |
40101 | * set seasq here (the one from DTCHAI should be used in the future) | |
40102 | SEASQ = 0.5D0 | |
40103 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) | |
40104 | * | |
40105 | * sample energy fractions of sea pair | |
40106 | * we first sample the energy fraction of a gluon and then split the gluon | |
40107 | * | |
40108 | * maximum energy fraction of the gluon forced via input | |
40109 | XGMAXI = XQMAX+XAQMAX | |
40110 | * minimum energy fraction of the gluon | |
40111 | XTHR1 = 4.0D0 /UMO**2 | |
40112 | XTHR2 = 0.54D0/UMO**1.5D0 | |
40113 | XGMIN = MAX(XTHR1,XTHR2) | |
40114 | * maximum energy fraction of the gluon | |
40115 | XGMAX = 0.3D0 | |
40116 | XGMAX = MIN(XGMAXI,XGMAX) | |
40117 | IF (XGMIN.GE.XGMAX) THEN | |
40118 | IREJ = 1 | |
40119 | RETURN | |
40120 | ENDIF | |
40121 | * | |
40122 | * sample energy fraction of the gluon | |
40123 | NLOOP = 0 | |
40124 | 1 CONTINUE | |
40125 | NLOOP = NLOOP+1 | |
40126 | IF (NLOOP.GE.50) THEN | |
40127 | IREJ = 1 | |
40128 | RETURN | |
40129 | ENDIF | |
40130 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) | |
40131 | EGLUON = XGLUON*UMO/2.0D0 | |
40132 | * | |
40133 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) | |
40134 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) | |
40135 | ZMAX = 1.0D0-ZMIN | |
40136 | RZ = DT_RNDM(ZMAX) | |
40137 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 | |
40138 | RQ = DT_RNDM(ZMAX) | |
40139 | IF (RQ.LT.0.5D0) THEN | |
40140 | XQ = XGLUON*XHLP | |
40141 | XAQ = XGLUON-XQ | |
40142 | ELSE | |
40143 | XAQ = XGLUON*XHLP | |
40144 | XQ = XGLUON-XAQ | |
40145 | ENDIF | |
40146 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 | |
40147 | ||
40148 | RETURN | |
40149 | END |