]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/dpmjet3.0-5F.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
#33758: pA Production with DPMJET+Fragment
[u/mrichter/AliRoot.git] / DPMJET / dpmjet3.0-5F.f
CommitLineData
7b076c76 1*$ CREATE DT_INIT.FOR
2*COPY DT_INIT
3*
4* +-------------------------------------------------------------+
5* | |
6* | |
7* | DPMJET 3.0 |
8* | |
9* | |
10* | S. Roesler+), R. Engel#), J. Ranft*) |
11* | |
12* | +) CERN, SC-RP |
13* | CH-1211 Geneva 23, Switzerland |
14* | Email: Stefan.Roesler@cern.ch |
15* | |
16* | #) Institut fuer Kernphysik |
17* | Forschungszentrum Karlsruhe |
18* | D-76021 Karlsruhe, Germany |
19* | |
20* | *) University of Siegen, Dept. of Physics |
21* | D-57068 Siegen, Germany |
22* | |
23* | |
24* | http://home.cern.ch/sroesler/dpmjet3.html |
25* | |
26* | |
27* | Monte Carlo models used for event generation: |
28* | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
29* | |
30* +-------------------------------------------------------------+
31*
32*
33*===init===============================================================*
34*
35 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
36 & IDP,IGLAU)
37
38************************************************************************
39* Initialization of event generation *
40* This version dated 7.4.98 is written by S. Roesler. *
41* *
42* Last change 27.12.2006 by S. Roesler. *
43************************************************************************
44
45 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
46 SAVE
47
48 PARAMETER ( LINP = 10 ,
49 & LOUT = 6 ,
50 & LDAT = 9 )
51 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
52
53* particle properties (BAMJET index convention)
54 CHARACTER*8 ANAME
55 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
56 & IICH(210),IIBAR(210),K1(210),K2(210)
57
58* names of hadrons used in input-cards
59 CHARACTER*8 BTYPE
60 COMMON /DTPAIN/ BTYPE(30)
61
62* INCLUDE '(DIMPAR)'
63* DIMPAR taken from FLUKA
64 PARAMETER ( MXXRGN =20000 )
65 PARAMETER ( MXXMDF = 710 )
66 PARAMETER ( MXXMDE = 702 )
67 PARAMETER ( MFSTCK =40000 )
68 PARAMETER ( MESTCK = 100 )
69 PARAMETER ( MOSTCK = 2000 )
70 PARAMETER ( MXPRSN = 100 )
71 PARAMETER ( MXPDPM = 800 )
72 PARAMETER ( MXPSCS =30000 )
73 PARAMETER ( MXGLWN = 300 )
74 PARAMETER ( MXOUTU = 50 )
75 PARAMETER ( NALLWP = 64 )
76 PARAMETER ( NELEMX = 80 )
77 PARAMETER ( MPDPDX = 18 )
78 PARAMETER ( MXHTTR = 260 )
79 PARAMETER ( MXSEAX = 20 )
80 PARAMETER ( MXHTNC = MXSEAX + 1 )
81 PARAMETER ( ICOMAX = 2400 )
82 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
83 PARAMETER ( NSTBIS = 304 )
84 PARAMETER ( NQSTIS = 46 )
85 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
86 PARAMETER ( MXPABL = 120 )
87 PARAMETER ( IDMAXP = 450 )
88 PARAMETER ( IDMXDC = 2000 )
89 PARAMETER ( MXMCIN = 410 )
90 PARAMETER ( IHYPMX = 4 )
91 PARAMETER ( MKBMX1 = 11 )
92 PARAMETER ( MKBMX2 = 11 )
93 PARAMETER ( MXIRRD = 2500 )
94 PARAMETER ( MXTRDC = 1500 )
95 PARAMETER ( NKTL = 17 )
96 PARAMETER ( NBLNMX = 40000000 )
97
98* INCLUDE '(PAREVT)'
99* PAREVT taken from FLUKA
100 PARAMETER ( FRDIFF = 0.2D+00 )
101 PARAMETER ( ETHSEA = 1.0D+00 )
102*
103 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
104 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
105 & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
106 & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
107 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
108 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
109 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
110 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
111 & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
112 & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
113
114* INCLUDE '(EVAFLG)'
115* EVAFLG taken from FLUKA
116 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
117 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
118 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
119 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
120 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
121 & FDSCST,
122 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
123 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
124 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
125 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
126 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
127 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
128 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
129
130* INCLUDE '(FRBKCM)'
131* FRBKCM taken from FLUKA
132* Maximum number of fragments to be emitted:
133 PARAMETER ( MXFFBK = 6 )
134 PARAMETER ( MXZFBK = 10 )
135 PARAMETER ( MXNFBK = 12 )
136 PARAMETER ( MXAFBK = 16 )
137 PARAMETER ( MXASST = 25 )
138 PARAMETER ( NXAFBK = MXAFBK + 1 )
139 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
140 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
141 PARAMETER ( MXPSST = 700 )
142* Maximum number of pre-computed break-up combinations
143 PARAMETER ( MXPPFB = 42500 )
144* Maximum number of break-up combinations, including special
145* run-time ones:
146 PARAMETER ( MXPSFB = 43000 )
147* Base for J multiplicity encoding:
148 PARAMETER ( IBFRBK = 73 )
149* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
150* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
151* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
152* --> Ibfrbk^(Jpwfbx+1) < 2100000000
153 PARAMETER ( JPWFBX = 4 )
154 LOGICAL LFRMBK, LNCMSS
155 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
156 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
157 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
158 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
159 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
160 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
161 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
162 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
163 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
164 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
165 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
166
167* emulsion treatment
168 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
169 & NCOMPO,IEMUL
170
171* Glauber formalism: parameters
172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
173 & BMAX(NCOMPX),BSTEP(NCOMPX),
174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
175 & NSITEB,NSTATB
176
177* Glauber formalism: cross sections
178 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
179 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
180 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
181 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
182 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
183 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
184 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
185 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
186 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
187 & BSLOPE,NEBINI,NQBINI
188
189* interface HADRIN-DPM
190 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
191
192* central particle production, impact parameter biasing
193 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
194
195* parameter for intranuclear cascade
196 LOGICAL LPAULI
197 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
198
199* various options for treatment of partons (DTUNUC 1.x)
200* (chain recombination, Cronin,..)
201 LOGICAL LCO2CR,LINTPT
202 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
203 & LCO2CR,LINTPT
204
205* threshold values for x-sampling (DTUNUC 1.x)
206 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
207 & SSMIMQ,VVMTHR
208
209* flags for input different options
210 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
211 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
212 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
213
214* nuclear potential
215 LOGICAL LFERMI
216 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
217 & EBINDP(2),EBINDN(2),EPOT(2,210),
218 & ETACOU(2),ICOUL,LFERMI
219
220* n-n cross section fluctuations
221 PARAMETER (NBINS = 1000)
222 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
223
224* flags for particle decays
225 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
226 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
227 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
228
229* diquark-breaking mechanism
230 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
231
232* nucleon-nucleon event-generator
233 CHARACTER*8 CMODEL
234 LOGICAL LPHOIN
235 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
236
237* properties of interacting particles
238 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
239
240* properties of photon/lepton projectiles
241 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
242
243* flags for diffractive interactions (DTUNUC 1.x)
244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
245
246* parameters for hA-diffraction
247 COMMON /DTDIHA/ DIBETA,DIALPH
248
249* Lorentz-parameters of the current interaction
250 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
251 & UMO,PPCM,EPROJ,PPROJ
252
253* kinematical cuts for lepton-nucleus interactions
254 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
255 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
256
257* VDM parameter for photon-nucleus interactions
258 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
259
260* Glauber formalism: flags and parameters for statistics
261 LOGICAL LPROD
262 CHARACTER*8 CGLB
263 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
264
265* cuts for variable energy runs
266 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
267
268* flags for activated histograms
269 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
270
271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
272 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
273
274* LEPTO
275**LUND single / double precision
276 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
277 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
278 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
279
280* LEPTO
281 REAL RPPN
282 COMMON /LEPTOI/ RPPN,LEPIN,INTER
283
284* steering flags for qel neutrino scattering modules
285 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
286
287* event flag
288 COMMON /DTEVNO/ NEVENT,ICASCA
289
290 INTEGER PYCOMP
291
292C DIMENSION XPARA(5)
293 DIMENSION XDUMB(40),IPRANG(5)
294
295 PARAMETER (MXCARD=58)
296 CHARACTER*78 CLINE,CTITLE
297 CHARACTER*60 CWHAT
298 CHARACTER*8 BLANK,SDUM
299 CHARACTER*10 CODE,CODEWD
300 CHARACTER*72 HEADER
301 LOGICAL LSTART,LEINP,LXSTAB
302 DIMENSION WHAT(6),CODE(MXCARD)
303 DATA CODE/
304 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
305 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
306 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
307 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
308 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
309 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
310 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
311 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
312 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
313 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
314 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
315 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
316 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
317 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
318 & 'START ','STOP '/
319 DATA BLANK /' '/
320
321 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
322 DATA CMEOLD /0.0D0/
323
324*---------------------------------------------------------------------
325* at the first call of INIT: initialize event generation
326 EPNSAV = EPN
327 IF (LSTART) THEN
328 CALL DT_TITLE
329* initialization and test of the random number generator
330 IF (ITRSPT.NE.1) THEN
331
332 IJKLIN = -1
333 INSEED = 1
334 ISEED1 = 0
335 ISEED2 = 0
336 CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
337
338 ENDIF
339* initialization of BAMJET, DECAY and HADRIN
340 CALL DT_DDATAR
341 CALL DT_DHADDE
342 CALL DT_DCHANT
343 CALL DT_DCHANH
344* set default values for input variables
345 CALL DT_DEFAUL(EPN,PPN)
346 IGLAU = 0
347 IXSQEL = 0
348* flag for collision energy input
349 LEINP = .FALSE.
350 LSTART = .FALSE.
351 ENDIF
352
353*---------------------------------------------------------------------
354 10 CONTINUE
355
356* bypass reading input cards (e.g. for use with Fluka)
357* in this case Epn is expected to carry the beam momentum
358 IF (NCASES.EQ.-1) THEN
359 IP = NPMASS
360 IPZ = NPCHAR
361 PPN = EPNSAV
362 EPN = ZERO
363 CMENER = ZERO
364 LEINP = .TRUE.
365 MKCRON = 0
366 WHAT(1) = 1
367 WHAT(2) = 0
368 CODEWD = 'START '
369 GOTO 900
370 ENDIF
371
372* read control card from input-unit LINP
373 READ(LINP,'(A78)',END=9999) CLINE
374 IF (CLINE(1:1).EQ.'*') THEN
375* comment-line
376 WRITE(LOUT,'(A78)') CLINE
377 GOTO 10
378 ENDIF
379C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
380C1000 FORMAT(A10,6E10.0,A8)
381 DO 1008 I=1,6
382 WHAT(I) = ZERO
383 1008 CONTINUE
384 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
385 1006 FORMAT(A10,A60,A8)
386 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
387 1007 CONTINUE
388 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
389 1001 FORMAT(A10,6G10.3,A8)
390
391 900 CONTINUE
392
393* check for valid control card and get card index
394 ICW = 0
395 DO 11 I=1,MXCARD
396 IF (CODEWD.EQ.CODE(I)) ICW = I
397 11 CONTINUE
398 IF (ICW.EQ.0) THEN
399 WRITE(LOUT,1002) CODEWD
400 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
401 GOTO 10
402 ENDIF
403
404 GOTO(
405*------------------------------------------------------------
406* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
407 & 100 , 110 , 120 , 130 , 140 ,
408*
409*------------------------------------------------------------
410* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
411 & 150 , 160 , 170 , 180 , 190 ,
412*
413*------------------------------------------------------------
414* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
415 & 200 , 210 , 220 , 230 , 240 ,
416*
417*------------------------------------------------------------
418* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
419 & 250 , 260 , 270 , 280 , 290 ,
420*
421*------------------------------------------------------------
422* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
423 & 300 , 310 , 320 , 330 , 340 ,
424*
425*------------------------------------------------------------
426* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
427 & 350 , 360 , 370 , 380 , 390 ,
428*
429*------------------------------------------------------------
430* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
431 & 400 , 410 , 420 , 430 , 440 ,
432*
433*------------------------------------------------------------
434* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
435 & 450 , 451 , 452 , 460 , 470 ,
436*
437*------------------------------------------------------------
438* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
439 & 480 , 490 , 500 , 510 , 520 ,
440*
441*------------------------------------------------------------
442* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
443 & 530 , 540 , 550 , 560 , 565 ,
444*
445*------------------------------------------------------------
446* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
447 & 570 , 580 , 590 ,
448*
449*------------------------------------------------------------
450* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
451 & 600 , 610 , 620 , 630 , 640 ) , ICW
452*
453*------------------------------------------------------------
454
455 GOTO 10
456
457*********************************************************************
458* *
459* control card: codewd = TITLE *
460* *
461* what (1..6), sdum no meaning *
462* *
463* Note: The control-card following this must consist of *
464* a string of characters usually giving the title of *
465* the run. *
466* *
467*********************************************************************
468
469 100 CONTINUE
470 READ(LINP,'(A78)') CTITLE
471 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
472 GOTO 10
473
474*********************************************************************
475* *
476* control card: codewd = PROJPAR *
477* *
478* what (1) = mass number of projectile nucleus default: 1 *
479* what (2) = charge of projectile nucleus default: 1 *
480* what (3..6) no meaning *
481* sdum projectile particle code word *
482* *
483* Note: If sdum is defined what (1..2) have no meaning. *
484* *
485*********************************************************************
486
487 110 CONTINUE
488 IF (SDUM.EQ.BLANK) THEN
489 IP = INT(WHAT(1))
490 IPZ = INT(WHAT(2))
491 IJPROJ = 1
492 IBPROJ = 1
493 ELSE
494 IJPROJ = 0
495 DO 111 II=1,30
496 IF (SDUM.EQ.BTYPE(II)) THEN
497 IP = 1
498 IPZ = 1
499 IF (II.EQ.26) THEN
500 IJPROJ = 135
501 ELSEIF (II.EQ.27) THEN
502 IJPROJ = 136
503 ELSEIF (II.EQ.28) THEN
504 IJPROJ = 133
505 ELSEIF (II.EQ.29) THEN
506 IJPROJ = 134
507 ELSE
508 IJPROJ = II
509 ENDIF
510 IBPROJ = IIBAR(IJPROJ)
511* photon
512 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
513* lepton
514 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
515 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
516 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
517 ENDIF
518 111 CONTINUE
519 IF (IJPROJ.EQ.0) THEN
520 WRITE(LOUT,1110)
521 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
522 GOTO 9999
523 ENDIF
524 ENDIF
525 GOTO 10
526
527*********************************************************************
528* *
529* control card: codewd = TARPAR *
530* *
531* what (1) = mass number of target nucleus default: 1 *
532* what (2) = charge of target nucleus default: 1 *
533* what (3..6) no meaning *
534* sdum target particle code word *
535* *
536* Note: If sdum is defined what (1..2) have no meaning. *
537* *
538*********************************************************************
539
540 120 CONTINUE
541 IF (SDUM.EQ.BLANK) THEN
542 IT = INT(WHAT(1))
543 ITZ = INT(WHAT(2))
544 IJTARG = 1
545 IBTARG = 1
546 ELSE
547 IJTARG = 0
548 DO 121 II=1,30
549 IF (SDUM.EQ.BTYPE(II)) THEN
550 IT = 1
551 ITZ = 1
552 IJTARG = II
553 IBTARG = IIBAR(IJTARG)
554 ENDIF
555 121 CONTINUE
556 IF (IJTARG.EQ.0) THEN
557 WRITE(LOUT,1120)
558 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
559 GOTO 9999
560 ENDIF
561 ENDIF
562 GOTO 10
563
564*********************************************************************
565* *
566* control card: codewd = ENERGY *
567* *
568* what (1) = energy (GeV) of projectile in Lab. *
569* if what(1) < 0: |what(1)| = kinetic energy *
570* default: 200 GeV *
571* if |what(2)| > 0: min. energy for variable *
572* energy runs *
573* what (2) = max. energy for variable energy runs *
574* if what(2) < 0: |what(2)| = kinetic energy *
575* *
576*********************************************************************
577
578 130 CONTINUE
579 EPN = WHAT(1)
580 PPN = ZERO
581 CMENER = ZERO
582 IF ((ABS(WHAT(2)).GT.ZERO).AND.
583 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
584 VARELO = WHAT(1)
585 VAREHI = WHAT(2)
586 EPN = VAREHI
587 ENDIF
588 LEINP = .TRUE.
589 GOTO 10
590
591*********************************************************************
592* *
593* control card: codewd = MOMENTUM *
594* *
595* what (1) = momentum (GeV/c) of projectile in Lab. *
596* default: 200 GeV/c *
597* what (2..6), sdum no meaning *
598* *
599*********************************************************************
600
601 140 CONTINUE
602 EPN = ZERO
603 PPN = WHAT(1)
604 CMENER = ZERO
605 LEINP = .TRUE.
606 GOTO 10
607
608*********************************************************************
609* *
610* control card: codewd = CMENERGY *
611* *
612* what (1) = energy in nucleon-nucleon cms. *
613* default: none *
614* what (2..6), sdum no meaning *
615* *
616*********************************************************************
617
618 150 CONTINUE
619 EPN = ZERO
620 PPN = ZERO
621 CMENER = WHAT(1)
622 LEINP = .TRUE.
623 GOTO 10
624
625*********************************************************************
626* *
627* control card: codewd = EMULSION *
628* *
629* definition of nuclear emulsions *
630* *
631* what(1) mass number of emulsion component *
632* what(2) charge of emulsion component *
633* what(3) fraction of events in which a scattering on a *
634* nucleus of this properties is performed *
635* what(4,5,6) as what(1,2,3) but for another component *
636* default: no emulsion *
637* sdum no meaning *
638* *
639* Note: If this input-card is once used with valid parameters *
640* TARPAR is obsolete. *
641* Not the absolute values of the fractions are important *
642* but only the ratios of fractions of different comp. *
643* This control card can be repeatedly used to define *
644* emulsions consisting of up to 10 elements. *
645* *
646*********************************************************************
647
648 160 CONTINUE
649 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
650 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
651 NCOMPO = NCOMPO+1
652 IF (NCOMPO.GT.NCOMPX) THEN
653 WRITE(LOUT,1600)
654 STOP
655 ENDIF
656 IEMUMA(NCOMPO) = INT(WHAT(1))
657 IEMUCH(NCOMPO) = INT(WHAT(2))
658 EMUFRA(NCOMPO) = WHAT(3)
659 IEMUL = 1
660C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
661 ENDIF
662 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
663 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
664 NCOMPO = NCOMPO+1
665 IF (NCOMPO.GT.NCOMPX) THEN
666 WRITE(LOUT,1001)
667 STOP
668 ENDIF
669 IEMUMA(NCOMPO) = INT(WHAT(4))
670 IEMUCH(NCOMPO) = INT(WHAT(5))
671 EMUFRA(NCOMPO) = WHAT(6)
672C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
673 ENDIF
674 1600 FORMAT(1X,'too many emulsion components - program stopped')
675 GOTO 10
676
677*********************************************************************
678* *
679* control card: codewd = FERMI *
680* *
681* what (1) = -1 Fermi-motion of nucleons not treated *
682* default: 1 *
683* what (2) = scale factor for Fermi-momentum *
684* default: 0.75 *
685* what (3..6), sdum no meaning *
686* *
687*********************************************************************
688
689 170 CONTINUE
690 IF (WHAT(1).EQ.-1.0D0) THEN
691 LFERMI = .FALSE.
692 ELSE
693 LFERMI = .TRUE.
694 ENDIF
695 XMOD = WHAT(2)
696 IF (XMOD.GE.ZERO) FERMOD = XMOD
697 GOTO 10
698
699*********************************************************************
700* *
701* control card: codewd = TAUFOR *
702* *
703* formation time supressed intranuclear cascade *
704* *
705* what (1) formation time (in fm/c) *
706* note: what(1)=10. corresponds roughly to an *
707* average formation time of 1 fm/c *
708* default: 5. fm/c *
709* what (2) number of generations followed *
710* default: 25 *
711* what (3) = 1. p_t-dependent formation zone *
712* = 2. constant formation zone *
713* default: 1 *
714* what (4) modus of selection of nucleus where the *
715* cascade if followed first *
716* = 1. proj./target-nucleus with probab. 1/2 *
717* = 2. nucleus with highest mass *
718* = 3. proj. nucleus if particle is moving in pos. z *
719* targ. nucleus if particle is moving in neg. z *
720* default: 1 *
721* what (5..6), sdum no meaning *
722* *
723*********************************************************************
724
725 180 CONTINUE
726 TAUFOR = WHAT(1)
727 KTAUGE = INT(WHAT(2))
728 INCMOD = 1
729 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
730 & ITAUVE = INT(WHAT(3))
731 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
732 & INCMOD = INT(WHAT(4))
733 GOTO 10
734
735*********************************************************************
736* *
737* control card: codewd = PAULI *
738* *
739* what (1) = -1 Pauli's principle for secondary *
740* interactions not treated *
741* default: 1 *
742* what (2..6), sdum no meaning *
743* *
744*********************************************************************
745
746 190 CONTINUE
747 IF (WHAT(1).EQ.-1.0D0) THEN
748 LPAULI = .FALSE.
749 ELSE
750 LPAULI = .TRUE.
751 ENDIF
752 GOTO 10
753
754*********************************************************************
755* *
756* control card: codewd = COULOMB *
757* *
758* what (1) = -1. Coulomb-energy treatment switched off *
759* default: 1 *
760* what (2..6), sdum no meaning *
761* *
762*********************************************************************
763
764 200 CONTINUE
765 ICOUL = 1
766 IF (WHAT(1).EQ.-1.0D0) THEN
767 ICOUL = 0
768 ELSE
769 ICOUL = 1
770 ENDIF
771 GOTO 10
772
773*********************************************************************
774* *
775* control card: codewd = HADRIN *
776* *
777* HADRIN module *
778* *
779* what (1) = 0. elastic/inelastic interactions with probab. *
780* as defined by cross-sections *
781* = 1. inelastic interactions forced *
782* = 2. elastic interactions forced *
783* default: 1 *
784* what (2) upper threshold in total energy (GeV) below *
785* which interactions are sampled by HADRIN *
786* default: 5. GeV *
787* what (3..6), sdum no meaning *
788* *
789*********************************************************************
790
791 210 CONTINUE
792 IWHAT = INT(WHAT(1))
793 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
794 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
795 GOTO 10
796
797*********************************************************************
798* *
799* control card: codewd = EVAP *
800* *
801* evaporation module *
802* *
803* what (1) =< -1 ==> evaporation is switched off *
804* >= 1 ==> evaporation is performed *
805* *
806* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
807* (i1, i2, i3, i4 >= 0 ) *
808* *
809* i1 is the flag for selecting the T=0 level density option used *
810* = 1: standard EVAP level densities with Cook pairing *
811* energies *
812* = 2: Z,N-dependent Gilbert & Cameron level densities *
813* (default) *
814* = 3: Julich A-dependent level densities *
815* = 4: Z,N-dependent Brancazio & Cameron level densities *
816* *
817* i2 >= 1: high energy fission activated *
818* (default high energy fission activated) *
819* *
820* i3 = 0: No energy dependence for level densities *
821* = 1: Standard Ignyatuk (1975, 1st) energy dependence *
822* for level densities (default) *
823* = 2: Standard Ignyatuk (1975, 1st) energy dependence *
824* for level densities with NOT used set of parameters *
825* = 3: Standard Ignyatuk (1975, 1st) energy dependence *
826* for level densities with NOT used set of parameters *
827* = 4: Second Ignyatuk (1975, 2nd) energy dependence *
828* for level densities *
829* = 5: Second Ignyatuk (1975, 2nd) energy dependence *
830* for level densities with fit 1 Iljinov & Mebel set of *
831* parameters *
832* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
833* for level densities with fit 2 Iljinov & Mebel set of *
834* parameters *
835* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
836* for level densities with fit 3 Iljinov & Mebel set of *
837* parameters *
838* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
839* for level densities with fit 4 Iljinov & Mebel set of *
840* parameters *
841* *
842* i4 >= 1: Original Gilbert and Cameron pairing energies used *
843* (default Cook's modified pairing energies) *
844* *
845* what (2) = ig + 10 * if (ig and if must have the same sign) *
846* *
847* ig =< -1 ==> deexcitation gammas are not produced *
848* (if the evaporation step is not performed *
849* they are never produced) *
850* if =< -1 ==> Fermi Break Up is not invoked *
851* (if the evaporation step is not performed *
852* it is never invoked) *
853* The default is: deexcitation gamma produced and Fermi break up *
854* activated for the new preequilibrium, not *
855* activated otherwise. *
856* what (3..6), sdum no meaning *
857* *
858*********************************************************************
859
860 220 CONTINUE
861 IF (WHAT(1).LE.-1.0D0) THEN
862 LEVPRT = .FALSE.
863 LDEEXG = .FALSE.
864 LHEAVY = .FALSE.
865 GOTO 10
866 ENDIF
867 WHTSAV = WHAT (1)
868 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
869 LLVMOD = .FALSE.
870 JLVHLP = NINT (WHAT (1)) / 10000
871 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
872 END IF
873 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
874 JLVMOD = NINT (WHAT (1)) / 100
875 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
876 END IF
877 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
878
879 IEVFSS = 1
880
881 JLVHLP = NINT (WHAT (1)) / 10
882 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
883 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
884
885 IEVFSS = 0
886
887 END IF
888 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
889 LEVPRT = .TRUE.
890 ILVMOD = NINT (WHAT(1))
891 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
892 LFRMBK = .TRUE.
893 JLVHLP = NINT (WHAT (2)) / 10
894 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
895 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
896 LFRMBK = .FALSE.
897 END IF
898 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
899 LDEEXG = .TRUE.
900 ELSE
901 LDEEXG = .FALSE.
902 END IF
903**sr heavies are always put to /FKFHVY/
904C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
905C LHEAVY = .TRUE.
906C ELSE
907C LHEAVY = .FALSE.
908C END IF
909 LHEAVY = .TRUE.
910 ELSE
911 LEVPRT = .FALSE.
912 LDEEXG = .FALSE.
913 LHEAVY = .FALSE.
914 END IF
915
916 LOLDEV = .FALSE.
917
918 GOTO 10
919
920*********************************************************************
921* *
922* control card: codewd = EMCCHECK *
923* *
924* extended energy-momentum / quantum-number conservation check *
925* *
926* what (1) = -1 extended check not performed *
927* default: 1. *
928* what (2..6), sdum no meaning *
929* *
930*********************************************************************
931
932 230 CONTINUE
933 IF (WHAT(1).EQ.-1) THEN
934 LEMCCK = .FALSE.
935 ELSE
936 LEMCCK = .TRUE.
937 ENDIF
938 GOTO 10
939
940*********************************************************************
941* *
942* control card: codewd = MODEL *
943* *
944* Model to be used to treat nucleon-nucleon interactions *
945* *
946* sdum = DTUNUC two-chain model *
947* = PHOJET multiple chains including minijets *
948* = LEPTO DIS *
949* = QNEUTRIN quasi-elastic neutrino scattering *
950* default: PHOJET *
951* *
952* if sdum = LEPTO: *
953* what (1) (variable INTER) *
954* = 1 gamma exchange *
955* = 2 W+- exchange *
956* = 3 Z0 exchange *
957* = 4 gamma/Z0 exchange *
958* *
959* if sdum = QNEUTRIN: *
960* what (1) = 0 elastic scattering on nucleon and *
961* tau does not decay (default) *
962* = 1 decay of tau into mu.. *
963* = 2 decay of tau into e.. *
964* = 10 CC events on p and n *
965* = 11 NC events on p and n *
966* *
967* what (2..6) no meaning *
968* *
969*********************************************************************
970
971 240 CONTINUE
972 IF (SDUM.EQ.CMODEL(1)) THEN
973 MCGENE = 1
974 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
975 MCGENE = 2
976 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
977 MCGENE = 3
978 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
979 & INTER = INT(WHAT(1))
980 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
981 MCGENE = 4
982 IWHAT = INT(WHAT(1))
983 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
984 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
985 & NEUDEC = IWHAT
986 ELSE
987 STOP ' Unknown model !'
988 ENDIF
989 GOTO 10
990
991*********************************************************************
992* *
993* control card: codewd = PHOINPUT *
994* *
995* Start of input-section for PHOJET-specific input-cards *
996* Note: This section will not be finished before giving *
997* ENDINPUT-card *
998* what (1..6), sdum no meaning *
999* *
1000*********************************************************************
1001
1002 250 CONTINUE
1003 IF (LPHOIN) THEN
1004
1005 CALL PHO_INIT(LINP,LOUT,IREJ1)
1006
1007 IF (IREJ1.NE.0) THEN
1008 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
1009 STOP
1010 ENDIF
1011 LPHOIN = .FALSE.
1012 ENDIF
1013 GOTO 10
1014
1015*********************************************************************
1016* *
1017* control card: codewd = GLAUBERI *
1018* *
1019* Pre-initialization of impact parameter selection *
1020* *
1021* what (1..6), sdum no meaning *
1022* *
1023*********************************************************************
1024
1025 260 CONTINUE
1026 IF (IFIRST.NE.99) THEN
1027 CALL DT_RNDMST(12,34,56,78)
1028 CALL DT_RNDMTE(1)
1029 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1031 IFIRST = 99
1032 ENDIF
1033
1034 IPPN = 8
1035 PLOW = 10.0D0
1036C IPPN = 1
1037C PLOW = 100.0D0
1038 PHI = 1.0D5
1039 APLOW = LOG10(PLOW)
1040 APHI = LOG10(PHI)
1041 ADP = (APHI-APLOW)/DBLE(IPPN)
1042
1043 IPLOW = 1
1044 IDIP = 1
1045 IIP = 5
1046C IPLOW = 1
1047C IDIP = 1
1048C IIP = 1
1049 IPRANG(1) = 1
1050 IPRANG(2) = 2
1051 IPRANG(3) = 5
1052 IPRANG(4) = 10
1053 IPRANG(5) = 20
1054
1055 ITLOW = 30
1056 IDIT = 3
1057 IIT = 60
1058C IDIT = 10
1059C IIT = 21
1060
1061 DO 473 NCIT=1,IIT
1062 IT = ITLOW+(NCIT-1)*IDIT
1063C IPHI = IT
1064C IDIP = 10
1065C IIP = (IPHI-IPLOW)/IDIP
1066C IF (IIP.EQ.0) IIP = 1
1067C IF (IT.EQ.IPLOW) IIP = 0
1068
1069 DO 472 NCIP=1,IIP
1070 IP = IPRANG(NCIP)
1071CC IF (NCIP.LE.IIP) THEN
1072C IP = IPLOW+(NCIP-1)*IDIP
1073CC ELSE
1074CC IP = IT
1075CC ENDIF
1076 IF (IP.GT.IT) GOTO 472
1077
1078 DO 471 NCP=1,IPPN+1
1079 APPN = APLOW+DBLE(NCP-1)*ADP
1080 PPN = 10**APPN
1081
1082 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1084 CLOSE(12)
1085
1086 XLIM1 = 0.0D0
1087 XLIM2 = 50.0D0
1088 XLIM3 = ZERO
1089 IBIN = 50
1090 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1092
1093 NEVFIT = 5
1094C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1095C NEVFIT = 5
1096C ELSE
1097C NEVFIT = 10
1098C ENDIF
1099 SIGAV = 0.0D0
1100
1101 DO 478 I=1,NEVFIT
1102 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103 SIGAV = SIGAV+XSPRO(1,1,1)
1104 DO 479 J=1,50
1105 XC = DBLE(J)
1106 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1107 479 CONTINUE
1108 478 CONTINUE
1109
1110 CALL DT_EVTHIS(IDUM)
1111 HEADER = ' BSITE'
1112C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1113
1114C CALL GENFIT(XPARA)
1115C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1117
1118 471 CONTINUE
1119
1120 472 CONTINUE
1121
1122 473 CONTINUE
1123
1124 STOP
1125
1126*********************************************************************
1127* *
1128* control card: codewd = FLUCTUAT *
1129* *
1130* Treatment of cross section fluctuations *
1131* *
1132* what (1) = 1 treat cross section fluctuations *
1133* default: 0. *
1134* what (1..6), sdum no meaning *
1135* *
1136*********************************************************************
1137
1138 270 CONTINUE
1139 IFLUCT = 0
1140 IF (WHAT(1).EQ.ONE) THEN
1141 IFLUCT = 1
1142 CALL DT_FLUINI
1143 ENDIF
1144 GOTO 10
1145
1146*********************************************************************
1147* *
1148* control card: codewd = CENTRAL *
1149* *
1150* what (1) = 1. central production forced default: 0 *
1151* if what (1) < 0 and > -100 *
1152* what (2) = min. impact parameter default: 0 *
1153* what (3) = max. impact parameter default: b_max *
1154* if what (1) < -99 *
1155* what (2) = fraction of cross section default: 1 *
1156* if what (1) = -1 : evaporation/fzc suppressed *
1157* if what (1) < -1 : evaporation/fzc allowed *
1158* *
1159* what (4..6), sdum no meaning *
1160* *
1161*********************************************************************
1162
1163 280 CONTINUE
1164 ICENTR = INT(WHAT(1))
1165 IF (ICENTR.LT.0) THEN
1166 IF (ICENTR.GT.-100) THEN
1167 BIMIN = WHAT(2)
1168 BIMAX = WHAT(3)
1169 ELSE
1170 XSFRAC = WHAT(2)
1171 ENDIF
1172 ENDIF
1173 GOTO 10
1174
1175*********************************************************************
1176* *
1177* control card: codewd = RECOMBIN *
1178* *
1179* Chain recombination *
1180* (recombine S-S and V-V chains to V-S chains) *
1181* *
1182* what (1) = -1. recombination switched off default: 1 *
1183* what (2..6), sdum no meaning *
1184* *
1185*********************************************************************
1186
1187 290 CONTINUE
1188 IRECOM = 1
1189 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1190 GOTO 10
1191
1192*********************************************************************
1193* *
1194* control card: codewd = COMBIJET *
1195* *
1196* chain fusion (2 q-aq --> qq-aqaq) *
1197* *
1198* what (1) = 1 fusion treated *
1199* default: 0. *
1200* what (2) minimum number of uncombined chains from *
1201* single projectile or target nucleons *
1202* default: 0. *
1203* what (3..6), sdum no meaning *
1204* *
1205*********************************************************************
1206
1207 300 CONTINUE
1208 LCO2CR = .FALSE.
1209 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1211 GOTO 10
1212
1213*********************************************************************
1214* *
1215* control card: codewd = XCUTS *
1216* *
1217* thresholds for x-sampling *
1218* *
1219* what (1) defines lower threshold for val.-q x-value (CVQ) *
1220* default: 1. *
1221* what (2) defines lower threshold for val.-qq x-value (CDQ) *
1222* default: 2. *
1223* what (3) defines lower threshold for sea-q x-value (CSEA) *
1224* default: 0.2 *
1225* what (4) sea-q x-values in S-S chains (SSMIMA) *
1226* default: 0.14 *
1227* what (5) not used *
1228* default: 2. *
1229* what (6), sdum no meaning *
1230* *
1231* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1232* *
1233*********************************************************************
1234
1235 310 CONTINUE
1236 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1237 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1238 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1239 IF (WHAT(4).GE.ZERO) THEN
1240 SSMIMA = WHAT(4)
1241 SSMIMQ = SSMIMA**2
1242 ENDIF
1243 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1244 GOTO 10
1245
1246*********************************************************************
1247* *
1248* control card: codewd = INTPT *
1249* *
1250* what (1) = -1 intrinsic transverse momenta of partons *
1251* not treated default: 1 *
1252* what (2..6), sdum no meaning *
1253* *
1254*********************************************************************
1255
1256 320 CONTINUE
1257 IF (WHAT(1).EQ.-1.0D0) THEN
1258 LINTPT = .FALSE.
1259 ELSE
1260 LINTPT = .TRUE.
1261 ENDIF
1262 GOTO 10
1263
1264*********************************************************************
1265* *
1266* control card: codewd = CRONINPT *
1267* *
1268* Cronin effect (multiple scattering of partons at chain ends) *
1269* *
1270* what (1) = -1 Cronin effect not treated default: 1 *
1271* what (2) = 0 scattering parameter default: 0.64 *
1272* what (3..6), sdum no meaning *
1273* *
1274*********************************************************************
1275
1276 330 CONTINUE
1277 IF (WHAT(1).EQ.-1.0D0) THEN
1278 MKCRON = 0
1279 ELSE
1280 MKCRON = 1
1281 ENDIF
1282 CRONCO = WHAT(2)
1283 GOTO 10
1284
1285*********************************************************************
1286* *
1287* control card: codewd = SEADISTR *
1288* *
1289* what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1290* what (2) (UNON) default: 2. *
1291* what (3) (UNOM) default: 1.5 *
1292* what (4) (UNOSEA) default: 5. *
1293* qdis(x) prop. (1-x)**what (1) etc. *
1294* what (5..6), sdum no meaning *
1295* *
1296*********************************************************************
1297
1298 340 CONTINUE
1299 XSEACO = WHAT(1)
1300 XSEACU = 1.05D0-XSEACO
1301 UNON = WHAT(2)
1302 IF (UNON.LT.0.1D0) UNON = 2.0D0
1303 UNOM = WHAT(3)
1304 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1305 UNOSEA = WHAT(4)
1306 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1307 GOTO 10
1308
1309*********************************************************************
1310* *
1311* control card: codewd = SEASU3 *
1312* *
1313* Treatment of strange-quarks at chain ends *
1314* *
1315* what (1) (SEASQ) strange-quark supression factor *
1316* iflav = 1.+rndm*(2.+SEASQ) *
1317* default: 1. *
1318* what (2..6), sdum no meaning *
1319* *
1320*********************************************************************
1321
1322 350 CONTINUE
1323 SEASQ = WHAT(1)
1324 GOTO 10
1325
1326*********************************************************************
1327* *
1328* control card: codewd = DIQUARKS *
1329* *
1330* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1331* default: 1. *
1332* what (2..6), sdum no meaning *
1333* *
1334*********************************************************************
1335
1336 360 CONTINUE
1337 IF (WHAT(1).EQ.-1.0D0) THEN
1338 LSEADI = .FALSE.
1339 ELSE
1340 LSEADI = .TRUE.
1341 ENDIF
1342 GOTO 10
1343
1344*********************************************************************
1345* *
1346* control card: codewd = RESONANC *
1347* *
1348* treatment of low mass chains *
1349* *
1350* what (1) = -1 low chain masses are not corrected for resonance *
1351* masses (obsolete for BAMJET-fragmentation) *
1352* default: 1. *
1353* what (2) = -1 massless partons default: 1. (massive) *
1354* default: 1. (massive) *
1355* what (3) = -1 chain-system containing chain of too small *
1356* mass is rejected (note: this does not fully *
1357* apply to S-S chains) default: 0. *
1358* what (4..6), sdum no meaning *
1359* *
1360*********************************************************************
1361
1362 370 CONTINUE
1363 IRESCO = 1
1364 IMSHL = 1
1365 IRESRJ = 0
1366 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1368 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1369 GOTO 10
1370
1371*********************************************************************
1372* *
1373* control card: codewd = DIFFRACT *
1374* *
1375* Treatment of diffractive events *
1376* *
1377* what (1) = (ISINGD) 0 no single diffraction *
1378* 1 single diffraction included *
1379* +-2 single diffractive events only *
1380* +-3 projectile single diffraction only *
1381* +-4 target single diffraction only *
1382* -5 double pomeron exchange only *
1383* (neg. sign applies to PHOJET events) *
1384* default: 0. *
1385* *
1386* what (2) = (IDOUBD) 0 no double diffraction *
1387* 1 double diffraction included *
1388* 2 double diffractive events only *
1389* default: 0. *
1390* what (3) = 1 projectile diffraction treated (2-channel form.) *
1391* default: 0. *
1392* what (4) = alpha-parameter in projectile diffraction *
1393* default: 0. *
1394* what (5..6), sdum no meaning *
1395* *
1396*********************************************************************
1397
1398 380 CONTINUE
1399 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1402 WRITE(LOUT,1380)
1403 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1404 & 11X,'IDOUBD is reset to zero')
1405 IDOUBD = 0
1406 ENDIF
1407 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1409 GOTO 10
1410
1411*********************************************************************
1412* *
1413* control card: codewd = SINGLECH *
1414* *
1415* what (1) = 1. Regge contribution (one chain) included *
1416* default: 0. *
1417* what (2..6), sdum no meaning *
1418* *
1419*********************************************************************
1420
1421 390 CONTINUE
1422 ISICHA = 0
1423 IF (WHAT(1).EQ.ONE) ISICHA = 1
1424 GOTO 10
1425
1426*********************************************************************
1427* *
1428* control card: codewd = NOFRAGME *
1429* *
1430* biased chain hadronization *
1431* *
1432* what (1..6) = -1 no of hadronizsation of S-S chains *
1433* = -2 no of hadronizsation of D-S chains *
1434* = -3 no of hadronizsation of S-D chains *
1435* = -4 no of hadronizsation of S-V chains *
1436* = -5 no of hadronizsation of D-V chains *
1437* = -6 no of hadronizsation of V-S chains *
1438* = -7 no of hadronizsation of V-D chains *
1439* = -8 no of hadronizsation of V-V chains *
1440* = -9 no of hadronizsation of comb. chains *
1441* default: complete hadronization *
1442* sdum no meaning *
1443* *
1444*********************************************************************
1445
1446 400 CONTINUE
1447 DO 401 I=1,6
1448 ICHAIN = INT(WHAT(I))
1449 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450 & LHADRO(ABS(ICHAIN)) = .FALSE.
1451 401 CONTINUE
1452 GOTO 10
1453
1454*********************************************************************
1455* *
1456* control card: codewd = HADRONIZE *
1457* *
1458* hadronization model and parameter switch *
1459* *
1460* what (1) = 1 hadronization via BAMJET *
1461* = 2 hadronization via JETSET *
1462* default: 2 *
1463* what (2) = 1..3 parameter set to be used *
1464* JETSET: 3 sets available *
1465* ( = 3 default JETSET-parameters) *
1466* BAMJET: 1 set available *
1467* default: 1 *
1468* what (3..6), sdum no meaning *
1469* *
1470*********************************************************************
1471
1472 410 CONTINUE
1473 IWHAT1 = INT(WHAT(1))
1474 IWHAT2 = INT(WHAT(2))
1475 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1477 & IFRAG(2) = IWHAT2
1478 GOTO 10
1479
1480*********************************************************************
1481* *
1482* control card: codewd = POPCORN *
1483* *
1484* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1485* *
1486* what (1) = (PDB) frac. of diquark fragmenting directly into *
1487* baryons (PYTHIA/JETSET fragmentation) *
1488* (JETSET: = 0. Popcorn mechanism switched off) *
1489* default: 0.5 *
1490* what (2) = probability for accepting a diquark breaking *
1491* diagram involving the generation of a u/d quark- *
1492* antiquark pair default: 0.0 *
1493* what (3) = same a what (2), here for s quark-antiquark pair *
1494* default: 0.0 *
1495* what (4..6), sdum no meaning *
1496* *
1497*********************************************************************
1498
1499 420 CONTINUE
1500 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501 IF (WHAT(2).GE.0.0D0) THEN
1502 PDBSEA(1) = WHAT(2)
1503 PDBSEA(2) = WHAT(2)
1504 ENDIF
1505 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1506 DO 421 I=1,8
1507 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1510 421 CONTINUE
1511 GOTO 10
1512
1513*********************************************************************
1514* *
1515* control card: codewd = PARDECAY *
1516* *
1517* what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1518* = 2. pion^0 decay after intranucl. cascade *
1519* default: no decay *
1520* what (2..6), sdum no meaning *
1521* *
1522*********************************************************************
1523
1524 430 CONTINUE
1525 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1526 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1527 GOTO 10
1528
1529*********************************************************************
1530* *
1531* control card: codewd = BEAM *
1532* *
1533* definition of beam parameters *
1534* *
1535* what (1/2) > 0 : energy of beam 1/2 (GeV) *
1536* < 0 : abs(what(1/2)) energy per charge of *
1537* beam 1/2 (GeV) *
1538* (beam 1 is directed into positive z-direction) *
1539* what (3) beam crossing angle, defined as 2x angle between *
1540* one beam and the z-axis (micro rad) *
1541* what (4) angle with x-axis defining the collision plane *
1542* what (5..6), sdum no meaning *
1543* *
1544* Note: this card requires previously defined projectile and *
1545* target identities (PROJPAR, TARPAR) *
1546* *
1547*********************************************************************
1548
1549 440 CONTINUE
1550 CALL DT_BEAMPR(WHAT,PPN,1)
1551 EPN = ZERO
1552 CMENER = ZERO
1553 LEINP = .TRUE.
1554 GOTO 10
1555
1556*********************************************************************
1557* *
1558* control card: codewd = LUND-MSTU *
1559* *
1560* set parameter MSTU in JETSET-common /LUDAT1/ *
1561* *
1562* what (1) = index according to LUND-common block *
1563* what (2) = new value of MSTU( int(what(1)) ) *
1564* what (3), what(4) and what (5), what(6) further *
1565* parameter in the same way as what (1) and *
1566* what (2) *
1567* default: default-Lund or corresponding to *
1568* the set given in HADRONIZE *
1569* *
1570*********************************************************************
1571
1572 450 CONTINUE
1573 IF (WHAT(1).GT.ZERO) THEN
1574 NMSTU = NMSTU+1
1575 IMSTU(NMSTU) = INT(WHAT(1))
1576 MSTUX(NMSTU) = INT(WHAT(2))
1577 ENDIF
1578 IF (WHAT(3).GT.ZERO) THEN
1579 NMSTU = NMSTU+1
1580 IMSTU(NMSTU) = INT(WHAT(3))
1581 MSTUX(NMSTU) = INT(WHAT(4))
1582 ENDIF
1583 IF (WHAT(5).GT.ZERO) THEN
1584 NMSTU = NMSTU+1
1585 IMSTU(NMSTU) = INT(WHAT(5))
1586 MSTUX(NMSTU) = INT(WHAT(6))
1587 ENDIF
1588 GOTO 10
1589
1590*********************************************************************
1591* *
1592* control card: codewd = LUND-MSTJ *
1593* *
1594* set parameter MSTJ in JETSET-common /LUDAT1/ *
1595* *
1596* what (1) = index according to LUND-common block *
1597* what (2) = new value of MSTJ( int(what(1)) ) *
1598* what (3), what(4) and what (5), what(6) further *
1599* parameter in the same way as what (1) and *
1600* what (2) *
1601* default: default-Lund or corresponding to *
1602* the set given in HADRONIZE *
1603* *
1604*********************************************************************
1605
1606 451 CONTINUE
1607 IF (WHAT(1).GT.ZERO) THEN
1608 NMSTJ = NMSTJ+1
1609 IMSTJ(NMSTJ) = INT(WHAT(1))
1610 MSTJX(NMSTJ) = INT(WHAT(2))
1611 ENDIF
1612 IF (WHAT(3).GT.ZERO) THEN
1613 NMSTJ = NMSTJ+1
1614 IMSTJ(NMSTJ) = INT(WHAT(3))
1615 MSTJX(NMSTJ) = INT(WHAT(4))
1616 ENDIF
1617 IF (WHAT(5).GT.ZERO) THEN
1618 NMSTJ = NMSTJ+1
1619 IMSTJ(NMSTJ) = INT(WHAT(5))
1620 MSTJX(NMSTJ) = INT(WHAT(6))
1621 ENDIF
1622 GOTO 10
1623
1624*********************************************************************
1625* *
1626* control card: codewd = LUND-MDCY *
1627* *
1628* set parameter MDCY(I,1) for particle decays in JETSET-common *
1629* /LUDAT3/ *
1630* *
1631* what (1-6) = PDG particle index of particle which should *
1632* not decay *
1633* default: default-Lund or forced in *
1634* DT_INITJS *
1635* *
1636*********************************************************************
1637
1638 452 CONTINUE
1639 DO 4521 I=1,6
1640 IF (WHAT(I).NE.ZERO) THEN
1641
1642 KC = PYCOMP(INT(WHAT(I)))
1643
1644 MDCY(KC,1) = 0
1645 ENDIF
1646 4521 CONTINUE
1647 GOTO 10
1648
1649*********************************************************************
1650* *
1651* control card: codewd = LUND-PARJ *
1652* *
1653* set parameter PARJ in JETSET-common /LUDAT1/ *
1654* *
1655* what (1) = index according to LUND-common block *
1656* what (2) = new value of PARJ( int(what(1)) ) *
1657* what (3), what(4) and what (5), what(6) further *
1658* parameter in the same way as what (1) and *
1659* what (2) *
1660* default: default-Lund or corresponding to *
1661* the set given in HADRONIZE *
1662* *
1663*********************************************************************
1664
1665 460 CONTINUE
1666 IF (WHAT(1).NE.ZERO) THEN
1667 NPARJ = NPARJ+1
1668 IPARJ(NPARJ) = INT(WHAT(1))
1669 PARJX(NPARJ) = WHAT(2)
1670 ENDIF
1671 IF (WHAT(3).NE.ZERO) THEN
1672 NPARJ = NPARJ+1
1673 IPARJ(NPARJ) = INT(WHAT(3))
1674 PARJX(NPARJ) = WHAT(4)
1675 ENDIF
1676 IF (WHAT(5).NE.ZERO) THEN
1677 NPARJ = NPARJ+1
1678 IPARJ(NPARJ) = INT(WHAT(5))
1679 PARJX(NPARJ) = WHAT(6)
1680 ENDIF
1681 GOTO 10
1682
1683*********************************************************************
1684* *
1685* control card: codewd = LUND-PARU *
1686* *
1687* set parameter PARJ in JETSET-common /LUDAT1/ *
1688* *
1689* what (1) = index according to LUND-common block *
1690* what (2) = new value of PARU( int(what(1)) ) *
1691* what (3), what(4) and what (5), what(6) further *
1692* parameter in the same way as what (1) and *
1693* what (2) *
1694* default: default-Lund or corresponding to *
1695* the set given in HADRONIZE *
1696* *
1697*********************************************************************
1698
1699 470 CONTINUE
1700 IF (WHAT(1).GT.ZERO) THEN
1701 NPARU = NPARU+1
1702 IPARU(NPARU) = INT(WHAT(1))
1703 PARUX(NPARU) = WHAT(2)
1704 ENDIF
1705 IF (WHAT(3).GT.ZERO) THEN
1706 NPARU = NPARU+1
1707 IPARU(NPARU) = INT(WHAT(3))
1708 PARUX(NPARU) = WHAT(4)
1709 ENDIF
1710 IF (WHAT(5).GT.ZERO) THEN
1711 NPARU = NPARU+1
1712 IPARU(NPARU) = INT(WHAT(5))
1713 PARUX(NPARU) = WHAT(6)
1714 ENDIF
1715 GOTO 10
1716
1717*********************************************************************
1718* *
1719* control card: codewd = OUTLEVEL *
1720* *
1721* output control switches *
1722* *
1723* what (1) = internal rejection informations default: 0 *
1724* what (2) = energy-momentum conservation check output *
1725* default: 0 *
1726* what (3) = internal warning messages default: 0 *
1727* what (4..6), sdum not yet used *
1728* *
1729*********************************************************************
1730
1731 480 CONTINUE
1732 DO 481 K=1,6
1733 IOULEV(K) = INT(WHAT(K))
1734 481 CONTINUE
1735 GOTO 10
1736
1737*********************************************************************
1738* *
1739* control card: codewd = FRAME *
1740* *
1741* frame in which final state is given in DTEVT1 *
1742* *
1743* what (1) = 1 target rest frame (laboratory) *
1744* = 2 nucleon-nucleon cms *
1745* default: 1 *
1746* *
1747*********************************************************************
1748
1749 490 CONTINUE
1750 KFRAME = INT(WHAT(1))
1751 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1752 GOTO 10
1753
1754*********************************************************************
1755* *
1756* control card: codewd = L-TAG *
1757* *
1758* lepton tagger: *
1759* definition of kinematical cuts for radiated photon and *
1760* outgoing lepton detection in lepton-nucleus interactions *
1761* *
1762* what (1) = y_min *
1763* what (2) = y_max *
1764* what (3) = Q^2_min *
1765* what (4) = Q^2_max *
1766* what (5) = theta_min (Lab) *
1767* what (6) = theta_max (Lab) *
1768* default: no cuts *
1769* sdum no meaning *
1770* *
1771*********************************************************************
1772
1773 500 CONTINUE
1774 YMIN = WHAT(1)
1775 YMAX = WHAT(2)
1776 Q2MIN = WHAT(3)
1777 Q2MAX = WHAT(4)
1778 THMIN = WHAT(5)
1779 THMAX = WHAT(6)
1780 GOTO 10
1781
1782*********************************************************************
1783* *
1784* control card: codewd = L-ETAG *
1785* *
1786* lepton tagger: *
1787* what (1) = min. outgoing lepton energy (in Lab) *
1788* what (2) = min. photon energy (in Lab) *
1789* what (3) = max. photon energy (in Lab) *
1790* default: no cuts *
1791* what (2..6), sdum no meaning *
1792* *
1793*********************************************************************
1794
1795 510 CONTINUE
1796 ELMIN = MAX(WHAT(1),ZERO)
1797 EGMIN = MAX(WHAT(2),ZERO)
1798 EGMAX = MAX(WHAT(3),ZERO)
1799 GOTO 10
1800
1801*********************************************************************
1802* *
1803* control card: codewd = ECMS-CUT *
1804* *
1805* what (1) = min. c.m. energy to be sampled *
1806* what (2) = max. c.m. energy to be sampled *
1807* what (3) = min x_Bj to be sampled *
1808* default: no cuts *
1809* what (3..6), sdum no meaning *
1810* *
1811*********************************************************************
1812
1813 520 CONTINUE
1814 ECMIN = WHAT(1)
1815 ECMAX = WHAT(2)
1816 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817 XBJMIN = MAX(WHAT(3),ZERO)
1818 GOTO 10
1819
1820*********************************************************************
1821* *
1822* control card: codewd = VDM-PAR1 *
1823* *
1824* parameters in gamma-nucleus cross section calculation *
1825* *
1826* what (1) = Lambda^2 default: 2. *
1827* what (2) lower limit in M^2 integration *
1828* = 1 (3m_pi)^2 *
1829* = 2 (m_rho0)^2 *
1830* = 3 (m_phi)^2 default: 1 *
1831* what (3) upper limit in M^2 integration *
1832* = 1 s/2 *
1833* = 2 s/4 *
1834* = 3 s default: 3 *
1835* what (4) CKMT F_2 structure function *
1836* = 2212 proton *
1837* = 100 deuteron default: 2212 *
1838* what (5) calculation of gamma-nucleon xsections *
1839* = 1 according to CKMT-parametrization of F_2 *
1840* = 2 integrating SIGVP over M^2 *
1841* = 3 using SIGGA *
1842* = 4 PHOJET cross sections default: 4 *
1843* *
1844* what (6), sdum no meaning *
1845* *
1846*********************************************************************
1847
1848 530 CONTINUE
1849 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1854 GOTO 10
1855
1856*********************************************************************
1857* *
1858* control card: codewd = HISTOGRAM *
1859* *
1860* activate different classes of histograms *
1861* *
1862* default: no histograms *
1863* *
1864*********************************************************************
1865
1866 540 CONTINUE
1867 DO 541 J=1,6
1868 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869 IHISPP(INT(WHAT(J))-100) = 1
1870 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1873 ENDIF
1874 541 CONTINUE
1875 GOTO 10
1876
1877*********************************************************************
1878* *
1879* control card: codewd = XS-TABLE *
1880* *
1881* output of cross section table for requested interaction *
1882* - particle production deactivated ! - *
1883* *
1884* what (1) lower energy limit for tabulation *
1885* > 0 Lab. frame *
1886* < 0 nucleon-nucleon cms *
1887* what (2) upper energy limit for tabulation *
1888* > 0 Lab. frame *
1889* < 0 nucleon-nucleon cms *
1890* what (3) > 0 # of equidistant lin. bins in E *
1891* < 0 # of equidistant log. bins in E *
1892* what (4) lower limit of particle virtuality (photons) *
1893* what (5) upper limit of particle virtuality (photons) *
1894* what (6) > 0 # of equidistant lin. bins in Q^2 *
1895* < 0 # of equidistant log. bins in Q^2 *
1896* *
1897*********************************************************************
1898
1899 550 CONTINUE
1900 IF (WHAT(1).EQ.99999.0D0) THEN
1901 IRATIO = INT(WHAT(2))
1902 GOTO 10
1903 ENDIF
1904 CMENER = ABS(WHAT(2))
1905 IF (.NOT.LXSTAB) THEN
1906
1907 CALL NCDTRD
1908 CALL INCINI
1909
1910 ENDIF
1911 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1912 CMEOLD = CMENER
1913 IF (WHAT(2).GT.ZERO)
1914 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1915 EPN = ZERO
1916 PPN = ZERO
1917C WRITE(LOUT,*) 'CMENER = ',CMENER
1918 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1919 CALL DT_PHOINI
1920 ENDIF
1921 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1922 IXSQEL = 0
1923 LXSTAB = .TRUE.
1924 GOTO 10
1925
1926*********************************************************************
1927* *
1928* control card: codewd = GLAUB-PAR *
1929* *
1930* parameters in Glauber-formalism *
1931* *
1932* what (1) # of nucleon configurations sampled in integration *
1933* over nuclear desity default: 1000 *
1934* what (2) # of bins for integration over impact-parameter and *
1935* for profile-function calculation default: 49 *
1936* what (3) = 1 calculation of tot., el. and qel. cross sections *
1937* default: 0 *
1938* what (4) = 1 read pre-calculated impact-parameter distrib. *
1939* from "sdum".glb *
1940* =-1 dump pre-calculated impact-parameter distrib. *
1941* into "sdum".glb *
1942* = 100 read pre-calculated impact-parameter distrib. *
1943* for variable projectile/target/energy runs *
1944* from "sdum".glb *
1945* default: 0 *
1946* what (5..6) no meaning *
1947* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1948* *
1949*********************************************************************
1950
1951 560 CONTINUE
1952 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956 IOGLB = INT(WHAT(4))
1957 CGLB = SDUM
1958 ENDIF
1959 GOTO 10
1960
1961*********************************************************************
1962* *
1963* control card: codewd = GLAUB-INI *
1964* *
1965* pre-initialization of profile function *
1966* *
1967* what (1) lower energy limit for initialization *
1968* > 0 Lab. frame *
1969* < 0 nucleon-nucleon cms *
1970* what (2) upper energy limit for initialization *
1971* > 0 Lab. frame *
1972* < 0 nucleon-nucleon cms *
1973* what (3) > 0 # of equidistant lin. bins in E *
1974* < 0 # of equidistant log. bins in E *
1975* what (4) maximum projectile mass number for which the *
1976* Glauber data are initialized for each *
1977* projectile mass number *
1978* (if <= mass given with the PROJPAR-card) *
1979* default: 18 *
1980* what (5) steps in mass number starting from what (4) *
1981* up to mass number defined with PROJPAR-card *
1982* for which Glauber data are initialized *
1983* default: 5 *
1984* what (6) no meaning *
1985* sdum no meaning *
1986* *
1987*********************************************************************
1988
1989 565 CONTINUE
1990 IOGLB = -100
1991 CALL DT_GLBINI(WHAT)
1992 GOTO 10
1993
1994*********************************************************************
1995* *
1996* control card: codewd = VDM-PAR2 *
1997* *
1998* parameters in gamma-nucleus cross section calculation *
1999* *
2000* what (1) = 0 no suppression of shadowing by direct photon *
2001* processes *
2002* = 1 suppression .. default: 1 *
2003* what (2) = 0 no suppression of shadowing by anomalous *
2004* component if photon-F_2 *
2005* = 1 suppression .. default: 1 *
2006* what (3) = 0 no suppression of shadowing by coherence *
2007* length of the photon *
2008* = 1 suppression .. default: 1 *
2009* what (4) = 1 longitudinal polarized photons are taken into *
2010* account *
2011* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
2012* what (5..6), sdum no meaning *
2013* *
2014*********************************************************************
2015
2016 570 CONTINUE
2017 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2020 EPSPOL = WHAT(4)
2021 GOTO 10
2022
2023*********************************************************************
2024* *
2025* control card: XS-QELPRO *
2026* *
2027* what (1..6), sdum no meaning *
2028* *
2029*********************************************************************
2030
2031 580 CONTINUE
2032 IXSQEL = ABS(WHAT(1))
2033 GOTO 10
2034
2035*********************************************************************
2036* *
2037* control card: RNDMINIT *
2038* *
2039* initialization of random number generator *
2040* *
2041* what (1..4) values for initialization (= 1..168) *
2042* what (5..6), sdum no meaning *
2043* *
2044*********************************************************************
2045
2046 590 CONTINUE
2047 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2048 NA1 = 22
2049 ELSE
2050 NA1 = WHAT(1)
2051 ENDIF
2052 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2053 NA2 = 54
2054 ELSE
2055 NA2 = WHAT(2)
2056 ENDIF
2057 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2058 NA3 = 76
2059 ELSE
2060 NA3 = WHAT(3)
2061 ENDIF
2062 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2063 NA4 = 92
2064 ELSE
2065 NA4 = WHAT(4)
2066 ENDIF
2067 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2068 GOTO 10
2069
2070*********************************************************************
2071* *
2072* control card: codewd = LEPTO-CUT *
2073* *
2074* set parameter CUT in LEPTO-common /LEPTOU/ *
2075* *
2076* what (1) = index in CUT-array *
2077* what (2) = new value of CUT( int(what(1)) ) *
2078* what (3), what(4) and what (5), what(6) further *
2079* parameter in the same way as what (1) and *
2080* what (2) *
2081* default: default-LEPTO parameters *
2082* *
2083*********************************************************************
2084
2085 600 CONTINUE
2086 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2089 GOTO 10
2090
2091*********************************************************************
2092* *
2093* control card: codewd = LEPTO-LST *
2094* *
2095* set parameter LST in LEPTO-common /LEPTOU/ *
2096* *
2097* what (1) = index in LST-array *
2098* what (2) = new value of LST( int(what(1)) ) *
2099* what (3), what(4) and what (5), what(6) further *
2100* parameter in the same way as what (1) and *
2101* what (2) *
2102* default: default-LEPTO parameters *
2103* *
2104*********************************************************************
2105
2106 610 CONTINUE
2107 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2110 GOTO 10
2111
2112*********************************************************************
2113* *
2114* control card: codewd = LEPTO-PARL *
2115* *
2116* set parameter PARL in LEPTO-common /LEPTOU/ *
2117* *
2118* what (1) = index in PARL-array *
2119* what (2) = new value of PARL( int(what(1)) ) *
2120* what (3), what(4) and what (5), what(6) further *
2121* parameter in the same way as what (1) and *
2122* what (2) *
2123* default: default-LEPTO parameters *
2124* *
2125*********************************************************************
2126
2127 620 CONTINUE
2128 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2131 GOTO 10
2132
2133*********************************************************************
2134* *
2135* control card: codewd = START *
2136* *
2137* what (1) = number of events default: 100. *
2138* what (2) = 0 Glauber initialization follows *
2139* = 1 Glauber initialization supressed, fitted *
2140* results are used instead *
2141* (this does not apply if emulsion-treatment *
2142* is requested) *
2143* = 2 Glauber initialization is written to *
2144* output-file shmakov.out *
2145* = 3 Glauber initialization is read from input-file *
2146* shmakov.out default: 0 *
2147* what (3..6) no meaning *
2148* what (3..6) no meaning *
2149* *
2150*********************************************************************
2151
2152 630 CONTINUE
2153
2154* check for cross-section table output only
2155 IF (LXSTAB) STOP
2156
2157 NCASES = INT(WHAT(1))
2158 IF (NCASES.LE.0) NCASES = 100
2159 IGLAU = INT(WHAT(2))
2160 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2161 & IGLAU = 0
2162
2163 NPMASS = IP
2164 NPCHAR = IPZ
2165 NTMASS = IT
2166 NTCHAR = ITZ
2167 IDP = IJPROJ
2168 IDT = IJTARG
2169 IF (IDP.LE.0) IDP = 1
2170* muon neutrinos: temporary (missing index)
2171* (new patch in projpar: therefore the following this is probably not
2172* necessary anymore..)
2173C IF (IDP.EQ.26) IDP = 5
2174C IF (IDP.EQ.27) IDP = 6
2175
2176* redefine collision energy
2177 IF (LEINP) THEN
2178 IF (ABS(VAREHI).GT.ZERO) THEN
2179 PDUM = ZERO
2180 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2182 PDUM = ZERO
2183 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2184 ENDIF
2185 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2186 ELSE
2187 WRITE(LOUT,1003)
2188 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2189 & 1X,' -program stopped- ')
2190 STOP
2191 ENDIF
2192
2193* switch off evaporation (even if requested) if central coll. requ.
2194 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2195 IF (LEVPRT) THEN
2196 WRITE(LOUT,1004)
2197 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2198 & ' central collisions forced.')
2199 LEVPRT = .FALSE.
2200 LDEEXG = .FALSE.
2201 LHEAVY = .FALSE.
2202 ENDIF
2203 ENDIF
2204
2205* initialization of evaporation-module
2206
2207* initialize evaporation if the code is not used as Fluka event generator
2208 WRITE(LOUT,*) ' ITRSPT = ', ITRSPT
2209 IF (ITRSPT.NE.1) THEN
2210 CALL NCDTRD
2211 CALL INCINI
2212 ENDIF
2213 WRITE(LOUT,*) ' LEVPRT = ',LEVPRT
2214 IF (LEVPRT) LHEAVY = .TRUE.
2215* save the default JETSET-parameter
2216 CALL DT_JSPARA(0)
2217
2218 WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE
2219* force use of phojet for g-A
2220 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221* initialization of nucleon-nucleon event generator
2222 IF (MCGENE.EQ.2) CALL DT_PHOINI
2223* initialization of LEPTO event generator
2224 IF (MCGENE.EQ.3) THEN
2225
2226 STOP ' This version does not contain LEPTO !'
2227
2228 ENDIF
2229
2230* initialization of quasi-elastic neutrino scattering
2231 IF (MCGENE.EQ.4) THEN
2232 IF (IJPROJ.EQ.5) THEN
2233 NEUTYP = 1
2234 ELSEIF (IJPROJ.EQ.6) THEN
2235 NEUTYP = 2
2236 ELSEIF (IJPROJ.EQ.135) THEN
2237 NEUTYP = 3
2238 ELSEIF (IJPROJ.EQ.136) THEN
2239 NEUTYP = 4
2240 ELSEIF (IJPROJ.EQ.133) THEN
2241 NEUTYP = 5
2242 ELSEIF (IJPROJ.EQ.134) THEN
2243 NEUTYP = 6
2244 ENDIF
2245 ENDIF
2246
2247* normalize fractions of emulsion components
2248 IF (NCOMPO.GT.0) THEN
2249 SUMFRA = ZERO
2250 DO 491 I=1,NCOMPO
2251 SUMFRA = SUMFRA+EMUFRA(I)
2252 491 CONTINUE
2253 IF (SUMFRA.GT.ZERO) THEN
2254 DO 492 I=1,NCOMPO
2255 EMUFRA(I) = EMUFRA(I)/SUMFRA
2256 492 CONTINUE
2257 ENDIF
2258 ENDIF
2259
2260* disallow Cronin's multiple scattering for nucleus-nucleus interactions
2261 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2262 WRITE(LOUT,1005)
2263 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2264 MKCRON = 0
2265 ENDIF
2266
2267* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2268C IF (NCOMPO.LE.0) THEN
2269C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2270C ELSE
2271C DO 493 I=1,NCOMPO
2272C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2273C 493 CONTINUE
2274C ENDIF
2275
2276* pre-tabulation of elastic cross-sections
2277 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2278
2279 CALL DT_XTIME
2280
2281 RETURN
2282
2283*********************************************************************
2284* *
2285* control card: codewd = STOP *
2286* *
2287* stop of the event generation *
2288* *
2289* what (1..6) no meaning *
2290* *
2291*********************************************************************
2292
2293 9999 CONTINUE
2294 WRITE(LOUT,9000)
2295 9000 FORMAT(1X,'---> unexpected end of input !')
2296
2297 640 CONTINUE
2298 STOP
2299
2300 END
2301
2302*$ CREATE DT_KKINC.FOR
2303*COPY DT_KKINC
2304*
2305*===kkinc==============================================================*
2306*
2307 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2308 & IREJ)
2309
2310************************************************************************
2311* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2312* This subroutine is an update of the previous version written *
2313* by J. Ranft/ H.-J. Moehring. *
2314* This version dated 19.11.95 is written by S. Roesler *
2315************************************************************************
2316
2317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2318 SAVE
2319
2320 PARAMETER ( LINP = 10 ,
2321 & LOUT = 6 ,
2322 & LDAT = 9 )
2323
2324 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2325 & TINY2=1.0D-2,TINY3=1.0D-3)
2326
2327 LOGICAL LFZC
2328
2329* event history
2330
2331 PARAMETER (NMXHKK=200000)
2332
2333 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2334 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2335 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2336
2337* extended event history
2338 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2339 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2340 & IHIST(2,NMXHKK)
2341
2342* particle properties (BAMJET index convention)
2343 CHARACTER*8 ANAME
2344 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2345 & IICH(210),IIBAR(210),K1(210),K2(210)
2346
2347* properties of interacting particles
2348 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2349
2350* Lorentz-parameters of the current interaction
2351 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2352 & UMO,PPCM,EPROJ,PPROJ
2353
2354* flags for input different options
2355 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2356 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2357 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2358
2359* flags for particle decays
2360 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2361 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2362 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2363
2364* cuts for variable energy runs
2365 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2366
2367* Glauber formalism: flags and parameters for statistics
2368 LOGICAL LPROD
2369 CHARACTER*8 CGLB
2370 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2371
2372 DIMENSION WHAT(6)
2373
2374 IREJ = 0
2375 ILOOP = 0
2376 100 CONTINUE
2377 IF (ILOOP.EQ.4) THEN
2378 WRITE(LOUT,1000) NEVHKK
2379 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2380 GOTO 9999
2381 ENDIF
2382 ILOOP = ILOOP+1
2383
2384* variable energy-runs, recalculate parameters for LT's
2385 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2386 PDUM = ZERO
2387 CDUM = ZERO
2388 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2389 ENDIF
2390 IF (EPN.GT.EPROJ) THEN
2391 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2392 & ' Requested energy (',EPN,'GeV) exceeds',
2393 & ' initialization energy (',EPROJ,'GeV) !'
2394 STOP
2395 ENDIF
2396
2397* re-initialize /DTPRTA/
2398 IP = NPMASS
2399 IPZ = NPCHAR
2400 IT = NTMASS
2401 ITZ = NTCHAR
2402 IJPROJ = IDP
2403 IBPROJ = IIBAR(IJPROJ)
2404
2405* calculate nuclear potentials (common /DTNPOT/)
2406 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2407
2408* initialize treatment for residual nuclei
2409 CALL DT_RESNCL(EPN,NLOOP,1)
2410
2411* sample hadron/nucleus-nucleus interaction
2412 CALL DT_KKEVNT(KKMAT,IREJ1)
2413 IF (IREJ1.GT.0) THEN
2414 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2415 GOTO 9999
2416 ENDIF
2417
2418 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2419
2420* intranuclear cascade of final state particles for KTAUGE generations
2421* of secondaries
2422 CALL DT_FOZOCA(LFZC,IREJ1)
2423 IF (IREJ1.GT.0) THEN
2424 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2425 GOTO 9999
2426 ENDIF
2427
2428* baryons unable to escape the nuclear potential are treated as
2429* excited nucleons (ISTHKK=15,16)
2430 CALL DT_SCN4BA
2431
2432* decay of resonances produced in intranuclear cascade processes
2433**sr 15-11-95 should be obsolete
2434C IF (LFZC) CALL DT_DECAY1
2435
2436 101 CONTINUE
2437* treatment of residual nuclei
2438 CALL DT_RESNCL(EPN,NLOOP,2)
2439
2440* evaporation / fission / fragmentation
2441* (if intranuclear cascade was sampled only)
2442 IF (LFZC) THEN
2443 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2444 IF (IREJ1.GT.1) GOTO 101
2445 IF (IREJ1.EQ.1) GOTO 100
2446 ENDIF
2447
2448 ENDIF
2449
2450* rejection of unphysical configurations
2451C CALL DT_REJUCO(1,IREJ1)
2452C IF (IREJ1.GT.0) THEN
2453C IF (IOULEV(1).GT.0)
2454C & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2455C GOTO 100
2456C ENDIF
2457
2458* transform finale state into Lab.
2459 IFLAG = 2
2460 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2461 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2462
2463 IF (IPI0.EQ.1) CALL DT_DECPI0
2464
2465C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2466
2467 RETURN
2468 9999 CONTINUE
2469 IREJ = 1
2470 RETURN
2471 END
2472
2473*$ CREATE DT_DEFAUL.FOR
2474*COPY DT_DEFAUL
2475*
2476*===defaul=============================================================*
2477*
2478 SUBROUTINE DT_DEFAUL(EPN,PPN)
2479
2480************************************************************************
2481* Variables are set to default values. *
2482* This version dated 8.5.95 is written by S. Roesler. *
2483************************************************************************
2484
2485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2486 SAVE
2487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2488 PARAMETER (TWOPI = 6.283185307179586454D+00)
2489
2490* particle properties (BAMJET index convention)
2491 CHARACTER*8 ANAME
2492 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2493 & IICH(210),IIBAR(210),K1(210),K2(210)
2494
2495* nuclear potential
2496 LOGICAL LFERMI
2497 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2498 & EBINDP(2),EBINDN(2),EPOT(2,210),
2499 & ETACOU(2),ICOUL,LFERMI
2500
2501* interface HADRIN-DPM
2502 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2503
2504* central particle production, impact parameter biasing
2505 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2506
2507* properties of interacting particles
2508 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2509
2510* properties of photon/lepton projectiles
2511 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2512
2513 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2514
2515* emulsion treatment
2516 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2517 & NCOMPO,IEMUL
2518
2519* parameter for intranuclear cascade
2520 LOGICAL LPAULI
2521 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2522
2523* various options for treatment of partons (DTUNUC 1.x)
2524* (chain recombination, Cronin,..)
2525 LOGICAL LCO2CR,LINTPT
2526 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2527 & LCO2CR,LINTPT
2528
2529* threshold values for x-sampling (DTUNUC 1.x)
2530 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2531 & SSMIMQ,VVMTHR
2532
2533* flags for input different options
2534 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2535 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2536 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2537
2538* n-n cross section fluctuations
2539 PARAMETER (NBINS = 1000)
2540 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2541
2542* flags for particle decays
2543 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2544 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2545 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2546
2547* diquark-breaking mechanism
2548 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2549
2550* nucleon-nucleon event-generator
2551 CHARACTER*8 CMODEL
2552 LOGICAL LPHOIN
2553 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2554
2555* flags for diffractive interactions (DTUNUC 1.x)
2556 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2557
2558* VDM parameter for photon-nucleus interactions
2559 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2560
2561* Glauber formalism: flags and parameters for statistics
2562 LOGICAL LPROD
2563 CHARACTER*8 CGLB
2564 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2565
2566* kinematical cuts for lepton-nucleus interactions
2567 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2568 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2569
2570* flags for activated histograms
2571 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2572
2573* cuts for variable energy runs
2574 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2575
2576* parameters for hA-diffraction
2577 COMMON /DTDIHA/ DIBETA,DIALPH
2578
2579* LEPTO
2580 REAL RPPN
2581 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2582
2583* steering flags for qel neutrino scattering modules
2584 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2585
2586* event flag
2587 COMMON /DTEVNO/ NEVENT,ICASCA
2588
2589 DATA POTMES /0.002D0/
2590
2591* common /DTNPOT/
2592 DO 10 I=1,2
2593 PFERMP(I) = ZERO
2594 PFERMN(I) = ZERO
2595 EBINDP(I) = ZERO
2596 EBINDN(I) = ZERO
2597 DO 11 J=1,210
2598 EPOT(I,J) = ZERO
2599 11 CONTINUE
2600* nucleus independent meson potential
2601 EPOT(I,13) = POTMES
2602 EPOT(I,14) = POTMES
2603 EPOT(I,15) = POTMES
2604 EPOT(I,16) = POTMES
2605 EPOT(I,23) = POTMES
2606 EPOT(I,24) = POTMES
2607 EPOT(I,25) = POTMES
2608 10 CONTINUE
2609 FERMOD = 0.55D0
2610 ETACOU(1) = ZERO
2611 ETACOU(2) = ZERO
2612 ICOUL = 1
2613 LFERMI = .TRUE.
2614
2615* common /HNTHRE/
2616 EHADTH = -99.0D0
2617 EHADLO = 4.06D0
2618 EHADHI = 6.0D0
2619 INTHAD = 1
2620 IDXTA = 2
2621
2622* common /DTIMPA/
2623 ICENTR = 0
2624 BIMIN = ZERO
2625 BIMAX = 1.0D10
2626 XSFRAC = 1.0D0
2627
2628* common /DTPRTA/
2629 IP = 1
2630 IPZ = 1
2631 IT = 1
2632 ITZ = 1
2633 IJPROJ = 1
2634 IBPROJ = 1
2635 IJTARG = 1
2636 IBTARG = 1
2637* common /DTGPRO/
2638 VIRT = ZERO
2639 DO 14 I=1,4
2640 PGAMM(I) = ZERO
2641 PLEPT0(I) = ZERO
2642 PLEPT1(I) = ZERO
2643 PNUCL(I) = ZERO
2644 14 CONTINUE
2645 IDIREC = 0
2646
2647* common /DTFOTI/
2648**sr 7.4.98: changed after corrected B-sampling
2649C TAUFOR = 4.4D0
2650 TAUFOR = 3.5D0
2651 KTAUGE = 25
2652 ITAUVE = 1
2653 INCMOD = 1
2654 LPAULI = .TRUE.
2655
2656* common /DTCHAI/
2657 SEASQ = ONE
2658 MKCRON = 1
2659 CRONCO = 0.64D0
2660 ISICHA = 0
2661 CUTOF = 100.0D0
2662 LCO2CR = .FALSE.
2663 IRECOM = 1
2664 LINTPT = .TRUE.
2665
2666* common /DTXCUT/
2667* definition of soft quark distributions
2668 XSEACU = 0.05D0
2669 UNON = 2.0D0
2670 UNOM = 1.5D0
2671 UNOSEA = 5.0D0
2672* cutoff parameters for x-sampling
2673 CVQ = 1.0D0
2674 CDQ = 2.0D0
2675C CSEA = 0.3D0
2676 CSEA = 0.1D0
2677 SSMIMA = 1.2D0
2678 SSMIMQ = SSMIMA**2
2679 VVMTHR = 2.0D0
2680
2681* common /DTXSFL/
2682 IFLUCT = 0
2683
2684* common /DTFRPA/
2685 PDB = 0.15D0
2686 PDBSEA(1) = 0.0D0
2687 PDBSEA(2) = 0.0D0
2688 PDBSEA(3) = 0.0D0
2689 ISIG0 = 0
2690 IPI0 = 0
2691 NMSTU = 0
2692 NPARU = 0
2693 NMSTJ = 0
2694 NPARJ = 0
2695
2696* common /DTDIQB/
2697 DO 15 I=1,8
2698 DBRKR(1,I) = 5.0D0
2699 DBRKR(2,I) = 5.0D0
2700 DBRKR(3,I) = 10.0D0
2701 DBRKA(1,I) = ZERO
2702 DBRKA(2,I) = ZERO
2703 DBRKA(3,I) = ZERO
2704 15 CONTINUE
2705 CHAM1 = 0.2D0
2706 CHAM3 = 0.5D0
2707 CHAB1 = 0.7D0
2708 CHAB3 = 1.0D0
2709
2710* common /DTFLG3/
2711 ISINGD = 0
2712 IDOUBD = 0
2713 IFLAGD = 0
2714 IDIFF = 0
2715
2716* common /DTMODL/
2717 MCGENE = 2
2718 CMODEL(1) = 'DTUNUC '
2719 CMODEL(2) = 'PHOJET '
2720 CMODEL(3) = 'LEPTO '
2721 CMODEL(4) = 'QNEUTRIN'
2722 LPHOIN = .TRUE.
2723 ELOJET = 5.0D0
2724
2725* common /DTLCUT/
2726 ECMIN = 3.5D0
2727 ECMAX = 1.0D10
2728 XBJMIN = ZERO
2729 ELMIN = ZERO
2730 EGMIN = ZERO
2731 EGMAX = 1.0D10
2732 YMIN = TINY10
2733 YMAX = 0.999D0
2734 Q2MIN = TINY10
2735 Q2MAX = 10.0D0
2736 THMIN = ZERO
2737 THMAX = TWOPI
2738 Q2LI = ZERO
2739 Q2HI = 1.0D10
2740 ECMLI = ZERO
2741 ECMHI = 1.0D10
2742
2743* common /DTVDMP/
2744 RL2 = 2.0D0
2745 INTRGE(1) = 1
2746 INTRGE(2) = 3
2747 IDPDF = 2212
2748 MODEGA = 4
2749 ISHAD(1) = 1
2750 ISHAD(2) = 1
2751 ISHAD(3) = 1
2752 EPSPOL = ZERO
2753
2754* common /DTGLGP/
2755 JSTATB = 1000
2756 JBINSB = 49
2757 CGLB = ' '
2758 IF (ITRSPT.EQ.1) THEN
2759 IOGLB = 100
2760 ELSE
2761 IOGLB = 0
2762 ENDIF
2763 LPROD = .TRUE.
2764
2765* common /DTHIS3/
2766 DO 16 I=1,50
2767 IHISPP(I) = 0
2768 IHISXS(I) = 0
2769 16 CONTINUE
2770 IXSTBL = 0
2771
2772* common /DTVARE/
2773 VARELO = ZERO
2774 VAREHI = ZERO
2775 VARCLO = ZERO
2776 VARCHI = ZERO
2777
2778* common /DTDIHA/
2779 DIBETA = -1.0D0
2780 DIALPH = ZERO
2781
2782* common /LEPTOI/
2783 RPPN = 0.0
2784 LEPIN = 0
2785 INTER = 0
2786
2787* common /QNEUTO/
2788 NEUTYP = 1
2789 NEUDEC = 0
2790
2791* common /DTEVNO/
2792 NEVENT = 1
2793 IF (ITRSPT.EQ.1) THEN
2794 ICASCA = 1
2795 ELSE
2796 ICASCA = 0
2797 ENDIF
2798
2799* default Lab.-energy
2800 EPN = 200.0D0
2801 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2802
2803 RETURN
2804 END
2805
2806*$ CREATE DT_AAEVT.FOR
2807*COPY DT_AAEVT
2808*
2809*===aaevt==============================================================*
2810*
2811 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2812 & IDP,IGLAU)
2813
2814************************************************************************
2815* This version dated 22.03.96 is written by S. Roesler. *
2816************************************************************************
2817
2818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2819 SAVE
2820
2821 PARAMETER ( LINP = 10 ,
2822 & LOUT = 6 ,
2823 & LDAT = 9 )
2824
2825 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2826
2827* emulsion treatment
2828 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2829 & NCOMPO,IEMUL
2830
2831* event flag
2832 COMMON /DTEVNO/ NEVENT,ICASCA
2833
2834 CHARACTER*8 DATE,HHMMSS
2835 CHARACTER*9 CHDATE,CHTIME,CHZONE
2836 DIMENSION JDMNYR(8),IDMNYR(3)
2837
2838 KKMAT = 1
2839 NMSG = MAX(NEVTS/100,1)
2840
2841* initialization of run-statistics and histograms
2842 CALL DT_STATIS(1)
2843
2844 CALL PHO_PHIST(1000,DUM)
2845
2846* initialization of Glauber-formalism
2847 IF (NCOMPO.LE.0) THEN
2848 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2849 ELSE
2850 DO 1 I=1,NCOMPO
2851 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2852 1 CONTINUE
2853 ENDIF
2854 CALL DT_SIGEMU
2855
2856C CALL IDATE(IDMNYR)
2857C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2858C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2859 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2860 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2861 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2862 CALL ITIME(IDMNYR)
2863 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2864 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2865 WRITE(LOUT,1001) DATE,HHMMSS
2866 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2867 & ' Time: ',A8,' )')
2868
2869* generate NEVTS events
2870 DO 2 IEVT=1,NEVTS
2871
2872* print run-status message
2873 IF (MOD(IEVT,NMSG).EQ.0) THEN
2874C CALL IDATE(IDMNYR)
2875C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2876C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2877 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2878 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2879 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2880 CALL ITIME(IDMNYR)
2881 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2882 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2883 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2884 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2885 & ' Time: ',A,' )',/)
2886C WRITE(LOUT,1000) IEVT-1
2887C1000 FORMAT(1X,I8,' events sampled')
2888 ENDIF
2889 NEVENT = IEVT
2890* treat nuclear emulsions
2891 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2892* composite targets only
2893 KKMAT = -KKMAT
2894* sample this event
2895 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2896
2897 CALL PHO_PHIST(2000,DUM)
2898
2899 2 CONTINUE
2900
2901* print run-statistics and histograms to output-unit 6
2902
2903 CALL PHO_PHIST(3000,DUM)
2904
2905 CALL DT_STATIS(2)
2906
2907 RETURN
2908 END
2909
2910*$ CREATE DT_LAEVT.FOR
2911*COPY DT_LAEVT
2912*
2913*===laevt==============================================================*
2914*
2915 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2916 & IDP,IGLAU)
2917
2918************************************************************************
2919* Interface to run DPMJET for lepton-nucleus interactions. *
2920* Kinematics is sampled using the equivalent photon approximation *
2921* Based on GPHERA-routine by R. Engel. *
2922* This version dated 23.03.96 is written by S. Roesler. *
2923************************************************************************
2924
2925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2926 SAVE
2927
2928 PARAMETER ( LINP = 10 ,
2929 & LOUT = 6 ,
2930 & LDAT = 9 )
2931
2932 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2933 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2934 PARAMETER (TWOPI = 6.283185307179586454D+00,
2935 & PI = TWOPI/TWO,
2936 & ALPHEM = ONE/137.0D0)
2937
2938C CHARACTER*72 HEADER
2939
2940* particle properties (BAMJET index convention)
2941 CHARACTER*8 ANAME
2942 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2943 & IICH(210),IIBAR(210),K1(210),K2(210)
2944
2945* event history
2946
2947 PARAMETER (NMXHKK=200000)
2948
2949 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2950 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2951 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2952
2953* extended event history
2954 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2955 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2956 & IHIST(2,NMXHKK)
2957
2958* kinematical cuts for lepton-nucleus interactions
2959 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2960 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2961
2962* properties of interacting particles
2963 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2964
2965* properties of photon/lepton projectiles
2966 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2967
2968* kinematics at lepton-gamma vertex
2969 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2970
2971* flags for activated histograms
2972 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2973
2974 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2975
2976* emulsion treatment
2977 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2978 & NCOMPO,IEMUL
2979
2980* Glauber formalism: cross sections
2981 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2982 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2983 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2984 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2985 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2986 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2987 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2988 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2989 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2990 & BSLOPE,NEBINI,NQBINI
2991
2992* nucleon-nucleon event-generator
2993 CHARACTER*8 CMODEL
2994 LOGICAL LPHOIN
2995 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2996
2997* flags for input different options
2998 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2999 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3000 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3001
3002* event flag
3003 COMMON /DTEVNO/ NEVENT,ICASCA
3004
3005 DIMENSION XDUMB(40),BGTA(4)
3006
3007* LEPTO
3008 IF (MCGENE.EQ.3) THEN
3009
3010 STOP ' This version does not contain LEPTO !'
3011
3012 ENDIF
3013
3014 KKMAT = 1
3015 NMSG = MAX(NEVTS/10,1)
3016
3017* mass of incident lepton
3018 AMLPT = AAM(IDP)
3019 AMLPT2 = AMLPT**2
3020 IDPPDG = IDT_IPDGHA(IDP)
3021
3022* consistency of kinematical limits
3023 Q2MIN = MAX(Q2MIN,TINY10)
3024 Q2MAX = MAX(Q2MAX,TINY10)
3025 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
3026 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
3027
3028* total energy of the lepton-nucleon system
3029 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
3030 & +(PLEPT0(3)+PNUCL(3))**2 )
3031 ETOTLN = PLEPT0(4)+PNUCL(4)
3032 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
3033 ECMAX = MIN(ECMAX,ECMLN)
3034 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
3035 & THMIN,THMAX,ELMIN
3036 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
3037 & '------------------',/,9X,'W (min) =',
3038 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
3039 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
3040 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
3041 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
3042 & F7.4,' for E_lpt >',F7.1,' GeV',/)
3043
3044* Lorentz-parameter for transf. into Lab
3045 BGTA(1) = PNUCL(1)/AAM(1)
3046 BGTA(2) = PNUCL(2)/AAM(1)
3047 BGTA(3) = PNUCL(3)/AAM(1)
3048 BGTA(4) = PNUCL(4)/AAM(1)
3049* LT of incident lepton into Lab and dump it in DTEVT1
3050 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3051 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
3052 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
3053 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3054 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
3055 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
3056* maximum energy of photon nucleon system
3057 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
3058 & +(YMAX*PPL0(3)+PPA(3))**2)
3059 ETOTGN = YMAX*PPL0(4)+PPA(4)
3060 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3061 EGNMAX = MIN(EGNMAX,ECMAX)
3062* minimum energy of photon nucleon system
3063 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
3064 & +(YMIN*PPL0(3)+PPA(3))**2)
3065 ETOTGN = YMIN*PPL0(4)+PPA(4)
3066 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3067 EGNMIN = MAX(EGNMIN,ECMIN)
3068
3069* limits for Glauber-initialization
3070 Q2LI = Q2MIN
3071 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
3072 ECMLI = MAX(EGNMIN,THREE)
3073 ECMHI = EGNMAX
3074 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
3075 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
3076 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
3077 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
3078 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
3079 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
3080* initialization of Glauber-formalism
3081 IF (NCOMPO.LE.0) THEN
3082 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3083 ELSE
3084 DO 9 I=1,NCOMPO
3085 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3086 9 CONTINUE
3087 ENDIF
3088 CALL DT_SIGEMU
3089
3090* initialization of run-statistics and histograms
3091 CALL DT_STATIS(1)
3092
3093 CALL PHO_PHIST(1000,DUM)
3094
3095* maximum photon-nucleus cross section
3096 I1 = 1
3097 I2 = 1
3098 RAT = ONE
3099 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
3100 I1 = NEBINI
3101 I2 = NEBINI
3102 RAT = ONE
3103 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
3104 DO 5 I=2,NEBINI
3105 IF (EGNMAX.LT.ECMNN(I)) THEN
3106 I1 = I-1
3107 I2 = I
3108 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3109 GOTO 6
3110 ENDIF
3111 5 CONTINUE
3112 6 CONTINUE
3113 ENDIF
3114 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3115 EGNXX = EGNMAX
3116 I1 = 1
3117 I2 = 1
3118 RAT = ONE
3119 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
3120 I1 = NEBINI
3121 I2 = NEBINI
3122 RAT = ONE
3123 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
3124 DO 7 I=2,NEBINI
3125 IF (EGNMIN.LT.ECMNN(I)) THEN
3126 I1 = I-1
3127 I2 = I
3128 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3129 GOTO 8
3130 ENDIF
3131 7 CONTINUE
3132 8 CONTINUE
3133 ENDIF
3134 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3135 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
3136 SIGMAX = MAX(SIGMAX,SIGXX)
3137 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
3138
3139* plot photon flux table
3140 AYMIN = LOG(YMIN)
3141 AYMAX = LOG(YMAX)
3142 AYRGE = AYMAX-AYMIN
3143 MAXTAB = 50
3144 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
3145C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
3146 DO 1 I=1,MAXTAB
3147 Y = EXP(AYMIN+ADY*DBLE(I-1))
3148 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
3149 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3150 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
3151 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3152 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
3153C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
3154 1 CONTINUE
3155
3156* maximum residual weight for flux sampling (dy/y)
3157 YY = YMIN
3158 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3159 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
3160 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3161
3162 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
3163 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
3164 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
3165 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
3166 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
3167 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3168 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3169 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3170 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3171 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3172 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3173 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3174 XBLOW = 0.001D0
3175 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3176 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3177 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3178
3179 ITRY = 0
3180 ITRW = 0
3181 NC0 = 0
3182 NC1 = 0
3183
3184* generate events
3185 DO 2 IEVT=1,NEVTS
3186 IF (MOD(IEVT,NMSG).EQ.0) THEN
3187C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3188C & STATUS='UNKNOWN')
3189 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3190C CLOSE(LDAT)
3191 ENDIF
3192 NEVENT = IEVT
3193
3194 100 CONTINUE
3195 ITRY = ITRY+1
3196
3197* sample y
3198 101 CONTINUE
3199 ITRW = ITRW+1
3200 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3201 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3202 Q2LOG = LOG(Q2MAX/Q2LOW)
3203 WGH = (ONE+(ONE-YY)**2)*Q2LOG
3204 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3205 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3206 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
3207 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3208
3209* sample Q2
3210 YEFF = ONE+(ONE-YY)**2
3211 102 CONTINUE
3212 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3213 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3214 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3215
3216c NC0 = NC0+1
3217c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3218c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3219
3220* kinematics at lepton-photon vertex
3221* scattered electron
3222 YQ2 = SQRT((ONE-YY)*Q2)
3223 Q2E = Q2/(4.0D0*PLEPT0(4))
3224 E1Y = (ONE-YY)*PLEPT0(4)
3225 CALL DT_DSFECF(SIF,COF)
3226 PLEPT1(1) = YQ2*COF
3227 PLEPT1(2) = YQ2*SIF
3228 PLEPT1(3) = E1Y-Q2E
3229 PLEPT1(4) = E1Y+Q2E
3230C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3231* radiated photon
3232 PGAMM(1) = -PLEPT1(1)
3233 PGAMM(2) = -PLEPT1(2)
3234 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3235 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3236* E_cm cut
3237 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3238 & +(PGAMM(3)+PNUCL(3))**2 )
3239 ETOTGN = PGAMM(4)+PNUCL(4)
3240 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3241 IF (ECMGN.LT.0.1D0) GOTO 101
3242 ECMGN = SQRT(ECMGN)
3243 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3244
3245* Lorentz-transformation into nucleon-rest system
3246 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3247 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3248 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3249 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3250 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3251 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3252* temporary checks..
3253 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3254 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3255 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3256 & 2F10.4)
3257 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3258 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3259 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3260 & 2F10.2)
3261 YYTMP = PPG(4)/PPL0(4)
3262 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3263 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3264 & 2F10.4)
3265
3266* lepton tagger (Lab)
3267 THETA = ACOS( PPL1(3)/PLTOT )
3268 IF (PPL1(4).GT.ELMIN) THEN
3269 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3270 ENDIF
3271* photon energy-cut (Lab)
3272 IF (PPG(4).LT.EGMIN) GOTO 101
3273 IF (PPG(4).GT.EGMAX) GOTO 101
3274* x_Bj cut
3275 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3276 IF (XBJ.LT.XBJMIN) GOTO 101
3277
3278 NC0 = NC0+1
3279 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3280 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3281 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3282 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3283 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3284
3285* rotation angles against z-axis
3286 COD = PPG(3)/PGTOT
3287C SID = SQRT((ONE-COD)*(ONE+COD))
3288 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3289 SID = PPT/PGTOT
3290 COF = ONE
3291 SIF = ZERO
3292 IF (PGTOT*SID.GT.TINY10) THEN
3293 COF = PPG(1)/(SID*PGTOT)
3294 SIF = PPG(2)/(SID*PGTOT)
3295 ANORF = SQRT(COF*COF+SIF*SIF)
3296 COF = COF/ANORF
3297 SIF = SIF/ANORF
3298 ENDIF
3299
3300 IF (IXSTBL.EQ.0) THEN
3301* change to photon projectile
3302 IJPROJ = 7
3303* set virtuality
3304 VIRT = Q2
3305* re-initialize LTs with new kinematics
3306* !!PGAMM ist set in cms (ECMGN) along z
3307 EPN = ZERO
3308 PPN = ZERO
3309 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3310* force Lab-system
3311 IFRAME = 1
3312* get emulsion component if requested
3313 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3314* convolute with cross section
3315 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3316 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3317 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3318 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3319 & Q2,ECMGN,STOT
3320 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3321 NC1 = NC1+1
3322 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3323 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3324 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3325 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3326 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3327* composite targets only
3328 KKMAT = -KKMAT
3329* sample this event
3330 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3331 & IREJ)
3332* rotate momenta of final state particles back in photon-nucleon syst.
3333 DO 4 I=NPOINT(4),NHKK
3334 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3335 & (ISTHKK(I).EQ.1001)) THEN
3336 PX = PHKK(1,I)
3337 PY = PHKK(2,I)
3338 PZ = PHKK(3,I)
3339 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3340 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3341 ENDIF
3342 4 CONTINUE
3343 ENDIF
3344
3345 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3346 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3347 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3348 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3349 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3350
3351* dump this event to histograms
3352
3353 CALL PHO_PHIST(2000,DUM)
3354
3355 2 CONTINUE
3356
3357 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3358 WGY = WGY*LOG(YMAX/YMIN)
3359 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3360
3361C HEADER = ' LAEVT: Q^2 distribution 0'
3362C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3363C HEADER = ' LAEVT: Q^2 distribution 1'
3364C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3365C HEADER = ' LAEVT: Q^2 distribution 2'
3366C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3367C HEADER = ' LAEVT: y distribution 0'
3368C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3369C HEADER = ' LAEVT: y distribution 1'
3370C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3371C HEADER = ' LAEVT: y distribution 2'
3372C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3373C HEADER = ' LAEVT: x distribution 0'
3374C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3375C HEADER = ' LAEVT: x distribution 1'
3376C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3377C HEADER = ' LAEVT: x distribution 2'
3378C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3379C HEADER = ' LAEVT: E_g distribution 0'
3380C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3381C HEADER = ' LAEVT: E_g distribution 1'
3382C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3383C HEADER = ' LAEVT: E_g distribution 2'
3384C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3385C HEADER = ' LAEVT: E_c distribution 0'
3386C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3387C HEADER = ' LAEVT: E_c distribution 1'
3388C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3389C HEADER = ' LAEVT: E_c distribution 2'
3390C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3391
3392* print run-statistics and histograms to output-unit 6
3393
3394 CALL PHO_PHIST(3000,DUM)
3395
3396 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3397
3398 RETURN
3399 END
3400
3401*$ CREATE DT_DTUINI.FOR
3402*COPY DT_DTUINI
3403*
3404*===dtuini=============================================================*
3405*
3406 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3407 & IDP,IEMU)
3408
3409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3410 SAVE
3411
3412 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3413
3414* emulsion treatment
3415 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3416 & NCOMPO,IEMUL
3417
3418* Glauber formalism: flags and parameters for statistics
3419 LOGICAL LPROD
3420 CHARACTER*8 CGLB
3421 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3422
3423 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3424 CALL DT_STATIS(1)
3425
3426 CALL PHO_PHIST(1000,DUM)
3427
3428 IF (NCOMPO.LE.0) THEN
3429 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3430 ELSE
3431 DO 1 I=1,NCOMPO
3432 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3433 1 CONTINUE
3434 ENDIF
3435 IF (IOGLB.NE.100) CALL DT_SIGEMU
3436 IEMU = IEMUL
3437
3438 RETURN
3439 END
3440
3441*$ CREATE DT_DTUOUT.FOR
3442*COPY DT_DTUOUT
3443*
3444*===dtuout=============================================================*
3445*
3446 SUBROUTINE DT_DTUOUT
3447
3448 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3449 SAVE
3450
3451 CALL PHO_PHIST(3000,DUM)
3452
3453 CALL DT_STATIS(2)
3454
3455 RETURN
3456 END
3457
3458*$ CREATE DT_BEAMPR.FOR
3459*COPY DT_BEAMPR
3460*
3461*===beampr=============================================================*
3462*
3463 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3464
3465************************************************************************
3466* Initialization of event generation *
3467* This version dated 7.4.98 is written by S. Roesler. *
3468************************************************************************
3469
3470 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3471 SAVE
3472
3473 PARAMETER ( LINP = 10 ,
3474 & LOUT = 6 ,
3475 & LDAT = 9 )
3476
3477 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3478 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3479
3480 LOGICAL LBEAM
3481
3482* event history
3483
3484 PARAMETER (NMXHKK=200000)
3485
3486 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3487 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3488 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3489
3490* extended event history
3491 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3492 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3493 & IHIST(2,NMXHKK)
3494
3495* properties of interacting particles
3496 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3497
3498* particle properties (BAMJET index convention)
3499 CHARACTER*8 ANAME
3500 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3501 & IICH(210),IIBAR(210),K1(210),K2(210)
3502
3503* beam momenta
3504 COMMON /DTBEAM/ P1(4),P2(4)
3505
3506C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3507 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3508
3509 DATA LBEAM /.FALSE./
3510
3511 GOTO (1,2) MODE
3512
3513 1 CONTINUE
3514
3515 E1 = WHAT(1)
3516 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3517 E2 = WHAT(2)
3518 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3519 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3520 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3521 TH = 1.D-6*WHAT(3)/2.D0
3522 PH = WHAT(4)*BOG
3523 P1(1) = PP1*SIN(TH)*COS(PH)
3524 P1(2) = PP1*SIN(TH)*SIN(PH)
3525 P1(3) = PP1*COS(TH)
3526 P1(4) = E1
3527 P2(1) = PP2*SIN(TH)*COS(PH)
3528 P2(2) = PP2*SIN(TH)*SIN(PH)
3529 P2(3) = -PP2*COS(TH)
3530 P2(4) = E2
3531 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3532 & -(P1(3)+P2(3))**2 )
3533 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3534 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3535 BGX = (P1(1)+P2(1))/ECM
3536 BGY = (P1(2)+P2(2))/ECM
3537 BGZ = (P1(3)+P2(3))/ECM
3538 BGE = (P1(4)+P2(4))/ECM
3539 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3540 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3541 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3542 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3543 COD = P1CMS(3)/P1TOT
3544C SID = SQRT((ONE-COD)*(ONE+COD))
3545 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3546 SID = PPT/P1TOT
3547 COF = ONE
3548 SIF = ZERO
3549 IF (P1TOT*SID.GT.TINY10) THEN
3550 COF = P1CMS(1)/(SID*P1TOT)
3551 SIF = P1CMS(2)/(SID*P1TOT)
3552 ANORF = SQRT(COF*COF+SIF*SIF)
3553 COF = COF/ANORF
3554 SIF = SIF/ANORF
3555 ENDIF
3556**check
3557C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3558C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3559C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3560C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3561C PAX = ZERO
3562C PAY = ZERO
3563C PAZ = P1TOT
3564C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3565C PBX = ZERO
3566C PBY = ZERO
3567C PBZ = -P2TOT
3568C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3569C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3570C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3571C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3572C & P1CMS(1),P1CMS(2),P1CMS(3))
3573C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3574C & P2CMS(1),P2CMS(2),P2CMS(3))
3575C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3576C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3577C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3578C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3579C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3580C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3581C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3582C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3583C STOP
3584**
3585
3586 LBEAM = .TRUE.
3587
3588 RETURN
3589
3590 2 CONTINUE
3591
3592 IF (LBEAM) THEN
3593 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3594 DO 20 I=NPOINT(4),NHKK
3595 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3596 & (ISTHKK(I).EQ.1001)) THEN
3597 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3598 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3599 PECMS = PHKK(4,I)
3600 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3601 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3602 ENDIF
3603 20 CONTINUE
3604 ELSE
3605 MODE = -1
3606 ENDIF
3607
3608 RETURN
3609 END
3610
3611*$ CREATE DT_REJUCO.FOR
3612*COPY DT_REJUCO
3613*
3614*===rejuco=============================================================*
3615*
3616 SUBROUTINE DT_REJUCO(MODE,IREJ)
3617
3618************************************************************************
3619* REJection of Unphysical COnfigurations *
3620* MODE = 1 rejection of particles with unphysically large energy *
3621* *
3622* This version dated 27.12.2006 is written by S. Roesler. *
3623************************************************************************
3624
3625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3626 SAVE
3627
3628 PARAMETER ( LINP = 10 ,
3629 & LOUT = 6 ,
3630 & LDAT = 9 )
3631
3632 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3633 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3634
3635* maximum x_cms of final state particle
3636 PARAMETER (XCMSMX = 1.4D0)
3637
3638* event history
3639
3640 PARAMETER (NMXHKK=200000)
3641
3642 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3643 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3644 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3645
3646* extended event history
3647 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3648 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3649 & IHIST(2,NMXHKK)
3650
3651* Lorentz-parameters of the current interaction
3652 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3653 & UMO,PPCM,EPROJ,PPROJ
3654
3655 IREJ = 0
3656
3657 IF (MODE.EQ.1) THEN
3658 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3659 ECMHLF = UMO/2.0D0
3660 DO 10 I=NPOINT(4),NHKK
3661 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3662 XCMS = ABS(PHKK(4,I))/ECMHLF
3663 IF (XCMS.GT.XCMSMX) GOTO 9999
3664 ENDIF
3665 10 CONTINUE
3666 ENDIF
3667
3668 RETURN
3669 9999 CONTINUE
3670 IREJ = 1
3671 RETURN
3672 END
3673*$ CREATE DT_EVENTB.FOR
3674*COPY DT_EVENTB
3675*
3676*===eventb=============================================================*
3677*
3678 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3679
3680************************************************************************
3681* Treatment of nucleon-nucleon interactions with full two-component *
3682* Dual Parton Model. *
3683* NCSY number of nucleon-nucleon interactions *
3684* IREJ rejection flag *
3685* This version dated 14.01.2000 is written by S. Roesler *
3686************************************************************************
3687
3688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3689 SAVE
3690
3691 PARAMETER ( LINP = 10 ,
3692 & LOUT = 6 ,
3693 & LDAT = 9 )
3694
3695 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3696
3697* event history
3698
3699 PARAMETER (NMXHKK=200000)
3700
3701 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3702 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3703 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3704
3705* extended event history
3706 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3707 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3708 & IHIST(2,NMXHKK)
3709*! uncomment this line for internal phojet-fragmentation
3710C #include "dtu_dtevtp.inc"
3711
3712* particle properties (BAMJET index convention)
3713 CHARACTER*8 ANAME
3714 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3715 & IICH(210),IIBAR(210),K1(210),K2(210)
3716
3717* flags for input different options
3718 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3719 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3720 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3721
3722* rejection counter
3723 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3724 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3725 & IREXCI(3),IRDIFF(2),IRINC
3726
3727* properties of interacting particles
3728 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3729
3730* properties of photon/lepton projectiles
3731 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3732
3733* various options for treatment of partons (DTUNUC 1.x)
3734* (chain recombination, Cronin,..)
3735 LOGICAL LCO2CR,LINTPT
3736 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3737 & LCO2CR,LINTPT
3738
3739* statistics
3740 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3741 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3742 & ICEVTG(8,0:30)
3743
3744* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3745 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3746
3747* Glauber formalism: collision properties
3748 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3749 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3750
3751* flags for diffractive interactions (DTUNUC 1.x)
3752 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3753
3754* statistics: double-Pomeron exchange
3755 COMMON /DTFLG2/ INTFLG,IPOPO
3756
3757* flags for particle decays
3758 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3759 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3760 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3761
3762* nucleon-nucleon event-generator
3763 CHARACTER*8 CMODEL
3764 LOGICAL LPHOIN
3765 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3766
3767C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3768 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3769 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3770 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3771 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3772
3773C model switches and parameters
3774 CHARACTER*8 MDLNA
3775 INTEGER ISWMDL,IPAMDL
3776 DOUBLE PRECISION PARMDL
3777 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3778
3779C initial state parton radiation (internal part)
3780 INTEGER MXISR3,MXISR4
3781 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3782 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3783 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3784 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3785 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3786 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3787 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3788
3789C event debugging information
3790 INTEGER NMAXD
3791 PARAMETER (NMAXD=100)
3792 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3793 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3794 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3795 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3796
3797C general process information
3798 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3799 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3800
3801 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3802 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3803 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3804 & KPRON(15),ISINGL(2000)
3805
3806* initial values for max. number of phojet scatterings and dtunuc chains
3807* to be fragmented with one pyexec call
3808 DATA MXPHFR,MXDTFR /10,100/
3809
3810 IREJ = 0
3811* pointer to first parton of the first chain in dtevt common
3812 NPOINT(3) = NHKK+1
3813* special flag for double-Pomeron statistics
3814 IPOPO = 1
3815* counter for low-mass (DTUNUC) interactions
3816 NDTUSC = 0
3817* counter for interactions treated by PHOJET
3818 NPHOSC = 0
3819
3820* scan interactions for single nucleon-nucleon interactions
3821* (this has to be checked here because Cronin modifies parton momenta)
3822 NC = NPOINT(2)
3823 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3824 DO 8 I=1,NCSY
3825 ISINGL(I) = 0
3826 MOP = JMOHKK(1,NC)
3827 MOT = JMOHKK(1,NC+1)
3828 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3829 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3830 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3831 NC = NC+4
3832 8 CONTINUE
3833
3834* multiple scattering of chain ends
3835 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3836 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3837
3838* switch to PHOJET-settings for JETSET parameter
3839 CALL DT_INITJS(1)
3840
3841* loop over nucleon-nucleon interaction
3842 NC = NPOINT(2)
3843 DO 2 I=1,NCSY
3844*
3845* pick up one nucleon-nucleon interaction from DTEVT1
3846* ppnn / ptnn - momenta of the interacting nucleons (cms)
3847* ptotnn - total momentum of the interacting nucleons (cms)
3848* pp1,2 / pt1,2 - momenta of the four partons
3849* pp / pt - total momenta of the proj / targ partons
3850* ptot - total momentum of the four partons
3851 MOP = JMOHKK(1,NC)
3852 MOT = JMOHKK(1,NC+1)
3853 DO 3 K=1,4
3854 PPNN(K) = PHKK(K,MOP)
3855 PTNN(K) = PHKK(K,MOT)
3856 PTOTNN(K) = PPNN(K)+PTNN(K)
3857 PP1(K) = PHKK(K,NC)
3858 PT1(K) = PHKK(K,NC+1)
3859 PP2(K) = PHKK(K,NC+2)
3860 PT2(K) = PHKK(K,NC+3)
3861 PP(K) = PP1(K)+PP2(K)
3862 PT(K) = PT1(K)+PT2(K)
3863 PTOT(K) = PP(K)+PT(K)
3864 3 CONTINUE
3865*
3866*-----------------------------------------------------------------------
3867* this is a complete nucleon-nucleon interaction
3868*
3869 IF (ISINGL(I).EQ.1) THEN
3870*
3871* initialize PHOJET-variables for remnant/valence-partons
3872 IHFLD(1,1) = 0
3873 IHFLD(1,2) = 0
3874 IHFLD(2,1) = 0
3875 IHFLD(2,2) = 0
3876 IHFLS(1) = 1
3877 IHFLS(2) = 1
3878* save current settings of PHOJET process and min. bias flags
3879 DO 9 K=1,11
3880 KPRON(K) = IPRON(K,1)
3881 9 CONTINUE
3882 ISWSAV = ISWMDL(2)
3883*
3884* check if forced sampling of diffractive interaction requested
3885 IF (ISINGD.LT.-1) THEN
3886 DO 90 K=1,11
3887 IPRON(K,1) = 0
3888 90 CONTINUE
3889 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3890 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3891 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3892 ENDIF
3893*
3894* for photons: a direct/anomalous interaction is not sampled
3895* in PHOJET but already in Glauber-formalism. Here we check if such
3896* an interaction is requested
3897 IF (IJPROJ.EQ.7) THEN
3898* first switch off direct interactions
3899 IPRON(8,1) = 0
3900* this is a direct interactions
3901 IF (IDIREC.EQ.1) THEN
3902 DO 12 K=1,11
3903 IPRON(K,1) = 0
3904 12 CONTINUE
3905 IPRON(8,1) = 1
3906* this is an anomalous interactions
3907* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3908 ELSEIF (IDIREC.EQ.2) THEN
3909 ISWMDL(2) = 0
3910 ENDIF
3911 ELSE
3912 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3913 ENDIF
3914*
3915* make sure that total momenta of partons, pp and pt, are on mass
3916* shell (Cronin may have srewed this up..)
3917 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3918 IF (IR1.NE.0) THEN
3919 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3920 & 'EVENTB: mass shell correction rejected'
3921 GOTO 9999
3922 ENDIF
3923*
3924* initialize the incoming particles in PHOJET
3925 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3926
3927 CALL PHO_SETPAR(1,22,0,VIRT)
3928
3929 ELSE
3930
3931 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3932
3933 ENDIF
3934
3935 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3936
3937*
3938* initialize rejection loop counter for anomalous processes
3939 IRJANO = 0
3940 800 CONTINUE
3941 IRJANO = IRJANO+1
3942*
3943* temporary fix for ifano problem
3944 IFANO(1) = 0
3945 IFANO(2) = 0
3946*
3947* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3948
3949 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3950
3951*
3952* for photons: special consistency check for anomalous interactions
3953 IF (IJPROJ.EQ.7) THEN
3954 IF (IRJANO.LT.30) THEN
3955 IF (IFANO(1).NE.0) THEN
3956* here, an anomalous interaction was generated. Check if it
3957* was also requested. Otherwise reject this event.
3958 IF (IDIREC.EQ.0) GOTO 800
3959 ELSE
3960* here, an anomalous interaction was not generated. Check if it
3961* was requested in which case we need to reject this event.
3962 IF (IDIREC.EQ.2) GOTO 800
3963 ENDIF
3964 ELSE
3965 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3966 & IRJANO,IDIREC,NEVHKK
3967 ENDIF
3968 ENDIF
3969*
3970* copy back original settings of PHOJET process and min. bias flags
3971 DO 10 K=1,11
3972 IPRON(K,1) = KPRON(K)
3973 10 CONTINUE
3974 ISWMDL(2) = ISWSAV
3975*
3976* check if PHOJET has rejected this event
3977 IF (IREJ1.NE.0) THEN
3978C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979 WRITE(LOUT,'(1X,A,I4)')
3980 & 'EVENTB: chain system rejected',IDIREC
3981
3982 CALL PHO_PREVNT(0)
3983
3984 GOTO 9999
3985 ENDIF
3986*
3987* copy partons and strings from PHOJET common back into DTEVT for
3988* external fragmentation
3989 MO1 = NC
3990 MO2 = NC+3
3991*! uncomment this line for internal phojet-fragmentation
3992C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3993 NPHOSC = NPHOSC+1
3994 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3995 IF (IREJ1.NE.0) THEN
3996 IF (IOULEV(1).GT.0)
3997 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3998 GOTO 9999
3999 ENDIF
4000*
4001* update statistics counter
4002 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4003*
4004*-----------------------------------------------------------------------
4005* this interaction involves "remnants"
4006*
4007 ELSE
4008*
4009* total mass of this system
4010 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4011 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4012 IF (AMTOT2.LT.ZERO) THEN
4013 AMTOT = ZERO
4014 ELSE
4015 AMTOT = SQRT(AMTOT2)
4016 ENDIF
4017*
4018* systems with masses larger than elojet are treated with PHOJET
4019 IF (AMTOT.GT.ELOJET) THEN
4020*
4021* initialize PHOJET-variables for remnant/valence-partons
4022* projectile parton flavors and valence flag
4023 IHFLD(1,1) = IDHKK(NC)
4024 IHFLD(1,2) = IDHKK(NC+2)
4025 IHFLS(1) = 0
4026 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4027 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4028* target parton flavors and valence flag
4029 IHFLD(2,1) = IDHKK(NC+1)
4030 IHFLD(2,2) = IDHKK(NC+3)
4031 IHFLS(2) = 0
4032 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4033 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4034* flag signalizing PHOJET how to treat the remnant:
4035* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4036* iremn > -1 valence remnant: PHOJET assumes flavors according
4037* to mother particle
4038 IREMN1 = IHFLS(1)-1
4039 IREMN2 = IHFLS(2)-1
4040*
4041* initialize the incoming particles in PHOJET
4042 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4043
4044 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4045
4046 ELSE
4047
4048 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4049
4050 ENDIF
4051
4052 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4053
4054*
4055* calculate Lorentz parameter of the nucleon-nucleon cm-system
4056 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4057 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4058 BGX = PTOTNN(1)/AMNN
4059 BGY = PTOTNN(2)/AMNN
4060 BGZ = PTOTNN(3)/AMNN
4061 GAM = PTOTNN(4)/AMNN
4062* transform interacting nucleons into nucleon-nucleon cm-system
4063 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4064 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4065 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4066 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4067 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4068 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4069* transform (total) momenta of the proj and targ partons into
4070* nucleon-nucleon cm-system
4071 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4072 & PP(1),PP(2),PP(3),PP(4),
4073 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4074 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4075 & PT(1),PT(2),PT(3),PT(4),
4076 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4077* energy fractions of the proj and targ partons
4078 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4079 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4080***
4081* testprint
4082c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4083c & (PPTCMS(2)+PTTCMS(2))**2 +
4084c & (PPTCMS(3)+PTTCMS(3))**2 )
4085c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4086c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4087c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4088c & (PPSUB(2)+PTSUB(2))**2 +
4089c & (PPSUB(3)+PTSUB(3))**2 )
4090c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4091c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4092***
4093*
4094* save current settings of PHOJET process and min. bias flags
4095 DO 7 K=1,11
4096 KPRON(K) = IPRON(K,1)
4097 7 CONTINUE
4098* disallow direct photon int. (does not make sense here anyway)
4099 IPRON(8,1) = 0
4100* disallow double pomeron processes (due to technical problems
4101* in PHOJET, needs to be solved sometime)
4102 IPRON(4,1) = 0
4103* disallow diffraction for sea-diquarks
4104 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4105 & (IABS(IHFLD(1,2)).GT.1100)) THEN
4106 IPRON(3,1) = 0
4107 IPRON(6,1) = 0
4108 ENDIF
4109 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4110 & (IABS(IHFLD(2,2)).GT.1100)) THEN
4111 IPRON(3,1) = 0
4112 IPRON(5,1) = 0
4113 ENDIF
4114*
4115* we need massless partons: transform them on mass shell
4116 XMP = ZERO
4117 XMT = ZERO
4118 DO 6 K=1,4
4119 PPTMP(K) = PPSUB(K)
4120 PTTMP(K) = PTSUB(K)
4121 6 CONTINUE
4122 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4123 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4124 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4125 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4126 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4127* total energy of the subsysten after mass transformation
4128* (should be the same as before..)
4129 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4130 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
4131*
4132* after mass shell transformation the x_sub - relation has to be
4133* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4134*
4135* The old version was to scale based on the original x_sub and the
4136* 4-momenta of the subsystem. At very high energy this could lead to
4137* "pseudo-cm energies" of the parent system considerably exceeding
4138* the true cm energy. Now we keep the true cm energy and calculate
4139* new x_sub instead.
4140C old version PPTCMS(4) = PPSUB(4)/XPSUB
4141 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4142 XPSUB = PPSUB(4)/PPTCMS(4)
4143 IF (IJPROJ.EQ.7) THEN
4144 AMP2 = PHKK(5,MOT)**2
4145 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4146 ELSE
4147*???????
4148 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4149 & *(PPTCMS(4)+PHKK(5,MOP)))
4150C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4151C & *(PPTCMS(4)+PHKK(5,MOT)))
4152 ENDIF
4153C old version PTTCMS(4) = PTSUB(4)/XTSUB
4154 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4155 XTSUB = PTSUB(4)/PTTCMS(4)
4156 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4157 & *(PTTCMS(4)+PHKK(5,MOT)))
4158 DO 4 K=1,3
4159 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4160 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4161 4 CONTINUE
4162***
4163* testprint
4164*
4165* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
4166* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
4167* pptcms/ pttcms - momenta of the interacting nucleons (cms)
4168* pp1,2 / pt1,2 - momenta of the four partons
4169*
4170* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
4171* ptot - total momentum of the four partons (cms, negl. Fermi)
4172* ppsub / ptsub - total momenta of the proj / targ partons (cms)
4173*
4174c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4175c & (PPTCMS(2)+PTTCMS(2))**2 +
4176c & (PPTCMS(3)+PTTCMS(3))**2 )
4177c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4178c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4179c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4180c & (PPSUB(2)+PTSUB(2))**2 +
4181c & (PPSUB(3)+PTSUB(3))**2 )
4182c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4183c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4184c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4185c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4186c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4187c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
4188c ENDIF
4189c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4190c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4191c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4192c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4193* transform interacting nucleons into nucleon-nucleon cm-system
4194c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4195c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4196c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4197c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4198c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4199c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4200c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4201c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4202c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4203c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4204c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4205c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4206c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4207c & (PPNEW2+PTNEW2)**2 +
4208c & (PPNEW3+PTNEW3)**2 )
4209c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4210c & (PPNEW4+PTNEW4+PTSTCM) )
4211c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4212c & (PPSUB2+PTSUB2)**2 +
4213c & (PPSUB3+PTSUB3)**2 )
4214c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4215c & (PPSUB4+PTSUB4+PTSTSU) )
4216C WRITE(*,*) ' mother cmE :'
4217C WRITE(*,*) ETSTCM,ENEWCM
4218C WRITE(*,*) ' subsystem cmE :'
4219C WRITE(*,*) ETSTSU,ENEWSU
4220C WRITE(*,*) ' projectile mother :'
4221C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4222C WRITE(*,*) ' target mother :'
4223C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4224C WRITE(*,*) ' projectile subsystem:'
4225C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4226C WRITE(*,*) ' target subsystem:'
4227C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4228C WRITE(*,*) ' projectile subsystem should be:'
4229C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4230C & XPSUB*ETSTCM/2.0D0
4231C WRITE(*,*) ' target subsystem should be:'
4232C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4233C & XTSUB*ETSTCM/2.0D0
4234C WRITE(*,*) ' subsystem cmE should be: '
4235C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4236***
4237*
4238* generate complete remnant - nucleon/remnant event with PHOJET
4239
4240 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4241
4242*
4243* copy back original settings of PHOJET process flags
4244 DO 11 K=1,11
4245 IPRON(K,1) = KPRON(K)
4246 11 CONTINUE
4247*
4248* check if PHOJET has rejected this event
4249 IF (IREJ1.NE.0) THEN
4250 IF (IOULEV(1).GT.0)
4251 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
4252 WRITE(LOUT,*)
4253 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4254
4255 CALL PHO_PREVNT(0)
4256
4257 GOTO 9999
4258 ENDIF
4259*
4260* copy partons and strings from PHOJET common back into DTEVT for
4261* external fragmentation
4262 MO1 = NC
4263 MO2 = NC+3
4264*! uncomment this line for internal phojet-fragmentation
4265C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4266 NPHOSC = NPHOSC+1
4267 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4268 IF (IREJ1.NE.0) THEN
4269 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4270 & 'EVENTB: chain system rejected 2'
4271 GOTO 9999
4272 ENDIF
4273*
4274* update statistics counter
4275 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4276*
4277*-----------------------------------------------------------------------
4278* two-chain approx. for smaller systems
4279*
4280 ELSE
4281*
4282 NDTUSC = NDTUSC+1
4283* special flag for double-Pomeron statistics
4284 IPOPO = 0
4285*
4286* pick up flavors at the ends of the two chains
4287 IFP1 = IDHKK(NC)
4288 IFT1 = IDHKK(NC+1)
4289 IFP2 = IDHKK(NC+2)
4290 IFT2 = IDHKK(NC+3)
4291* ..and the indices of the mothers
4292 MOP1 = NC
4293 MOT1 = NC+1
4294 MOP2 = NC+2
4295 MOT2 = NC+3
4296 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4297 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4298*
4299* check if this chain system was rejected
4300 IF (IREJ1.GT.0) THEN
4301 IF (IOULEV(1).GT.0) THEN
4302 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4303 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4304 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4305 ENDIF
4306 IRHHA = IRHHA+1
4307 GOTO 9999
4308 ENDIF
4309* the following lines are for sea-sea chains rejected in GETCSY
4310 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4311 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4312 ENDIF
4313*
4314 ENDIF
4315*
4316* update statistics counter
4317 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4318*
4319 NC = NC+4
4320*
4321 2 CONTINUE
4322*
4323*-----------------------------------------------------------------------
4324* treatment of low-mass chains (if there are any)
4325*
4326 IF (NDTUSC.GT.0) THEN
4327*
4328* correct chains of very low masses for possible resonances
4329 IF (IRESCO.EQ.1) THEN
4330 CALL DT_EVTRES(IREJ1)
4331 IF (IREJ1.GT.0) THEN
4332 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4333 IRRES(1) = IRRES(1)+1
4334 GOTO 9999
4335 ENDIF
4336 ENDIF
4337* fragmentation of low-mass chains
4338*! uncomment this line for internal phojet-fragmentation
4339* (of course it will still be fragmented by DPMJET-routines but it
4340* has to be done here instead of further below)
4341C CALL DT_EVTFRA(IREJ1)
4342C IF (IREJ1.GT.0) THEN
4343C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4344C IRFRAG = IRFRAG+1
4345C GOTO 9999
4346C ENDIF
4347 ELSE
4348*! uncomment this line for internal phojet-fragmentation
4349C NPOINT(4) = NHKK+1
4350 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4351 ENDIF
4352*
4353*-----------------------------------------------------------------------
4354* new di-quark breaking mechanisms
4355*
4356 MXLEFT = 2
4357 CALL DT_CHASTA(0)
4358 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4359 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4360 CALL DT_DIQBRK
4361 MXLEFT = 4
4362 ENDIF
4363*
4364*-----------------------------------------------------------------------
4365* hadronize this event
4366*
4367* hadronize PHOJET chain systems
4368 NPYMAX = 0
4369 NPJE = NPHOSC/MXPHFR
4370 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4371 IF (NPJE.GT.1) THEN
4372 NLEFT = NPHOSC-NPJE*MXPHFR
4373 DO 20 JFRG=1,NPJE
4374 NFRG = JFRG*MXPHFR
4375 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4376 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4377 IF (IREJ1.GT.0) GOTO 22
4378 NLEFT = 0
4379 ELSE
4380 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4381 IF (IREJ1.GT.0) GOTO 22
4382 ENDIF
4383 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4384 20 CONTINUE
4385 IF (NLEFT.GT.0) THEN
4386 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4387 IF (IREJ1.GT.0) GOTO 22
4388 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4389 ENDIF
4390 ELSE
4391 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4392 IF (IREJ1.GT.0) GOTO 22
4393 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4394 ENDIF
4395*
4396* check max. filling level of jetset common and
4397* reduce mxphfr if necessary
4398 IF (NPYMAX.GT.3000) THEN
4399 IF (NPYMAX.GT.3500) THEN
4400 MXPHFR = MAX(1,MXPHFR-2)
4401 ELSE
4402 MXPHFR = MAX(1,MXPHFR-1)
4403 ENDIF
4404C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4405 ENDIF
4406*
4407* hadronize DTUNUC chain systems
4408 23 CONTINUE
4409 IBACK = MXDTFR
4410 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4411 IF (IREJ2.GT.0) GOTO 22
4412*
4413* check max. filling level of jetset common and
4414* reduce mxdtfr if necessary
4415 IF (NPYMEM.GT.3000) THEN
4416 IF (NPYMEM.GT.3500) THEN
4417 MXDTFR = MAX(1,MXDTFR-20)
4418 ELSE
4419 MXDTFR = MAX(1,MXDTFR-10)
4420 ENDIF
4421C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4422 ENDIF
4423*
4424 IF (IBACK.EQ.-1) GOTO 23
4425*
4426 22 CONTINUE
4427C CALL DT_EVTFRG(1,IREJ1)
4428C CALL DT_EVTFRG(2,IREJ2)
4429 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4430 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4431 IRFRAG = IRFRAG+1
4432 GOTO 9999
4433 ENDIF
4434*
4435* get final state particles from /DTEVTP/
4436*! uncomment this line for internal phojet-fragmentation
4437C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4438
4439 IF (IJPROJ.NE.7)
4440 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4441C IF (IREJ3.NE.0) GOTO 9999
4442
4443 RETURN
4444
4445 9999 CONTINUE
4446 IREVT = IREVT+1
4447 IREJ = 1
4448 RETURN
4449 END
4450
4451*$ CREATE DT_GETPJE.FOR
4452*COPY DT_GETPJE
4453*
4454*===getpje=============================================================*
4455*
4456 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4457
4458************************************************************************
4459* This subroutine copies PHOJET partons and strings from POEVT1 into *
4460* DTEVT1. *
4461* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4462* PP,PT 4-momenta of projectile/target being handled by *
4463* PHOJET *
4464* This version dated 11.12.99 is written by S. Roesler *
4465************************************************************************
4466
4467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4468 SAVE
4469
4470 PARAMETER ( LINP = 10 ,
4471 & LOUT = 6 ,
4472 & LDAT = 9 )
4473
4474 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4475 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4476
4477 LOGICAL LFLIP
4478
4479* event history
4480
4481 PARAMETER (NMXHKK=200000)
4482
4483 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4484 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4485 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4486
4487* extended event history
4488 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4489 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4490 & IHIST(2,NMXHKK)
4491
4492* Lorentz-parameters of the current interaction
4493 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4494 & UMO,PPCM,EPROJ,PPROJ
4495
4496* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4497 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4498
4499* flags for input different options
4500 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4501 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4502 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4503
4504* statistics: double-Pomeron exchange
4505 COMMON /DTFLG2/ INTFLG,IPOPO
4506
4507* statistics
4508 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4509 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4510 & ICEVTG(8,0:30)
4511
4512* rejection counter
4513 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4514 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4515 & IREXCI(3),IRDIFF(2),IRINC
4516C standard particle data interface
4517 INTEGER NMXHEP
4518
4519 PARAMETER (NMXHEP=4000)
4520
4521 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4522 DOUBLE PRECISION PHEP,VHEP
4523 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4524 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4525 & VHEP(4,NMXHEP)
4526C extension to standard particle data interface (PHOJET specific)
4527 INTEGER IMPART,IPHIST,ICOLOR
4528 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4529
4530C color string configurations including collapsed strings and hadrons
4531 INTEGER MSTR
4532 PARAMETER (MSTR=500)
4533 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4534 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4535 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4536 & NNCH(MSTR),IBHAD(MSTR),ISTR
4537
4538C general process information
4539 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4540 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4541
4542C model switches and parameters
4543 CHARACTER*8 MDLNA
4544 INTEGER ISWMDL,IPAMDL
4545 DOUBLE PRECISION PARMDL
4546 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4547
4548C event debugging information
4549 INTEGER NMAXD
4550 PARAMETER (NMAXD=100)
4551 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4552 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4553 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4554 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4555
4556 DIMENSION PP(4),PT(4)
4557 DATA MAXLOP /10000/
4558
4559 INHKK = NHKK
4560 LFLIP = .TRUE.
4561 1 CONTINUE
4562 NPVAL = 0
4563 NTVAL = 0
4564 IREJ = 0
4565
4566* store initial momenta for energy-momentum conservation check
4567 IF (LEMCCK) THEN
4568 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4569 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4570 ENDIF
4571* copy partons and strings from POEVT1 into DTEVT1
4572 DO 11 I=1,ISTR
4573C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4574 IF (NCODE(I).EQ.-99) THEN
4575 IDXSTG = NPOS(1,I)
4576 IDSTG = IDHEP(IDXSTG)
4577 PX = PHEP(1,IDXSTG)
4578 PY = PHEP(2,IDXSTG)
4579 PZ = PHEP(3,IDXSTG)
4580 PE = PHEP(4,IDXSTG)
4581 IF (MODE.LT.0) THEN
4582 ISTAT = 70000+IPJE
4583 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4584 & 11,IDSTG,0)
4585 IF (LEMCCK) THEN
4586 PX = -PX
4587 PY = -PY
4588 PZ = -PZ
4589 PE = -PE
4590 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4591 ENDIF
4592 ELSE
4593 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4594 & PPX,PPY,PPZ,PPE)
4595 ISTAT = 70000+IPJE
4596 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4597 & 11,IDSTG,0)
4598 IF (LEMCCK) THEN
4599 PX = -PPX
4600 PY = -PPY
4601 PZ = -PPZ
4602 PE = -PPE
4603 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4604 ENDIF
4605 ENDIF
4606 NOBAM(NHKK) = 0
4607 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4608 IHIST(2,NHKK) = 0
4609 ELSEIF (NCODE(I).GE.0) THEN
4610* indices of partons and string in POEVT1
4611 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4612 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4613 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4614 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4615 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4616 STOP ' GETPJE 1'
4617 ENDIF
4618 IDXSTG = NPOS(1,I)
4619* find "mother" string of the string
4620 IDXMS1 = ABS(JMOHEP(1,IDX1))
4621 IDXMS2 = ABS(JMOHEP(1,IDX2))
4622 IF (IDXMS1.NE.IDXMS2) THEN
4623 IDXMS1 = IDXSTG
4624 IDXMS2 = IDXSTG
4625C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4626 ENDIF
4627* search POEVT1 for the original hadron of the parton
4628 ILOOP = 0
4629 IPOM1 = 0
4630 14 CONTINUE
4631 ILOOP = ILOOP+1
4632
4633 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4634
4635 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4636 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4637 & (ILOOP.LT.MAXLOP)) GOTO 14
4638 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4639 IPOM2 = 0
4640 ILOOP = 0
4641 15 CONTINUE
4642 ILOOP = ILOOP+1
4643
4644 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4645
4646 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4647 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4648 ELSE
4649 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4650 ENDIF
4651 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4652 & (ILOOP.LT.MAXLOP)) GOTO 15
4653 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4654* parton 1
4655 IF (IDXMS1.EQ.1) THEN
4656 ISPTN1 = ISTHKK(MO1)
4657 M1PTN1 = MO1
4658 M2PTN1 = MO1+2
4659 ELSE
4660 ISPTN1 = ISTHKK(MO2)
4661 M1PTN1 = MO2-2
4662 M2PTN1 = MO2
4663 ENDIF
4664* parton 2
4665 IF (IDXMS2.EQ.1) THEN
4666 ISPTN2 = ISTHKK(MO1)
4667 M1PTN2 = MO1
4668 M2PTN2 = MO1+2
4669 ELSE
4670 ISPTN2 = ISTHKK(MO2)
4671 M1PTN2 = MO2-2
4672 M2PTN2 = MO2
4673 ENDIF
4674* check for mis-identified mothers and switch mother indices if necessary
4675 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4676 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4677 & (LFLIP)) THEN
4678 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4679 ISPTN1 = ISTHKK(MO1)
4680 M1PTN1 = MO1
4681 M2PTN1 = MO1+2
4682 ISPTN2 = ISTHKK(MO2)
4683 M1PTN2 = MO2-2
4684 M2PTN2 = MO2
4685 ELSE
4686 ISPTN1 = ISTHKK(MO2)
4687 M1PTN1 = MO2-2
4688 M2PTN1 = MO2
4689 ISPTN2 = ISTHKK(MO1)
4690 M1PTN2 = MO1
4691 M2PTN2 = MO1+2
4692 ENDIF
4693 ENDIF
4694* register partons in temporary common
4695* parton at chain end
4696 PX = PHEP(1,IDX1)
4697 PY = PHEP(2,IDX1)
4698 PZ = PHEP(3,IDX1)
4699 PE = PHEP(4,IDX1)
4700* flag only partons coming from Pomeron with 41/42
4701C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4702 IF (IPOM1.NE.0) THEN
4703 ISTX = ABS(ISPTN1)/10
4704 IMO = ABS(ISPTN1)-10*ISTX
4705 ISPTN1 = -(40+IMO)
4706 ELSE
4707 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4708 ISTX = ABS(ISPTN1)/10
4709 IMO = ABS(ISPTN1)-10*ISTX
4710 IF ((IDHEP(IDX1).EQ.21).OR.
4711 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4712 ISPTN1 = -(60+IMO)
4713 ELSE
4714 ISPTN1 = -(50+IMO)
4715 ENDIF
4716 ENDIF
4717 ENDIF
4718 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4719 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4720 IF (MODE.LT.0) THEN
4721 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4722 & PZ,PE,0,0,0)
4723 ELSE
4724 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4725 & PPX,PPY,PPZ,PPE)
4726 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4727 & PPZ,PPE,0,0,0)
4728 ENDIF
4729 IHIST(1,NHKK) = IPHIST(1,IDX1)
4730 IHIST(2,NHKK) = 0
4731 DO 19 KK=1,4
4732 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4733 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4734 19 CONTINUE
4735 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4736 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4737 M1STRG = NHKK
4738* gluon kinks
4739 NGLUON = IDX2-IDX1-1
4740 IF (NGLUON.GT.0) THEN
4741 DO 17 IGLUON=1,NGLUON
4742 IDX = IDX1+IGLUON
4743 IDXMS = ABS(JMOHEP(1,IDX))
4744 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4745 ILOOP = 0
4746 16 CONTINUE
4747 ILOOP = ILOOP+1
4748 IDXMS = ABS(JMOHEP(1,IDXMS))
4749 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4750 & (ILOOP.LT.MAXLOP)) GOTO 16
4751 IF (ILOOP.EQ.MAXLOP)
4752 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4753 ENDIF
4754 IF (IDXMS.EQ.1) THEN
4755 ISPTN = ISTHKK(MO1)
4756 M1PTN = MO1
4757 M2PTN = MO1+2
4758 ELSE
4759 ISPTN = ISTHKK(MO2)
4760 M1PTN = MO2-2
4761 M2PTN = MO2
4762 ENDIF
4763 PX = PHEP(1,IDX)
4764 PY = PHEP(2,IDX)
4765 PZ = PHEP(3,IDX)
4766 PE = PHEP(4,IDX)
4767 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4768 ISTX = ABS(ISPTN)/10
4769 IMO = ABS(ISPTN)-10*ISTX
4770 IF ((IDHEP(IDX).EQ.21).OR.
4771 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4772 ISPTN = -(60+IMO)
4773 ELSE
4774 ISPTN = -(50+IMO)
4775 ENDIF
4776 ENDIF
4777 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4778 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4779 IF (MODE.LT.0) THEN
4780 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4781 & PX,PY,PZ,PE,0,0,0)
4782 ELSE
4783 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4784 & PPX,PPY,PPZ,PPE)
4785 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4786 & PPX,PPY,PPZ,PPE,0,0,0)
4787 ENDIF
4788 IHIST(1,NHKK) = IPHIST(1,IDX)
4789 IHIST(2,NHKK) = 0
4790 DO 20 KK=1,4
4791 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4792 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4793 20 CONTINUE
4794 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4795 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4796 17 CONTINUE
4797 ENDIF
4798* parton at chain end
4799 PX = PHEP(1,IDX2)
4800 PY = PHEP(2,IDX2)
4801 PZ = PHEP(3,IDX2)
4802 PE = PHEP(4,IDX2)
4803* flag only partons coming from Pomeron with 41/42
4804C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4805 IF (IPOM2.NE.0) THEN
4806 ISTX = ABS(ISPTN2)/10
4807 IMO = ABS(ISPTN2)-10*ISTX
4808 ISPTN2 = -(40+IMO)
4809 ELSE
4810 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4811 ISTX = ABS(ISPTN2)/10
4812 IMO = ABS(ISPTN2)-10*ISTX
4813 IF ((IDHEP(IDX2).EQ.21).OR.
4814 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4815 ISPTN2 = -(60+IMO)
4816 ELSE
4817 ISPTN2 = -(50+IMO)
4818 ENDIF
4819 ENDIF
4820 ENDIF
4821 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4822 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4823 IF (MODE.LT.0) THEN
4824 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4825 & PX,PY,PZ,PE,0,0,0)
4826 ELSE
4827 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4828 & PPX,PPY,PPZ,PPE)
4829 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4830 & PPX,PPY,PPZ,PPE,0,0,0)
4831 ENDIF
4832 IHIST(1,NHKK) = IPHIST(1,IDX2)
4833 IHIST(2,NHKK) = 0
4834 DO 21 KK=1,4
4835 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4836 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4837 21 CONTINUE
4838 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4839 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4840 M2STRG = NHKK
4841* register string
4842 JSTRG = 100*IPROCE+NCODE(I)
4843 PX = PHEP(1,IDXSTG)
4844 PY = PHEP(2,IDXSTG)
4845 PZ = PHEP(3,IDXSTG)
4846 PE = PHEP(4,IDXSTG)
4847 IF (MODE.LT.0) THEN
4848 ISTAT = 70000+IPJE
4849 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4850 & PX,PY,PZ,PE,0,0,0)
4851 IF (LEMCCK) THEN
4852 PX = -PX
4853 PY = -PY
4854 PZ = -PZ
4855 PE = -PE
4856 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4857 ENDIF
4858 ELSE
4859 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4860 & PPX,PPY,PPZ,PPE)
4861 ISTAT = 70000+IPJE
4862 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4863 & PPX,PPY,PPZ,PPE,0,0,0)
4864 IF (LEMCCK) THEN
4865 PX = -PPX
4866 PY = -PPY
4867 PZ = -PPZ
4868 PE = -PPE
4869 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4870 ENDIF
4871 ENDIF
4872 NOBAM(NHKK) = 0
4873 IHIST(1,NHKK) = 0
4874 IHIST(2,NHKK) = 0
4875 DO 18 KK=1,4
4876 VHKK(KK,NHKK) = VHKK(KK,MO2)
4877 WHKK(KK,NHKK) = WHKK(KK,MO1)
4878 18 CONTINUE
4879 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4880 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4881 ENDIF
4882 11 CONTINUE
4883
4884 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4885 NHKK = INHKK
4886 LFLIP = .FALSE.
4887 GOTO 1
4888 ENDIF
4889
4890 IF (LEMCCK) THEN
4891 IF (UMO.GT.1.0D5) THEN
4892 CHKLEV = 1.0D0
4893 ELSE
4894 CHKLEV = TINY1
4895 ENDIF
4896 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4897
4898 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4899
4900 ENDIF
4901
4902* internal statistics
4903* dble-Po statistics.
4904 IF (IPROCE.NE.4) IPOPO = 0
4905
4906 INTFLG = IPROCE
4907 IDCHSY = IDCH(MO1)
4908 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4909 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4910 ELSE
4911 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4912 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4913 & ') at evt(chain) ',I6,'(',I2,')')
4914 ENDIF
4915 IF (IPROCE.EQ.5) THEN
4916 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4917 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4918 ELSE
4919C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4920 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4921 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4922 ENDIF
4923 ELSEIF (IPROCE.EQ.6) THEN
4924 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4925 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4926 ELSE
4927C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4928 ENDIF
4929 ELSEIF (IPROCE.EQ.7) THEN
4930 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4931 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4932 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4933 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4934 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4935 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4936 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4937 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4938 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4939 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4940 ELSE
4941 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4942 ENDIF
4943 ENDIF
4944 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4945 & THEN
4946 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4947 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4948 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4949 ENDIF
4950 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4951 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4952 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4953 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4954 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4955
4956 RETURN
4957
4958 9999 CONTINUE
4959 IREJ = 1
4960 RETURN
4961 END
4962
4963*$ CREATE DT_PHOINI.FOR
4964*COPY DT_PHOINI
4965*
4966*===phoini=============================================================*
4967*
4968 SUBROUTINE DT_PHOINI
4969
4970************************************************************************
4971* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4972* This version dated 16.11.95 is written by S. Roesler *
4973* *
4974* Last change 27.12.2006 by S. Roesler. *
4975************************************************************************
4976
4977 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4978 SAVE
4979
4980 PARAMETER ( LINP = 10 ,
4981 & LOUT = 6 ,
4982 & LDAT = 9 )
4983
4984 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4985
4986* nucleon-nucleon event-generator
4987 CHARACTER*8 CMODEL
4988 LOGICAL LPHOIN
4989 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4990
4991* particle properties (BAMJET index convention)
4992 CHARACTER*8 ANAME
4993 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4994 & IICH(210),IIBAR(210),K1(210),K2(210)
4995
4996* Lorentz-parameters of the current interaction
4997 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4998 & UMO,PPCM,EPROJ,PPROJ
4999
5000* properties of interacting particles
5001 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5002
5003* properties of photon/lepton projectiles
5004 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5005
5006 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5007
5008* emulsion treatment
5009 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5010 & NCOMPO,IEMUL
5011
5012* VDM parameter for photon-nucleus interactions
5013 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5014
5015* nuclear potential
5016 LOGICAL LFERMI
5017 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5018 & EBINDP(2),EBINDN(2),EPOT(2,210),
5019 & ETACOU(2),ICOUL,LFERMI
5020
5021* Glauber formalism: flags and parameters for statistics
5022 LOGICAL LPROD
5023 CHARACTER*8 CGLB
5024 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5025*
5026* parameters for cascade calculations:
5027* maximum mumber of PDF's which can be defined in phojet (limited
5028* by the dimension of ipdfs in pho_setpdf)
5029 PARAMETER (MAXPDF = 20)
5030* PDF parametrization and number of set for the first 30 hadrons in
5031* the bamjet-code list
5032* negative numbers mean that the PDF is set in phojet,
5033* zero stands for "not a hadron"
5034 DIMENSION IPARPD(30),ISETPD(30)
5035* PDF parametrization
5036 DATA IPARPD /
5037 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5038 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5039* number of set
5040 DATA ISETPD /
5041 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5042 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5043
5044**PHOJET105a
5045C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5046C PARAMETER ( MAXPRO = 16 )
5047C PARAMETER ( MAXTAB = 20 )
5048C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5049C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5050C CHARACTER*8 MDLNA
5051C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5052C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5053**PHOJET110
5054
5055C global event kinematics and particle IDs
5056 INTEGER IFPAP,IFPAB
5057 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5058 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5059
5060C hard cross sections and MC selection weights
5061 INTEGER Max_pro_2
5062 PARAMETER ( Max_pro_2 = 16 )
5063 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5064 & MH_acc_1,MH_acc_2
5065 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5066 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5067 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5068 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5069 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5070 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5071
5072C model switches and parameters
5073 CHARACTER*8 MDLNA
5074 INTEGER ISWMDL,IPAMDL
5075 DOUBLE PRECISION PARMDL
5076 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5077
5078C general process information
5079 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5080 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5081**
5082 DIMENSION PP(4),PT(4)
5083
5084 LOGICAL LSTART
5085 DATA LSTART /.TRUE./
5086
5087 IJP = IJPROJ
5088 IJT = IJTARG
5089 Q2 = VIRT
5090* lepton-projectiles: initialize real photon instead
5091 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5092 IJP = 7
5093 Q2 = ZERO
5094 ENDIF
5095
5096 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5097
5098* switch Reggeon off
5099C IPAMDL(3)= 0
5100 IF (IP.EQ.1) THEN
5101 IFPAP(1) = IDT_IPDGHA(IJP)
5102 IFPAB(1) = IJP
5103 ELSE
5104 IFPAP(1) = 2212
5105 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5106 ENDIF
5107 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5108 PVIRT(1) = PMASS(1)**2
5109 IF (IT.EQ.1) THEN
5110 IFPAP(2) = IDT_IPDGHA(IJT)
5111 IFPAB(2) = IJT
5112 ELSE
5113 IFPAP(2) = 2212
5114 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5115 ENDIF
5116 PMASS(2) = AAM(IFPAB(2))
5117 PVIRT(2) = ZERO
5118 DO 1 K=1,4
5119 PP(K) = ZERO
5120 PT(K) = ZERO
5121 1 CONTINUE
5122* get max. possible momenta of incoming particles to be used for PHOJET ini.
5123 PPF = ZERO
5124 PTF = ZERO
5125 SCPF= 1.5D0
5126 IF (UMO.GE.1.E5) THEN
5127 SCPF= 5.0D0
5128 ENDIF
5129 IF (NCOMPO.GT.0) THEN
5130 DO 2 I=1,NCOMPO
5131 IF (IT.GT.1) THEN
5132 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5133 ELSE
5134 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5135 ENDIF
5136 PPFTMP = MAX(PFERMP(1),PFERMN(1))
5137 PTFTMP = MAX(PFERMP(2),PFERMN(2))
5138 IF (PPFTMP.GT.PPF) PPF = PPFTMP
5139 IF (PTFTMP.GT.PTF) PTF = PTFTMP
5140 2 CONTINUE
5141 ELSE
5142 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5143 PPF = MAX(PFERMP(1),PFERMN(1))
5144 PTF = MAX(PFERMP(2),PFERMN(2))
5145 ENDIF
5146 PTF = -PTF
5147 PPF = SCPF*PPF
5148 PTF = SCPF*PTF
5149 IF (IJP.EQ.7) THEN
5150 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5151 PP(3) = PPCM
5152 PP(4) = SQRT(AMP2+PP(3)**2)
5153 ELSE
5154 EPF = SQRT(PPF**2+PMASS(1)**2)
5155 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5156 ENDIF
5157 ETF = SQRT(PTF**2+PMASS(2)**2)
5158 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5159 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5160 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5161 IF (LSTART) THEN
5162 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5163 1001 FORMAT(
5164 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
5165 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5166 IF (NCOMPO.GT.0) THEN
5167 WRITE(LOUT,1002) SCPF,PTF,PT
5168 ELSE
5169 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5170 ENDIF
5171 1002 FORMAT(
5172 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
5173 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5174 1003 FORMAT(
5175 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
5176 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5177 WRITE(LOUT,1004) ECMINI
5178 1004 FORMAT(' E_cm = ',E10.3)
5179 IF (IJP.EQ.8) WRITE(LOUT,1005)
5180 1005 FORMAT(
5181 & ' DT_PHOINI: warning! proton parameters used for neutron',
5182 & ' projectile')
5183 LSTART = .FALSE.
5184 ENDIF
5185* switch off new diffractive cross sections at low energies for nuclei
5186* (temporary solution)
5187 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5188 WRITE(LOUT,'(1X,A)')
5189 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5190 CALL PHO_SETMDL(30,0,1)
5191 ENDIF
5192*
5193C IF (IJP.EQ.7) THEN
5194C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5195C PP(3) = PPCM
5196C PP(4) = SQRT(AMP2+PP(3)**2)
5197C ELSE
5198C PFERMX = ZERO
5199C IF (IP.GT.1) PFERMX = 0.5D0
5200C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5201C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5202C ENDIF
5203C PFERMX = ZERO
5204C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5205C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5206C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5207**sr 26.10.96
5208 ISAV = IPAMDL(13)
5209 IF ((ISHAD(2).EQ.1).AND.
5210 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5211 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5212**
5213
5214 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5215
5216**sr 26.10.96
5217 IPAMDL(13) = ISAV
5218**
5219*
5220* patch for cascade calculations:
5221* define parton distribution functions for other hadrons, i.e. other
5222* then defined already in phojet
5223 IF (IOGLB.EQ.100) THEN
5224 WRITE(LOUT,1006)
5225 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5226 & ' assiged (ID,IPAR,ISET)',/)
5227 NPDF = 0
5228 DO 3 I=1,30
5229 IF (IPARPD(I).NE.0) THEN
5230 NPDF = NPDF+1
5231 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5232 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5233 IDPDG = IDT_IPDGHA(I)
5234 IPAR = IPARPD(I)
5235 ISET = ISETPD(I)
5236 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5237 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5238 ENDIF
5239 ENDIF
5240 3 CONTINUE
5241 ENDIF
5242
5243C CALL PHO_PHIST(-1,SIGMAX)
5244
5245 IF (IREJ1.NE.0) THEN
5246 WRITE(LOUT,1000)
5247 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
5248 STOP
5249 ENDIF
5250
5251 RETURN
5252 END
5253
5254*$ CREATE DT_EVENTD.FOR
5255*COPY DT_EVENTD
5256*
5257*===eventd=============================================================*
5258*
5259 SUBROUTINE DT_EVENTD(IREJ)
5260
5261************************************************************************
5262* Quasi-elastic neutrino nucleus scattering. *
5263* This version dated 29.04.00 is written by S. Roesler. *
5264************************************************************************
5265
5266 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5267 SAVE
5268
5269 PARAMETER ( LINP = 10 ,
5270 & LOUT = 6 ,
5271 & LDAT = 9 )
5272
5273 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5274 PARAMETER (SQTINF=1.0D+15)
5275
5276 LOGICAL LFIRST
5277
5278* event history
5279
5280 PARAMETER (NMXHKK=200000)
5281
5282 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5283 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5284 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5285
5286* extended event history
5287 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5288 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5289 & IHIST(2,NMXHKK)
5290
5291* flags for input different options
5292 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5293 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5294 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5295 PARAMETER (MAXLND=4000)
5296 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5297
5298* properties of interacting particles
5299 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5300
5301* Lorentz-parameters of the current interaction
5302 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5303 & UMO,PPCM,EPROJ,PPROJ
5304
5305* nuclear potential
5306 LOGICAL LFERMI
5307 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5308 & EBINDP(2),EBINDN(2),EPOT(2,210),
5309 & ETACOU(2),ICOUL,LFERMI
5310
5311* steering flags for qel neutrino scattering modules
5312 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5313
5314 COMMON /QNPOL/ POLARX(4),PMODUL
5315
5316 INTEGER PYK
5317
5318 DATA LFIRST /.TRUE./
5319
5320 IREJ = 0
5321
5322 IF (LFIRST) THEN
5323 LFIRST = .FALSE.
5324 CALL DT_MASS_INI
5325 ENDIF
5326
5327* JETSET parameter
5328 CALL DT_INITJS(0)
5329
5330* interacting target nucleon
5331 LTYP = NEUTYP
5332 IF (NEUDEC.LE.9) THEN
5333 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5334 NUCTYP = 2112
5335 NUCTOP = 2
5336 ELSE
5337 NUCTYP = 2212
5338 NUCTOP = 1
5339 ENDIF
5340 ELSE
5341 RTYP = DT_RNDM(RTYP)
5342 ZFRAC = DBLE(ITZ)/DBLE(IT)
5343 IF (RTYP.LE.ZFRAC) THEN
5344 NUCTYP = 2212
5345 NUCTOP = 1
5346 ELSE
5347 NUCTYP = 2112
5348 NUCTOP = 2
5349 ENDIF
5350 ENDIF
5351
5352* select first nucleon in list with matching id and reset all other
5353* nucleons which have been marked as "wounded" by ININUC
5354 IFOUND = 0
5355 DO 1 I=1,NHKK
5356 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5357 ISTHKK(I) = 12
5358 IFOUND = 1
5359 IDX = I
5360 ELSE
5361 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5362 ENDIF
5363 1 CONTINUE
5364 IF (IFOUND.EQ.0)
5365 & STOP ' EVENTD: interacting target nucleon not found! '
5366
5367* correct position of proj. lepton: assume position of target nucleon
5368 DO 3 I=1,4
5369 VHKK(I,1) = VHKK(I,IDX)
5370 WHKK(I,1) = WHKK(I,IDX)
5371 3 CONTINUE
5372
5373* load initial momenta for conservation check
5374 IF (LEMCCK) THEN
5375 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5376 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5377 & 2,IDUM,IDUM)
5378 ENDIF
5379
5380* quasi-elastic scattering
5381 IF (NEUDEC.LT.9) THEN
5382 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5383 & PHKK(4,IDX),PHKK(5,IDX))
5384* CC event on p or n
5385 ELSEIF (NEUDEC.EQ.10) THEN
5386 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5387 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5388* NC event on p or n
5389 ELSEIF (NEUDEC.EQ.11) THEN
5390 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5391 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392 ENDIF
5393
5394* get final state particles from Lund-common and write them into HKKEVT
5395 NPOINT(1) = NHKK+1
5396 NPOINT(4) = NHKK+1
5397
5398 NLINES = PYK(0,1)
5399
5400 NHKK0 = NHKK+1
5401 DO 4 I=4,NLINES
5402 IF (K(I,1).EQ.1) THEN
5403 ID = K(I,2)
5404 PX = P(I,1)
5405 PY = P(I,2)
5406 PZ = P(I,3)
5407 PE = P(I,4)
5408 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5409 IDBJ = IDT_ICIHAD(ID)
5410 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5411 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5412 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5413 ENDIF
5414 VHKK(1,NHKK) = VHKK(1,IDX)
5415 VHKK(2,NHKK) = VHKK(2,IDX)
5416 VHKK(3,NHKK) = VHKK(3,IDX)
5417 VHKK(4,NHKK) = VHKK(4,IDX)
5418C IF (I.EQ.4) THEN
5419C WHKK(1,NHKK) = POLARX(1)
5420C WHKK(2,NHKK) = POLARX(2)
5421C WHKK(3,NHKK) = POLARX(3)
5422C WHKK(4,NHKK) = POLARX(4)
5423C ELSE
5424 WHKK(1,NHKK) = WHKK(1,IDX)
5425 WHKK(2,NHKK) = WHKK(2,IDX)
5426 WHKK(3,NHKK) = WHKK(3,IDX)
5427 WHKK(4,NHKK) = WHKK(4,IDX)
5428C ENDIF
5429 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5430 ENDIF
5431 4 CONTINUE
5432
5433 IF (LEMCCK) THEN
5434 CHKLEV = TINY5
5435 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5436 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5437 ENDIF
5438
5439* transform momenta into cms (as required for inc etc.)
5440 DO 5 I=NHKK0,NHKK
5441 IF (ISTHKK(I).EQ.1) THEN
5442 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5443 PHKK(3,I) = PZ
5444 PHKK(4,I) = PE
5445 ENDIF
5446 5 CONTINUE
5447
5448 RETURN
5449 END
5450*$ CREATE DT_KKEVNT.FOR
5451*COPY DT_KKEVNT
5452*
5453*===kkevnt=============================================================*
5454*
5455 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5456
5457************************************************************************
5458* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5459* without nuclear effects (one event). *
5460* This subroutine is an update of the previous version (KKEVT) written *
5461* by J. Ranft/ H.-J. Moehring. *
5462* This version dated 20.04.95 is written by S. Roesler *
5463************************************************************************
5464
5465 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5466 SAVE
5467
5468 PARAMETER ( LINP = 10 ,
5469 & LOUT = 6 ,
5470 & LDAT = 9 )
5471
5472 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5473
5474 PARAMETER ( MAXNCL = 260,
5475
5476 & MAXVQU = MAXNCL,
5477 & MAXSQU = 20*MAXVQU,
5478 & MAXINT = MAXVQU+MAXSQU)
5479
5480* event history
5481
5482 PARAMETER (NMXHKK=200000)
5483
5484 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487
5488* extended event history
5489 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5490 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5491 & IHIST(2,NMXHKK)
5492
5493* flags for input different options
5494 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5495 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5496 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5497
5498* rejection counter
5499 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5500 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5501 & IREXCI(3),IRDIFF(2),IRINC
5502
5503* statistics
5504 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5505 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5506 & ICEVTG(8,0:30)
5507
5508* properties of interacting particles
5509 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5510
5511* Lorentz-parameters of the current interaction
5512 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5513 & UMO,PPCM,EPROJ,PPROJ
5514
5515* flags for diffractive interactions (DTUNUC 1.x)
5516 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5517
5518* interface HADRIN-DPM
5519 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5520
5521* nucleon-nucleon event-generator
5522 CHARACTER*8 CMODEL
5523 LOGICAL LPHOIN
5524 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5525
5526* coordinates of nucleons
5527 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5528
5529* interface between Glauber formalism and DPM
5530 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5531 & INTER1(MAXINT),INTER2(MAXINT)
5532
5533* Glauber formalism: collision properties
5534 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5535 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5536
5537* central particle production, impact parameter biasing
5538 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5539**temporary
5540
5541* statistics: Glauber-formalism
5542 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5543**
5544
5545 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5546
5547 IREJ = 0
5548 ICREQU = ICREQU+1
5549 NC = 0
5550
5551 1 CONTINUE
5552 ICSAMP = ICSAMP+1
5553 NC = NC+1
5554 IF (MOD(NC,10).EQ.0) THEN
5555 WRITE(LOUT,1000) NEVHKK
5556 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5557 GOTO 9999
5558 ENDIF
5559
5560* initialize DTEVT1/DTEVT2
5561 CALL DT_EVTINI
5562
5563* We need the following only in order to sample nucleon coordinates.
5564* However we don't have parameters (cross sections, slope etc.)
5565* for neutrinos available. Therefore switch projectile to proton
5566* in this case.
5567 IF (MCGENE.EQ.4) THEN
5568 JJPROJ = 1
5569 ELSE
5570 JJPROJ = IJPROJ
5571 ENDIF
5572
5573 10 CONTINUE
5574 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5575* make sure that Glauber-formalism is called each time the interaction
5576* configuration changed
5577 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5578 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5579* sample number of nucleon-nucleon coll. according to Glauber-form.
5580 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5581 NWTSAM = NN
5582 NWASAM = NP
5583 NWBSAM = NT
5584 NEVOLD = NEVHKK
5585 IPOLD = IP
5586 ITOLD = IT
5587 JJPOLD = JJPROJ
5588 EPROLD = EPROJ
5589 ENDIF
5590
5591* force diffractive particle production in h-K interactions
5592 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5593 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5594 NEVOLD = 0
5595 GOTO 10
5596 ENDIF
5597
5598* check number of involved proj. nucl. (NP) if central prod.is requested
5599 IF (ICENTR.GT.0) THEN
5600 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5601 IF (IBACK.GT.0) GOTO 10
5602 ENDIF
5603
5604* get initial nucleon-configuration in projectile and target
5605* rest-system (including Fermi-momenta if requested)
5606 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5607 MODE = 2
5608 IF (EPROJ.LE.EHADTH) MODE = 3
5609 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5610
5611 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5612
5613* activate HADRIN at low energies (implemented for h-N scattering only)
5614 IF (EPROJ.LE.EHADHI) THEN
5615 IF (EHADTH.LT.ZERO) THEN
5616* smooth transition btwn. DPM and HADRIN
5617 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5618 RR = DT_RNDM(FRAC)
5619 IF (RR.GT.FRAC) THEN
5620 IF (IP.EQ.1) THEN
5621 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5622 IF (IREJ1.GT.0) GOTO 1
5623 RETURN
5624 ELSE
5625 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5626 ENDIF
5627 ENDIF
5628 ELSE
5629* fixed threshold for onset of production via HADRIN
5630 IF (EPROJ.LE.EHADTH) THEN
5631 IF (IP.EQ.1) THEN
5632 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633 IF (IREJ1.GT.0) GOTO 1
5634 RETURN
5635 ELSE
5636 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5637 ENDIF
5638 ENDIF
5639 ENDIF
5640 ENDIF
5641 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5642 & I3,') with target (m=',I3,')',/,11X,
5643 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5644 & 'GeV) cannot be handled')
5645
5646* sampling of momentum-x fractions & flavors of chain ends
5647 CALL DT_SPLPTN(NN)
5648
5649* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5650 CALL DT_NUC2CM
5651
5652* collect momenta of chain ends and put them into DTEVT1
5653 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5654 IF (IREJ1.NE.0) GOTO 1
5655
5656 ENDIF
5657
5658* handle chains including fragmentation (two-chain approximation)
5659 IF (MCGENE.EQ.1) THEN
5660* two-chain approximation
5661 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5662 IF (IREJ1.NE.0) THEN
5663 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5664 GOTO 1
5665 ENDIF
5666 ELSEIF (MCGENE.EQ.2) THEN
5667* multiple-Po exchange including minijets
5668 CALL DT_EVENTB(NCSY,IREJ1)
5669 IF (IREJ1.NE.0) THEN
5670 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5671 GOTO 1
5672 ENDIF
5673 ELSEIF (MCGENE.EQ.3) THEN
5674 STOP ' This version does not contain LEPTO !'
5675
5676 ELSEIF (MCGENE.EQ.4) THEN
5677* quasi-elastic neutrino scattering
5678 CALL DT_EVENTD(IREJ1)
5679 IF (IREJ1.NE.0) THEN
5680 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5681 GOTO 1
5682 ENDIF
5683 ELSE
5684 WRITE(LOUT,1002) MCGENE
5685 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5686 & ' not available - program stopped')
5687 STOP
5688 ENDIF
5689
5690 RETURN
5691
5692 9999 CONTINUE
5693 IREJ = 1
5694 RETURN
5695 END
5696
5697*$ CREATE DT_CHKCEN.FOR
5698*COPY DT_CHKCEN
5699*
5700*===chkcen=============================================================*
5701*
5702 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5703
5704************************************************************************
5705* Check of number of involved projectile nucleons if central production*
5706* is requested. *
5707* Adopted from a part of the old KKEVT routine which was written by *
5708* J. Ranft/H.-J.Moehring. *
5709* This version dated 13.01.95 is written by S. Roesler *
5710************************************************************************
5711
5712 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5713 SAVE
5714
5715 PARAMETER ( LINP = 10 ,
5716 & LOUT = 6 ,
5717 & LDAT = 9 )
5718
5719* statistics
5720 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5721 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5722 & ICEVTG(8,0:30)
5723
5724* central particle production, impact parameter biasing
5725 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5726
5727 IBACK = 0
5728
5729* old version
5730 IF (ICENTR.EQ.2) THEN
5731 IF (IP.LT.IT) THEN
5732 IF (IP.LE.8) THEN
5733 IF (NP.LT.IP-1) IBACK = 1
5734 ELSEIF (IP.LE.16) THEN
5735 IF (NP.LT.IP-2) IBACK = 1
5736 ELSEIF (IP.LE.32) THEN
5737 IF (NP.LT.IP-3) IBACK = 1
5738 ELSEIF (IP.GE.33) THEN
5739 IF (NP.LT.IP-5) IBACK = 1
5740 ENDIF
5741 ELSEIF (IP.EQ.IT) THEN
5742 IF (IP.EQ.32) THEN
5743 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5744 ELSE
5745 IF (NP.LT.IP-IP/8) IBACK = 1
5746 ENDIF
5747 ELSEIF (ABS(IP-IT).LT.3) THEN
5748 IF (NP.LT.IP-IP/8) IBACK = 1
5749 ENDIF
5750 ELSE
5751* new version (DPMJET, 5.6.99)
5752 IF (IP.LT.IT) THEN
5753 IF (IP.LE.8) THEN
5754 IF (NP.LT.IP-1) IBACK = 1
5755 ELSEIF (IP.LE.16) THEN
5756 IF (NP.LT.IP-2) IBACK = 1
5757 ELSEIF (IP.LT.32) THEN
5758 IF (NP.LT.IP-3) IBACK = 1
5759 ELSEIF (IP.GE.32) THEN
5760 IF (IT.LE.150) THEN
5761* Example: S-Ag
5762 IF (NP.LT.IP-1) IBACK = 1
5763 ELSE
5764* Example: S-Au
5765 IF (NP.LT.IP) IBACK = 1
5766 ENDIF
5767 ENDIF
5768 ELSEIF (IP.EQ.IT) THEN
5769* Example: S-S
5770 IF (IP.EQ.32) THEN
5771 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5772* Example: Pb-Pb
5773 ELSE
5774 IF (NP.LT.IP-IP/4) IBACK = 1
5775 ENDIF
5776 ELSEIF (ABS(IP-IT).LT.3) THEN
5777 IF (NP.LT.IP-IP/8) IBACK = 1
5778 ENDIF
5779 ENDIF
5780
5781 ICCPRO = ICCPRO+1
5782
5783 RETURN
5784 END
5785
5786*$ CREATE DT_ININUC.FOR
5787*COPY DT_ININUC
5788*
5789*===ininuc=============================================================*
5790*
5791 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5792
5793************************************************************************
5794* Samples initial configuration of nucleons in nucleus with mass NMASS *
5795* including Fermi-momenta (if reqested). *
5796* ID BAMJET-code for hadrons (instead of nuclei) *
5797* NMASS mass number of nucleus (number of nucleons) *
5798* NCH charge of nucleus *
5799* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5800* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5801* IMODE = 1 projectile nucleus *
5802* = 2 target nucleus *
5803* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5804* Adopted from a part of the old KKEVT routine which was written by *
5805* J. Ranft/H.-J.Moehring. *
5806* This version dated 13.01.95 is written by S. Roesler *
5807************************************************************************
5808
5809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5810 SAVE
5811
5812 PARAMETER ( LINP = 10 ,
5813 & LOUT = 6 ,
5814 & LDAT = 9 )
5815
5816 PARAMETER (FM2MM=1.0D-12)
5817
5818 PARAMETER ( MAXNCL = 260,
5819
5820 & MAXVQU = MAXNCL,
5821 & MAXSQU = 20*MAXVQU,
5822 & MAXINT = MAXVQU+MAXSQU)
5823
5824* event history
5825
5826 PARAMETER (NMXHKK=200000)
5827
5828 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5829 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5830 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5831
5832* extended event history
5833 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5834 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5835 & IHIST(2,NMXHKK)
5836
5837* flags for input different options
5838 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5839 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5840 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5841
5842* auxiliary common for chain system storage (DTUNUC 1.x)
5843 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5844
5845* nuclear potential
5846 LOGICAL LFERMI
5847 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5848 & EBINDP(2),EBINDN(2),EPOT(2,210),
5849 & ETACOU(2),ICOUL,LFERMI
5850
5851* properties of photon/lepton projectiles
5852 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5853
5854* particle properties (BAMJET index convention)
5855 CHARACTER*8 ANAME
5856 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5857 & IICH(210),IIBAR(210),K1(210),K2(210)
5858
5859* Glauber formalism: collision properties
5860 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5861 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5862
5863* flavors of partons (DTUNUC 1.x)
5864 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5865 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5866 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5867 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5868 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5869 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5870 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5871
5872* interface HADRIN-DPM
5873 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5874
5875 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5876
5877* number of neutrons
5878 NNEU = NMASS-NCH
5879* initializations
5880 NP = 0
5881 NN = 0
5882 DO 1 K=1,4
5883 PFTOT(K) = 0.0D0
5884 1 CONTINUE
5885 MODE = IMODE
5886 IF (IMODE.GT.2) MODE = 2
5887**sr 29.5. new NPOINT(1)-definition
5888C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5889**
5890 NHADRI = 0
5891 NC = NHKK
5892
5893* get initial configuration
5894 DO 2 I=1,NMASS
5895 NHKK = NHKK+1
5896 IF (JS(I).GT.0) THEN
5897 ISTHKK(NHKK) = 10+MODE
5898 IF (IMODE.EQ.3) THEN
5899* additional treatment if HADRIN-generator is requested
5900 NHADRI = NHADRI+1
5901 IF (NHADRI.EQ.1) IDXTA = NHKK
5902 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5903 ENDIF
5904 ELSE
5905 ISTHKK(NHKK) = 12+MODE
5906 ENDIF
5907 IF (NMASS.GE.2) THEN
5908* treatment for nuclei
5909 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5910 RR = DT_RNDM(FRAC)
5911 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5912 IDX = 8
5913 NN = NN+1
5914 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5915 IDX = 1
5916 NP = NP+1
5917 ELSEIF (NN.LT.NNEU) THEN
5918 IDX = 8
5919 NN = NN+1
5920 ELSEIF (NP.LT.NCH) THEN
5921 IDX = 1
5922 NP = NP+1
5923 ENDIF
5924 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5925 IDBAM(NHKK) = IDX
5926 IF (MODE.EQ.1) THEN
5927 IPOSP(I) = NHKK
5928 KKPROJ(I) = IDX
5929 ELSE
5930 IPOST(I) = NHKK
5931 KKTARG(I) = IDX
5932 ENDIF
5933 IF (IDX.EQ.1) THEN
5934 PFER = PFERMP(MODE)
5935 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5936 ELSE
5937 PFER = PFERMN(MODE)
5938 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5939 ENDIF
5940 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5941 DO 3 K=1,4
5942 PFTOT(K) = PFTOT(K)+PF(K)
5943 PHKK(K,NHKK) = PF(K)
5944 3 CONTINUE
5945 PHKK(5,NHKK) = AAM(IDX)
5946 ELSE
5947* treatment for hadrons
5948 IDHKK(NHKK) = IDT_IPDGHA(ID)
5949 IDBAM(NHKK) = ID
5950 PHKK(4,NHKK) = AAM(ID)
5951 PHKK(5,NHKK) = AAM(ID)
5952C* VDM assumption
5953C IF (IDHKK(NHKK).EQ.22) THEN
5954C PHKK(4,NHKK) = AAM(33)
5955C PHKK(5,NHKK) = AAM(33)
5956C ENDIF
5957 IF (MODE.EQ.1) THEN
5958 IPOSP(I) = NHKK
5959 KKPROJ(I) = ID
5960 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5961 ELSE
5962 IPOST(I) = NHKK
5963 KKTARG(I) = ID
5964 ENDIF
5965 ENDIF
5966 DO 4 K=1,3
5967 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5968 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5969 4 CONTINUE
5970 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5971 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5972 VHKK(4,NHKK) = 0.0D0
5973 WHKK(4,NHKK) = 0.0D0
5974 2 CONTINUE
5975
5976* balance Fermi-momenta
5977 IF (NMASS.GE.2) THEN
5978 DO 5 I=1,NMASS
5979 NC = NC+1
5980 DO 6 K=1,3
5981 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5982 6 CONTINUE
5983 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5984 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5985 5 CONTINUE
5986 ENDIF
5987
5988 RETURN
5989 END
5990
5991*$ CREATE DT_FER4M.FOR
5992*COPY DT_FER4M
5993*
5994*===fer4m==============================================================*
5995*
5996 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5997
5998************************************************************************
5999* Sampling of nucleon Fermi-momenta from distributions at T=0. *
6000* processed by S. Roesler, 17.10.95 *
6001************************************************************************
6002
6003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6004 SAVE
6005
6006 PARAMETER ( LINP = 10 ,
6007 & LOUT = 6 ,
6008 & LDAT = 9 )
6009
6010 LOGICAL LSTART
6011
6012* particle properties (BAMJET index convention)
6013 CHARACTER*8 ANAME
6014 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6015 & IICH(210),IIBAR(210),K1(210),K2(210)
6016
6017* nuclear potential
6018 LOGICAL LFERMI
6019 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6020 & EBINDP(2),EBINDN(2),EPOT(2,210),
6021 & ETACOU(2),ICOUL,LFERMI
6022
6023 DATA LSTART /.TRUE./
6024
6025 ILOOP = 0
6026 IF (LFERMI) THEN
6027 IF (LSTART) THEN
6028 WRITE(LOUT,1000)
6029 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6030 LSTART = .FALSE.
6031 ENDIF
6032 1 CONTINUE
6033 CALL DT_DFERMI(PABS)
6034 PABS = PFERM*PABS
6035C IF (PABS.GE.PBIND) THEN
6036C ILOOP = ILOOP+1
6037C IF (MOD(ILOOP,500).EQ.0) THEN
6038C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6039C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6040C & ' energy ',2E12.3,I6)
6041C ENDIF
6042C GOTO 1
6043C ENDIF
6044 CALL DT_DPOLI(POLC,POLS)
6045 CALL DT_DSFECF(SFE,CFE)
6046 CXTA = POLS*CFE
6047 CYTA = POLS*SFE
6048 CZTA = POLC
6049 ET = SQRT(PABS*PABS+AAM(KT)**2)
6050 PXT = CXTA*PABS
6051 PYT = CYTA*PABS
6052 PZT = CZTA*PABS
6053 ELSE
6054 ET = AAM(KT)
6055 PXT = 0.0D0
6056 PYT = 0.0D0
6057 PZT = 0.0D0
6058 ENDIF
6059
6060 RETURN
6061 END
6062
6063*$ CREATE DT_NUC2CM.FOR
6064*COPY DT_NUC2CM
6065*
6066*===nuc2cm=============================================================*
6067*
6068 SUBROUTINE DT_NUC2CM
6069
6070************************************************************************
6071* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6072* nucl. cms. (This subroutine replaces NUCMOM.) *
6073* This version dated 15.01.95 is written by S. Roesler *
6074************************************************************************
6075
6076 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6077 SAVE
6078
6079 PARAMETER ( LINP = 10 ,
6080 & LOUT = 6 ,
6081 & LDAT = 9 )
6082
6083 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6084
6085* event history
6086
6087 PARAMETER (NMXHKK=200000)
6088
6089 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6090 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6091 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6092
6093* extended event history
6094 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6095 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6096 & IHIST(2,NMXHKK)
6097
6098* statistics
6099 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6100 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6101 & ICEVTG(8,0:30)
6102
6103* properties of photon/lepton projectiles
6104 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6105
6106* particle properties (BAMJET index convention)
6107 CHARACTER*8 ANAME
6108 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6109 & IICH(210),IIBAR(210),K1(210),K2(210)
6110
6111* Glauber formalism: collision properties
6112 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6113 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6114**temporary
6115
6116* statistics: Glauber-formalism
6117 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6118**
6119
6120 ICWP = 0
6121 ICWT = 0
6122 NWTACC = 0
6123 NWAACC = 0
6124 NWBACC = 0
6125
6126 NPOINT(1) = NHKK+1
6127 NEND = NHKK
6128 DO 1 I=1,NEND
6129 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6130 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6131 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6132 MODE = ISTHKK(I)-9
6133C IF (IDHKK(I).EQ.22) THEN
6134C* VDM assumption
6135C PEIN = AAM(33)
6136C IDB = 33
6137C ELSE
6138C PEIN = PHKK(4,I)
6139C IDB = IDBAM(I)
6140C ENDIF
6141C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6142C & PX,PY,PZ,PE,IDB,MODE)
6143 IF (PHKK(5,I).GT.ZERO) THEN
6144 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6145 & PX,PY,PZ,PE,IDBAM(I),MODE)
6146 ELSE
6147 PX = PGAMM(1)
6148 PY = PGAMM(2)
6149 PZ = PGAMM(3)
6150 PE = PGAMM(4)
6151 ENDIF
6152 IST = ISTHKK(I)-2
6153 ID = IDHKK(I)
6154C* VDM assumption
6155C IF (ID.EQ.22) ID = 113
6156 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6157 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6158 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6159 ENDIF
6160 1 CONTINUE
6161
6162 NWTACC = MAX(NWAACC,NWBACC)
6163 ICDPR = ICDPR+ICWP
6164 ICDTA = ICDTA+ICWT
6165**temporary
6166 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6167 CALL DT_EVTOUT(4)
6168 STOP
6169 ENDIF
6170
6171 RETURN
6172 END
6173
6174*$ CREATE DT_SPLPTN.FOR
6175*COPY DT_SPLPTN
6176*
6177*===splptn=============================================================*
6178*
6179 SUBROUTINE DT_SPLPTN(NN)
6180
6181************************************************************************
6182* SamPLing of ParToN momenta and flavors. *
6183* This version dated 15.01.95 is written by S. Roesler *
6184************************************************************************
6185
6186 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6187 SAVE
6188
6189 PARAMETER ( LINP = 10 ,
6190 & LOUT = 6 ,
6191 & LDAT = 9 )
6192
6193* Lorentz-parameters of the current interaction
6194 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6195 & UMO,PPCM,EPROJ,PPROJ
6196
6197* sample flavors of sea-quarks
6198 CALL DT_SPLFLA(NN,1)
6199
6200* sample x-values of partons at chain ends
6201 ECM = UMO
6202 CALL DT_XKSAMP(NN,ECM)
6203
6204* samle flavors
6205 CALL DT_SPLFLA(NN,2)
6206
6207 RETURN
6208 END
6209
6210*$ CREATE DT_SPLFLA.FOR
6211*COPY DT_SPLFLA
6212*
6213*===splfla=============================================================*
6214*
6215 SUBROUTINE DT_SPLFLA(NN,MODE)
6216
6217************************************************************************
6218* SamPLing of FLAvors of partons at chain ends. *
6219* This subroutine replaces FLKSAA/FLKSAM. *
6220* NN number of nucleon-nucleon interactions *
6221* MODE = 1 sea-flavors *
6222* = 2 valence-flavors *
6223* Based on the original version written by J. Ranft/H.-J. Moehring. *
6224* This version dated 16.01.95 is written by S. Roesler *
6225************************************************************************
6226
6227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6228 SAVE
6229
6230 PARAMETER ( LINP = 10 ,
6231 & LOUT = 6 ,
6232 & LDAT = 9 )
6233
6234 PARAMETER ( MAXNCL = 260,
6235
6236 & MAXVQU = MAXNCL,
6237 & MAXSQU = 20*MAXVQU,
6238 & MAXINT = MAXVQU+MAXSQU)
6239
6240* flavors of partons (DTUNUC 1.x)
6241 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6242 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6243 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6244 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6245 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6246 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6247 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6248
6249* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6250 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6251 & IXPV,IXPS,IXTV,IXTS,
6252 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6253 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6254 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6255 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6256 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6257 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6258 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6259 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6260
6261* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6262 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6263 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6264
6265* particle properties (BAMJET index convention)
6266 CHARACTER*8 ANAME
6267 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6268 & IICH(210),IIBAR(210),K1(210),K2(210)
6269
6270* various options for treatment of partons (DTUNUC 1.x)
6271* (chain recombination, Cronin,..)
6272 LOGICAL LCO2CR,LINTPT
6273 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6274 & LCO2CR,LINTPT
6275
6276 IF (MODE.EQ.1) THEN
6277* sea-flavors
6278 DO 1 I=1,NN
6279 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6280 IPSAQ(I) = -IPSQ(I)
6281 1 CONTINUE
6282 DO 2 I=1,NN
6283 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6284 ITSAQ(I)= -ITSQ(I)
6285 2 CONTINUE
6286 ELSEIF (MODE.EQ.2) THEN
6287* valence flavors
6288 DO 3 I=1,IXPV
6289 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6290 3 CONTINUE
6291 DO 4 I=1,IXTV
6292 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6293 4 CONTINUE
6294 ENDIF
6295
6296 RETURN
6297 END
6298
6299*$ CREATE DT_GETPTN.FOR
6300*COPY DT_GETPTN
6301*
6302*===getptn=============================================================*
6303*
6304 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6305
6306************************************************************************
6307* This subroutine collects partons at chain ends from temporary *
6308* commons and puts them into DTEVT1. *
6309* This version dated 15.01.95 is written by S. Roesler *
6310************************************************************************
6311
6312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6313 SAVE
6314
6315 PARAMETER ( LINP = 10 ,
6316 & LOUT = 6 ,
6317 & LDAT = 9 )
6318
6319 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6320
6321 LOGICAL LCHK
6322
6323 PARAMETER ( MAXNCL = 260,
6324
6325 & MAXVQU = MAXNCL,
6326 & MAXSQU = 20*MAXVQU,
6327 & MAXINT = MAXVQU+MAXSQU)
6328
6329* event history
6330
6331 PARAMETER (NMXHKK=200000)
6332
6333 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6334 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6335 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6336
6337* extended event history
6338 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6339 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6340 & IHIST(2,NMXHKK)
6341
6342* flags for input different options
6343 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6344 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6345 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6346
6347* auxiliary common for chain system storage (DTUNUC 1.x)
6348 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6349
6350* statistics
6351 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6352 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6353 & ICEVTG(8,0:30)
6354
6355* flags for diffractive interactions (DTUNUC 1.x)
6356 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6357
6358* x-values of partons (DTUNUC 1.x)
6359 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6360 & XTVQ(MAXVQU),XTVD(MAXVQU),
6361 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6362 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6363
6364* flavors of partons (DTUNUC 1.x)
6365 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6366 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6367 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6368 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6369 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6370 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6371 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6372
6373* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6374 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6375 & IXPV,IXPS,IXTV,IXTS,
6376 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6377 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6378 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6379 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6380 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6381 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6382 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6383 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6384
6385* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6386 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6387 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6388
6389 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6390
6391 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6392
6393 IREJ = 0
6394 NCSY = 0
6395 NPOINT(2) = NHKK+1
6396
6397* sea-sea chains
6398 DO 10 I=1,NSS
6399 IF (ISKPCH(1,I).EQ.99) GOTO 10
6400 ICCHAI(1,1) = ICCHAI(1,1)+2
6401 IDXP = INTSS1(I)
6402 IDXT = INTSS2(I)
6403 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6404 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6405 DO 11 K=1,4
6406 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6407 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6408 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6409 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6410 11 CONTINUE
6411 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6412 & +(PP1(3)+PT1(3))**2)
6413 ECH = PP1(4)+PT1(4)
6414 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6415 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6416 & +(PP2(3)+PT2(3))**2)
6417 ECH = PP2(4)+PT2(4)
6418 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6419 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6420 AM1 = SQRT(AM1)
6421 AM2 = SQRT(AM2)
6422 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6423C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6424 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6425 ENDIF
6426 ELSE
6427 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6428 ENDIF
6429 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6430 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6431 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6432 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6433 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6434 & 0,0,1)
6435 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6436 & 0,0,1)
6437 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6438 & 0,0,1)
6439 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6440 & 0,0,1)
6441 NCSY = NCSY+1
6442 10 CONTINUE
6443
6444* disea-sea chains
6445 DO 20 I=1,NDS
6446 IF (ISKPCH(2,I).EQ.99) GOTO 20
6447 ICCHAI(1,2) = ICCHAI(1,2)+2
6448 IDXP = INTDS1(I)
6449 IDXT = INTDS2(I)
6450 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6451 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6452 DO 21 K=1,4
6453 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6454 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6455 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6456 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6457 21 CONTINUE
6458 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6459 & +(PP1(3)+PT1(3))**2)
6460 ECH = PP1(4)+PT1(4)
6461 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6462 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6463 & +(PP2(3)+PT2(3))**2)
6464 ECH = PP2(4)+PT2(4)
6465 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6466 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6467 AM1 = SQRT(AM1)
6468 AM2 = SQRT(AM2)
6469 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6470C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6471 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6472 ENDIF
6473 ELSE
6474 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6475 ENDIF
6476 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6477 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6478 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6479 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6480 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6481 & 0,0,2)
6482 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6483 & 0,0,2)
6484 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6485 & 0,0,2)
6486 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6487 & 0,0,2)
6488 NCSY = NCSY+1
6489 20 CONTINUE
6490
6491* sea-disea chains
6492 DO 30 I=1,NSD
6493 IF (ISKPCH(3,I).EQ.99) GOTO 30
6494 ICCHAI(1,3) = ICCHAI(1,3)+2
6495 IDXP = INTSD1(I)
6496 IDXT = INTSD2(I)
6497 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6498 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6499 DO 31 K=1,4
6500 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6501 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6502 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6503 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6504 31 CONTINUE
6505 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6506 & +(PP1(3)+PT1(3))**2)
6507 ECH = PP1(4)+PT1(4)
6508 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6509 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6510 & +(PP2(3)+PT2(3))**2)
6511 ECH = PP2(4)+PT2(4)
6512 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6513 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6514 AM1 = SQRT(AM1)
6515 AM2 = SQRT(AM2)
6516 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6517C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6518 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6519 ENDIF
6520 ELSE
6521 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6522 ENDIF
6523 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6524 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6525 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6526 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6527 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6528 & 0,0,3)
6529 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6530 & 0,0,3)
6531 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6532 & 0,0,3)
6533 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6534 & 0,0,3)
6535 NCSY = NCSY+1
6536 30 CONTINUE
6537
6538* disea-valence chains
6539 DO 50 I=1,NDV
6540 IF (ISKPCH(5,I).EQ.99) GOTO 50
6541 ICCHAI(1,5) = ICCHAI(1,5)+2
6542 IDXP = INTDV1(I)
6543 IDXT = INTDV2(I)
6544 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6545 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6546 DO 51 K=1,4
6547 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6548 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6549 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6550 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6551 51 CONTINUE
6552 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6553 & +(PP1(3)+PT1(3))**2)
6554 ECH = PP1(4)+PT1(4)
6555 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6556 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6557 & +(PP2(3)+PT2(3))**2)
6558 ECH = PP2(4)+PT2(4)
6559 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6560 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6561 AM1 = SQRT(AM1)
6562 AM2 = SQRT(AM2)
6563 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6564C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6565 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6566 ENDIF
6567 ELSE
6568 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6569 ENDIF
6570 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6571 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6572 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6573 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6574 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6575 & 0,0,5)
6576 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6577 & 0,0,5)
6578 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6579 & 0,0,5)
6580 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6581 & 0,0,5)
6582 NCSY = NCSY+1
6583 50 CONTINUE
6584
6585* valence-sea chains
6586 DO 60 I=1,NVS
6587 IF (ISKPCH(6,I).EQ.99) GOTO 60
6588 ICCHAI(1,6) = ICCHAI(1,6)+2
6589 IDXP = INTVS1(I)
6590 IDXT = INTVS2(I)
6591 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6592 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6593 DO 61 K=1,4
6594 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6595 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6596 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6597 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6598 61 CONTINUE
6599 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6600 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6601 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6602 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6603 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6604 IF (LCHK) THEN
6605 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6606 & 0,0,6)
6607 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6608 & 0,0,6)
6609 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6610 & 0,0,6)
6611 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6612 & 0,0,6)
6613 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6614 & +(PP1(3)+PT1(3))**2)
6615 ECH = PP1(4)+PT1(4)
6616 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6617 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6618 & +(PP2(3)+PT2(3))**2)
6619 ECH = PP2(4)+PT2(4)
6620 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6621 ELSE
6622 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6623 & 0,0,6)
6624 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6625 & 0,0,6)
6626 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6627 & 0,0,6)
6628 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6629 & 0,0,6)
6630 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6631 & +(PP1(3)+PT2(3))**2)
6632 ECH = PP1(4)+PT2(4)
6633 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6634 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6635 & +(PP2(3)+PT1(3))**2)
6636 ECH = PP2(4)+PT1(4)
6637 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6638 ENDIF
6639 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6640 AM1 = SQRT(AM1)
6641 AM2 = SQRT(AM2)
6642 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6643C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6644 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6645 ENDIF
6646 ELSE
6647 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6648 ENDIF
6649 NCSY = NCSY+1
6650 60 CONTINUE
6651
6652* sea-valence chains
6653 DO 40 I=1,NSV
6654 IF (ISKPCH(4,I).EQ.99) GOTO 40
6655 ICCHAI(1,4) = ICCHAI(1,4)+2
6656 IDXP = INTSV1(I)
6657 IDXT = INTSV2(I)
6658 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6659 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6660 DO 41 K=1,4
6661 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6662 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6663 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6664 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6665 41 CONTINUE
6666 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6667 & +(PP1(3)+PT1(3))**2)
6668 ECH = PP1(4)+PT1(4)
6669 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6670 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6671 & +(PP2(3)+PT2(3))**2)
6672 ECH = PP2(4)+PT2(4)
6673 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6674 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6675 AM1 = SQRT(AM1)
6676 AM2 = SQRT(AM2)
6677 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6678C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6679 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6680 ENDIF
6681 ELSE
6682 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6683 ENDIF
6684 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6685 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6686 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6687 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6688 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6689 & 0,0,4)
6690 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6691 & 0,0,4)
6692 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6693 & 0,0,4)
6694 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6695 & 0,0,4)
6696 NCSY = NCSY+1
6697 40 CONTINUE
6698
6699* valence-disea chains
6700 DO 70 I=1,NVD
6701 IF (ISKPCH(7,I).EQ.99) GOTO 70
6702 ICCHAI(1,7) = ICCHAI(1,7)+2
6703 IDXP = INTVD1(I)
6704 IDXT = INTVD2(I)
6705 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6706 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6707 DO 71 K=1,4
6708 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6709 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6710 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6711 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6712 71 CONTINUE
6713 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6714 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6715 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6716 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6717 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6718 IF (LCHK) THEN
6719 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6720 & 0,0,7)
6721 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6722 & 0,0,7)
6723 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6724 & 0,0,7)
6725 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6726 & 0,0,7)
6727 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6728 & +(PP1(3)+PT1(3))**2)
6729 ECH = PP1(4)+PT1(4)
6730 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6731 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6732 & +(PP2(3)+PT2(3))**2)
6733 ECH = PP2(4)+PT2(4)
6734 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6735 ELSE
6736 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6737 & 0,0,7)
6738 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6739 & 0,0,7)
6740 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6741 & 0,0,7)
6742 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6743 & 0,0,7)
6744 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6745 & +(PP1(3)+PT2(3))**2)
6746 ECH = PP1(4)+PT2(4)
6747 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6748 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6749 & +(PP2(3)+PT1(3))**2)
6750 ECH = PP2(4)+PT1(4)
6751 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6752 ENDIF
6753 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6754 AM1 = SQRT(AM1)
6755 AM2 = SQRT(AM2)
6756 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6757C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6758 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6759 ENDIF
6760 ELSE
6761 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6762 ENDIF
6763 NCSY = NCSY+1
6764 70 CONTINUE
6765
6766* valence-valence chains
6767 DO 80 I=1,NVV
6768 IF (ISKPCH(8,I).EQ.99) GOTO 80
6769 ICCHAI(1,8) = ICCHAI(1,8)+2
6770 IDXP = INTVV1(I)
6771 IDXT = INTVV2(I)
6772 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6773 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6774 DO 81 K=1,4
6775 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6776 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6777 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6778 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6779 81 CONTINUE
6780 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6781 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6782 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6783 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6784
6785* check for diffractive event
6786 IDIFF = 0
6787 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6788 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6789 DO 800 K=1,4
6790 PP(K) = PP1(K)+PP2(K)
6791 PT(K) = PT1(K)+PT2(K)
6792 800 CONTINUE
6793 ISTCK = NHKK
6794 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6795 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6796C IF (IREJ1.NE.0) GOTO 9999
6797 IF (IREJ1.NE.0) THEN
6798 IDIFF = 0
6799 NHKK = ISTCK
6800 ENDIF
6801 ELSE
6802 IDIFF = 0
6803 ENDIF
6804
6805 IF (IDIFF.EQ.0) THEN
6806* valence-valence chain system
6807 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6808 IF (LCHK) THEN
6809* baryon-baryon
6810 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6811 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6812 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6813 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6814 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6815 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6816 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6817 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6818 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6819 & +(PP1(3)+PT1(3))**2)
6820 ECH = PP1(4)+PT1(4)
6821 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6822 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6823 & +(PP2(3)+PT2(3))**2)
6824 ECH = PP2(4)+PT2(4)
6825 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6826 ELSE
6827* antibaryon-baryon
6828 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6829 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6830 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6831 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6832 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6833 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6834 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6835 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6836 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6837 & +(PP1(3)+PT2(3))**2)
6838 ECH = PP1(4)+PT2(4)
6839 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6840 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6841 & +(PP2(3)+PT1(3))**2)
6842 ECH = PP2(4)+PT1(4)
6843 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6844 ENDIF
6845 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6846 AM1 = SQRT(AM1)
6847 AM2 = SQRT(AM2)
6848 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6849C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6850 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6851 ENDIF
6852 ELSE
6853 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6854 ENDIF
6855 NCSY = NCSY+1
6856 ENDIF
6857 80 CONTINUE
6858 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6859
6860* energy-momentum & flavor conservation check
6861 IF (ABS(IDIFF).NE.1) THEN
6862 IF (IDIFF.NE.0) THEN
6863 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6864 & 1,3,10,IREJ)
6865 ELSE
6866 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6867 & 1,3,10,IREJ)
6868 ENDIF
6869 IF (IREJ.NE.0) THEN
6870 CALL DT_EVTOUT(4)
6871 STOP
6872 ENDIF
6873 ENDIF
6874
6875 RETURN
6876
6877 9999 CONTINUE
6878 IREJ = 1
6879 RETURN
6880 END
6881
6882*$ CREATE DT_CHKCSY.FOR
6883*COPY DT_CHKCSY
6884*
6885*===chkcsy=============================================================*
6886*
6887 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6888
6889************************************************************************
6890* CHeCk Chain SYstem for consistency of partons at chain ends. *
6891* ID1,ID2 PDG-numbers of partons at chain ends *
6892* LCHK = .true. consistent chain *
6893* = .false. inconsistent chain *
6894* This version dated 18.01.95 is written by S. Roesler *
6895************************************************************************
6896
6897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6898 SAVE
6899
6900 PARAMETER ( LINP = 10 ,
6901 & LOUT = 6 ,
6902 & LDAT = 9 )
6903
6904 LOGICAL LCHK
6905
6906 LCHK = .TRUE.
6907
6908* q-aq chain
6909 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6910 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6911* q-qq, aq-aqaq chain
6912 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6913 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6914 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6915* qq-aqaq chain
6916 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6917 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6918 ENDIF
6919
6920 RETURN
6921 END
6922
6923*$ CREATE DT_EVENTA.FOR
6924*COPY DT_EVENTA
6925*
6926*===eventa=============================================================*
6927*
6928 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6929
6930************************************************************************
6931* Treatment of nucleon-nucleon interactions in a two-chain *
6932* approximation. *
6933* (input) ID BAMJET-index of projectile hadron (in case of *
6934* h-K scattering) *
6935* IP/IT mass number of projectile/target nucleus *
6936* NCSY number of two chain systems *
6937* IREJ rejection flag *
6938* This version dated 15.01.95 is written by S. Roesler *
6939************************************************************************
6940
6941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6942 SAVE
6943
6944 PARAMETER ( LINP = 10 ,
6945 & LOUT = 6 ,
6946 & LDAT = 9 )
6947
6948 PARAMETER (TINY10=1.0D-10)
6949
6950* event history
6951
6952 PARAMETER (NMXHKK=200000)
6953
6954 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6955 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6956 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6957
6958* extended event history
6959 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6960 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6961 & IHIST(2,NMXHKK)
6962
6963* rejection counter
6964 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6965 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6966 & IREXCI(3),IRDIFF(2),IRINC
6967
6968* flags for diffractive interactions (DTUNUC 1.x)
6969 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6970
6971* particle properties (BAMJET index convention)
6972 CHARACTER*8 ANAME
6973 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6974 & IICH(210),IIBAR(210),K1(210),K2(210)
6975
6976* flags for input different options
6977 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6978 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6979 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6980
6981* various options for treatment of partons (DTUNUC 1.x)
6982* (chain recombination, Cronin,..)
6983 LOGICAL LCO2CR,LINTPT
6984 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6985 & LCO2CR,LINTPT
6986
6987 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6988
6989 IREJ = 0
6990 NPOINT(3) = NHKK+1
6991
6992* skip following treatment for low-mass diffraction
6993 IF (ABS(IFLAGD).EQ.1) THEN
6994 NPOINT(3) = NPOINT(2)
6995 GOTO 5
6996 ENDIF
6997
6998* multiple scattering of chain ends
6999 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7000 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7001
7002 NC = NPOINT(2)
7003* get a two-chain system from DTEVT1
7004 DO 3 I=1,NCSY
7005 IFP1 = IDHKK(NC)
7006 IFT1 = IDHKK(NC+1)
7007 IFP2 = IDHKK(NC+2)
7008 IFT2 = IDHKK(NC+3)
7009 DO 4 K=1,4
7010 PP1(K) = PHKK(K,NC)
7011 PT1(K) = PHKK(K,NC+1)
7012 PP2(K) = PHKK(K,NC+2)
7013 PT2(K) = PHKK(K,NC+3)
7014 4 CONTINUE
7015 MOP1 = NC
7016 MOT1 = NC+1
7017 MOP2 = NC+2
7018 MOT2 = NC+3
7019 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7020 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7021 IF (IREJ1.GT.0) THEN
7022 IRHHA = IRHHA+1
7023 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7024 GOTO 9999
7025 ENDIF
7026 NC = NC+4
7027 3 CONTINUE
7028
7029* meson/antibaryon projectile:
7030* sample single-chain valence-valence systems (Reggeon contrib.)
7031 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7032 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7033 ENDIF
7034
7035 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7036* check DTEVT1 for remaining resonance mass corrections
7037 CALL DT_EVTRES(IREJ1)
7038 IF (IREJ1.GT.0) THEN
7039 IRRES(1) = IRRES(1)+1
7040 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7041 GOTO 9999
7042 ENDIF
7043 ENDIF
7044
7045* assign p_t to two-"chain" systems consisting of two resonances only
7046* since only entries for chains will be affected, this is obsolete
7047* in case of JETSET-fragmetation
7048 CALL DT_RESPT
7049
7050* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7051 IF (LCO2CR) CALL DT_COM2CR
7052
7053 5 CONTINUE
7054
7055* fragmentation of the complete event
7056**uncomment for internal phojet-fragmentation
7057C CALL DT_EVTFRA(IREJ1)
7058 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7059 IF (IREJ1.GT.0) THEN
7060 IRFRAG = IRFRAG+1
7061 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7062 GOTO 9999
7063 ENDIF
7064
7065* decay of possible resonances (should be obsolete)
7066 CALL DT_DECAY1
7067
7068 RETURN
7069
7070 9999 CONTINUE
7071 IREVT = IREVT+1
7072 IREJ = 1
7073 RETURN
7074 END
7075
7076*$ CREATE DT_GETCSY.FOR
7077*COPY DT_GETCSY
7078*
7079*===getcsy=============================================================*
7080*
7081 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7082 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7083
7084************************************************************************
7085* This version dated 15.01.95 is written by S. Roesler *
7086************************************************************************
7087
7088 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7089 SAVE
7090
7091 PARAMETER ( LINP = 10 ,
7092 & LOUT = 6 ,
7093 & LDAT = 9 )
7094
7095 PARAMETER (TINY10=1.0D-10)
7096
7097* event history
7098
7099 PARAMETER (NMXHKK=200000)
7100
7101 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7102 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7103 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7104
7105* extended event history
7106 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7107 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7108 & IHIST(2,NMXHKK)
7109
7110* rejection counter
7111 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7112 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7113 & IREXCI(3),IRDIFF(2),IRINC
7114
7115* flags for input different options
7116 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7117 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7118 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7119
7120* flags for diffractive interactions (DTUNUC 1.x)
7121 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7122
7123 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7124 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7125
7126 IREJ = 0
7127
7128* get quark content of partons
7129 DO 1 I=1,2
7130 IFP1(I) = 0
7131 IFP2(I) = 0
7132 IFT1(I) = 0
7133 IFT2(I) = 0
7134 1 CONTINUE
7135 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7136 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7137 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7138 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7139 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7140 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7141 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7142 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7143
7144* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7145 IDCH1 = 2
7146 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7147 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7148 IDCH2 = 2
7149 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7150 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7151
7152* store initial configuration for energy-momentum cons. check
7153 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7154
7155* sample intrinsic p_t at chain-ends
7156 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7157 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7158 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7159 IF (IREJ1.NE.0) THEN
7160 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7161 IRPT = IRPT+1
7162 GOTO 9999
7163 ENDIF
7164
7165C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7166C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7167C* check second chain for resonance
7168C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7169C & AMCH2,AMCH2N,IDCH2,IREJ1)
7170C IF (IREJ1.NE.0) GOTO 9999
7171C IF (IDR2.NE.0) THEN
7172C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7173C & AMCH2,AMCH2N,AMCH1,IREJ1)
7174C IF (IREJ1.NE.0) GOTO 9999
7175C ENDIF
7176C* check first chain for resonance
7177C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7178C & AMCH1,AMCH1N,IDCH1,IREJ1)
7179C IF (IREJ1.NE.0) GOTO 9999
7180C IF (IDR1.NE.0) IDR1 = 100*IDR1
7181C ELSE
7182C* check first chain for resonance
7183C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7184C & AMCH1,AMCH1N,IDCH1,IREJ1)
7185C IF (IREJ1.NE.0) GOTO 9999
7186C IF (IDR1.NE.0) THEN
7187C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7188C & AMCH1,AMCH1N,AMCH2,IREJ1)
7189C IF (IREJ1.NE.0) GOTO 9999
7190C ENDIF
7191C* check second chain for resonance
7192C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7193C & AMCH2,AMCH2N,IDCH2,IREJ1)
7194C IF (IREJ1.NE.0) GOTO 9999
7195C IF (IDR2.NE.0) IDR2 = 100*IDR2
7196C ENDIF
7197C ENDIF
7198
7199 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7200* check chains for resonances
7201 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7202 & AMCH1,AMCH1N,IDCH1,IREJ1)
7203 IF (IREJ1.NE.0) GOTO 9999
7204 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7205 & AMCH2,AMCH2N,IDCH2,IREJ1)
7206 IF (IREJ1.NE.0) GOTO 9999
7207* change kinematics corresponding to resonance-masses
7208 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7209 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7210 & AMCH1,AMCH1N,AMCH2,IREJ1)
7211 IF (IREJ1.GT.0) GOTO 9999
7212 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7213 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7214 & AMCH2,AMCH2N,IDCH2,IREJ1)
7215 IF (IREJ1.NE.0) GOTO 9999
7216 IF (IDR2.NE.0) IDR2 = 100*IDR2
7217 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7218 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7219 & AMCH2,AMCH2N,AMCH1,IREJ1)
7220 IF (IREJ1.GT.0) GOTO 9999
7221 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7222 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7223 & AMCH1,AMCH1N,IDCH1,IREJ1)
7224 IF (IREJ1.NE.0) GOTO 9999
7225 IF (IDR1.NE.0) IDR1 = 100*IDR1
7226 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7227 AMDIF1 = ABS(AMCH1-AMCH1N)
7228 AMDIF2 = ABS(AMCH2-AMCH2N)
7229 IF (AMDIF2.LT.AMDIF1) THEN
7230 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7231 & AMCH2,AMCH2N,AMCH1,IREJ1)
7232 IF (IREJ1.GT.0) GOTO 9999
7233 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7234 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7235 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7236 IF (IREJ1.NE.0) GOTO 9999
7237 IF (IDR1.NE.0) IDR1 = 100*IDR1
7238 ELSE
7239 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7240 & AMCH1,AMCH1N,AMCH2,IREJ1)
7241 IF (IREJ1.GT.0) GOTO 9999
7242 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7243 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7244 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7245 IF (IREJ1.NE.0) GOTO 9999
7246 IF (IDR2.NE.0) IDR2 = 100*IDR2
7247 ENDIF
7248 ENDIF
7249 ENDIF
7250
7251* store final configuration for energy-momentum cons. check
7252 IF (LEMCCK) THEN
7253 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7254 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7255 IF (IREJ1.NE.0) GOTO 9999
7256 ENDIF
7257
7258* put partons and chains into DTEVT1
7259 DO 10 I=1,4
7260 PCH1(I) = PP1(I)+PT1(I)
7261 PCH2(I) = PP2(I)+PT2(I)
7262 10 CONTINUE
7263 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7264 & PP1(3),PP1(4),0,0,0)
7265 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7266 & PT1(3),PT1(4),0,0,0)
7267 KCH = 100+IDCH(MOP1)*10+1
7268 CALL DT_EVTPUT(KCH,88888,-2,-1,
7269 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7270 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7271 & PP2(3),PP2(4),0,0,0)
7272 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7273 & PT2(3),PT2(4),0,0,0)
7274 KCH = KCH+1
7275 CALL DT_EVTPUT(KCH,88888,-2,-1,
7276 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7277
7278 RETURN
7279
7280 9999 CONTINUE
7281 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7282* "cancel" sea-sea chains
7283 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7284 IF (IREJ1.NE.0) GOTO 9998
7285**sr 16.5. flag for EVENTB
7286 IREJ = -1
7287 RETURN
7288 ENDIF
7289 9998 CONTINUE
7290 IREJ = 1
7291 RETURN
7292 END
7293
7294*$ CREATE DT_CHKINE.FOR
7295*COPY DT_CHKINE
7296*
7297*===chkine=============================================================*
7298*
7299 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7300 & AMCH1,AMCH1N,AMCH2,IREJ)
7301
7302************************************************************************
7303* This subroutine replaces CORMOM. *
7304* This version dated 05.01.95 is written by S. Roesler *
7305************************************************************************
7306
7307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7308 SAVE
7309
7310 PARAMETER ( LINP = 10 ,
7311 & LOUT = 6 ,
7312 & LDAT = 9 )
7313
7314 PARAMETER (TINY10=1.0D-10)
7315
7316* flags for input different options
7317 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7318 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7319 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7320
7321* rejection counter
7322 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7323 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7324 & IREXCI(3),IRDIFF(2),IRINC
7325
7326 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7327 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7328
7329 IREJ = 0
7330 JMSHL = IMSHL
7331
7332 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7333 DO 10 I=1,4
7334 PP1(I) = PP1I(I)
7335 PP2(I) = PP2I(I)
7336 PT1(I) = PT1I(I)
7337 PT2(I) = PT2I(I)
7338 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7339 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7340 PP1(I) = SCALE*PP1(I)
7341 PT1(I) = SCALE*PT1(I)
7342 10 CONTINUE
7343 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7344 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7345
7346 ECH = PP2(4)+PT2(4)
7347 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7348 & (PP2(3)+PT2(3))**2 )
7349 AMCH22 = (ECH-PCH)*(ECH+PCH)
7350 IF (AMCH22.LT.0.0D0) THEN
7351 IF (IOULEV(1).GT.0)
7352 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7353 GOTO 9997
7354 ENDIF
7355
7356 AMCH1 = AMCH1N
7357 AMCH2 = SQRT(AMCH22)
7358
7359* put partons again on mass shell
7360 13 CONTINUE
7361 XM1 = 0.0D0
7362 XM2 = 0.0D0
7363 IF (JMSHL.EQ.1) THEN
7364
7365 XM1 = PYMASS(IFP1)
7366 XM2 = PYMASS(IFT1)
7367
7368 ENDIF
7369 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7370 IF (IREJ1.NE.0) THEN
7371 IF (JMSHL.EQ.0) GOTO 9998
7372 JMSHL = 0
7373 GOTO 13
7374 ENDIF
7375 JMSHL = IMSHL
7376 DO 11 I=1,4
7377 PP1(I) = P1(I)
7378 PT1(I) = P2(I)
7379 11 CONTINUE
7380 14 CONTINUE
7381 XM1 = 0.0D0
7382 XM2 = 0.0D0
7383 IF (JMSHL.EQ.1) THEN
7384
7385 XM1 = PYMASS(IFP2)
7386 XM2 = PYMASS(IFT2)
7387
7388 ENDIF
7389 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7390 IF (IREJ1.NE.0) THEN
7391 IF (JMSHL.EQ.0) GOTO 9998
7392 JMSHL = 0
7393 GOTO 14
7394 ENDIF
7395 DO 12 I=1,4
7396 PP2(I) = P1(I)
7397 PT2(I) = P2(I)
7398 12 CONTINUE
7399 DO 15 I=1,4
7400 PP1I(I) = PP1(I)
7401 PP2I(I) = PP2(I)
7402 PT1I(I) = PT1(I)
7403 PT2I(I) = PT2(I)
7404 15 CONTINUE
7405 RETURN
7406
7407 9997 IRCHKI(1) = IRCHKI(1)+1
7408**sr
7409C GOTO 9999
7410 IREJ = -1
7411 RETURN
7412**
7413 9998 IRCHKI(2) = IRCHKI(2)+1
7414
7415 9999 CONTINUE
7416 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7417 IREJ = 1
7418 RETURN
7419 END
7420
7421*$ CREATE DT_CH2RES.FOR
7422*COPY DT_CH2RES
7423*
7424*===ch2res=============================================================*
7425*
7426 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7427 & AM,AMN,IMODE,IREJ)
7428
7429************************************************************************
7430* Check chains for resonance production. *
7431* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7432* input: *
7433* IF1,2,3,4 input flavors (q,aq in any order) *
7434* AM chain mass *
7435* MODE = 1 check q-aq chain for meson-resonance *
7436* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7437* = 3 check qq-aqaq chain for lower mass cut *
7438* output: *
7439* IDR = 0 no resonances found *
7440* = -1 pseudoscalar meson/octet baryon *
7441* = 1 vector-meson/decuplet baryon *
7442* IDXR BAMJET-index of corresponding resonance *
7443* AMN mass of corresponding resonance *
7444* *
7445* IREJ rejection flag *
7446* This version dated 06.01.95 is written by S. Roesler *
7447************************************************************************
7448
7449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7450 SAVE
7451
7452 PARAMETER ( LINP = 10 ,
7453 & LOUT = 6 ,
7454 & LDAT = 9 )
7455
7456* particle properties (BAMJET index convention)
7457 CHARACTER*8 ANAME
7458 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7459 & IICH(210),IIBAR(210),K1(210),K2(210)
7460
7461* quark-content to particle index conversion (DTUNUC 1.x)
7462 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7463 & IA08(6,21),IA10(6,21)
7464
7465* rejection counter
7466 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7467 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7468 & IREXCI(3),IRDIFF(2),IRINC
7469
7470* flags for input different options
7471 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7472 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7473 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7474
7475 DIMENSION IF(4),JF(4)
7476
7477**sr 4.7. test
7478C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7479 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7480**
7481C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7482
7483 MODE = ABS(IMODE)
7484
7485 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7486 WRITE(LOUT,1000) MODE
7487 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7488 & 1X,' program stopped')
7489 STOP
7490 ENDIF
7491
7492 AMX = AM
7493 IREJ = 0
7494 IDR = 0
7495 IDXR = 0
7496 AMN = AMX
7497 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7498 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7499
7500 IF(1) = IF1
7501 IF(2) = IF2
7502 IF(3) = IF3
7503 IF(4) = IF4
7504 NF = 0
7505 DO 100 I=1,4
7506 IF (IF(I).NE.0) THEN
7507 NF = NF+1
7508 JF(NF) = IF(I)
7509 ENDIF
7510 100 CONTINUE
7511 IF (NF.LE.MODE) THEN
7512 WRITE(LOUT,1001) MODE,IF
7513 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7514 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7515 GOTO 9999
7516 ENDIF
7517
7518 GOTO (1,2,3) MODE
7519
7520* check for meson resonance
7521 1 CONTINUE
7522 IFQ = JF(1)
7523 IFAQ = ABS(JF(2))
7524 IF (JF(2).GT.0) THEN
7525 IFQ = JF(2)
7526 IFAQ = ABS(JF(1))
7527 ENDIF
7528 IFPS = IMPS(IFAQ,IFQ)
7529 IFV = IMVE(IFAQ,IFQ)
7530 AMPS = AAM(IFPS)
7531 AMV = AAM(IFV)
7532 AMHI = AMV+0.3D0
7533 IF (AMX.LT.AMV) THEN
7534 IF (AMX.LT.AMPS) THEN
7535 IF (IMODE.GT.0) THEN
7536 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7537 ELSE
7538 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7539 ENDIF
7540 LOMRES = LOMRES+1
7541 ENDIF
7542* replace chain by pseudoscalar meson
7543 IDR = -1
7544 IDXR = IFPS
7545 AMN = AMPS
7546 ELSEIF (AMX.LT.AMHI) THEN
7547* replace chain by vector-meson
7548 IDR = 1
7549 IDXR = IFV
7550 AMN = AMV
7551 ENDIF
7552 RETURN
7553
7554* check for baryon resonance
7555 2 CONTINUE
7556 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7557 AM8 = AAM(JB8)
7558 AM10 = AAM(JB10)
7559 AMHI = AM10+0.3D0
7560 IF (AMX.LT.AM10) THEN
7561 IF (AMX.LT.AM8) THEN
7562 IF (IMODE.GT.0) THEN
7563 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7564 ELSE
7565 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7566 ENDIF
7567 LOBRES = LOBRES+1
7568 ENDIF
7569* replace chain by oktet baryon
7570 IDR = -1
7571 IDXR = JB8
7572 AMN = AM8
7573 ELSEIF (AMX.LT.AMHI) THEN
7574 IDR = 1
7575 IDXR = JB10
7576 AMN = AM10
7577 ENDIF
7578 RETURN
7579
7580* check qq-aqaq for lower mass cut
7581 3 CONTINUE
7582* empirical definition of AMHI to allow for (b-antib)-pair prod.
7583 AMHI = 2.5D0
7584 IF (AMX.LT.AMHI) GOTO 9999
7585 RETURN
7586
7587 9999 CONTINUE
7588 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7589 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7590 IREJ = 1
7591 IRRES(2) = IRRES(2)+1
7592 RETURN
7593 END
7594
7595*$ CREATE DT_RJSEAC.FOR
7596*COPY DT_RJSEAC
7597*
7598*===rjseac=============================================================*
7599*
7600 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7601
7602************************************************************************
7603* ReJection of SEA-sea Chains. *
7604* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7605* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7606* This version dated 16.01.95 is written by S. Roesler *
7607************************************************************************
7608
7609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7610 SAVE
7611
7612 PARAMETER ( LINP = 10 ,
7613 & LOUT = 6 ,
7614 & LDAT = 9 )
7615
7616 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7617
7618* event history
7619
7620 PARAMETER (NMXHKK=200000)
7621
7622 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7623 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7624 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7625
7626* extended event history
7627 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7628 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7629 & IHIST(2,NMXHKK)
7630
7631* statistics
7632 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7633 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7634 & ICEVTG(8,0:30)
7635
7636 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7637
7638 IREJ = 0
7639
7640* projectile sea q-aq-pair
7641* indices of sea-pair
7642 IDXSEA(1,1) = MOP1
7643 IDXSEA(1,2) = MOP2
7644* index of mother-nucleon
7645 IDXNUC(1) = JMOHKK(1,MOP1)
7646* status of valence quarks to be corrected
7647 ISTVAL(1) = -21
7648
7649* target sea q-aq-pair
7650* indices of sea-pair
7651 IDXSEA(2,1) = MOT1
7652 IDXSEA(2,2) = MOT2
7653* index of mother-nucleon
7654 IDXNUC(2) = JMOHKK(1,MOT1)
7655* status of valence quarks to be corrected
7656 ISTVAL(2) = -22
7657
7658 DO 1 N=1,2
7659 IDONE = 0
7660 DO 2 I=NPOINT(2),NHKK
7661 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7662 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7663* valence parton found
7664* inrease 4-momentum by sea 4-momentum
7665 DO 3 K=1,4
7666 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7667 & PHKK(K,IDXSEA(N,2))
7668 3 CONTINUE
7669 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7670 & PHKK(2,I)**2-PHKK(3,I)**2))
7671* "cancel" sea-pair
7672 DO 4 J=1,2
7673 ISTHKK(IDXSEA(N,J)) = 100
7674 IDHKK(IDXSEA(N,J)) = 0
7675 JMOHKK(1,IDXSEA(N,J)) = 0
7676 JMOHKK(2,IDXSEA(N,J)) = 0
7677 JDAHKK(1,IDXSEA(N,J)) = 0
7678 JDAHKK(2,IDXSEA(N,J)) = 0
7679 DO 5 K=1,4
7680 PHKK(K,IDXSEA(N,J)) = ZERO
7681 VHKK(K,IDXSEA(N,J)) = ZERO
7682 WHKK(K,IDXSEA(N,J)) = ZERO
7683 5 CONTINUE
7684 PHKK(5,IDXSEA(N,J)) = ZERO
7685 4 CONTINUE
7686 IDONE = 1
7687 ENDIF
7688 2 CONTINUE
7689 IF (IDONE.NE.1) THEN
7690 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7691 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7692 & '-record!',/,1X,' sea-quark pairs ',
7693 & 2I5,4X,2I5,' could not be canceled!')
7694 GOTO 9999
7695 ENDIF
7696 1 CONTINUE
7697 ICRJSS = ICRJSS+1
7698 RETURN
7699
7700 9999 CONTINUE
7701 IREJ = 1
7702 RETURN
7703 END
7704
7705*$ CREATE DT_VV2SCH.FOR
7706*COPY DT_VV2SCH
7707*
7708*===vv2sch=============================================================*
7709*
7710 SUBROUTINE DT_VV2SCH
7711
7712************************************************************************
7713* Change Valence-Valence chain systems to Single CHain systems for *
7714* hadron-nucleus collisions with meson or antibaryon projectile. *
7715* (Reggeon contribution) *
7716* The single chain system is approximately treated as one chain and a *
7717* meson at rest. *
7718* This version dated 18.01.95 is written by S. Roesler *
7719************************************************************************
7720
7721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7722 SAVE
7723
7724 PARAMETER ( LINP = 10 ,
7725 & LOUT = 6 ,
7726 & LDAT = 9 )
7727
7728 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7729
7730 LOGICAL LSTART
7731
7732* event history
7733
7734 PARAMETER (NMXHKK=200000)
7735
7736 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7737 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7738 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7739
7740* extended event history
7741 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7742 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7743 & IHIST(2,NMXHKK)
7744
7745* flags for input different options
7746 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7747 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7748 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7749
7750* statistics
7751 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7752 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7753 & ICEVTG(8,0:30)
7754
7755 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7756 & PCH2(4)
7757
7758 DATA LSTART /.TRUE./
7759
7760 IFSC = 0
7761 IF (LSTART) THEN
7762 WRITE(LOUT,1000)
7763 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7764 & 'valence chains treated')
7765 LSTART = .FALSE.
7766 ENDIF
7767
7768 NSTOP = NHKK
7769
7770* get index of first chain
7771 DO 1 I=NPOINT(3),NHKK
7772 IF (IDHKK(I).EQ.88888) THEN
7773 NC = I
7774 GOTO 2
7775 ENDIF
7776 1 CONTINUE
7777
7778 2 CONTINUE
7779 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7780 & .AND.(NC.LT.NSTOP)) THEN
7781* get valence-valence chains
7782 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7783* get "mother"-hadron indices
7784 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7785 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7786 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7787 KTARG = IDT_ICIHAD(IDHKK(MO2))
7788* Lab momentum of projectile hadron
7789 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7790 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7791 & PHKK(3,MO1)**2)
7792
7793 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7794 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7795 ICVV2S = ICVV2S+1
7796* single chain requested
7797* get flavors of chain-end partons
7798 MO(1) = JMOHKK(1,NC)
7799 MO(2) = JMOHKK(2,NC)
7800 MO(3) = JMOHKK(1,NC+3)
7801 MO(4) = JMOHKK(2,NC+3)
7802 DO 3 I=1,4
7803 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7804 IF(I,2) = 0
7805 IF (ABS(IDHKK(MO(I))).GE.1000)
7806 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7807 3 CONTINUE
7808* which one is the q-aq chain?
7809* N1,N1+1 - DTEVT1-entries for q-aq system
7810* N2,N2+1 - DTEVT1-entries for the other chain
7811 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7812 K1 = 1
7813 K2 = 3
7814 N1 = NC-2
7815 N2 = NC+1
7816 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7817 K1 = 3
7818 K2 = 1
7819 N1 = NC+1
7820 N2 = NC-2
7821 ELSE
7822 GOTO 10
7823 ENDIF
7824 DO 4 K=1,4
7825 PP1(K) = PHKK(K,N1)
7826 PT1(K) = PHKK(K,N1+1)
7827 PP2(K) = PHKK(K,N2)
7828 PT2(K) = PHKK(K,N2+1)
7829 4 CONTINUE
7830 AMCH1 = PHKK(5,N1+2)
7831 AMCH2 = PHKK(5,N2+2)
7832* get meson-identity corresponding to flavors of q-aq chain
7833 ITMP = IRESRJ
7834 IRESRJ = 0
7835 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7836 & ZERO,AMCH1N,1,IDUM)
7837 IRESRJ = ITMP
7838* change kinematics of chains
7839 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7840 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7841 & AMCH1,AMCH1N,AMCH2,IREJ1)
7842 IF (IREJ1.NE.0) GOTO 10
7843* check second chain for resonance
7844 IDCHAI = 2
7845 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7846 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7847 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7848 IF (IREJ1.NE.0) GOTO 10
7849 IF (IDR2.NE.0) IDR2 = 100*IDR2
7850* add partons and chains to DTEVT1
7851 DO 5 K=1,4
7852 PCH1(K) = PP1(K)+PT1(K)
7853 PCH2(K) = PP2(K)+PT2(K)
7854 5 CONTINUE
7855 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7856 & PP1(3),PP1(4),0,0,0)
7857 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7858 & PT1(2),PT1(3),PT1(4),0,0,0)
7859 KCH = ISTHKK(N1+2)+100
7860 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7861 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7862 IDHKK(N1+2) = 22222
7863 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7864 & PP2(3),PP2(4),0,0,0)
7865 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7866 & PT2(2),PT2(3),PT2(4),0,0,0)
7867 KCH = ISTHKK(N2+2)+100
7868 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7869 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7870 IDHKK(N2+2) = 22222
7871 ENDIF
7872 ENDIF
7873 ELSE
7874 GOTO 11
7875 ENDIF
7876 10 CONTINUE
7877 NC = NC+6
7878 GOTO 2
7879
7880 11 CONTINUE
7881
7882 RETURN
7883 END
7884
7885*$ CREATE DT_PHNSCH.FOR
7886*COPY DT_PHNSCH
7887*
7888*=== phnsch ===========================================================*
7889*
7890 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7891
7892*----------------------------------------------------------------------*
7893* *
7894* Probability for Hadron Nucleon Single CHain interactions: *
7895* *
7896* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7897* Infn - Milan *
7898* *
7899* Last change on 04-jan-94 by Alfredo Ferrari *
7900* *
7901* modified by J.R.for use in DTUNUC 6.1.94 *
7902* *
7903* Input variables: *
7904* Kp = hadron projectile index (Part numbering *
7905* scheme) *
7906* Ktarg = target nucleon index (1=proton, 8=neutron) *
7907* Plab = projectile laboratory momentum (GeV/c) *
7908* Output variable: *
7909* Phnsch = probability per single chain (particle *
7910* exchange) interactions *
7911* *
7912*----------------------------------------------------------------------*
7913
7914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7915 SAVE
7916
7917 PARAMETER ( LUNOUT = 6 )
7918 PARAMETER ( LUNERR = 6 )
7919 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7920 PARAMETER ( ZERZER = 0.D+00 )
7921 PARAMETER ( ONEONE = 1.D+00 )
7922 PARAMETER ( TWOTWO = 2.D+00 )
7923 PARAMETER ( FIVFIV = 5.D+00 )
7924 PARAMETER ( HLFHLF = 0.5D+00 )
7925
7926 PARAMETER ( NALLWP = 39 )
7927 PARAMETER ( IDMAXP = 210 )
7928
7929 DIMENSION ICHRGE(39),AM(39)
7930
7931* particle properties (BAMJET index convention)
7932 CHARACTER*8 ANAME
7933 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7934 & IICH(210),IIBAR(210),K1(210),K2(210)
7935
7936 DIMENSION KPTOIP(210)
7937
7938* auxiliary common for reggeon exchange (DTUNUC 1.x)
7939 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7940 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7941 & IQTCHR(-6:6),MQUARK(3,39)
7942
7943 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7944 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7945 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7946 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7947 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7948
7949* Conversion from part to paprop numbering
7950 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7951 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7952 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7953
7954* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7955 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7956 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7957C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7958 DATA SGTCO1 /
7959* 1st reaction: gamma p total
7960 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7961* 2nd reaction: gamma d total
7962 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7963* 3rd reaction: pi+ p total
7964 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7965* 4th reaction: pi- p total
7966 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7967* 5th reaction: pi+/- d total
7968 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7969* 6th reaction: K+ p total
7970 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7971* 7th reaction: K+ n total
7972 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7973* 8th reaction: K+ d total
7974 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7975* 9th reaction: K- p total
7976 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7977* 10th reaction: K- n total
7978 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7979C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7980 DATA SGTCO2 /
7981* 11th reaction: K- d total
7982 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7983* 12th reaction: p p total
7984 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7985* 13th reaction: p n total
7986 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7987* 14th reaction: p d total
7988 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7989* 15th reaction: pbar p total
7990 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7991* 16th reaction: pbar n total
7992 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7993* 17th reaction: pbar d total
7994 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7995* 18th reaction: Lamda p total
7996 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7997C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7998 DATA SGTCO3 /
7999* 19th reaction: pi+ p elastic
8000 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8001* 20th reaction: pi- p elastic
8002 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8003* 21st reaction: K+ p elastic
8004 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8005* 22nd reaction: K- p elastic
8006 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8007* 23rd reaction: p p elastic
8008 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8009* 24th reaction: p d elastic
8010 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8011* 25th reaction: pbar p elastic
8012 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8013* 26th reaction: pbar p elastic bis
8014 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8015* 27th reaction: pbar n elastic
8016 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8017* 28th reaction: Lamda p elastic
8018 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8019* 29th reaction: K- p ela bis
8020 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8021* 30th reaction: pi- p cx
8022 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8023* 31st reaction: K- p cx
8024 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8025* 32nd reaction: K+ n cx
8026 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8027* 33rd reaction: pbar p cx
8028 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8029*
8030* +-------------------------------------------------------------------*
8031 ICHRGE(KTARG)=IICH(KTARG)
8032 AM (KTARG)=AAM (KTARG)
8033* | Check for pi0 (d-dbar)
8034 IF ( KP .NE. 26 ) THEN
8035 IP = KPTOIP (KP)
8036 IF(IP.EQ.0)IP=1
8037 ICHRGE(IP)=IICH(KP)
8038 AM (IP)=AAM (KP)
8039* |
8040* +-------------------------------------------------------------------*
8041* |
8042 ELSE
8043 IP = 23
8044 ICHRGE(IP)=0
8045 END IF
8046* |
8047* +-------------------------------------------------------------------*
8048* +-------------------------------------------------------------------*
8049* | No such interactions for baryon-baryon
8050 IF ( IIBAR (KP) .GT. 0 ) THEN
8051 DT_PHNSCH = ZERZER
8052 RETURN
8053* |
8054* +-------------------------------------------------------------------*
8055* | No "annihilation" diagram possible for K+ p/n
8056 ELSE IF ( IP .EQ. 15 ) THEN
8057 DT_PHNSCH = ZERZER
8058 RETURN
8059* |
8060* +-------------------------------------------------------------------*
8061* | No "annihilation" diagram possible for K0 p/n
8062 ELSE IF ( IP .EQ. 24 ) THEN
8063 DT_PHNSCH = ZERZER
8064 RETURN
8065* |
8066* +-------------------------------------------------------------------*
8067* | No "annihilation" diagram possible for Omebar p/n
8068 ELSE IF ( IP .GE. 38 ) THEN
8069 DT_PHNSCH = ZERZER
8070 RETURN
8071 END IF
8072* |
8073* +-------------------------------------------------------------------*
8074* +-------------------------------------------------------------------*
8075* | If the momentum is larger than 50 GeV/c, compute the single
8076* | chain probability at 50 GeV/c and extrapolate to the present
8077* | momentum according to 1/sqrt(s)
8078* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8079* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8080* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8081* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8082* | x sqrt(s/s(50))
8083* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8084 IF ( PLAB .GT. 50.D+00 ) THEN
8085 PLA = 50.D+00
8086 AMPSQ = AM (IP)**2
8087 AMTSQ = AM (KTARG)**2
8088 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8089 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8090 EPROJ = SQRT ( PLA**2 + AMPSQ )
8091 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8092 UMORAT = SQRT ( UMOSQ / UMO50 )
8093* |
8094* +-------------------------------------------------------------------*
8095* | P < 3 GeV/c
8096 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8097 PLA = 3.D+00
8098 AMPSQ = AM (IP)**2
8099 AMTSQ = AM (KTARG)**2
8100 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8101 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8102 EPROJ = SQRT ( PLA**2 + AMPSQ )
8103 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8104 UMORAT = SQRT ( UMOSQ / UMO50 )
8105* |
8106* +-------------------------------------------------------------------*
8107* | P < 50 GeV/c
8108 ELSE
8109 PLA = PLAB
8110 UMORAT = ONEONE
8111 END IF
8112* |
8113* +-------------------------------------------------------------------*
8114 ALGPLA = LOG (PLA)
8115* +-------------------------------------------------------------------*
8116* | Pions:
8117 IF ( IHLP (IP) .EQ. 2 ) THEN
8118 ACOF = SGTCOE (1,3)
8119 BCOF = SGTCOE (2,3)
8120 ENNE = SGTCOE (3,3)
8121 CCOF = SGTCOE (4,3)
8122 DCOF = SGTCOE (5,3)
8123* | Compute the pi+ p total cross section:
8124 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8125 & + DCOF * ALGPLA
8126 ACOF = SGTCOE (1,19)
8127 BCOF = SGTCOE (2,19)
8128 ENNE = SGTCOE (3,19)
8129 CCOF = SGTCOE (4,19)
8130 DCOF = SGTCOE (5,19)
8131* | Compute the pi+ p elastic cross section:
8132 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8133 & + DCOF * ALGPLA
8134* | Compute the pi+ p inelastic cross section:
8135 SPPPIN = SPPPTT - SPPPEL
8136 ACOF = SGTCOE (1,4)
8137 BCOF = SGTCOE (2,4)
8138 ENNE = SGTCOE (3,4)
8139 CCOF = SGTCOE (4,4)
8140 DCOF = SGTCOE (5,4)
8141* | Compute the pi- p total cross section:
8142 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8143 & + DCOF * ALGPLA
8144 ACOF = SGTCOE (1,20)
8145 BCOF = SGTCOE (2,20)
8146 ENNE = SGTCOE (3,20)
8147 CCOF = SGTCOE (4,20)
8148 DCOF = SGTCOE (5,20)
8149* | Compute the pi- p elastic cross section:
8150 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8151 & + DCOF * ALGPLA
8152* | Compute the pi- p inelastic cross section:
8153 SPMPIN = SPMPTT - SPMPEL
8154 SIGDIA = SPMPIN - SPPPIN
8155* | +----------------------------------------------------------------*
8156* | | Charged pions: besides isospin consideration it is supposed
8157* | | that (pi+ n)el is almost equal to (pi- p)el
8158* | | and (pi+ p)el " " " " (pi- n)el
8159* | | and all are almost equal among each others
8160* | | (reasonable above 5 GeV/c)
8161 IF ( ICHRGE (IP) .NE. 0 ) THEN
8162 KHELP = KTARG / 8
8163 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8164 ACOF = SGTCOE (1,JREAC)
8165 BCOF = SGTCOE (2,JREAC)
8166 ENNE = SGTCOE (3,JREAC)
8167 CCOF = SGTCOE (4,JREAC)
8168 DCOF = SGTCOE (5,JREAC)
8169* | | Compute the total cross section:
8170 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8171 & + DCOF * ALGPLA
8172 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8173 ACOF = SGTCOE (1,JREAC)
8174 BCOF = SGTCOE (2,JREAC)
8175 ENNE = SGTCOE (3,JREAC)
8176 CCOF = SGTCOE (4,JREAC)
8177 DCOF = SGTCOE (5,JREAC)
8178* | | Compute the elastic cross section:
8179 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8180 & + DCOF * ALGPLA
8181* | | Compute the inelastic cross section:
8182 SHNCIN = SHNCTT - SHNCEL
8183* | | Number of diagrams:
8184 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8185* | | Now compute the chain end (anti)quark-(anti)diquark
8186 IQFSC1 = 1 + IP - 13
8187 IQFSC2 = 0
8188 IQBSC1 = 1 + KHELP
8189 IQBSC2 = 1 + IP - 13
8190* | |
8191* | +----------------------------------------------------------------*
8192* | | pi0: besides isospin consideration it is supposed that the
8193* | | elastic cross section is not very different from
8194* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8195 ELSE
8196 KHELP = KTARG / 8
8197 K2HLP = ( KP - 23 ) / 3
8198* | | Number of diagrams:
8199* | | For u ubar (k2hlp=0):
8200* NDIAGR = 2 - KHELP
8201* | | For d dbar (k2hlp=1):
8202* NDIAGR = 2 + KHELP - K2HLP
8203 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8204 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8205* | | Now compute the chain end (anti)quark-(anti)diquark
8206 IQFSC1 = 1 + K2HLP
8207 IQFSC2 = 0
8208 IQBSC1 = 1 + KHELP
8209 IQBSC2 = 2 - K2HLP
8210 END IF
8211* | |
8212* | +----------------------------------------------------------------*
8213* | end pi's
8214* +-------------------------------------------------------------------*
8215* | Kaons:
8216 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8217 ACOF = SGTCOE (1,6)
8218 BCOF = SGTCOE (2,6)
8219 ENNE = SGTCOE (3,6)
8220 CCOF = SGTCOE (4,6)
8221 DCOF = SGTCOE (5,6)
8222* | Compute the K+ p total cross section:
8223 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8224 & + DCOF * ALGPLA
8225 ACOF = SGTCOE (1,21)
8226 BCOF = SGTCOE (2,21)
8227 ENNE = SGTCOE (3,21)
8228 CCOF = SGTCOE (4,21)
8229 DCOF = SGTCOE (5,21)
8230* | Compute the K+ p elastic cross section:
8231 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8232 & + DCOF * ALGPLA
8233* | Compute the K+ p inelastic cross section:
8234 SKPPIN = SKPPTT - SKPPEL
8235 ACOF = SGTCOE (1,9)
8236 BCOF = SGTCOE (2,9)
8237 ENNE = SGTCOE (3,9)
8238 CCOF = SGTCOE (4,9)
8239 DCOF = SGTCOE (5,9)
8240* | Compute the K- p total cross section:
8241 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8242 & + DCOF * ALGPLA
8243 ACOF = SGTCOE (1,22)
8244 BCOF = SGTCOE (2,22)
8245 ENNE = SGTCOE (3,22)
8246 CCOF = SGTCOE (4,22)
8247 DCOF = SGTCOE (5,22)
8248* | Compute the K- p elastic cross section:
8249 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8250 & + DCOF * ALGPLA
8251* | Compute the K- p inelastic cross section:
8252 SKMPIN = SKMPTT - SKMPEL
8253 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8254* | +----------------------------------------------------------------*
8255* | | Charged Kaons: actually only K-
8256 IF ( ICHRGE (IP) .NE. 0 ) THEN
8257 KHELP = KTARG / 8
8258* | | +-------------------------------------------------------------*
8259* | | | Proton target:
8260 IF ( KHELP .EQ. 0 ) THEN
8261 SHNCIN = SKMPIN
8262* | | | Number of diagrams:
8263 NDIAGR = 2
8264* | | |
8265* | | +-------------------------------------------------------------*
8266* | | | Neutron target: besides isospin consideration it is supposed
8267* | | | that (K- n)el is almost equal to (K- p)el
8268* | | | (reasonable above 5 GeV/c)
8269 ELSE
8270 ACOF = SGTCOE (1,10)
8271 BCOF = SGTCOE (2,10)
8272 ENNE = SGTCOE (3,10)
8273 CCOF = SGTCOE (4,10)
8274 DCOF = SGTCOE (5,10)
8275* | | | Compute the total cross section:
8276 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8277 & + DCOF * ALGPLA
8278* | | | Compute the elastic cross section:
8279 SHNCEL = SKMPEL
8280* | | | Compute the inelastic cross section:
8281 SHNCIN = SHNCTT - SHNCEL
8282* | | | Number of diagrams:
8283 NDIAGR = 1
8284 END IF
8285* | | |
8286* | | +-------------------------------------------------------------*
8287* | | Now compute the chain end (anti)quark-(anti)diquark
8288 IQFSC1 = 3
8289 IQFSC2 = 0
8290 IQBSC1 = 1 + KHELP
8291 IQBSC2 = 2
8292* | |
8293* | +----------------------------------------------------------------*
8294* | | K0's: (actually only K0bar)
8295 ELSE
8296 KHELP = KTARG / 8
8297* | | +-------------------------------------------------------------*
8298* | | | Proton target: (K0bar p)in supposed to be given by
8299* | | | (K- p)in - Sig_diagr
8300 IF ( KHELP .EQ. 0 ) THEN
8301 SHNCIN = SKMPIN - SIGDIA
8302* | | | Number of diagrams:
8303 NDIAGR = 1
8304* | | |
8305* | | +-------------------------------------------------------------*
8306* | | | Neutron target: (K0bar n)in supposed to be given by
8307* | | | (K- n)in + Sig_diagr
8308* | | | besides isospin consideration it is supposed
8309* | | | that (K- n)el is almost equal to (K- p)el
8310* | | | (reasonable above 5 GeV/c)
8311 ELSE
8312 ACOF = SGTCOE (1,10)
8313 BCOF = SGTCOE (2,10)
8314 ENNE = SGTCOE (3,10)
8315 CCOF = SGTCOE (4,10)
8316 DCOF = SGTCOE (5,10)
8317* | | | Compute the total cross section:
8318 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8319 & + DCOF * ALGPLA
8320* | | | Compute the elastic cross section:
8321 SHNCEL = SKMPEL
8322* | | | Compute the inelastic cross section:
8323 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8324* | | | Number of diagrams:
8325 NDIAGR = 2
8326 END IF
8327* | | |
8328* | | +-------------------------------------------------------------*
8329* | | Now compute the chain end (anti)quark-(anti)diquark
8330 IQFSC1 = 3
8331 IQFSC2 = 0
8332 IQBSC1 = 1
8333 IQBSC2 = 1 + KHELP
8334 END IF
8335* | |
8336* | +----------------------------------------------------------------*
8337* | end Kaon's
8338* +-------------------------------------------------------------------*
8339* | Antinucleons:
8340 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8341* | For momenta between 3 and 5 GeV/c the use of tabulated data
8342* | should be implemented!
8343 ACOF = SGTCOE (1,15)
8344 BCOF = SGTCOE (2,15)
8345 ENNE = SGTCOE (3,15)
8346 CCOF = SGTCOE (4,15)
8347 DCOF = SGTCOE (5,15)
8348* | Compute the pbar p total cross section:
8349 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8350 & + DCOF * ALGPLA
8351 IF ( PLA .LT. FIVFIV ) THEN
8352 JREAC = 26
8353 ELSE
8354 JREAC = 25
8355 END IF
8356 ACOF = SGTCOE (1,JREAC)
8357 BCOF = SGTCOE (2,JREAC)
8358 ENNE = SGTCOE (3,JREAC)
8359 CCOF = SGTCOE (4,JREAC)
8360 DCOF = SGTCOE (5,JREAC)
8361* | Compute the pbar p elastic cross section:
8362 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8363 & + DCOF * ALGPLA
8364* | Compute the pbar p inelastic cross section:
8365 SAPPIN = SAPPTT - SAPPEL
8366 ACOF = SGTCOE (1,12)
8367 BCOF = SGTCOE (2,12)
8368 ENNE = SGTCOE (3,12)
8369 CCOF = SGTCOE (4,12)
8370 DCOF = SGTCOE (5,12)
8371* | Compute the p p total cross section:
8372 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8373 & + DCOF * ALGPLA
8374 ACOF = SGTCOE (1,23)
8375 BCOF = SGTCOE (2,23)
8376 ENNE = SGTCOE (3,23)
8377 CCOF = SGTCOE (4,23)
8378 DCOF = SGTCOE (5,23)
8379* | Compute the p p elastic cross section:
8380 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8381 & + DCOF * ALGPLA
8382* | Compute the K- p inelastic cross section:
8383 SPPINE = SPPTOT - SPPELA
8384 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8385 KHELP = KTARG / 8
8386* | +----------------------------------------------------------------*
8387* | | Pbar:
8388 IF ( ICHRGE (IP) .NE. 0 ) THEN
8389 NDIAGR = 5 - KHELP
8390* | | +-------------------------------------------------------------*
8391* | | | Proton target:
8392 IF ( KHELP .EQ. 0 ) THEN
8393* | | | Number of diagrams:
8394 SHNCIN = SAPPIN
8395 PUUBAR = 0.8D+00
8396* | | |
8397* | | +-------------------------------------------------------------*
8398* | | | Neutron target: it is supposed that (ap n)el is almost equal
8399* | | | to (ap p)el (reasonable above 5 GeV/c)
8400 ELSE
8401 ACOF = SGTCOE (1,16)
8402 BCOF = SGTCOE (2,16)
8403 ENNE = SGTCOE (3,16)
8404 CCOF = SGTCOE (4,16)
8405 DCOF = SGTCOE (5,16)
8406* | | | Compute the total cross section:
8407 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8408 & + DCOF * ALGPLA
8409* | | | Compute the elastic cross section:
8410 SHNCEL = SAPPEL
8411* | | | Compute the inelastic cross section:
8412 SHNCIN = SHNCTT - SHNCEL
8413 PUUBAR = HLFHLF
8414 END IF
8415* | | |
8416* | | +-------------------------------------------------------------*
8417* | | Now compute the chain end (anti)quark-(anti)diquark
8418* | | there are different possibilities, make a random choiche:
8419 IQFSC1 = -1
8420 RNCHEN = DT_RNDM(PUUBAR)
8421 IF ( RNCHEN .LT. PUUBAR ) THEN
8422 IQFSC2 = -2
8423 ELSE
8424 IQFSC2 = -1
8425 END IF
8426 IQBSC1 = -IQFSC1 + KHELP
8427 IQBSC2 = -IQFSC2
8428* | |
8429* | +----------------------------------------------------------------*
8430* | | nbar:
8431 ELSE
8432 NDIAGR = 4 + KHELP
8433* | | +-------------------------------------------------------------*
8434* | | | Proton target: (nbar p)in supposed to be given by
8435* | | | (pbar p)in - Sig_diagr
8436 IF ( KHELP .EQ. 0 ) THEN
8437 SHNCIN = SAPPIN - SIGDIA
8438 PDDBAR = HLFHLF
8439* | | |
8440* | | +-------------------------------------------------------------*
8441* | | | Neutron target: (nbar n)el is supposed to be equal to
8442* | | | (pbar p)el (reasonable above 5 GeV/c)
8443 ELSE
8444* | | | Compute the total cross section:
8445 SHNCTT = SAPPTT
8446* | | | Compute the elastic cross section:
8447 SHNCEL = SAPPEL
8448* | | | Compute the inelastic cross section:
8449 SHNCIN = SHNCTT - SHNCEL
8450 PDDBAR = 0.8D+00
8451 END IF
8452* | | |
8453* | | +-------------------------------------------------------------*
8454* | | Now compute the chain end (anti)quark-(anti)diquark
8455* | | there are different possibilities, make a random choiche:
8456 IQFSC1 = -2
8457 RNCHEN = DT_RNDM(RNCHEN)
8458 IF ( RNCHEN .LT. PDDBAR ) THEN
8459 IQFSC2 = -1
8460 ELSE
8461 IQFSC2 = -2
8462 END IF
8463 IQBSC1 = -IQFSC1 + KHELP - 1
8464 IQBSC2 = -IQFSC2
8465 END IF
8466* | |
8467* | +----------------------------------------------------------------*
8468* |
8469* +-------------------------------------------------------------------*
8470* | Others: not yet implemented
8471 ELSE
8472 SIGDIA = ZERZER
8473 SHNCIN = ONEONE
8474 NDIAGR = 0
8475 DT_PHNSCH = ZERZER
8476 RETURN
8477 END IF
8478* | end others
8479* +-------------------------------------------------------------------*
8480 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8481 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8482 & + IQECHR (IQBSC2)
8483 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8484 & + IQBCHR (IQBSC2)
8485 IQECHC = IQECHC / 3
8486 IQBCHC = IQBCHC / 3
8487 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8488 & + IQSCHR (IQBSC2)
8489 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8490 & + IQSCHR (MQUARK(3,IP))
8491* +-------------------------------------------------------------------*
8492* | Consistency check:
8493 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8494 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8495 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8496 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8497 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8498 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8499 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8500 END IF
8501* |
8502* +-------------------------------------------------------------------*
8503* +-------------------------------------------------------------------*
8504* | Consistency check:
8505 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8506 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8507 WRITE (LUNOUT,*)
8508 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8509 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8510 WRITE (LUNERR,*)
8511 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8512 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8513 END IF
8514* |
8515* +-------------------------------------------------------------------*
8516* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8517 IF ( UMORAT .GT. ONEPLS )
8518 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8519 & - ONEONE ) * UMORAT + ONEONE )
8520 RETURN
8521*
8522 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8523 DT_SCHQUA = ONEONE
8524 JQFSC1 = IQFSC1
8525 JQFSC2 = IQFSC2
8526 JQBSC1 = IQBSC1
8527 JQBSC2 = IQBSC2
8528*=== End of function Phnsch ===========================================*
8529 RETURN
8530 END
8531
8532*$ CREATE DT_RESPT.FOR
8533*COPY DT_RESPT
8534*
8535*===respt==============================================================*
8536*
8537 SUBROUTINE DT_RESPT
8538
8539************************************************************************
8540* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8541* This version dated 18.01.95 is written by S. Roesler *
8542************************************************************************
8543
8544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8545 SAVE
8546
8547 PARAMETER ( LINP = 10 ,
8548 & LOUT = 6 ,
8549 & LDAT = 9 )
8550
8551 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8552
8553* event history
8554
8555 PARAMETER (NMXHKK=200000)
8556
8557 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8558 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8559 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8560
8561* extended event history
8562 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8563 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8564 & IHIST(2,NMXHKK)
8565
8566* get index of first chain
8567 DO 1 I=NPOINT(3),NHKK
8568 IF (IDHKK(I).EQ.88888) THEN
8569 NC = I
8570 GOTO 2
8571 ENDIF
8572 1 CONTINUE
8573
8574 2 CONTINUE
8575 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8576C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8577* skip VV-,SS- systems
8578 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8579 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8580* check if both "chains" are resonances
8581 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8582 CALL DT_SAPTRE(NC,NC+3)
8583 ENDIF
8584 ENDIF
8585 ELSE
8586 GOTO 3
8587 ENDIF
8588 NC = NC+6
8589 GOTO 2
8590
8591 3 CONTINUE
8592
8593 RETURN
8594 END
8595
8596*$ CREATE DT_EVTRES.FOR
8597*COPY DT_EVTRES
8598*
8599*===evtres=============================================================*
8600*
8601 SUBROUTINE DT_EVTRES(IREJ)
8602
8603************************************************************************
8604* This version dated 14.12.94 is written by S. Roesler *
8605************************************************************************
8606
8607 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8608 SAVE
8609
8610 PARAMETER ( LINP = 10 ,
8611 & LOUT = 6 ,
8612 & LDAT = 9 )
8613
8614 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8615
8616* event history
8617
8618 PARAMETER (NMXHKK=200000)
8619
8620 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8621 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8622 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8623
8624* extended event history
8625 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8626 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8627 & IHIST(2,NMXHKK)
8628
8629* flags for input different options
8630 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8631 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8632 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8633
8634* particle properties (BAMJET index convention)
8635 CHARACTER*8 ANAME
8636 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8637 & IICH(210),IIBAR(210),K1(210),K2(210)
8638
8639 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8640
8641 IREJ = 0
8642
8643 DO 1 I=NPOINT(3),NHKK
8644 IF (ABS(IDRES(I)).GE.100) THEN
8645 AMMX = 0.0D0
8646 DO 2 J=NPOINT(3),NHKK
8647 IF (IDHKK(J).EQ.88888) THEN
8648 IF (PHKK(5,J).GT.AMMX) THEN
8649 AMMX = PHKK(5,J)
8650 IMMX = J
8651 ENDIF
8652 ENDIF
8653 2 CONTINUE
8654 IF (IDRES(IMMX).NE.0) THEN
8655 IF (IOULEV(3).GT.0) THEN
8656 WRITE(LOUT,'(1X,A)')
8657 & 'EVTRES: no chain for correc. found'
8658C GOTO 6
8659 GOTO 9999
8660 ELSE
8661 GOTO 9999
8662 ENDIF
8663 ENDIF
8664 IMO11 = JMOHKK(1,I)
8665 IMO12 = JMOHKK(2,I)
8666 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8667 IMO11 = JMOHKK(2,I)
8668 IMO12 = JMOHKK(1,I)
8669 ENDIF
8670 IMO21 = JMOHKK(1,IMMX)
8671 IMO22 = JMOHKK(2,IMMX)
8672 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8673 IMO21 = JMOHKK(2,IMMX)
8674 IMO22 = JMOHKK(1,IMMX)
8675 ENDIF
8676 AMCH1 = PHKK(5,I)
8677 AMCH1N = AAM(IDXRES(I))
8678
8679 IFPR1 = IDHKK(IMO11)
8680 IFPR2 = IDHKK(IMO21)
8681 IFTA1 = IDHKK(IMO12)
8682 IFTA2 = IDHKK(IMO22)
8683 DO 4 J=1,4
8684 PP1(J) = PHKK(J,IMO11)
8685 PP2(J) = PHKK(J,IMO21)
8686 PT1(J) = PHKK(J,IMO12)
8687 PT2(J) = PHKK(J,IMO22)
8688 4 CONTINUE
8689* store initial configuration for energy-momentum cons. check
8690 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8691* correct kinematics of second chain
8692 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8693 & AMCH1,AMCH1N,AMCH2,IREJ1)
8694 IF (IREJ1.NE.0) GOTO 9999
8695* check now this chain for resonance mass
8696 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8697 IFP(2) = 0
8698 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8699 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8700 IFT(2) = 0
8701 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8702 IDCH2 = 2
8703 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8704 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8705 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8706 & AMCH2,AMCH2N,IDCH2,IREJ1)
8707 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8708 IF (IOULEV(1).GT.0)
8709 & WRITE(LOUT,*) ' correction for resonance not poss.'
8710**sr test
8711C GOTO 1
8712C GOTO 9999
8713**
8714 ENDIF
8715* store final configuration for energy-momentum cons. check
8716 IF (LEMCCK) THEN
8717 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8718 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8719 IF (IREJ1.NE.0) GOTO 9999
8720 ENDIF
8721 DO 5 J=1,4
8722 PHKK(J,IMO11) = PP1(J)
8723 PHKK(J,IMO21) = PP2(J)
8724 PHKK(J,IMO12) = PT1(J)
8725 PHKK(J,IMO22) = PT2(J)
8726 5 CONTINUE
8727* correct entries of chains
8728 DO 3 K=1,4
8729 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8730 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8731 3 CONTINUE
8732 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8733 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8734 & PHKK(3,IMMX)**2
8735* ?? the following should now be obsolete
8736**sr test
8737C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8738 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8739**
8740 WRITE(LOUT,'(1X,A,4G10.3)')
8741 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8742C GOTO 9999
8743 GOTO 1
8744 ENDIF
8745 PHKK(5,I) = SQRT(AM1)
8746 PHKK(5,IMMX) = SQRT(AM2)
8747 IDRES(I) = IDRES(I)/100
8748 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8749 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8750 WRITE(LOUT,'(1X,A,4G10.3)')
8751 & 'EVTRES: inconsistent chain-masses',
8752 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8753 GOTO 9999
8754 ENDIF
8755 ENDIF
8756 1 CONTINUE
8757 6 CONTINUE
8758 RETURN
8759
8760 9999 CONTINUE
8761 IREJ = 1
8762 RETURN
8763 END
8764
8765*$ CREATE DT_GETSPT.FOR
8766*COPY DT_GETSPT
8767*
8768*===getspt=============================================================*
8769*
8770 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8771 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8772 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8773
8774************************************************************************
8775* This version dated 12.12.94 is written by S. Roesler *
8776************************************************************************
8777
8778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8779 SAVE
8780
8781 PARAMETER ( LINP = 10 ,
8782 & LOUT = 6 ,
8783 & LDAT = 9 )
8784
8785 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8786
8787* various options for treatment of partons (DTUNUC 1.x)
8788* (chain recombination, Cronin,..)
8789 LOGICAL LCO2CR,LINTPT
8790 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8791 & LCO2CR,LINTPT
8792
8793* flags for input different options
8794 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8795 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8796 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8797
8798* flags for diffractive interactions (DTUNUC 1.x)
8799 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8800
8801 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8802 & PT2(4),PT2I(4),P1(4),P2(4),
8803 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8804 & PTOTI(4),PTOTF(4),DIFF(4)
8805
8806 IC = 0
8807 IREJ = 0
8808C B33P = 4.0D0
8809C B33T = 4.0D0
8810C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8811C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8812 REDU = 1.0D0
8813C B33P = 3.5D0
8814C B33T = 3.5D0
8815 B33P = 4.0D0
8816 B33T = 4.0D0
8817 IF (IDIFF.NE.0) THEN
8818 B33P = 16.0D0
8819 B33T = 16.0D0
8820 ENDIF
8821
8822 DO 1 I=1,4
8823 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8824 PP1(I) = PP1I(I)
8825 PP2(I) = PP2I(I)
8826 PT1(I) = PT1I(I)
8827 PT2(I) = PT2I(I)
8828 1 CONTINUE
8829* get initial chain masses
8830 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8831 & +(PP1(3)+PT1(3))**2)
8832 ECH = PP1(4)+PT1(4)
8833 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8834 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8835 & +(PP2(3)+PT2(3))**2)
8836 ECH = PP2(4)+PT2(4)
8837 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8838 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8839 IF (IOULEV(1).GT.0)
8840 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8841 & AM1,AM2
8842 GOTO 9999
8843 ENDIF
8844 AM1 = SQRT(AM1)
8845 AM2 = SQRT(AM2)
8846 AM1N = ZERO
8847 AM2N = ZERO
8848
8849 MODE = 0
8850C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8851C MODE = 0
8852C ELSE
8853C MODE = 1
8854C IF (AM1.LT.0.6) THEN
8855C B33P = 10.0D0
8856C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8857CC B33P = 4.0D0
8858C ENDIF
8859C IF (AM2.LT.0.6) THEN
8860C B33T = 10.0D0
8861C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8862CC B33T = 4.0D0
8863C ENDIF
8864C ENDIF
8865
8866* check chain masses for very low mass chains
8867C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8868C & AM1,DUM,-IDCH1,IREJ1)
8869C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8870C & AM2,DUM,-IDCH2,IREJ2)
8871C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8872C B33P = 20.0D0
8873C B33T = 20.0D0
8874C ENDIF
8875
8876 JMSHL = IMSHL
8877
8878 2 CONTINUE
8879 IC = IC+1
8880 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8881 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8882 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8883C IF (MOD(IC,19).EQ.0) JMSHL = 0
8884 IF (MOD(IC,20).EQ.0) GOTO 7
8885C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8886C RETURN
8887C GOTO 9999
8888C ENDIF
8889
8890* get transverse momentum
8891 IF (LINTPT) THEN
8892 ES = -2.0D0/(B33P**2)
8893 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8894 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8895 HPSP = HPSP*REDU
8896 ES = -2.0D0/(B33T**2)
8897 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8898 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8899 HPST = HPST*REDU
8900 ELSE
8901 HPSP = ZERO
8902 HPST = ZERO
8903 ENDIF
8904 CALL DT_DSFECF(SFE1,CFE1)
8905 CALL DT_DSFECF(SFE2,CFE2)
8906 IF (MODE.EQ.0) THEN
8907 PP1(1) = PP1I(1)+HPSP*CFE1
8908 PP1(2) = PP1I(2)+HPSP*SFE1
8909 PP2(1) = PP2I(1)-HPSP*CFE1
8910 PP2(2) = PP2I(2)-HPSP*SFE1
8911 PT1(1) = PT1I(1)+HPST*CFE2
8912 PT1(2) = PT1I(2)+HPST*SFE2
8913 PT2(1) = PT2I(1)-HPST*CFE2
8914 PT2(2) = PT2I(2)-HPST*SFE2
8915 ELSE
8916 PP1(1) = PP1I(1)+HPSP*CFE1
8917 PP1(2) = PP1I(2)+HPSP*SFE1
8918 PT1(1) = PT1I(1)-HPSP*CFE1
8919 PT1(2) = PT1I(2)-HPSP*SFE1
8920 PP2(1) = PP2I(1)+HPST*CFE2
8921 PP2(2) = PP2I(2)+HPST*SFE2
8922 PT2(1) = PT2I(1)-HPST*CFE2
8923 PT2(2) = PT2I(2)-HPST*SFE2
8924 ENDIF
8925
8926* put partons on mass shell
8927 XMP1 = 0.0D0
8928 XMT1 = 0.0D0
8929 IF (JMSHL.EQ.1) THEN
8930
8931 XMP1 = PYMASS(IFPR1)
8932 XMT1 = PYMASS(IFTA1)
8933
8934 ENDIF
8935 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8936 IF (IREJ1.NE.0) GOTO 2
8937 DO 3 I=1,4
8938 PTOTF(I) = P1(I)+P2(I)
8939 PP1(I) = P1(I)
8940 PT1(I) = P2(I)
8941 3 CONTINUE
8942 XMP2 = 0.0D0
8943 XMT2 = 0.0D0
8944 IF (JMSHL.EQ.1) THEN
8945
8946 XMP2 = PYMASS(IFPR2)
8947 XMT2 = PYMASS(IFTA2)
8948
8949 ENDIF
8950 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8951 IF (IREJ1.NE.0) GOTO 2
8952 DO 4 I=1,4
8953 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8954 PP2(I) = P1(I)
8955 PT2(I) = P2(I)
8956 4 CONTINUE
8957
8958* check consistency
8959 DO 5 I=1,4
8960 DIFF(I) = PTOTI(I)-PTOTF(I)
8961 5 CONTINUE
8962 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8963 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8964 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8965 GOTO 9999
8966 ENDIF
8967 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8968 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8969 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8970 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8971 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8972 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8973 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8974 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8975 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8976 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8977 & THEN
8978 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8979 & 'GETSPT: inconsistent masses',
8980 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8981* sr 22.11.00: commented. It should only have inconsistent masses for
8982* ultrahigh energies due to rounding problems
8983C GOTO 9999
8984 ENDIF
8985
8986* get chain masses
8987 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8988 & +(PP1(3)+PT1(3))**2)
8989 ECH = PP1(4)+PT1(4)
8990 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8991 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8992 & +(PP2(3)+PT2(3))**2)
8993 ECH = PP2(4)+PT2(4)
8994 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8995 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8996 IF (IOULEV(1).GT.0)
8997 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8998 & AM1N,AM2N
8999 GOTO 2
9000 ENDIF
9001 AM1N = SQRT(AM1N)
9002 AM2N = SQRT(AM2N)
9003
9004* check chain masses for very low mass chains
9005 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9006 & AM1N,DUM,-IDCH1,IREJ1)
9007 IF (IREJ1.NE.0) GOTO 2
9008 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9009 & AM2N,DUM,-IDCH2,IREJ2)
9010 IF (IREJ2.NE.0) GOTO 2
9011
9012 7 CONTINUE
9013 IF (AM1N.GT.ZERO) THEN
9014 AM1 = AM1N
9015 AM2 = AM2N
9016 ENDIF
9017 DO 6 I=1,4
9018 PP1I(I) = PP1(I)
9019 PP2I(I) = PP2(I)
9020 PT1I(I) = PT1(I)
9021 PT2I(I) = PT2(I)
9022 6 CONTINUE
9023
9024 RETURN
9025
9026 9999 CONTINUE
9027 IREJ = 1
9028 RETURN
9029 END
9030
9031*$ CREATE DT_SAPTRE.FOR
9032*COPY DT_SAPTRE
9033*
9034*===saptre=============================================================*
9035*
9036 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9037
9038************************************************************************
9039* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9040* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9041* Adopted from the original SAPTRE written by J. Ranft. *
9042* This version dated 18.01.95 is written by S. Roesler *
9043************************************************************************
9044
9045 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9046 SAVE
9047
9048 PARAMETER ( LINP = 10 ,
9049 & LOUT = 6 ,
9050 & LDAT = 9 )
9051
9052 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9053
9054* event history
9055
9056 PARAMETER (NMXHKK=200000)
9057
9058 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9059 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9060 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9061
9062* extended event history
9063 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9064 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9065 & IHIST(2,NMXHKK)
9066
9067* flags for input different options
9068 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9069 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9070 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9071
9072 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9073
9074 DATA B3 /4.0D0/
9075
9076 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9077 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9078 ESMAX = MIN(ESMAX1,ESMAX2)
9079 IF (ESMAX.LE.0.05D0) RETURN
9080
9081 HMA = PHKK(5,IDX1)
9082 DO 1 K=1,4
9083 PA1(K) = PHKK(K,IDX1)
9084 PA2(K) = PHKK(K,IDX2)
9085 1 CONTINUE
9086
9087 IF (LEMCCK) THEN
9088 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9089 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9090 ENDIF
9091
9092 EXEB = 0.0D0
9093 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9094 BEXP = HMA*(1.0D0-EXEB)/B3
9095 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9096 WA = AXEXP/(BEXP+AXEXP)
9097 XAB = DT_RNDM(WA)
9098 10 CONTINUE
9099* ES is the transverse kinetic energy
9100 IF (XAB.LT.WA)THEN
9101 X = DT_RNDM(WA)
9102 Y = DT_RNDM(WA)
9103 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9104 ELSE
9105 X = DT_RNDM(Y)
9106 ES = ABS(-LOG(X+TINY7)/B3)
9107 ENDIF
9108 IF (ES.GT.ESMAX) GOTO 10
9109 ES = ES+HMA
9110* transverse momentum
9111 HPS = SQRT((ES-HMA)*(ES+HMA))
9112
9113 CALL DT_DSFECF(SFE,CFE)
9114 HPX = HPS*CFE
9115 HPY = HPS*SFE
9116 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9117 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9118 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9119
9120C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9121C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9122 PA1(1) = PA1(1)+HPX
9123 PA1(2) = PA1(2)+HPY
9124 PA2(1) = PA2(1)-HPX
9125 PA2(2) = PA2(2)-HPY
9126
9127* put resonances on mass-shell again
9128 XM1 = PHKK(5,IDX1)
9129 XM2 = PHKK(5,IDX2)
9130 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9131 IF (IREJ1.NE.0) RETURN
9132
9133 IF (LEMCCK) THEN
9134 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9135 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9136 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9137 IF (IREJ1.NE.0) RETURN
9138 ENDIF
9139
9140 DO 2 K=1,4
9141 PHKK(K,IDX1) = P1(K)
9142 PHKK(K,IDX2) = P2(K)
9143 2 CONTINUE
9144
9145 RETURN
9146 END
9147
9148*$ CREATE DT_CRONIN.FOR
9149*COPY DT_CRONIN
9150*
9151*===cronin=============================================================*
9152*
9153 SUBROUTINE DT_CRONIN(INCL)
9154
9155************************************************************************
9156* Cronin-Effect. Multiple scattering of partons at chain ends. *
9157* INCL = 1 multiple sc. in projectile *
9158* = 2 multiple sc. in target *
9159* This version dated 05.01.96 is written by S. Roesler. *
9160************************************************************************
9161
9162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9163 SAVE
9164
9165 PARAMETER ( LINP = 10 ,
9166 & LOUT = 6 ,
9167 & LDAT = 9 )
9168
9169 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9170
9171* event history
9172
9173 PARAMETER (NMXHKK=200000)
9174
9175 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9176 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9177 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9178
9179* extended event history
9180 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9181 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9182 & IHIST(2,NMXHKK)
9183
9184* rejection counter
9185 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9186 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9187 & IREXCI(3),IRDIFF(2),IRINC
9188
9189* Glauber formalism: collision properties
9190 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9191 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9192
9193 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9194
9195 DO 1 K=1,4
9196 DEV(K) = ZERO
9197 1 CONTINUE
9198
9199 DO 2 I=NPOINT(2),NHKK
9200 IF (ISTHKK(I).LT.0) THEN
9201* get z-position of the chain
9202 R(1) = VHKK(1,I)*1.0D12
9203 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9204 R(2) = VHKK(2,I)*1.0D12
9205 IDXNU = JMOHKK(1,I)
9206 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9207 & IDXNU = JMOHKK(1,I-1)
9208 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9209 & IDXNU = JMOHKK(1,I+1)
9210 R(3) = VHKK(3,IDXNU)*1.0D12
9211* position of target parton the chain is connected to
9212 DO 3 K=1,4
9213 PIN(K) = PHKK(K,I)
9214 3 CONTINUE
9215* multiple scattering of parton with DTEVT1-index I
9216 CALL DT_CROMSC(PIN,R,POUT,INCL)
9217**testprint
9218C IF (NEVHKK.EQ.5) THEN
9219C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9220C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9221C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9222C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9223C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9224C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9225C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9226C ENDIF
9227**
9228* increase accumulator by energy-momentum difference
9229 DO 4 K=1,4
9230 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9231 PHKK(K,I) = POUT(K)
9232 4 CONTINUE
9233 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9234 & PHKK(2,I)**2-PHKK(3,I)**2))
9235 ENDIF
9236 2 CONTINUE
9237
9238* dump accumulator to momenta of valence partons
9239 NVAL = 0
9240 ETOT = 0.0D0
9241 DO 5 I=NPOINT(2),NHKK
9242 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9243 NVAL = NVAL+1
9244 ETOT = ETOT+PHKK(4,I)
9245 ENDIF
9246 5 CONTINUE
9247C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9248 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9249 & 9X,4E12.4)
9250 DO 6 I=NPOINT(2),NHKK
9251 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9252 E = PHKK(4,I)
9253 DO 7 K=1,4
9254C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9255 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9256 7 CONTINUE
9257 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9258 & PHKK(2,I)**2-PHKK(3,I)**2))
9259 ENDIF
9260 6 CONTINUE
9261
9262 RETURN
9263 END
9264
9265*$ CREATE DT_CROMSC.FOR
9266*COPY DT_CROMSC
9267*
9268*===cromsc=============================================================*
9269*
9270 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9271
9272************************************************************************
9273* Cronin-Effect. Multiple scattering of one parton passing through *
9274* nuclear matter. *
9275* PIN(4) input 4-momentum of parton *
9276* POUT(4) 4-momentum of parton after mult. scatt. *
9277* R(3) spatial position of parton in target nucleus *
9278* INCL = 1 multiple sc. in projectile *
9279* = 2 multiple sc. in target *
9280* This is a revised version of the original version written by J. Ranft*
9281* This version dated 17.01.95 is written by S. Roesler. *
9282************************************************************************
9283
9284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9285 SAVE
9286
9287 PARAMETER ( LINP = 10 ,
9288 & LOUT = 6 ,
9289 & LDAT = 9 )
9290
9291 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9292
9293 LOGICAL LSTART
9294
9295* rejection counter
9296 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9297 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9298 & IREXCI(3),IRDIFF(2),IRINC
9299
9300* Glauber formalism: collision properties
9301 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9302 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9303
9304* various options for treatment of partons (DTUNUC 1.x)
9305* (chain recombination, Cronin,..)
9306 LOGICAL LCO2CR,LINTPT
9307 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9308 & LCO2CR,LINTPT
9309
9310 DIMENSION PIN(4),POUT(4),R(3)
9311
9312 DATA LSTART /.TRUE./
9313
9314 IRCRON(1) = IRCRON(1)+1
9315
9316 IF (LSTART) THEN
9317 WRITE(LOUT,1000) CRONCO
9318 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9319 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9320 LSTART = .FALSE.
9321 ENDIF
9322
9323 NCBACK = 0
9324 RNCL = RPROJ
9325 IF (INCL.EQ.2) RNCL = RTARG
9326
9327* Lorentz-transformation into Lab.
9328 MODE = -(INCL+1)
9329 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9330
9331 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9332 IF (PTOT.LE.8.0D0) GOTO 9997
9333
9334* direction cosines of parton before mult. scattering
9335 COSX = PIN(1)/PTOT
9336 COSY = PIN(2)/PTOT
9337 COSZ = PZ/PTOT
9338
9339 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9340 IF (RTESQ.GE.-TINY3) GOTO 9999
9341
9342* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9343* in the direction of particle motion
9344
9345 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9346 TMP = A**2-RTESQ
9347 IF (TMP.LT.ZERO) GOTO 9998
9348 DIST = -A+SQRT(TMP)
9349
9350* multiple scattering angle
9351 THETO = CRONCO*SQRT(DIST)/PTOT
9352 IF (THETO.GT.0.1D0) THETO=0.1D0
9353
9354 1 CONTINUE
9355* Gaussian sampling of spatial angle
9356 CALL DT_RANNOR(R1,R2)
9357 THETA = ABS(R1*THETO)
9358 IF (THETA.GT.0.3D0) GOTO 9997
9359 CALL DT_DSFECF(SFE,CFE)
9360 COSTH = COS(THETA)
9361 SINTH = SIN(THETA)
9362
9363* new direction cosines
9364 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9365 & COSXN,COSYN,COSZN)
9366
9367 POUT(1) = COSXN*PTOT
9368 POUT(2) = COSYN*PTOT
9369 PZ = COSZN*PTOT
9370* Lorentz-transformation into nucl.-nucl. cms
9371 MODE = INCL+1
9372 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9373
9374C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9375C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9376 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9377 THETO = THETO/2.0D0
9378 NCBACK = NCBACK+1
9379 IF (MOD(NCBACK,200).EQ.0) THEN
9380 WRITE(LOUT,1001) THETO,PIN,POUT
9381 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9382 & E12.4,/,1X,' PIN :',4E12.4,/,
9383 & 1X,' POUT:',4E12.4)
9384 GOTO 9997
9385 ENDIF
9386 GOTO 1
9387 ENDIF
9388
9389 RETURN
9390
9391 9997 IRCRON(2) = IRCRON(2)+1
9392 GOTO 9999
9393 9998 IRCRON(3) = IRCRON(3)+1
9394
9395 9999 CONTINUE
9396 DO 100 K=1,4
9397 POUT(K) = PIN(K)
9398 100 CONTINUE
9399 RETURN
9400 END
9401
9402*$ CREATE DT_COM2CR.FOR
9403*COPY DT_COM2CR
9404*
9405*===com2sr=============================================================*
9406*
9407 SUBROUTINE DT_COM2CR
9408
9409************************************************************************
9410* COMbine q-aq chains to Color Ropes (qq-aqaq). *
9411* CUTOF parameter determining minimum number of not *
9412* combined q-aq chains *
9413* This subroutine replaces KKEVCC etc. *
9414* This version dated 11.01.95 is written by S. Roesler. *
9415************************************************************************
9416
9417 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9418 SAVE
9419
9420 PARAMETER ( LINP = 10 ,
9421 & LOUT = 6 ,
9422 & LDAT = 9 )
9423
9424* event history
9425
9426 PARAMETER (NMXHKK=200000)
9427
9428 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9429 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9430 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9431
9432* extended event history
9433 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9434 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9435 & IHIST(2,NMXHKK)
9436
9437* statistics
9438 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9439 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9440 & ICEVTG(8,0:30)
9441
9442* various options for treatment of partons (DTUNUC 1.x)
9443* (chain recombination, Cronin,..)
9444 LOGICAL LCO2CR,LINTPT
9445 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9446 & LCO2CR,LINTPT
9447
9448 DIMENSION IDXQA(248),IDXAQ(248)
9449
9450 ICCHAI(1,9) = ICCHAI(1,9)+1
9451 NQA = 0
9452 NAQ = 0
9453* scan DTEVT1 for q-aq, aq-q chains
9454 DO 10 I=NPOINT(3),NHKK
9455* skip "chains" which are resonances
9456 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9457 MO1 = JMOHKK(1,I)
9458 MO2 = JMOHKK(2,I)
9459 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9460* q-aq, aq-q chain found, keep index
9461 IF (IDHKK(MO1).GT.0) THEN
9462 NQA = NQA+1
9463 IDXQA(NQA) = I
9464 ELSE
9465 NAQ = NAQ+1
9466 IDXAQ(NAQ) = I
9467 ENDIF
9468 ENDIF
9469 ENDIF
9470 10 CONTINUE
9471
9472* minimum number of q-aq chains requested for the same projectile/
9473* target
9474 NCHMIN = IDT_NPOISS(CUTOF)
9475
9476* combine q-aq chains of the same projectile
9477 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9478* combine q-aq chains of the same target
9479 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9480* combine aq-q chains of the same projectile
9481 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9482* combine aq-q chains of the same target
9483 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9484
9485 RETURN
9486 END
9487
9488*$ CREATE DT_SCN4CR.FOR
9489*COPY DT_SCN4CR
9490*
9491*===scn4cr=============================================================*
9492*
9493 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9494
9495************************************************************************
9496* SCan q-aq chains for Color Ropes. *
9497* This version dated 11.01.95 is written by S. Roesler. *
9498************************************************************************
9499
9500 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9501 SAVE
9502
9503 PARAMETER ( LINP = 10 ,
9504 & LOUT = 6 ,
9505 & LDAT = 9 )
9506
9507* event history
9508
9509 PARAMETER (NMXHKK=200000)
9510
9511 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9512 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9513 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9514
9515* extended event history
9516 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9517 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9518 & IHIST(2,NMXHKK)
9519
9520 DIMENSION IDXCH(248),IDXJN(248)
9521
9522 DO 1 I=1,NCH
9523 IF (IDXCH(I).GT.0) THEN
9524 NJOIN = 1
9525 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9526 IDXJN(NJOIN) = I
9527 IF (I.LT.NCH) THEN
9528 DO 2 J=I+1,NCH
9529 IF (IDXCH(J).GT.0) THEN
9530 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9531 IF (IDXMO.EQ.IDXMO1) THEN
9532 NJOIN = NJOIN+1
9533 IDXJN(NJOIN) = J
9534 ENDIF
9535 ENDIF
9536 2 CONTINUE
9537 ENDIF
9538 IF (NJOIN.GE.NCHMIN+2) THEN
9539 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9540 DO 3 J=1,2*NJ,2
9541 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9542 IF (IREJ1.NE.0) GOTO 3
9543 IDXCH(IDXJN(J)) = 0
9544 IDXCH(IDXJN(J+1)) = 0
9545 3 CONTINUE
9546 ENDIF
9547 ENDIF
9548 1 CONTINUE
9549
9550 RETURN
9551 END
9552
9553*$ CREATE DT_JOIN.FOR
9554*COPY DT_JOIN
9555*
9556*===join===============================================================*
9557*
9558 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9559
9560************************************************************************
9561* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9562* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9563* This version dated 11.01.95 is written by S. Roesler. *
9564************************************************************************
9565
9566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9567 SAVE
9568
9569 PARAMETER ( LINP = 10 ,
9570 & LOUT = 6 ,
9571 & LDAT = 9 )
9572
9573* event history
9574
9575 PARAMETER (NMXHKK=200000)
9576
9577 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9578 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9579 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9580
9581* extended event history
9582 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9583 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9584 & IHIST(2,NMXHKK)
9585
9586* flags for input different options
9587 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9588 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9589 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9590
9591* statistics
9592 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9593 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9594 & ICEVTG(8,0:30)
9595
9596 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9597
9598 IREJ = 0
9599
9600 IDX(1) = IDX1
9601 IDX(2) = IDX2
9602 DO 1 I=1,2
9603 DO 2 J=1,2
9604 MO(I,J) = JMOHKK(J,IDX(I))
9605 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9606 2 CONTINUE
9607 1 CONTINUE
9608
9609* check consistency
9610 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9611 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9612 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9613 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9614 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9615 & MO(2,2)
9616 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9617 & 2I5,' chain ',I4,':',2I5)
9618 ENDIF
9619
9620* join chains
9621 DO 3 K=1,4
9622 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9623 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9624 3 CONTINUE
9625 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9626 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9627 IST1 = ISTHKK(MO(1,1))
9628 IST2 = ISTHKK(MO(1,2))
9629
9630* put partons again on mass shell
9631 XM1 = 0.0D0
9632 XM2 = 0.0D0
9633 IF (IMSHL.EQ.1) THEN
9634
9635 XM1 = PYMASS(IF1)
9636 XM2 = PYMASS(IF2)
9637
9638 ENDIF
9639 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9640 IF (IREJ1.NE.0) GOTO 9999
9641 DO 4 I=1,4
9642 PP(I) = P1(I)
9643 PT(I) = P2(I)
9644 4 CONTINUE
9645
9646* store new partons in DTEVT1
9647 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9648 & 0,0,0)
9649 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9650 & 0,0,0)
9651 DO 5 K=1,4
9652 PCH(K) = PP(K)+PT(K)
9653 5 CONTINUE
9654
9655* check new chain for lower mass limit
9656 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9657 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9658 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9659 & AMCH,AMCHN,3,IREJ1)
9660 IF (IREJ1.NE.0) THEN
9661 NHKK = NHKK-2
9662 GOTO 9999
9663 ENDIF
9664 ENDIF
9665
9666 ICCHAI(2,9) = ICCHAI(2,9)+1
9667* store new chain in DTEVT1
9668 KCH = 191
9669 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9670 IDHKK(IDX(1)) = 22222
9671 IDHKK(IDX(2)) = 22222
9672* special treatment for space-time coordinates
9673 DO 6 K=1,4
9674 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9675 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9676 6 CONTINUE
9677 RETURN
9678
9679 9999 CONTINUE
9680 IREJ = 1
9681 RETURN
9682 END
9683*$ CREATE DT_XSGLAU.FOR
9684*COPY DT_XSGLAU
9685*
9686*===xsglau=============================================================*
9687*
9688 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9689
9690************************************************************************
9691* Total, elastic, quasi-elastic, inelastic cross sections according to *
9692* Glauber's approach. *
9693* NA / NB mass numbers of proj./target nuclei *
9694* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9695* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9696* IE,IQ indices of energy and virtuality (the latter for gamma *
9697* projectiles only) *
9698* NIDX index of projectile/target nucleus *
9699* This version dated 17.3.98 is written by S. Roesler *
9700************************************************************************
9701
9702 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9703 SAVE
9704
9705 PARAMETER ( LINP = 10 ,
9706 & LOUT = 6 ,
9707 & LDAT = 9 )
9708
9709 COMPLEX*16 CZERO,CONE,CTWO
9710 CHARACTER*12 CFILE
9711 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9712 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9713 PARAMETER (TWOPI = 6.283185307179586454D+00,
9714 & PI = TWOPI/TWO,
9715 & GEV2MB = 0.38938D0,
9716 & GEV2FM = 0.1972D0,
9717 & ALPHEM = ONE/137.0D0,
9718* proton mass
9719 & AMP = 0.938D0,
9720 & AMP2 = AMP**2,
9721* approx. nucleon radius
9722 & RNUCLE = 1.12D0)
9723
9724* particle properties (BAMJET index convention)
9725 CHARACTER*8 ANAME
9726 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9727 & IICH(210),IIBAR(210),K1(210),K2(210)
9728
9729 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9730
9731 PARAMETER ( MAXNCL = 260,
9732
9733 & MAXVQU = MAXNCL,
9734 & MAXSQU = 20*MAXVQU,
9735 & MAXINT = MAXVQU+MAXSQU)
9736
9737* Glauber formalism: parameters
9738 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9739 & BMAX(NCOMPX),BSTEP(NCOMPX),
9740 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9741 & NSITEB,NSTATB
9742
9743* Glauber formalism: cross sections
9744 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9745 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9746 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9747 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9748 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9749 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9750 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9751 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9752 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9753 & BSLOPE,NEBINI,NQBINI
9754
9755* Glauber formalism: flags and parameters for statistics
9756 LOGICAL LPROD
9757 CHARACTER*8 CGLB
9758 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9759
9760* nucleon-nucleon event-generator
9761 CHARACTER*8 CMODEL
9762 LOGICAL LPHOIN
9763 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9764
9765* VDM parameter for photon-nucleus interactions
9766 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9767
9768* parameters for hA-diffraction
9769 COMMON /DTDIHA/ DIBETA,DIALPH
9770
9771 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9772 & OMPP11,OMPP12,OMPP21,OMPP22,
9773 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9774 & PPTMP1,PPTMP2
9775 COMPLEX*16 C,CA,CI
9776 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9777 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9778 & BPROD(KSITEB)
9779
9780 PARAMETER (NPOINT=16)
9781 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9782
9783 LOGICAL LFIRST,LOPEN
9784 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9785
9786 NTARG = ABS(NIDX)
9787* for quasi-elastic neutrino scattering set projectile to proton
9788* it should not have an effect since the whole Glauber-formalism is
9789* not needed for these interactions..
9790 IF (MCGENE.EQ.4) THEN
9791 IJPROJ = 1
9792 ELSE
9793 IJPROJ = JJPROJ
9794 ENDIF
9795
9796 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9797 I = INDEX(CGLB,' ')
9798 IF (I.EQ.0) THEN
9799 CFILE = CGLB//'.glb'
9800 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9801 ELSEIF (I.GT.1) THEN
9802 CFILE = CGLB(1:I-1)//'.glb'
9803 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9804 ELSE
9805 STOP 'XSGLAU 1'
9806 ENDIF
9807 LOPEN = .TRUE.
9808 ENDIF
9809
9810 CZERO = DCMPLX(ZERO,ZERO)
9811 CONE = DCMPLX(ONE,ZERO)
9812 CTWO = DCMPLX(TWO,ZERO)
9813 NEBINI = IE
9814 NQBINI = IQ
9815
9816* re-define kinematics
9817 S = ECMI**2
9818 Q2 = Q2I
9819 X = XI
9820* g(Q2=0)-A, h-A, A-A scattering
9821 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9822 Q2 = 0.0001D0
9823 X = Q2/(S+Q2-AMP2)
9824* g(Q2>0)-A scattering
9825 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9826 X = Q2/(S+Q2-AMP2)
9827 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9828 Q2 = (S-AMP2)*X/(ONE-X)
9829 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9830 S = Q2*(ONE-X)/X+AMP2
9831 ELSE
9832 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9833 STOP
9834 ENDIF
9835 ECMNN(IE) = SQRT(S)
9836 Q2G(IQ) = Q2
9837 XNU = (S+Q2-AMP2)/(TWO*AMP)
9838
9839* parameters determining statistics in evaluating Glauber-xsection
9840 NSTATB = JSTATB
9841 NSITEB = JBINSB
9842 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9843
9844* set up interaction geometry (common /DTGLAM/)
9845* projectile/target radii
9846 RPRNCL = DT_RNCLUS(NA)
9847 RTANCL = DT_RNCLUS(NB)
9848 IF (IJPROJ.EQ.7) THEN
9849 RASH(1) = ZERO
9850 RBSH(NTARG) = RTANCL
9851 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9852 ELSE
9853 IF (NIDX.LE.-1) THEN
9854 RASH(1) = RPRNCL
9855 RBSH(NTARG) = RTANCL
9856 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9857 ELSE
9858 RASH(NTARG) = RPRNCL
9859 RBSH(1) = RTANCL
9860 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9861 ENDIF
9862 ENDIF
9863* maximum impact-parameter
9864 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9865
9866* slope, rho ( Re(f(0))/Im(f(0)) )
9867 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9868 IF (MCGENE.EQ.2) THEN
9869 ZERO1 = ZERO
9870 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9871 & BSLOPE,0)
9872 ELSE
9873 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9874 ENDIF
9875 IF (ECMNN(IE).LE.3.0D0) THEN
9876 ROSH = -0.43D0
9877 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9878 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9879 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9880 ROSH = 0.1D0
9881 ENDIF
9882 ELSEIF (IJPROJ.EQ.7) THEN
9883 ROSH = 0.1D0
9884 ELSE
9885 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9886 ROSH = 0.01D0
9887 ENDIF
9888
9889* projectile-nucleon xsection (in fm)
9890 IF (IJPROJ.EQ.7) THEN
9891 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9892 ELSE
9893 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9894 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9895C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9896 DUMZER = ZERO
9897 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9898 SIGSH = SIGSH/10.0D0
9899 ENDIF
9900
9901* parameters for projectile diffraction (hA scattering only)
9902 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9903 & .AND.(DIBETA.GE.ZERO)) THEN
9904 ZERO1 = ZERO
9905 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9906C DIBETA = SDIF1/STOT
9907 DIBETA = 0.2D0
9908 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9909 IF (DIBETA.LE.ZERO) THEN
9910 ALPGAM = ONE
9911 ELSE
9912 ALPGAM = DIALPH/DIGAMM
9913 ENDIF
9914 FACDI1 = ONE-ALPGAM
9915 FACDI2 = ONE+ALPGAM
9916 FACDI = SQRT(FACDI1*FACDI2)
9917 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9918 ELSE
9919 DIBETA = -1.0D0
9920 DIALPH = ZERO
9921 DIGAMM = ZERO
9922 FACDI1 = ZERO
9923 FACDI2 = 2.0D0
9924 FACDI = ZERO
9925 ENDIF
9926
9927* initializations
9928 DO 10 I=1,NSITEB
9929 BSITE( 0,IQ,NTARG,I) = ZERO
9930 BSITE(IE,IQ,NTARG,I) = ZERO
9931 BPROD(I) = ZERO
9932 10 CONTINUE
9933 STOT = ZERO
9934 STOT2 = ZERO
9935 SELA = ZERO
9936 SELA2 = ZERO
9937 SQEP = ZERO
9938 SQEP2 = ZERO
9939 SQET = ZERO
9940 SQET2 = ZERO
9941 SQE2 = ZERO
9942 SQE22 = ZERO
9943 SPRO = ZERO
9944 SPRO2 = ZERO
9945 SDEL = ZERO
9946 SDEL2 = ZERO
9947 SDQE = ZERO
9948 SDQE2 = ZERO
9949 FACN = ONE/DBLE(NSTATB)
9950
9951 IPNT = 0
9952 RPNT = ZERO
9953
9954* initialize Gauss-integration for photon-proj.
9955 JPOINT = 1
9956 IF (IJPROJ.EQ.7) THEN
9957 IF (INTRGE(1).EQ.1) THEN
9958 AMLO2 = (3.0D0*AAM(13))**2
9959 ELSEIF (INTRGE(1).EQ.2) THEN
9960 AMLO2 = AAM(33)**2
9961 ELSE
9962 AMLO2 = AAM(96)**2
9963 ENDIF
9964 IF (INTRGE(2).EQ.1) THEN
9965 AMHI2 = S/TWO
9966 ELSEIF (INTRGE(2).EQ.2) THEN
9967 AMHI2 = S/4.0D0
9968 ELSE
9969 AMHI2 = S
9970 ENDIF
9971 AMHI20 = (ECMNN(IE)-AMP)**2
9972 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9973 XAMLO = LOG( AMLO2+Q2 )
9974 XAMHI = LOG( AMHI2+Q2 )
9975**PHOJET105a
9976C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9977**PHOJET112
9978
9979 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9980
9981**
9982 JPOINT = NPOINT
9983* ratio direct/total photon-nucleon xsection
9984 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9985 ENDIF
9986
9987* read pre-initialized profile-function from file
9988 IF (IOGLB.EQ.1) THEN
9989 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9990 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9991 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9992 & NA,NB,NSTATB,NSITEB
9993 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9994 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9995 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9996 STOP
9997 ENDIF
9998 IF (LFIRST) WRITE(LOUT,1001) CFILE
9999 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10000 & 'file ',A12,/)
10001 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10002 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10003 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10004 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10005 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10006 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10007 NLINES = INT(DBLE(NSITEB)/7.0D0)
10008 IF (NLINES.GT.0) THEN
10009 DO 21 I=1,NLINES
10010 ISTART = 7*I-6
10011 READ(LDAT,'(7E11.4)')
10012 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10013 21 CONTINUE
10014 ENDIF
10015 ISTART = 7*NLINES+1
10016 IF (ISTART.LE.NSITEB) THEN
10017 READ(LDAT,'(7E11.4)')
10018 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10019 ENDIF
10020 LFIRST = .FALSE.
10021 GOTO 100
10022* variable projectile/target/energy runs:
10023* read pre-initialized profile-functions from file
10024 ELSEIF (IOGLB.EQ.100) THEN
10025 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10026 GOTO 100
10027 ENDIF
10028
10029* cross sections averaged over NSTATB nucleon configurations
10030 DO 11 IS=1,NSTATB
10031C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10032 STOTN = ZERO
10033 SELAN = ZERO
10034 SQEPN = ZERO
10035 SQETN = ZERO
10036 SQE2N = ZERO
10037 SPRON = ZERO
10038 SDELN = ZERO
10039 SDQEN = ZERO
10040
10041 IF (NIDX.LE.-1) THEN
10042 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10043 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10044 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10045 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10046 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10047 ENDIF
10048 ELSE
10049 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10050 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10051 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10052 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10053 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10054 ENDIF
10055 ENDIF
10056
10057* integration over impact parameter B
10058 DO 12 IB=1,NSITEB-1
10059 STOTB = ZERO
10060 SELAB = ZERO
10061 SQEPB = ZERO
10062 SQETB = ZERO
10063 SQE2B = ZERO
10064 SPROB = ZERO
10065 SDIR = ZERO
10066 SDELB = ZERO
10067 SDQEB = ZERO
10068 B = DBLE(IB)*BSTEP(NTARG)
10069 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10070
10071* integration over M_V^2 for photon-proj.
10072 DO 14 IM=1,JPOINT
10073 PP11(1) = CONE
10074 PP12(1) = CONE
10075 PP21(1) = CONE
10076 PP22(1) = CONE
10077 IF (IJPROJ.EQ.7) THEN
10078 DO 13 K=2,NB
10079 PP11(K) = CONE
10080 PP12(K) = CONE
10081 PP21(K) = CONE
10082 PP22(K) = CONE
10083 13 CONTINUE
10084 ENDIF
10085 SHI = ZERO
10086 FACM = ONE
10087 DCOH = 1.0D10
10088
10089 IF (IJPROJ.EQ.7) THEN
10090 AMV2 = EXP(ABSZX(IM))-Q2
10091 AMV = SQRT(AMV2)
10092 IF (AMV2.LT.16.0D0) THEN
10093 R = TWO
10094 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10095 R = 10.0D0/3.0D0
10096 ELSE
10097 R = 11.0D0/3.0D0
10098 ENDIF
10099* define M_V dependent properties of nucleon scattering amplitude
10100* V_M-nucleon xsection
10101 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10102 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10103* slope-parametrisation a la Kaidalov
10104 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10105 & +0.25D0*LOG(S/(AMV2+Q2)))
10106* coherence length
10107 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10108* integration weight factor
10109 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10110 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10111 ENDIF
10112 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10113 GAM = GSH
10114 IF (IJPROJ.EQ.7) THEN
10115 RCA = GAM*SIGMV/TWOPI
10116 ELSE
10117 RCA = GAM*SIGSH/TWOPI
10118 ENDIF
10119 FCA = -ROSH*RCA
10120 CA = DCMPLX(RCA,FCA)
10121 CI = CONE
10122
10123 DO 15 INA=1,NA
10124 KK1 = 1
10125 INT1 = 1
10126 KK2 = 1
10127 INT2 = 1
10128 DO 16 INB=1,NB
10129* photon-projectile: check for supression by coherence length
10130 IF (IJPROJ.EQ.7) THEN
10131 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10132 KK1 = INB
10133 INT1 = INT1+1
10134 ENDIF
10135 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10136 KK2 = INB
10137 INT2 = INT2+1
10138 ENDIF
10139 ENDIF
10140
10141 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10142 Y11 = COOT1(2,INB)-COOP1(2,INA)
10143 XY11 = GAM*(X11*X11+Y11*Y11)
10144 IF (XY11.LE.15.0D0) THEN
10145 C = CONE-CA*EXP(-XY11)
10146 AR = DBLE(PP11(INT1))
10147 AI = DIMAG(PP11(INT1))
10148 IF (ABS(AR).LT.TINY25) AR = ZERO
10149 IF (ABS(AI).LT.TINY25) AI = ZERO
10150 PP11(INT1) = DCMPLX(AR,AI)
10151 PP11(INT1) = PP11(INT1)*C
10152 AR = DBLE(C)
10153 AI = DIMAG(C)
10154 SHI = SHI+LOG(AR*AR+AI*AI)
10155 ENDIF
10156 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10157 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10158 Y12 = COOT2(2,INB)-COOP1(2,INA)
10159 XY12 = GAM*(X12*X12+Y12*Y12)
10160 IF (XY12.LE.15.0D0) THEN
10161 C = CONE-CA*EXP(-XY12)
10162 AR = DBLE(PP12(INT2))
10163 AI = DIMAG(PP12(INT2))
10164 IF (ABS(AR).LT.TINY25) AR = ZERO
10165 IF (ABS(AI).LT.TINY25) AI = ZERO
10166 PP12(INT2) = DCMPLX(AR,AI)
10167 PP12(INT2) = PP12(INT2)*C
10168 ENDIF
10169 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10170 Y21 = COOT1(2,INB)-COOP2(2,INA)
10171 XY21 = GAM*(X21*X21+Y21*Y21)
10172 IF (XY21.LE.15.0D0) THEN
10173 C = CONE-CA*EXP(-XY21)
10174 AR = DBLE(PP21(INT1))
10175 AI = DIMAG(PP21(INT1))
10176 IF (ABS(AR).LT.TINY25) AR = ZERO
10177 IF (ABS(AI).LT.TINY25) AI = ZERO
10178 PP21(INT1) = DCMPLX(AR,AI)
10179 PP21(INT1) = PP21(INT1)*C
10180 ENDIF
10181 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10182 Y22 = COOT2(2,INB)-COOP2(2,INA)
10183 XY22 = GAM*(X22*X22+Y22*Y22)
10184 IF (XY22.LE.15.0D0) THEN
10185 C = CONE-CA*EXP(-XY22)
10186 AR = DBLE(PP22(INT2))
10187 AI = DIMAG(PP22(INT2))
10188 IF (ABS(AR).LT.TINY25) AR = ZERO
10189 IF (ABS(AI).LT.TINY25) AI = ZERO
10190 PP22(INT2) = DCMPLX(AR,AI)
10191 PP22(INT2) = PP22(INT2)*C
10192 ENDIF
10193 ENDIF
10194 16 CONTINUE
10195 15 CONTINUE
10196
10197 OMPP11 = CZERO
10198 OMPP21 = CZERO
10199 DIPP11 = CZERO
10200 DIPP21 = CZERO
10201 DO 17 K=1,INT1
10202 IF (PP11(K).EQ.CZERO) THEN
10203 PPTMP1 = CZERO
10204 PPTMP2 = CZERO
10205 ELSE
10206 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10207 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10208 ENDIF
10209 AVDIPP = 0.5D0*
10210 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10211 OMPP11 = OMPP11+AVDIPP
10212C OMPP11 = OMPP11+(CONE-PP11(K))
10213 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10214 DIPP11 = DIPP11+AVDIPP
10215 IF (PP21(K).EQ.CZERO) THEN
10216 PPTMP1 = CZERO
10217 PPTMP2 = CZERO
10218 ELSE
10219 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10220 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10221 ENDIF
10222 AVDIPP = 0.5D0*
10223 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10224 OMPP21 = OMPP21+AVDIPP
10225C OMPP21 = OMPP21+(CONE-PP21(K))
10226 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10227 DIPP21 = DIPP21+AVDIPP
10228 17 CONTINUE
10229 OMPP12 = CZERO
10230 OMPP22 = CZERO
10231 DIPP12 = CZERO
10232 DIPP22 = CZERO
10233 DO 18 K=1,INT2
10234 IF (PP12(K).EQ.CZERO) THEN
10235 PPTMP1 = CZERO
10236 PPTMP2 = CZERO
10237 ELSE
10238 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10239 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10240 ENDIF
10241 AVDIPP = 0.5D0*
10242 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10243 OMPP12 = OMPP12+AVDIPP
10244C OMPP12 = OMPP12+(CONE-PP12(K))
10245 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10246 DIPP12 = DIPP12+AVDIPP
10247 IF (PP22(K).EQ.CZERO) THEN
10248 PPTMP1 = CZERO
10249 PPTMP2 = CZERO
10250 ELSE
10251 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10252 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10253 ENDIF
10254 AVDIPP = 0.5D0*
10255 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10256 OMPP22 = OMPP22+AVDIPP
10257C OMPP22 = OMPP22+(CONE-PP22(K))
10258 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10259 DIPP22 = DIPP22+AVDIPP
10260 18 CONTINUE
10261
10262 SPROM = ONE-EXP(SHI)
10263 SPROB = SPROB+FACM*SPROM
10264 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10265 STOTM = DBLE(OMPP11+OMPP22)
10266 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10267 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10268 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10269 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10270 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10271 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10272 STOTB = STOTB+FACM*STOTM
10273 SELAB = SELAB+FACM*SELAM
10274 SDELB = SDELB+FACM*SDELM
10275 IF (NB.GT.1) THEN
10276 SQEPB = SQEPB+FACM*SQEPM
10277 SDQEB = SDQEB+FACM*SDQEM
10278 ENDIF
10279 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10280 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10281 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10282 ENDIF
10283
10284 14 CONTINUE
10285
10286 STOTN = STOTN+FACB*STOTB
10287 SELAN = SELAN+FACB*SELAB
10288 SQEPN = SQEPN+FACB*SQEPB
10289 SQETN = SQETN+FACB*SQETB
10290 SQE2N = SQE2N+FACB*SQE2B
10291 SPRON = SPRON+FACB*SPROB
10292 SDELN = SDELN+FACB*SDELB
10293 SDQEN = SDQEN+FACB*SDQEB
10294
10295 IF (IJPROJ.EQ.7) THEN
10296 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10297 ELSE
10298 IF (DIBETA.GT.ZERO) THEN
10299 BPROD(IB+1)= BPROD(IB+1)
10300 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10301 ELSE
10302 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10303 ENDIF
10304 ENDIF
10305
10306 12 CONTINUE
10307
10308 STOT = STOT +FACN*STOTN
10309 STOT2 = STOT2+FACN*STOTN**2
10310 SELA = SELA +FACN*SELAN
10311 SELA2 = SELA2+FACN*SELAN**2
10312 SQEP = SQEP +FACN*SQEPN
10313 SQEP2 = SQEP2+FACN*SQEPN**2
10314 SQET = SQET +FACN*SQETN
10315 SQET2 = SQET2+FACN*SQETN**2
10316 SQE2 = SQE2 +FACN*SQE2N
10317 SQE22 = SQE22+FACN*SQE2N**2
10318 SPRO = SPRO +FACN*SPRON
10319 SPRO2 = SPRO2+FACN*SPRON**2
10320 SDEL = SDEL +FACN*SDELN
10321 SDEL2 = SDEL2+FACN*SDELN**2
10322 SDQE = SDQE +FACN*SDQEN
10323 SDQE2 = SDQE2+FACN*SDQEN**2
10324
10325 11 CONTINUE
10326
10327* final cross sections
10328* 1) total
10329 XSTOT(IE,IQ,NTARG) = STOT
10330 IF (IJPROJ.EQ.7)
10331 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10332* 2) elastic
10333 XSELA(IE,IQ,NTARG) = SELA
10334* 3) quasi-el.: A+B-->A+X (excluding 2)
10335 XSQEP(IE,IQ,NTARG) = SQEP
10336* 4) quasi-el.: A+B-->X+B (excluding 2)
10337 XSQET(IE,IQ,NTARG) = SQET
10338* 5) quasi-el.: A+B-->X (excluding 2-4)
10339 XSQE2(IE,IQ,NTARG) = SQE2
10340* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10341 IF (SDEL.GT.ZERO) THEN
10342 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10343 ELSE
10344 XSPRO(IE,IQ,NTARG) = SPRO
10345 ENDIF
10346* 7) projectile diffraction (el. scatt. off target)
10347 XSDEL(IE,IQ,NTARG) = SDEL
10348* 8) projectile diffraction (quasi-el. scatt. off target)
10349 XSDQE(IE,IQ,NTARG) = SDQE
10350* stat. errors
10351 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10352 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10353 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10354 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10355 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10356 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10357 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10358 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10359
10360 IF (IJPROJ.EQ.7) THEN
10361 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10362 & -XSQEP(IE,IQ,NTARG)
10363 ELSE
10364 BNORM = XSPRO(IE,IQ,NTARG)
10365 ENDIF
10366 DO 19 I=2,NSITEB
10367 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10368 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10369 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10370 19 CONTINUE
10371
10372* write profile function data into file
10373 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10374 WRITE(LDAT,'(5I10,1P,E15.5)')
10375 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10376 WRITE(LDAT,'(1P,6E12.5)')
10377 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10378 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10379 WRITE(LDAT,'(1P,6E12.5)')
10380 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10381 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10382 NLINES = INT(DBLE(NSITEB)/7.0D0)
10383 IF (NLINES.GT.0) THEN
10384 DO 20 I=1,NLINES
10385 ISTART = 7*I-6
10386 WRITE(LDAT,'(1P,7E11.4)')
10387 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10388 20 CONTINUE
10389 ENDIF
10390 ISTART = 7*NLINES+1
10391 IF (ISTART.LE.NSITEB) THEN
10392 WRITE(LDAT,'(1P,7E11.4)')
10393 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10394 ENDIF
10395 ENDIF
10396
10397 100 CONTINUE
10398
10399C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10400
10401 RETURN
10402 END
10403
10404*$ CREATE DT_GETBXS.FOR
10405*COPY DT_GETBXS
10406*
10407*===getbxs=============================================================*
10408*
10409 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10410
10411************************************************************************
10412* Biasing in impact parameter space. *
10413* XSFRAC = 0 : BLO - minimum impact parameter (input) *
10414* BHI - maximum impact parameter (input) *
10415* XSFRAC - fraction of cross section corresponding *
10416* to impact parameter range (BLO,BHI) *
10417* (output) *
10418* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10419* BHI - maximum impact parameter giving requested *
10420* fraction of cross section in impact *
10421* parameter range (0,BMAX) (output) *
10422* This version dated 17.03.00 is written by S. Roesler *
10423************************************************************************
10424
10425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10426 SAVE
10427
10428 PARAMETER ( LINP = 10 ,
10429 & LOUT = 6 ,
10430 & LDAT = 9 )
10431
10432 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10433
10434* Glauber formalism: parameters
10435 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10436 & BMAX(NCOMPX),BSTEP(NCOMPX),
10437 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10438 & NSITEB,NSTATB
10439
10440 NTARG = ABS(NIDX)
10441 IF (XSFRAC.LE.0.0D0) THEN
10442 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10443 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10444 IF (ILO.GE.IHI) THEN
10445 XSFRAC = 0.0D0
10446 RETURN
10447 ENDIF
10448 IF (ILO.EQ.NSITEB-1) THEN
10449 FRCLO = BSITE(0,1,NTARG,NSITEB)
10450 ELSE
10451 FRCLO = BSITE(0,1,NTARG,ILO+1)
10452 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10453 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10454 ENDIF
10455 IF (IHI.EQ.NSITEB-1) THEN
10456 FRCHI = BSITE(0,1,NTARG,NSITEB)
10457 ELSE
10458 FRCHI = BSITE(0,1,NTARG,IHI+1)
10459 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10460 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10461 ENDIF
10462 XSFRAC = FRCHI-FRCLO
10463 ELSE
10464 BLO = 0.0D0
10465 BHI = BMAX(NTARG)
10466 DO 1 I=1,NSITEB-1
10467 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10468 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10469 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10470 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10471 GOTO 2
10472 ENDIF
10473 1 CONTINUE
10474 2 CONTINUE
10475 ENDIF
10476
10477 RETURN
10478 END
10479
10480*$ CREATE DT_CONUCL.FOR
10481*COPY DT_CONUCL
10482*
10483*===conucl=============================================================*
10484*
10485 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10486
10487************************************************************************
10488* Calculation of coordinates of nucleons within nuclei. *
10489* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10490* N / R number of nucleons / radius of nucleus (input) *
10491* MODE = 0 coordinates not sorted *
10492* = 1 coordinates sorted with increasing X(3,i) *
10493* = 2 coordinates sorted with decreasing X(3,i) *
10494* This version dated 26.10.95 is revised by S. Roesler *
10495************************************************************************
10496
10497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10498 SAVE
10499
10500 PARAMETER ( LINP = 10 ,
10501 & LOUT = 6 ,
10502 & LDAT = 9 )
10503
10504 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10505 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10506
10507 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10508
10509 PARAMETER (NSRT=10)
10510 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10511 DIMENSION X(3,N),XTMP(3,260)
10512
10513 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10514
10515 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10516 K = 0
10517 DO 1 I=1,NSRT
10518 IF (MODE.EQ.2) THEN
10519 ISRT = NSRT+1-I
10520 ELSE
10521 ISRT = I
10522 ENDIF
10523 K1 = K
10524 DO 2 J=1,ICSRT(ISRT)
10525 K = K+1
10526 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10527 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10528 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10529 2 CONTINUE
10530 IF (ICSRT(ISRT).GT.1) THEN
10531 I0 = K1+1
10532 I1 = K
10533 CALL DT_SORT(X,N,I0,I1,MODE)
10534 ENDIF
10535 1 CONTINUE
10536 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10537 DO 3 I=1,N
10538 X(1,I) = XTMP(1,I)
10539 X(2,I) = XTMP(2,I)
10540 X(3,I) = XTMP(3,I)
10541 3 CONTINUE
10542 CALL DT_SORT(X,N,1,N,MODE)
10543 ELSE
10544 DO 4 I=1,N
10545 X(1,I) = XTMP(1,I)
10546 X(2,I) = XTMP(2,I)
10547 X(3,I) = XTMP(3,I)
10548 4 CONTINUE
10549 ENDIF
10550
10551 RETURN
10552 END
10553
10554*$ CREATE DT_COORDI.FOR
10555*COPY DT_COORDI
10556*
10557*===coordi=============================================================*
10558*
10559 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10560
10561************************************************************************
10562* Calculation of coordinates of nucleons within nuclei. *
10563* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10564* N / R number of nucleons / radius of nucleus (input) *
10565* Based on the original version by Shmakov et al. *
10566* This version dated 26.10.95 is revised by S. Roesler *
10567************************************************************************
10568
10569 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10570 SAVE
10571
10572 PARAMETER ( LINP = 10 ,
10573 & LOUT = 6 ,
10574 & LDAT = 9 )
10575
10576 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10577 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10578
10579 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10580
10581 LOGICAL LSTART
10582
10583 PARAMETER (NSRT=10)
10584 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10585 DIMENSION X(3,260),WD(4),RD(3)
10586
10587 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10588 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10589 DATA RD /2.09D0, 0.935D0, 0.697D0/
10590
10591 X1SUM = ZERO
10592 X2SUM = ZERO
10593 X3SUM = ZERO
10594
10595 IF (N.EQ.1) THEN
10596 X(1,1) = ZERO
10597 X(2,1) = ZERO
10598 X(3,1) = ZERO
10599 ELSEIF (N.EQ.2) THEN
10600 EPS = DT_RNDM(RD(1))
10601 DO 30 I=1,3
10602 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10603 30 CONTINUE
10604 40 CONTINUE
10605 DO 50 J=1,3
10606 CALL DT_RANNOR(X1,X2)
10607 X(J,1) = RD(I)*X1
10608 X(J,2) = -X(J,1)
10609 50 CONTINUE
10610 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10611 SIGMA = R/SQRTWO
10612 LSTART = .TRUE.
10613 CALL DT_RANNOR(X3,X4)
10614 DO 100 I=1,N
10615 CALL DT_RANNOR(X1,X2)
10616 X(1,I) = SIGMA*X1
10617 X(2,I) = SIGMA*X2
10618 IF (LSTART) GOTO 80
10619 X(3,I) = SIGMA*X4
10620 CALL DT_RANNOR(X3,X4)
10621 GOTO 90
10622 80 CONTINUE
10623 X(3,I) = SIGMA*X3
10624 90 CONTINUE
10625 LSTART = .NOT.LSTART
10626 X1SUM = X1SUM+X(1,I)
10627 X2SUM = X2SUM+X(2,I)
10628 X3SUM = X3SUM+X(3,I)
10629 100 CONTINUE
10630 X1SUM = X1SUM/DBLE(N)
10631 X2SUM = X2SUM/DBLE(N)
10632 X3SUM = X3SUM/DBLE(N)
10633 DO 101 I=1,N
10634 X(1,I) = X(1,I)-X1SUM
10635 X(2,I) = X(2,I)-X2SUM
10636 X(3,I) = X(3,I)-X3SUM
10637 101 CONTINUE
10638 ELSE
10639
10640* maximum nuclear radius for coordinate sampling
10641 RMAX = R+4.605D0*PDIF
10642
10643* initialize pre-sorting
10644 DO 121 I=1,NSRT
10645 ICSRT(I) = 0
10646 121 CONTINUE
10647 DR = TWO*RMAX/DBLE(NSRT)
10648
10649* sample coordinates for N nucleons
10650 DO 140 I=1,N
10651 120 CONTINUE
10652 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10653 F = DT_DENSIT(N,RAD,R)
10654 IF (DT_RNDM(RAD).GT.F) GOTO 120
10655* theta, phi uniformly distributed
10656 CT = ONE-TWO*DT_RNDM(F)
10657 ST = SQRT((ONE-CT)*(ONE+CT))
10658 CALL DT_DSFECF(SFE,CFE)
10659 X(1,I) = RAD*ST*CFE
10660 X(2,I) = RAD*ST*SFE
10661 X(3,I) = RAD*CT
10662* ensure that distance between two nucleons is greater than R2MIN
10663 IF (I.LT.2) GOTO 122
10664 I1 = I-1
10665 DO 130 I2=1,I1
10666 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10667 & (X(3,I)-X(3,I2))**2
10668 IF (DIST2.LE.R2MIN) GOTO 120
10669 130 CONTINUE
10670 122 CONTINUE
10671* save index according to z-bin
10672 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10673 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10674 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10675 X1SUM = X1SUM+X(1,I)
10676 X2SUM = X2SUM+X(2,I)
10677 X3SUM = X3SUM+X(3,I)
10678 140 CONTINUE
10679 X1SUM = X1SUM/DBLE(N)
10680 X2SUM = X2SUM/DBLE(N)
10681 X3SUM = X3SUM/DBLE(N)
10682 DO 141 I=1,N
10683 X(1,I) = X(1,I)-X1SUM
10684 X(2,I) = X(2,I)-X2SUM
10685 X(3,I) = X(3,I)-X3SUM
10686 141 CONTINUE
10687
10688 ENDIF
10689
10690 RETURN
10691 END
10692
10693*$ CREATE DT_DENSIT.FOR
10694*COPY DT_DENSIT
10695*
10696*===densit=============================================================*
10697*
10698 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10699
10700 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10701 SAVE
10702
10703 PARAMETER ( LINP = 10 ,
10704 & LOUT = 6 ,
10705 & LDAT = 9 )
10706
10707 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10708 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10709 & PI = TWOPI/TWO)
10710
10711 DIMENSION R0(18),FNORM(18)
10712 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10713 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10714 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10715 & 2.72D0, 2.66D0, 2.79D0/
10716 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10717 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10718 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10719 & .1214D+01,.1265D+01,.1318D+01/
10720 DATA PDIF /0.545D0/
10721
10722 DT_DENSIT = ZERO
10723* shell model
10724 IF (NA.LE.4) THEN
10725 STOP 'DT_DENSIT-0'
10726 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10727 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10728 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10729 & *EXP(-(R/R1)**2)/FNORM(NA)
10730* Woods-Saxon
10731 ELSEIF (NA.GT.18) THEN
10732 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10733 ENDIF
10734
10735 RETURN
10736 END
10737
10738*$ CREATE DT_RNCLUS.FOR
10739*COPY DT_RNCLUS
10740*
10741*===rnclus=============================================================*
10742*
10743 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10744
10745************************************************************************
10746* Nuclear radius for nucleus with mass number N. *
10747* This version dated 26.9.00 is written by S. Roesler *
10748************************************************************************
10749
10750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10751 SAVE
10752
10753 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10754
10755* nucleon radius
10756 PARAMETER (RNUCLE = 1.12D0)
10757
10758* nuclear radii for selected nuclei
10759 DIMENSION RADNUC(18)
10760 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10761 & 2.58D0,2.71D0,2.66D0,2.71D0/
10762
10763 IF (N.LE.18) THEN
10764 IF (RADNUC(N).GT.0.0D0) THEN
10765 DT_RNCLUS = RADNUC(N)
10766 ELSE
10767 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10768 ENDIF
10769 ELSE
10770 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10771 ENDIF
10772
10773 RETURN
10774 END
10775
10776*$ CREATE DT_DENTST.FOR
10777*COPY DT_DENTST
10778*
10779*===dentst=============================================================*
10780*
10781C PROGRAM DT_DENTST
10782 SUBROUTINE DT_DENTST
10783
10784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10785 SAVE
10786
10787 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10788 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10789
10790 RMIN = 0.0D0
10791 RMAX = 8.0D0
10792 NBINS = 500.0D0
10793 DR = (RMAX-RMIN)/DBLE(NBINS)
10794 DO 1 IA=5,18
10795 FMAX = 0.0D0
10796 DO 2 IR=1,NBINS+1
10797 R = RMIN+DBLE(IR-1)*DR
10798 F = DT_DENSIT(IA,R,R)
10799 IF (F.GT.FMAX) FMAX = F
10800 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10801 2 CONTINUE
10802 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10803 1 CONTINUE
10804
10805 CLOSE(40)
10806 CLOSE(41)
10807
10808 END
10809
10810*$ CREATE DT_SHMAKI.FOR
10811*COPY DT_SHMAKI
10812*
10813*===shmaki=============================================================*
10814*
10815 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10816
10817************************************************************************
10818* Initialisation of Glauber formalism. This subroutine has to be *
10819* called once (in case of target emulsions as often as many different *
10820* target nuclei are considered) before events are sampled. *
10821* NA / NCA mass number/charge of projectile nucleus *
10822* NB / NCB mass number/charge of target nucleus *
10823* IJP identity of projectile (hadrons/leptons/photons) *
10824* PPN projectile momentum (for projectile nuclei: *
10825* momentum per nucleon) in target rest system *
10826* MODE = 0 Glauber formalism invoked *
10827* = 1 fitted results are loaded from data-file *
10828* = 99 NTARG is forced to be 1 *
10829* (used in connection with GLAUBERI-card only) *
10830* This version dated 22.03.96 is based on the original SHMAKI-routine *
10831* and revised by S. Roesler. *
10832************************************************************************
10833
10834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10835 SAVE
10836
10837 PARAMETER ( LINP = 10 ,
10838 & LOUT = 6 ,
10839 & LDAT = 9 )
10840
10841 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10842 & THREE=3.0D0)
10843
10844 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10845
10846* Glauber formalism: parameters
10847 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10848 & BMAX(NCOMPX),BSTEP(NCOMPX),
10849 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10850 & NSITEB,NSTATB
10851
10852* Lorentz-parameters of the current interaction
10853 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10854 & UMO,PPCM,EPROJ,PPROJ
10855
10856* properties of photon/lepton projectiles
10857 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10858
10859* kinematical cuts for lepton-nucleus interactions
10860 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10861 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10862
10863* Glauber formalism: cross sections
10864 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10865 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10866 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10867 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10868 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10869 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10870 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10871 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10872 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10873 & BSLOPE,NEBINI,NQBINI
10874
10875* cuts for variable energy runs
10876 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10877
10878* nucleon-nucleon event-generator
10879 CHARACTER*8 CMODEL
10880 LOGICAL LPHOIN
10881 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10882
10883* Glauber formalism: flags and parameters for statistics
10884 LOGICAL LPROD
10885 CHARACTER*8 CGLB
10886 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10887
10888 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10889
10890C CALL DT_HISHAD
10891C STOP
10892
10893 NTARG = NTARG+1
10894 IF (MODE.EQ.99) NTARG = 1
10895 NIDX = -NTARG
10896 IF (MODE.EQ.-1) NIDX = NTARG
10897
10898 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10899 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10900 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10901 & ' initialization',/,12X,'--------------------------',
10902 & '-------------------------',/)
10903
10904 IF (MODE.EQ.2) THEN
10905 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10906 CALL DT_SHFAST(MODE,PPN,IBACK)
10907 STOP ' Glauber pre-initialization done'
10908 ENDIF
10909 IF (MODE.EQ.1) THEN
10910 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10911 ELSE
10912 IBACK = 1
10913 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10914 IF (IBACK.EQ.1) THEN
10915* lepton-nucleus (variable energy runs)
10916 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10917 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10918 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10919 & WRITE(LOUT,1002) NB,NCB
10920 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10921 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10922 & 'E_cm (GeV) Q^2 (GeV^2)',
10923 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10924 & '--------------------------------',
10925 & '------------------------------')
10926 AECMLO = LOG10(MIN(UMO,ECMLI))
10927 AECMHI = LOG10(MIN(UMO,ECMHI))
10928 IESTEP = NEB-1
10929 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10930 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10931 DO 1 I=1,IESTEP+1
10932 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10933 IF (Q2HI.GT.0.1D0) THEN
10934 IF (Q2LI.LT.0.01D0) THEN
10935 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10936 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10937 & WRITE(LOUT,1003)
10938 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10939 Q2LI = 0.01D0
10940 IBIN = 2
10941 ELSE
10942 IBIN = 1
10943 ENDIF
10944 IQSTEP = NQB-IBIN
10945 AQ2LO = LOG10(Q2LI)
10946 AQ2HI = LOG10(Q2HI)
10947 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10948 DO 2 J=IBIN,IQSTEP+IBIN
10949 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10950 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10951 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10952 & WRITE(LOUT,1003) ECMNN(I),
10953 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10954 2 CONTINUE
10955 ELSE
10956 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10957 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10958 & WRITE(LOUT,1003)
10959 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10960 ENDIF
10961 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10962 1 CONTINUE
10963 IVEOUT = 1
10964 ELSE
10965* hadron/photon/nucleus-nucleus
10966 IF ((ABS(VAREHI).GT.ZERO).AND.
10967 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10968 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10969 WRITE(LOUT,1004) NA,NB,NCB
10970 1004 FORMAT(1X,'variable energy run: projectile-id:',
10971 & I3,' target A/Z: ',I3,' /',I3,/)
10972 WRITE(LOUT,1005)
10973 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10974 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10975 & ' -------------------------------------',
10976 & '--------------------------------------')
10977 ENDIF
10978 AECMLO = LOG10(VARCLO)
10979 AECMHI = LOG10(VARCHI)
10980 IESTEP = NEB-1
10981 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10982 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10983 DO 3 I=1,IESTEP+1
10984 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10985 AMP = 0.938D0
10986 AMT = 0.938D0
10987 AMP2 = AMP**2
10988 AMT2 = AMT**2
10989 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10990 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10991 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10992 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10993 & WRITE(LOUT,1006)
10994 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10995 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10996 3 CONTINUE
10997 IVEOUT = 1
10998 ELSE
10999 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11000 ENDIF
11001 ENDIF
11002 ENDIF
11003 ENDIF
11004
11005 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11006 & (IOGLB.NE.100)) THEN
11007 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11008 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11009 1001 FORMAT(38X,'projectile',
11010 & ' target',/,1X,'Mass number / charge',
11011 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11012 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11013 & 'Parameters of elastic scattering amplitude:',/,5X,
11014 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11015 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11016 & 'statistics at each b-step',4X,I5,/,/,1X,
11017 & 'Prod. cross section ',5X,F10.4,' mb',/)
11018 ENDIF
11019
11020 RETURN
11021 END
11022
11023*$ CREATE DT_PROFBI.FOR
11024*COPY DT_PROFBI
11025*
11026*===profbi=============================================================*
11027*
11028 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11029
11030************************************************************************
11031* Integral over profile function (to be used for impact-parameter *
11032* sampling during event generation). *
11033* Fitted results are used. *
11034* NA / NB mass numbers of proj./target nuclei *
11035* PPN projectile momentum (for projectile nuclei: *
11036* momentum per nucleon) in target rest system *
11037* NTARG index of target material (i.e. kind of nucleus) *
11038* This version dated 31.05.95 is revised by S. Roesler *
11039************************************************************************
11040
11041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11042 SAVE
11043
11044 PARAMETER ( LINP = 10 ,
11045 & LOUT = 6 ,
11046 & LDAT = 9 )
11047
11048 SAVE
11049
11050 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11051
11052 LOGICAL LSTART
11053 CHARACTER CNAME*80
11054
11055 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11056
11057* Glauber formalism: parameters
11058 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11059 & BMAX(NCOMPX),BSTEP(NCOMPX),
11060 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11061 & NSITEB,NSTATB
11062
11063* Glauber formalism: cross sections
11064 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11065 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11066 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11067 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11068 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11069 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11070 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11071 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11072 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11073 & BSLOPE,NEBINI,NQBINI
11074
11075 PARAMETER (NGLMAX=8000)
11076 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11077 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11078
11079 DATA LSTART /.TRUE./
11080
11081 IF (LSTART) THEN
11082* read fit-parameters from file
11083 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11084 I = 0
11085 1 CONTINUE
11086 READ(47,'(A80)') CNAME
11087 IF (CNAME.EQ.'STOP') GOTO 2
11088 I = I+1
11089 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11090 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11091 & GLAFIT(4,I),GLAFIT(5,I)
11092 IF (I+1.GT.NGLMAX) THEN
11093 WRITE(LOUT,1000)
11094 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11095 & 'program stopped')
11096 STOP
11097 ENDIF
11098 GOTO 1
11099 2 CONTINUE
11100 NGLPAR = I
11101 LSTART = .FALSE.
11102 ENDIF
11103
11104 NNA = NA
11105 NNB = NB
11106 IF (NA.GT.NB) THEN
11107 NNA = NB
11108 NNB = NA
11109 ENDIF
11110 IDXGLA = 0
11111 DO 3 J=1,NGLPAR
11112 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11113 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11114 DO 4 K=1,J-1
11115 IPOINT = J-K
11116 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11117 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11118 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11119 IF (IPOINT.EQ.1) IPOINT = 0
11120 NATMP = NGLIP(IPOINT+1)
11121 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11122 IDXGLA = IPOINT+1
11123 GOTO 6
11124 ELSE
11125 J1BEG = IPOINT+1
11126 J1END = J
11127C IF (J.EQ.NGLPAR) THEN
11128C J1BEG = IPOINT
11129C J1END = J
11130C ENDIF
11131 DO 5 J1=J1BEG,J1END
11132 IF (NGLIP(J1).EQ.NATMP) THEN
11133 IF (PPN.LT.GLAPPN(J1)) THEN
11134 IDXGLA = J1
11135 GOTO 6
11136 ENDIF
11137 ELSE
11138 IDXGLA = J1-1
11139 GOTO 6
11140 ENDIF
11141 5 CONTINUE
11142 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11143 & IDXGLA = NGLPAR
11144 ENDIF
11145 ENDIF
11146 4 CONTINUE
11147 ENDIF
11148 3 CONTINUE
11149
11150 6 CONTINUE
11151 IF (IDXGLA.EQ.0) THEN
11152 WRITE(LOUT,1001) NNA,NNB,PPN
11153 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11154 & 2I4,F6.0,') not found ')
11155 STOP
11156 ENDIF
11157
11158* no interpolation yet available
11159 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11160
11161 BSITE(1,1,NTARG,1) = ZERO
11162 DO 10 I=2,NSITEB
11163 XX = DBLE(I)
11164 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11165 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11166 & GLAFIT(5,IDXGLA)*XX**4
11167 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11168 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11169 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11170 10 CONTINUE
11171
11172 RETURN
11173 END
11174
11175*$ CREATE DT_GLAUBE.FOR
11176*COPY DT_GLAUBE
11177*
11178*===glaube=============================================================*
11179*
11180 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11181
11182************************************************************************
11183* Calculation of configuartion of interacting nucleons for one event. *
11184* NB / NB mass numbers of proj./target nuclei (input) *
11185* B impact parameter (output) *
11186* INTT total number of wounded nucleons " *
11187* INTA / INTB number of wounded nucleons in proj. / target " *
11188* JS / JT(i) number of collisions proj. / target nucleon i is *
11189* involved (output) *
11190* NIDX index of projectile/target material (input) *
11191* = -2 call within FLUKA transport calculation *
11192* This is an update of the original routine SHMAKO by J.Ranft/HJM *
11193* This version dated 22.03.96 is revised by S. Roesler *
11194* *
11195* Last change 27.12.2006 by S. Roesler. *
11196************************************************************************
11197
11198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11199 SAVE
11200
11201 PARAMETER ( LINP = 10 ,
11202 & LOUT = 6 ,
11203 & LDAT = 9 )
11204
11205 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11206 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11207
11208 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11209
11210 PARAMETER ( MAXNCL = 260,
11211
11212 & MAXVQU = MAXNCL,
11213 & MAXSQU = 20*MAXVQU,
11214 & MAXINT = MAXVQU+MAXSQU)
11215
11216* Glauber formalism: parameters
11217 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11218 & BMAX(NCOMPX),BSTEP(NCOMPX),
11219 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11220 & NSITEB,NSTATB
11221
11222* Glauber formalism: cross sections
11223 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11224 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11225 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11226 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11227 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11228 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11229 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11230 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11231 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11232 & BSLOPE,NEBINI,NQBINI
11233
11234* Lorentz-parameters of the current interaction
11235 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11236 & UMO,PPCM,EPROJ,PPROJ
11237
11238* properties of photon/lepton projectiles
11239 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11240
11241* Glauber formalism: collision properties
11242 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11243 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11244
11245* Glauber formalism: flags and parameters for statistics
11246 LOGICAL LPROD
11247 CHARACTER*8 CGLB
11248 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11249
11250 DIMENSION JS(MAXNCL),JT(MAXNCL)
11251
11252 NTARG = ABS(NIDX)
11253
11254* get actual energy from /DTLTRA/
11255 ECMNOW = UMO
11256 Q2 = VIRT
11257*
11258* new patch for pre-initialized variable projectile/target/energy runs,
11259* bypassed for use within FLUKA (Nidx=-2)
11260 IF (IOGLB.EQ.100) THEN
11261 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11262*
11263* variable energy run, interpolate profile function
11264 ELSE
11265 I1 = 1
11266 I2 = 1
11267 RATE = ONE
11268 IF (NEBINI.GT.1) THEN
11269 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11270 I1 = NEBINI
11271 I2 = NEBINI
11272 RATE = ONE
11273 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11274 DO 1 I=2,NEBINI
11275 IF (ECMNOW.LT.ECMNN(I)) THEN
11276 I1 = I-1
11277 I2 = I
11278 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11279 GOTO 2
11280 ENDIF
11281 1 CONTINUE
11282 2 CONTINUE
11283 ENDIF
11284 ENDIF
11285 J1 = 1
11286 J2 = 1
11287 RATQ = ONE
11288 IF (NQBINI.GT.1) THEN
11289 IF (Q2.GE.Q2G(NQBINI)) THEN
11290 J1 = NQBINI
11291 J2 = NQBINI
11292 RATQ = ONE
11293 ELSEIF (Q2.GT.Q2G(1)) THEN
11294 DO 3 I=2,NQBINI
11295 IF (Q2.LT.Q2G(I)) THEN
11296 J1 = I-1
11297 J2 = I
11298 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11299 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11300C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11301 GOTO 4
11302 ENDIF
11303 3 CONTINUE
11304 4 CONTINUE
11305 ENDIF
11306 ENDIF
11307
11308 DO 5 I=1,KSITEB
11309 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11310 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11311 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11312 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11313 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11314 5 CONTINUE
11315 ENDIF
11316
11317 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11318 IF (NIDX.LE.-1) THEN
11319 RPROJ = RASH(1)
11320 RTARG = RBSH(NTARG)
11321 ELSE
11322 RPROJ = RASH(NTARG)
11323 RTARG = RBSH(1)
11324 ENDIF
11325
11326 RETURN
11327 END
11328
11329*$ CREATE DT_DIAGR.FOR
11330*COPY DT_DIAGR
11331*
11332*===diagr==============================================================*
11333*
11334 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11335 & NIDX)
11336
11337************************************************************************
11338* Based on the original version by Shmakov et al. *
11339* This version dated 21.04.95 is revised by S. Roesler *
11340************************************************************************
11341
11342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11343 SAVE
11344
11345 PARAMETER ( LINP = 10 ,
11346 & LOUT = 6 ,
11347 & LDAT = 9 )
11348
11349 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11350 PARAMETER (TWOPI = 6.283185307179586454D+00,
11351 & PI = TWOPI/TWO,
11352 & GEV2MB = 0.38938D0,
11353 & GEV2FM = 0.1972D0,
11354 & ALPHEM = ONE/137.0D0,
11355* proton mass
11356 & AMP = 0.938D0,
11357 & AMP2 = AMP**2,
11358* rho0 mass
11359 & AMRHO0 = 0.77D0)
11360
11361 COMPLEX*16 C,CA,CI
11362
11363 PARAMETER ( MAXNCL = 260,
11364
11365 & MAXVQU = MAXNCL,
11366 & MAXSQU = 20*MAXVQU,
11367 & MAXINT = MAXVQU+MAXSQU)
11368
11369* particle properties (BAMJET index convention)
11370 CHARACTER*8 ANAME
11371 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11372 & IICH(210),IIBAR(210),K1(210),K2(210)
11373
11374 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11375
11376* emulsion treatment
11377 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11378 & NCOMPO,IEMUL
11379
11380* Glauber formalism: parameters
11381 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11382 & BMAX(NCOMPX),BSTEP(NCOMPX),
11383 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11384 & NSITEB,NSTATB
11385
11386* Glauber formalism: cross sections
11387 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11388 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11389 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11390 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11391 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11392 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11393 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11394 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11395 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11396 & BSLOPE,NEBINI,NQBINI
11397
11398* VDM parameter for photon-nucleus interactions
11399 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11400
11401* nucleon-nucleon event-generator
11402 CHARACTER*8 CMODEL
11403 LOGICAL LPHOIN
11404 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11405**PHOJET105a
11406C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11407**PHOJET112
11408
11409C obsolete cut-off information
11410 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11411 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11412**
11413
11414* coordinates of nucleons
11415 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11416
11417* interface between Glauber formalism and DPM
11418 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11419 & INTER1(MAXINT),INTER2(MAXINT)
11420
11421* statistics: Glauber-formalism
11422 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11423
11424* n-n cross section fluctuations
11425 PARAMETER (NBINS = 1000)
11426 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11427
11428 DIMENSION JS(MAXNCL),JT(MAXNCL),
11429 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11430 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11431 DIMENSION NWA(0:210),NWB(0:210)
11432
11433 LOGICAL LFIRST
11434 DATA LFIRST /.TRUE./
11435
11436 DATA NTARGO,ICNT /0,0/
11437
11438 NTARG = ABS(NIDX)
11439
11440 IF (LFIRST) THEN
11441 LFIRST = .FALSE.
11442 IF (NCOMPO.EQ.0) THEN
11443 NCALL = 0
11444 NWAMAX = NA
11445 NWBMAX = NB
11446 DO 17 I=0,210
11447 NWA(I) = 0
11448 NWB(I) = 0
11449 17 CONTINUE
11450 ENDIF
11451 ENDIF
11452 IF (NTARG.EQ.-1) THEN
11453 IF (NCOMPO.EQ.0) THEN
11454 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11455 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11456 & NCALL,NWAMAX,NWBMAX
11457 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11458 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11459 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11460 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11461 18 CONTINUE
11462 ENDIF
11463 RETURN
11464 ENDIF
11465
11466 DCOH = 1.0D10
11467 IPNT = 0
11468
11469 SQ2 = Q2
11470 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11471 S = ECMNOW**2
11472 X = SQ2/(S+SQ2-AMP2)
11473 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11474* photon projectiles: recalculate photon-nucleon amplitude
11475 IF (IJPROJ.EQ.7) THEN
11476 15 CONTINUE
11477* VDM assumption: mass of V-meson
11478 AMV2 = DT_SAM2(SQ2,ECMNOW)
11479 AMV = SQRT(AMV2)
11480 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11481* check for pointlike interaction
11482 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11483**sr 27.10.
11484C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11485 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11486**
11487 ROSH = 0.1D0
11488 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11489 & +0.25D0*LOG(S/(AMV2+SQ2)))
11490* coherence length
11491 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11492 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11493 IF (MCGENE.EQ.2) THEN
11494 ZERO1 = ZERO
11495 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11496 & BSLOPE,0)
11497 ELSE
11498 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11499 ENDIF
11500 IF (ECMNOW.LE.3.0D0) THEN
11501 ROSH = -0.43D0
11502 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11503 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11504 ELSEIF (ECMNOW.GT.50.0D0) THEN
11505 ROSH = 0.1D0
11506 ENDIF
11507 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11508 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11509 IF (MCGENE.EQ.2) THEN
11510 ZERO1 = ZERO
11511 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11512 & BDUM,0)
11513 SIGSH = SIGSH/10.0D0
11514 ELSE
11515C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11516 DUMZER = ZERO
11517 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11518 SIGSH = SIGSH/10.0D0
11519 ENDIF
11520 ELSE
11521 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11522 ROSH = 0.01D0
11523 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11524 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11525C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11526 DUMZER = ZERO
11527 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11528 SIGSH = SIGSH/10.0D0
11529 ENDIF
11530 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11531 GAM = GSH
11532 RCA = GAM*SIGSH/TWOPI
11533 FCA = -ROSH*RCA
11534 CA = DCMPLX(RCA,FCA)
11535 CI = DCMPLX(ONE,ZERO)
11536
11537 16 CONTINUE
11538* impact parameter
11539 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11540
11541 NTRY = 0
11542 3 CONTINUE
11543 NTRY = NTRY+1
11544* initializations
11545 JNT = 0
11546 DO 1 I=1,NA
11547 JS(I) = 0
11548 1 CONTINUE
11549 DO 2 I=1,NB
11550 JT(I) = 0
11551 2 CONTINUE
11552 IF (IJPROJ.EQ.7) THEN
11553 DO 8 I=1,MAXNCL
11554 JS0(I) = 0
11555 JNT0(I)= 0
11556 DO 9 J=1,NB
11557 JT0(I,J) = 0
11558 9 CONTINUE
11559 8 CONTINUE
11560 ENDIF
11561
11562* nucleon configuration
11563C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11564 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11565C CALL DT_CONUCL(PKOO,NA,RASH,2)
11566C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11567 IF (NIDX.LE.-1) THEN
11568 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11569 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11570 ELSE
11571 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11572 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11573 ENDIF
11574 NTARGO = NTARG
11575 ENDIF
11576 ICNT = ICNT+1
11577
11578* LEPTO: pick out one struck nucleon
11579 IF (MCGENE.EQ.3) THEN
11580 JNT = 1
11581 JS(1) = 1
11582 IDX = INT(DT_RNDM(X)*NB)+1
11583 JT(IDX) = 1
11584 B = ZERO
11585 GOTO 19
11586 ENDIF
11587
11588 DO 4 INA=1,NA
11589* cross section fluctuations
11590 AFLUC = ONE
11591 IF (IFLUCT.EQ.1) THEN
11592 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11593 AFLUC = FLUIXX(IFLUK)
11594 ENDIF
11595 KK1 = 1
11596 KINT = 1
11597 DO 5 INB=1,NB
11598* photon-projectile: check for supression by coherence length
11599 IF (IJPROJ.EQ.7) THEN
11600 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11601 KK1 = INB
11602 KINT = KINT+1
11603 ENDIF
11604 ENDIF
11605 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11606 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11607 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11608 IF (XY.LE.15.0D0) THEN
11609 C = CI-CA*AFLUC*EXP(-XY)
11610 AR = DBLE(C)
11611 AI = DIMAG(C)
11612 P = AR*AR+AI*AI
11613 IF (DT_RNDM(XY).GE.P) THEN
11614 JNT = JNT+1
11615 IF (IJPROJ.EQ.7) THEN
11616 JNT0(KINT) = JNT0(KINT)+1
11617 IF (JNT0(KINT).GT.MAXNCL) THEN
11618 WRITE(LOUT,1001) MAXNCL
11619 1001 FORMAT(1X,
11620 & 'DIAGR: no. of requested interactions',
11621 & ' exceeds array dimensions ',I4)
11622 STOP
11623 ENDIF
11624 JS0(KINT) = JS0(KINT)+1
11625 JT0(KINT,INB) = JT0(KINT,INB)+1
11626 JI1(KINT,JNT0(KINT)) = INA
11627 JI2(KINT,JNT0(KINT)) = INB
11628 ELSE
11629 IF (JNT.GT.MAXINT) THEN
11630 WRITE(LOUT,1000) JNT, MAXINT
11631 1000 FORMAT(1X,
11632 & 'DIAGR: no. of requested interactions ('
11633 & ,I4,') exceeds array dimensions (',I4,')')
11634 STOP
11635 ENDIF
11636 JS(INA) = JS(INA)+1
11637 JT(INB) = JT(INB)+1
11638 INTER1(JNT) = INA
11639 INTER2(JNT) = INB
11640 ENDIF
11641 ENDIF
11642 ENDIF
11643 5 CONTINUE
11644 4 CONTINUE
11645
11646 IF (JNT.EQ.0) THEN
11647 IF (NTRY.LT.500) THEN
11648 GOTO 3
11649 ELSE
11650C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11651 GOTO 16
11652 ENDIF
11653 ENDIF
11654
11655 IDIREC = 0
11656 IF (IJPROJ.EQ.7) THEN
11657 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11658 10 CONTINUE
11659 IF (JNT0(K).EQ.0) THEN
11660 K = K+1
11661 IF (K.GT.KINT) K = 1
11662 GOTO 10
11663 ENDIF
11664* supress Glauber-cascade by direct photon processes
11665 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11666 IF (IPNT.GT.0) THEN
11667 JNT = 1
11668 JS(1) = 1
11669 DO 11 INB=1,NB
11670 JT(INB) = JT0(K,INB)
11671 IF (JT(INB).GT.0) GOTO 12
11672 11 CONTINUE
11673 12 CONTINUE
11674 INTER1(1) = 1
11675 INTER2(1) = INB
11676 IDIREC = IPNT
11677 ELSE
11678 JNT = JNT0(K)
11679 JS(1) = JS0(K)
11680 DO 13 INB=1,NB
11681 JT(INB) = JT0(K,INB)
11682 13 CONTINUE
11683 DO 14 I=1,JNT
11684 INTER1(I) = JI1(K,I)
11685 INTER2(I) = JI2(K,I)
11686 14 CONTINUE
11687 ENDIF
11688 ENDIF
11689
11690 19 CONTINUE
11691 INTA = 0
11692 INTB = 0
11693 DO 6 I=1,NA
11694 IF (JS(I).NE.0) INTA=INTA+1
11695 6 CONTINUE
11696 DO 7 I=1,NB
11697 IF (JT(I).NE.0) INTB=INTB+1
11698 7 CONTINUE
11699 ICWPG = INTA
11700 ICWTG = INTB
11701 ICIG = JNT
11702 IPGLB = IPGLB+INTA
11703 ITGLB = ITGLB+INTB
11704 NGLB = NGLB+1
11705
11706 IF (NCOMPO.EQ.0) THEN
11707 NCALL = NCALL+1
11708 NWA(INTA) = NWA(INTA)+1
11709 NWB(INTB) = NWB(INTB)+1
11710 ENDIF
11711
11712 RETURN
11713 END
11714
11715*$ CREATE DT_MODB.FOR
11716*COPY DT_MODB
11717*
11718*===modb===============================================================*
11719*
11720 SUBROUTINE DT_MODB(B,NIDX)
11721
11722************************************************************************
11723* Sampling of impact parameter of collision. *
11724* B impact parameter (output) *
11725* NIDX index of projectile/target material (input)*
11726* Based on the original version by Shmakov et al. *
11727* This version dated 21.04.95 is revised by S. Roesler *
11728* *
11729* Last change 27.12.2006 by S. Roesler. *
11730************************************************************************
11731
11732 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11733 SAVE
11734
11735 PARAMETER ( LINP = 10 ,
11736 & LOUT = 6 ,
11737 & LDAT = 9 )
11738
11739 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11740
11741 LOGICAL LEFT,LFIRST
11742
11743* central particle production, impact parameter biasing
11744 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11745
11746 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11747
11748* Glauber formalism: parameters
11749 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11750 & BMAX(NCOMPX),BSTEP(NCOMPX),
11751 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11752 & NSITEB,NSTATB
11753
11754* Glauber formalism: cross sections
11755 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11756 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11757 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11758 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11759 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11760 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11761 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11762 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11763 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11764 & BSLOPE,NEBINI,NQBINI
11765
11766 DATA LFIRST /.TRUE./
11767
11768 NTARG = ABS(NIDX)
11769 IF (NIDX.LE.-1) THEN
11770 RA = RASH(1)
11771 RB = RBSH(NTARG)
11772 ELSE
11773 RA = RASH(NTARG)
11774 RB = RBSH(1)
11775 ENDIF
11776
11777 IF (ICENTR.EQ.2) THEN
11778 IF (RA.EQ.RB) THEN
11779 BB = DT_RNDM(B)*(0.3D0*RA)**2
11780 B = SQRT(BB)
11781 ELSEIF(RA.LT.RB)THEN
11782 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11783 B = SQRT(BB)
11784 ELSEIF(RA.GT.RB)THEN
11785 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11786 B = SQRT(BB)
11787 ENDIF
11788 ELSE
11789 9 CONTINUE
11790 Y = DT_RNDM(BB)
11791 I0 = 1
11792 I2 = NSITEB
11793 10 CONTINUE
11794 I1 = (I0+I2)/2
11795 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11796 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11797 IF (LEFT) GOTO 20
11798 I0 = I1
11799 GOTO 30
11800 20 CONTINUE
11801 I2 = I1
11802 30 CONTINUE
11803 IF (I2-I0-2) 40,50,60
11804 40 CONTINUE
11805 I1 = I2+1
11806 IF (I1.GT.NSITEB) I1 = I0-1
11807 GOTO 70
11808 50 CONTINUE
11809 I1 = I0+1
11810 GOTO 70
11811 60 CONTINUE
11812 GOTO 10
11813 70 CONTINUE
11814 X0 = DBLE(I0-1)*BSTEP(NTARG)
11815 X1 = DBLE(I1-1)*BSTEP(NTARG)
11816 X2 = DBLE(I2-1)*BSTEP(NTARG)
11817 Y0 = BSITE(0,1,NTARG,I0)
11818 Y1 = BSITE(0,1,NTARG,I1)
11819 Y2 = BSITE(0,1,NTARG,I2)
11820 80 CONTINUE
11821 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11822 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11823 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11824**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11825 B = B+0.5D0*BSTEP(NTARG)
11826 IF (B.LT.ZERO) B = X1
11827 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11828 IF (ICENTR.LT.0) THEN
11829 IF (LFIRST) THEN
11830 LFIRST = .FALSE.
11831 IF (ICENTR.LE.-100) THEN
11832 BIMIN = 0.0D0
11833 ELSE
11834 XSFRAC = 0.0D0
11835 ENDIF
11836 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11837 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11838 & BIMIN,BIMAX,XSFRAC*100.0D0,
11839 & XSFRAC*XSPRO(1,1,NTARG)
11840 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11841 & /,15X,'---------------------------'/,/,4X,
11842 & 'average radii of proj / targ :',F10.3,' fm /',
11843 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11844 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11845 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11846 & ' cross section :',F10.3,' %',/,5X,
11847 & 'corresponding cross section :',F10.3,' mb',/)
11848 ENDIF
11849 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11850 B = BIMIN
11851 ELSE
11852 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11853 ENDIF
11854 ENDIF
11855 ENDIF
11856
11857 RETURN
11858 END
11859
11860*$ CREATE DT_SHFAST.FOR
11861*COPY DT_SHFAST
11862*
11863*===shfast=============================================================*
11864*
11865 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11866
11867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11868 SAVE
11869
11870 PARAMETER ( LINP = 10 ,
11871 & LOUT = 6 ,
11872 & LDAT = 9 )
11873
11874 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11875 & ONE=1.0D0,TWO=2.0D0)
11876
11877 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11878
11879* Glauber formalism: parameters
11880 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11881 & BMAX(NCOMPX),BSTEP(NCOMPX),
11882 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11883 & NSITEB,NSTATB
11884
11885* properties of interacting particles
11886 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11887
11888* Glauber formalism: cross sections
11889 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11890 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11891 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11892 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11893 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11894 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11895 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11896 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11897 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11898 & BSLOPE,NEBINI,NQBINI
11899
11900 IBACK = 0
11901
11902 IF (MODE.EQ.2) THEN
11903 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11904 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11905 1000 FORMAT(1X,8I5,E15.5)
11906 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11907 1001 FORMAT(1X,4E15.5)
11908 WRITE(47,1002) SIGSH,ROSH,GSH
11909 1002 FORMAT(1X,3E15.5)
11910 DO 10 I=1,100
11911 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11912 10 CONTINUE
11913 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11914 1003 FORMAT(1X,2I10,3E15.5)
11915 CLOSE(47)
11916 ELSE
11917 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11918 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11919 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11920 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11921 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11922 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11923 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11924 READ(47,1002) SIGSH,ROSH,GSH
11925 DO 11 I=1,100
11926 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11927 11 CONTINUE
11928 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11929 ELSE
11930 IBACK = 1
11931 ENDIF
11932 CLOSE(47)
11933 ENDIF
11934
11935 RETURN
11936 END
11937
11938*$ CREATE DT_POILIK.FOR
11939*COPY DT_POILIK
11940*
11941*===poilik=============================================================*
11942*
11943 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11944
11945 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11946 SAVE
11947
11948 PARAMETER ( LINP = 10 ,
11949 & LOUT = 6 ,
11950 & LDAT = 9 )
11951
11952 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11953 PARAMETER (NE = 8)
11954
11955**PHOJET105a
11956C CHARACTER*8 MDLNA
11957C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11958C PARAMETER (IEETAB=10)
11959C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11960**PHOJET110
11961
11962C model switches and parameters
11963 CHARACTER*8 MDLNA
11964 INTEGER ISWMDL,IPAMDL
11965 DOUBLE PRECISION PARMDL
11966 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11967
11968C energy-interpolation table
11969 INTEGER IEETA2
11970 PARAMETER ( IEETA2 = 20 )
11971 INTEGER ISIMAX
11972 DOUBLE PRECISION SIGTAB,SIGECM
11973 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11974**
11975
11976* VDM parameter for photon-nucleus interactions
11977 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11978**sr 22.7.97
11979
11980 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11981
11982* Glauber formalism: cross sections
11983 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11984 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11985 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11986 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11987 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11988 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11989 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11990 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11991 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11992 & BSLOPE,NEBINI,NQBINI
11993**
11994
11995 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11996
11997 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11998
11999* load cross sections from interpolation table
12000 IP = 1
12001 IF(ECM.LE.SIGECM(IP,1)) THEN
12002 I1 = 1
12003 I2 = 1
12004 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12005 DO 50 I=2,ISIMAX
12006 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12007 50 CONTINUE
12008 200 CONTINUE
12009 I1 = I-1
12010 I2 = I
12011 ELSE
12012 WRITE(LOUT,'(/1X,A,2E12.3)')
12013 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12014 I1 = ISIMAX
12015 I2 = ISIMAX
12016 ENDIF
12017 FAC2 = ZERO
12018 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12019 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12020 FAC1 = ONE-FAC2
12021
12022 SIGANO = DT_SANO(ECM)
12023
12024* cross section dependence on photon virtuality
12025 FSUP1 = ZERO
12026 DO 150 I=1,3
12027 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12028 & /(ONE+VIRT/PARMDL(30+I))**2
12029 150 CONTINUE
12030 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12031 FAC1 = FAC1*FSUP1
12032 FAC2 = FAC2*FSUP1
12033 FSUP2 = ONE
12034
12035 ECMOLD = ECM
12036 Q2OLD = VIRT
12037
12038 3 CONTINUE
12039
12040C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12041 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12042 IF (ISHAD(1).EQ.1) THEN
12043 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12044 ELSE
12045 SIGDIR = ZERO
12046 ENDIF
12047 SIGANO = FSUP1*FSUP2*SIGANO
12048 SIGTOT = SIGTOT-SIGDIR-SIGANO
12049 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12050 SIGANO = SIGANO/(FSUP1*FSUP2)
12051 SIGTOT = SIGTOT+SIGDIR+SIGANO
12052
12053 RR = DT_RNDM(SIGTOT)
12054 IF (RR.LT.SIGDIR/SIGTOT) THEN
12055 IPNT = 1
12056 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12057 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12058 IPNT = 2
12059 ELSE
12060 IPNT = 0
12061 ENDIF
12062 RPNT = (SIGDIR+SIGANO)/SIGTOT
12063C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12064C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12065C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12066C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12067 IF (MODE.EQ.1) RETURN
12068
12069**sr 22.7.97
12070 K1 = 1
12071 K2 = 1
12072 RATE = ZERO
12073 IF (ECM.GE.ECMNN(NEBINI)) THEN
12074 K1 = NEBINI
12075 K2 = NEBINI
12076 RATE = ONE
12077 ELSEIF (ECM.GT.ECMNN(1)) THEN
12078 DO 10 I=2,NEBINI
12079 IF (ECM.LT.ECMNN(I)) THEN
12080 K1 = I-1
12081 K2 = I
12082 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12083 GOTO 11
12084 ENDIF
12085 10 CONTINUE
12086 11 CONTINUE
12087 ENDIF
12088 J1 = 1
12089 J2 = 1
12090 RATQ = ZERO
12091 IF (NQBINI.GT.1) THEN
12092 IF (VIRT.GE.Q2G(NQBINI)) THEN
12093 J1 = NQBINI
12094 J2 = NQBINI
12095 RATQ = ONE
12096 ELSEIF (VIRT.GT.Q2G(1)) THEN
12097 DO 12 I=2,NQBINI
12098 IF (VIRT.LT.Q2G(I)) THEN
12099 J1 = I-1
12100 J2 = I
12101 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12102 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12103 GOTO 13
12104 ENDIF
12105 12 CONTINUE
12106 13 CONTINUE
12107 ENDIF
12108 ENDIF
12109 SGA = XSPRO(K1,J1,NTARG)+
12110 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12111 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12112 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12113 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12114 SDI = DBLE(NB)*SIGDIR
12115 SAN = DBLE(NB)*SIGANO
12116 SPL = SDI+SAN
12117 RR = DT_RNDM(SPL)
12118 IF (RR.LT.SDI/SGA) THEN
12119 IPNT = 1
12120 ELSEIF ((RR.GE.SDI/SGA).AND.
12121 & (RR.LT.SPL/SGA)) THEN
12122 IPNT = 2
12123 ELSE
12124 IPNT = 0
12125 ENDIF
12126 RPNT = SPL/SGA
12127C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12128**
12129
12130 RETURN
12131 END
12132
12133*$ CREATE DT_GLBINI.FOR
12134*COPY DT_GLBINI
12135*
12136*===glbini=============================================================*
12137*
12138 SUBROUTINE DT_GLBINI(WHAT)
12139
12140************************************************************************
12141* Pre-initialization of profile function *
12142* This version dated 28.11.00 is written by S. Roesler. *
12143* *
12144* Last change 27.12.2006 by S. Roesler. *
12145************************************************************************
12146
12147 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12148 SAVE
12149
12150 PARAMETER ( LINP = 10 ,
12151 & LOUT = 6 ,
12152 & LDAT = 9 )
12153
12154 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12155
12156 LOGICAL LCMS
12157
12158* particle properties (BAMJET index convention)
12159 CHARACTER*8 ANAME
12160 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12161 & IICH(210),IIBAR(210),K1(210),K2(210)
12162
12163* properties of interacting particles
12164 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12165
12166 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12167
12168* emulsion treatment
12169 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12170 & NCOMPO,IEMUL
12171
12172* Glauber formalism: flags and parameters for statistics
12173 LOGICAL LPROD
12174 CHARACTER*8 CGLB
12175 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12176
12177* number of data sets other than protons and nuclei
12178* at the moment = 2 (pions and kaons)
12179 PARAMETER (MAXOFF=2)
12180 DIMENSION IJPINI(5),IOFFST(25)
12181 DATA IJPINI / 13, 15, 0, 0, 0/
12182* Glauber data-set to be used for hadron projectiles
12183* (0=proton, 1=pion, 2=kaon)
12184 DATA (IOFFST(K),K=1,25) /
12185 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12186 & 0, 0, 1, 2, 2/
12187* Acceptance interval for target nucleus mass
12188 PARAMETER (KBACC = 6)
12189
12190* flags for input different options
12191 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12192 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12193 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12194
12195 PARAMETER (MAXMSS = 100)
12196 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12197 DIMENSION WHAT(6)
12198
12199 DATA JPEACH,JPSTEP / 18, 5 /
12200
12201* temporary patch until fix has been implemented in phojet:
12202* maximum energy for pion projectile
12203 DATA ECMXPI / 100000.0D0 /
12204*
12205*--------------------------------------------------------------------------
12206* general initializations
12207*
12208* steps in projectile mass number for initialization
12209 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12210 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12211*
12212* energy range and binning
12213 ELO = ABS(WHAT(1))
12214 EHI = ABS(WHAT(2))
12215 IF (ELO.GT.EHI) ELO = EHI
12216 NEBIN = MAX(INT(WHAT(3)),1)
12217 IF (ELO.EQ.EHI) NEBIN = 0
12218 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12219 IF (LCMS) THEN
12220 ECMINI = EHI
12221 ELSE
12222 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12223 & +2.0D0*AAM(IJTARG)*EHI)
12224 ENDIF
12225*
12226* default arguments for Glauber-routine
12227 XI = ZERO
12228 Q2I = ZERO
12229*
12230* initialize nuclear parameters, etc.
12231
12232* initialize evaporation if the code is not used as Fluka event generator
12233 IF (ITRSPT.NE.1) THEN
12234 CALL NCDTRD
12235 CALL INCINI
12236 ENDIF
12237
12238*
12239* open Glauber-data output file
12240 IDX = INDEX(CGLB,' ')
12241 K = 12
12242 IF (IDX.GT.1) K = IDX-1
12243 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12244*
12245*--------------------------------------------------------------------------
12246* Glauber-initialization for proton and nuclei projectiles
12247*
12248* initialize phojet for proton-proton interactions
12249 ELAB = ZERO
12250 PLAB = ZERO
12251 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12252 CALL DT_PHOINI
12253*
12254* record projectile masses
12255 NASAV = 0
12256 NPROJ = MIN(IP,JPEACH)
12257 DO 10 KPROJ=1,NPROJ
12258 NASAV = NASAV+1
12259 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12260 IASAV(NASAV) = KPROJ
12261 10 CONTINUE
12262 IF (IP.GT.JPEACH) THEN
12263 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12264 IF (NPROJ.EQ.0) THEN
12265 NASAV = NASAV+1
12266 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12267 IASAV(NASAV) = IP
12268 ELSE
12269 DO 11 IPROJ=1,NPROJ
12270 KPROJ = JPEACH+IPROJ*JPSTEP
12271 NASAV = NASAV+1
12272 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12273 IASAV(NASAV) = KPROJ
12274 11 CONTINUE
12275 IF (KPROJ.LT.IP) THEN
12276 NASAV = NASAV+1
12277 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278 IASAV(NASAV) = IP
12279 ENDIF
12280 ENDIF
12281 ENDIF
12282*
12283* record target masses
12284 NBSAV = 0
12285 NTARG = 1
12286 IF (NCOMPO.GT.0) NTARG = NCOMPO
12287 DO 12 ITARG=1,NTARG
12288 NBSAV = NBSAV+1
12289 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12290 IF (NCOMPO.GT.0) THEN
12291 IBSAV(NBSAV) = IEMUMA(ITARG)
12292 ELSE
12293 IBSAV(NBSAV) = IT
12294 ENDIF
12295 12 CONTINUE
12296*
12297* print masses
12298 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12299 1000 FORMAT(I4,A,1P,2E13.5)
12300 NLINES = DBLE(NASAV)/18.0D0
12301 IF (NLINES.GT.0) THEN
12302 DO 13 I=1,NLINES
12303 IF (I.EQ.1) THEN
12304 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12305 ELSE
12306 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12307 ENDIF
12308 13 CONTINUE
12309 ENDIF
12310 I0 = 18*NLINES+1
12311 IF (I0.LE.NASAV) THEN
12312 IF (I0.EQ.1) THEN
12313 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12314 ELSE
12315 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12316 ENDIF
12317 ENDIF
12318 NLINES = DBLE(NBSAV)/18.0D0
12319 IF (NLINES.GT.0) THEN
12320 DO 14 I=1,NLINES
12321 IF (I.EQ.1) THEN
12322 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12323 ELSE
12324 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12325 ENDIF
12326 14 CONTINUE
12327 ENDIF
12328 I0 = 18*NLINES+1
12329 IF (I0.LE.NBSAV) THEN
12330 IF (I0.EQ.1) THEN
12331 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12332 ELSE
12333 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12334 ENDIF
12335 ENDIF
12336*
12337* calculate Glauber-data for each energy and mass combination
12338*
12339* loop over energy bins
12340 ELO = LOG10(ELO)
12341 EHI = LOG10(EHI)
12342 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12343 DO 1 IE=1,NEBIN+1
12344 E = ELO+DBLE(IE-1)*DEBIN
12345 E = 10**E
12346 IF (LCMS) THEN
12347 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12348 ECM = E
12349 ELSE
12350 PLAB = ZERO
12351 ECM = ZERO
12352 E = MAX(AAM(IJPROJ)+0.1D0,E)
12353 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12354 ENDIF
12355*
12356* loop over projectile and target masses
12357 DO 2 ITARG=1,NBSAV
12358 DO 3 IPROJ=1,NASAV
12359 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12360 & XI,Q2I,ECM,1,1,-1)
12361 3 CONTINUE
12362 2 CONTINUE
12363*
12364 1 CONTINUE
12365*
12366*--------------------------------------------------------------------------
12367* Glauber-initialization for pion, kaon, ... projectiles
12368*
12369 DO 6 IJ=1,MAXOFF
12370*
12371* initialize phojet for this interaction
12372 ELAB = ZERO
12373 PLAB = ZERO
12374 IJPROJ = IJPINI(IJ)
12375 IP = 1
12376 IPZ = 1
12377*
12378* temporary patch until fix has been implemented in phojet:
12379 IF (ECMINI.GT.ECMXPI) THEN
12380 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12381 ELSE
12382 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12383 ENDIF
12384 CALL DT_PHOINI
12385*
12386* calculate Glauber-data for each energy and mass combination
12387*
12388* loop over energy bins
12389 DO 4 IE=1,NEBIN+1
12390 E = ELO+DBLE(IE-1)*DEBIN
12391 E = 10**E
12392 IF (LCMS) THEN
12393 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12394 ECM = E
12395 ELSE
12396 PLAB = ZERO
12397 ECM = ZERO
12398 E = MAX(AAM(IJPROJ)+TINY14,E)
12399 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12400 ENDIF
12401*
12402* loop over projectile and target masses
12403 DO 5 ITARG=1,NBSAV
12404 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12405 5 CONTINUE
12406*
12407 4 CONTINUE
12408*
12409 6 CONTINUE
12410
12411*--------------------------------------------------------------------------
12412* close output unit(s), etc.
12413*
12414 CLOSE(LDAT)
12415
12416 RETURN
12417 END
12418
12419*$ CREATE DT_GLBSET.FOR
12420*COPY DT_GLBSET
12421*
12422*===glbset=============================================================*
12423*
12424 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12425************************************************************************
12426* Interpolation of pre-initialized profile functions *
12427* This version dated 28.11.00 is written by S. Roesler. *
12428************************************************************************
12429
12430 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12431 SAVE
12432
12433 PARAMETER ( LINP = 10 ,
12434 & LOUT = 6 ,
12435 & LDAT = 9 )
12436
12437 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12438
12439 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12440
12441* particle properties (BAMJET index convention)
12442 CHARACTER*8 ANAME
12443 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12444 & IICH(210),IIBAR(210),K1(210),K2(210)
12445
12446* Glauber formalism: flags and parameters for statistics
12447 LOGICAL LPROD
12448 CHARACTER*8 CGLB
12449 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12450
12451 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12452
12453* Glauber formalism: parameters
12454 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12455 & BMAX(NCOMPX),BSTEP(NCOMPX),
12456 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12457 & NSITEB,NSTATB
12458
12459* Glauber formalism: cross sections
12460 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12461 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12462 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12463 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12464 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12465 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12466 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12467 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12468 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12469 & BSLOPE,NEBINI,NQBINI
12470
12471* number of data sets other than protons and nuclei
12472* at the moment = 2 (pions and kaons)
12473 PARAMETER (MAXOFF=2)
12474 DIMENSION IJPINI(5),IOFFST(25)
12475 DATA IJPINI / 13, 15, 0, 0, 0/
12476* Glauber data-set to be used for hadron projectiles
12477* (0=proton, 1=pion, 2=kaon)
12478 DATA (IOFFST(K),K=1,25) /
12479 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12480 & 0, 0, 1, 2, 2/
12481* Acceptance interval for target nucleus mass
12482 PARAMETER (KBACC = 6)
12483
12484* emulsion treatment
12485 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12486 & NCOMPO,IEMUL
12487
12488 PARAMETER (MAXSET=5000,
12489 & MAXBIN=100)
12490 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12491 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12492 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12493 & IAIDX(10)
12494
12495 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12496*
12497* read data from file
12498*
12499 IF (MODE.EQ.0) THEN
12500
12501 IF (LREAD) RETURN
12502
12503 DO 1 I=1,MAXSET
12504 DO 2 J=1,6
12505 XSIG(I,J) = ZERO
12506 XERR(I,J) = ZERO
12507 2 CONTINUE
12508 DO 3 J=1,KSITEB
12509 BPROFL(I,J) = ZERO
12510 3 CONTINUE
12511 1 CONTINUE
12512 DO 4 I=1,MAXBIN
12513 IABIN(I) = 0
12514 IBBIN(I) = 0
12515 4 CONTINUE
12516 DO 5 I=1,KSITEB
12517 BPRO0(I) = ZERO
12518 BPRO1(I) = ZERO
12519 BPRO(I) = ZERO
12520 5 CONTINUE
12521
12522 IDX = INDEX(CGLB,' ')
12523 K = 12
12524 IF (IDX.GT.1) K = IDX-1
12525 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12526 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12527 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12528 & 'file ',A12,/)
12529*
12530* read binning information
12531 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12532* return lower energy threshold to Fluka-interface
12533 ELAB = ELO
12534 LCMS = ELO.LT.ZERO
12535 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12536 IF (LCMS) THEN
12537 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12538 ELSE
12539 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12540 ENDIF
12541 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12542 & 'No. of bins:',I5,/)
12543 ELO = LOG10(ABS(ELO))
12544 EHI = LOG10(ABS(EHI))
12545 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12546 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12547 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12548 IF (NABIN.LT.18) THEN
12549 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12550 ELSE
12551 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12552 ENDIF
12553 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12554 IF (NABIN.GT.18) THEN
12555 NLINES = DBLE(NABIN-18)/18.0D0
12556 IF (NLINES.GT.0) THEN
12557 DO 7 I=1,NLINES
12558 I0 = 18*(I+1)-17
12559 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12560 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12561 7 CONTINUE
12562 ENDIF
12563 I0 = 18*(NLINES+1)+1
12564 IF (I0.LE.NABIN) THEN
12565 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12566 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12567 ENDIF
12568 ENDIF
12569 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12570 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12571 IF (NBBIN.LT.18) THEN
12572 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12573 ELSE
12574 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12575 ENDIF
12576 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12577 IF (NBBIN.GT.18) THEN
12578 NLINES = DBLE(NBBIN-18)/18.0D0
12579 IF (NLINES.GT.0) THEN
12580 DO 8 I=1,NLINES
12581 I0 = 18*(I+1)-17
12582 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12583 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12584 8 CONTINUE
12585 ENDIF
12586 I0 = 18*(NLINES+1)+1
12587 IF (I0.LE.NBBIN) THEN
12588 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12589 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12590 ENDIF
12591 ENDIF
12592* number of data sets to follow in the Glauber data file
12593* this variable is used for checks of consistency of projectile
12594* and target mass configurations given in header of Glauber data
12595* file and the data-sets which follow in this file
12596 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12597*
12598* read profile function data
12599 NSET = 0
12600 NAIDX = 0
12601 IPOLD = 0
12602 10 CONTINUE
12603 NSET = NSET+1
12604 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12605 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12606 1002 FORMAT(5I10,E15.5)
12607 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12608 NAIDX = NAIDX+1
12609 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12610 IAIDX(NAIDX) = IP
12611 IPOLD = IP
12612 ENDIF
12613 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12614 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12615 NLINES = INT(DBLE(ISITEB)/7.0D0)
12616 IF (NLINES.GT.0) THEN
12617 DO 11 I=1,NLINES
12618 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12619 11 CONTINUE
12620 ENDIF
12621 I0 = 7*NLINES+1
12622 IF (I0.LE.ISITEB)
12623 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12624 GOTO 10
12625 100 CONTINUE
12626 NSET = NSET-1
12627 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12628 WRITE(LOUT,'(/,1X,A)')
12629 & ' projectiles other than protons and nuclei: (particle index)'
12630 IF (NAIDX.GT.0) THEN
12631 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12632 ELSE
12633 WRITE(LOUT,'(6X,A)') 'none'
12634 ENDIF
12635*
12636 CLOSE(LDAT)
12637 WRITE(LOUT,*)
12638 LREAD = .TRUE.
12639
12640 IF (NCOMPO.EQ.0) THEN
12641 DO 12 J=1,NBBIN
12642 NCOMPO = NCOMPO+1
12643 IEMUMA(NCOMPO) = IBBIN(J)
12644 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12645 EMUFRA(NCOMPO) = 1.0D0
12646 12 CONTINUE
12647 IEMUL = 1
12648 ENDIF
12649*
12650* calculate profile function for certain set of parameters
12651*
12652 ELSE
12653
12654c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12655*
12656* check for type of projectile and set index-offset to entry in
12657* Glauber data array correspondingly
12658 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12659 IF (IOFFST(IDPROJ).EQ.-1) THEN
12660 STOP ' GLBSET: no data for this projectile !'
12661 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12662 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12663 ELSE
12664 IDXOFF = 0
12665 ENDIF
12666*
12667* get energy bin and interpolation factor
12668 IF (LCMS) THEN
12669 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12670 ELSE
12671 E = ELAB
12672 ENDIF
12673 E = LOG10(E)
12674 IF (E.LT.ELO) THEN
12675 IF (LFRST1) THEN
12676 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12677 LFRST1 = .FALSE.
12678 ENDIF
12679 E = ELO
12680 ENDIF
12681 IF (E.GT.EHI) THEN
12682 IF (LFRST2) THEN
12683 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12684 LFRST2 = .FALSE.
12685 ENDIF
12686 E = EHI
12687 ENDIF
12688 IE0 = (E-ELO)/DEBIN+1
12689 IE1 = IE0+1
12690 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12691*
12692* get target nucleus index
12693 KB = 0
12694 NBACC = KBACC
12695 DO 20 I=1,NBBIN
12696 NBDIFF = ABS(NB-IBBIN(I))
12697 IF (NB.EQ.IBBIN(I)) THEN
12698 KB = I
12699 GOTO 21
12700 ELSEIF (NBDIFF.LE.NBACC) THEN
12701 KB = I
12702 NBACC = NBDIFF
12703 ENDIF
12704 20 CONTINUE
12705 IF (KB.NE.0) GOTO 21
12706 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12707 STOP
12708 21 CONTINUE
12709*
12710* get projectile nucleus bin and interpolation factor
12711 KA0 = 0
12712 KA1 = 0
12713 FACNA = 0
12714 IF (IDXOFF.GT.0) THEN
12715 KA0 = 1
12716 KA1 = 1
12717 KABIN = 1
12718 ELSE
12719 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12720 DO 22 I=1,NABIN
12721 IF (NA.EQ.IABIN(I)) THEN
12722 KA0 = I
12723 KA1 = I
12724 GOTO 23
12725 ELSEIF (NA.LT.IABIN(I)) THEN
12726 KA0 = I-1
12727 KA1 = I
12728 GOTO 23
12729 ENDIF
12730 22 CONTINUE
12731 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12732 STOP
12733 23 CONTINUE
12734 IF (KA0.NE.KA1)
12735 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12736 KABIN = NABIN
12737 ENDIF
12738*
12739* interpolate profile functions for interactions ka0-kb and ka1-kb
12740* for energy E separately
12741 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12742 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12743 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12744 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12745 DO 30 I=1,ISITEB
12746 BPRO0(I) = BPROFL(IDX0,I)
12747 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12748 BPRO1(I) = BPROFL(IDY0,I)
12749 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12750 30 CONTINUE
12751 RADB = DT_RNCLUS(NB)
12752 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12753 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12754*
12755* interpolate cross sections for energy E and projectile mass
12756 DO 31 I=1,6
12757 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12758 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12759 XS(I) = XS0+FACNA*(XS1-XS0)
12760 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12761 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12762 XE(I) = XE0+FACNA*(XE1-XE0)
12763 31 CONTINUE
12764*
12765* interpolate between ka0 and ka1
12766 RADA = DT_RNCLUS(NA)
12767 BMX = 2.0D0*(RADA+RADB)
12768 BSTP = BMX/DBLE(ISITEB-1)
12769 BPRO(1) = ZERO
12770 DO 32 I=1,ISITEB-1
12771 B = DBLE(I)*BSTP
12772*
12773* calculate values of profile functions at B
12774 IDX0 = B/BSTP0+1
12775 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12776 IDX1 = MIN(IDX0+1,ISITEB)
12777 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12778 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12779 IDX0 = B/BSTP1+1
12780 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12781 IDX1 = MIN(IDX0+1,ISITEB)
12782 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12783 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12784*
12785 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12786 32 CONTINUE
12787*
12788* fill common dtglam
12789 NSITEB = ISITEB
12790 RASH(1) = RADA
12791 RBSH(1) = RADB
12792 BMAX(1) = BMX
12793 BSTEP(1) = BSTP
12794 DO 33 I=1,KSITEB
12795 BSITE(0,1,1,I) = BPRO(I)
12796 33 CONTINUE
12797*
12798* fill common dtglxs
12799 XSTOT(1,1,1) = XS(1)
12800 XSELA(1,1,1) = XS(2)
12801 XSQEP(1,1,1) = XS(3)
12802 XSQET(1,1,1) = XS(4)
12803 XSQE2(1,1,1) = XS(5)
12804 XSPRO(1,1,1) = XS(6)
12805 XETOT(1,1,1) = XE(1)
12806 XEELA(1,1,1) = XE(2)
12807 XEQEP(1,1,1) = XE(3)
12808 XEQET(1,1,1) = XE(4)
12809 XEQE2(1,1,1) = XE(5)
12810 XEPRO(1,1,1) = XE(6)
12811
12812 ENDIF
12813
12814 RETURN
12815 END
12816*$ CREATE DT_XKSAMP.FOR
12817*COPY DT_XKSAMP
12818*
12819*===xksamp=============================================================*
12820*
12821 SUBROUTINE DT_XKSAMP(NN,ECM)
12822
12823************************************************************************
12824* Sampling of parton x-values and chain system for one interaction. *
12825* processed by S. Roesler, 9.8.95 *
12826************************************************************************
12827
12828 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12829 SAVE
12830
12831 PARAMETER ( LINP = 10 ,
12832 & LOUT = 6 ,
12833 & LDAT = 9 )
12834
12835 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12836 SAVE
12837
12838 PARAMETER (
12839* lower cuts for (valence-sea/sea-valence) chain masses
12840* antiquark-quark (u/d-sea quark) (s-sea quark)
12841 & AMIU = 0.5D0, AMIS = 0.8D0,
12842* quark-diquark (u/d-sea quark) (s-sea quark)
12843 & AMAU = 2.6D0, AMAS = 2.6D0,
12844* maximum lower valence-x threshold
12845 & XVMAX = 0.98D0,
12846* fraction of sea-diquarks sampled out of sea-partons
12847**test
12848C & FRCDIQ = 0.9D0,
12849**
12850*
12851 & SQMA = 0.7D0,
12852*
12853* maximum number of trials to generate x's for the required number
12854* of sea quark pairs for a given hadron
12855 & NSEATY = 12
12856C & NSEATY = 3
12857 & )
12858
12859 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12860
12861 PARAMETER ( MAXNCL = 260,
12862
12863 & MAXVQU = MAXNCL,
12864 & MAXSQU = 20*MAXVQU,
12865 & MAXINT = MAXVQU+MAXSQU)
12866
12867* event history
12868
12869 PARAMETER (NMXHKK=200000)
12870
12871 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12872 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12873 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12874
12875* particle properties (BAMJET index convention)
12876 CHARACTER*8 ANAME
12877 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12878 & IICH(210),IIBAR(210),K1(210),K2(210)
12879
12880* interface between Glauber formalism and DPM
12881 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12882 & INTER1(MAXINT),INTER2(MAXINT)
12883
12884* properties of interacting particles
12885 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12886
12887* threshold values for x-sampling (DTUNUC 1.x)
12888 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12889 & SSMIMQ,VVMTHR
12890
12891* x-values of partons (DTUNUC 1.x)
12892 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12893 & XTVQ(MAXVQU),XTVD(MAXVQU),
12894 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12895 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12896
12897* flavors of partons (DTUNUC 1.x)
12898 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12899 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12900 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12901 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12902 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12903 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12904 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12905
12906* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12907 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12908 & IXPV,IXPS,IXTV,IXTS,
12909 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12910 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12911 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12912 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12913 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12914 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12915 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12916 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12917
12918* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12919 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12920 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12921
12922* auxiliary common for chain system storage (DTUNUC 1.x)
12923 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12924
12925* flags for input different options
12926 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12927 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12928 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12929
12930* various options for treatment of partons (DTUNUC 1.x)
12931* (chain recombination, Cronin,..)
12932 LOGICAL LCO2CR,LINTPT
12933 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12934 & LCO2CR,LINTPT
12935
12936 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12937 & INTLO(MAXINT)
12938
12939* (1) initializations
12940*-----------------------------------------------------------------------
12941
12942**test
12943 IF (ECM.LT.4.5D0) THEN
12944C FRCDIQ = 0.6D0
12945 FRCDIQ = 0.4D0
12946 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12947C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12948 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12949 ELSE
12950C FRCDIQ = 0.9D0
12951 FRCDIQ = 0.7D0
12952 ENDIF
12953**
12954 DO 30 I=1,MAXSQU
12955 ZUOSP(I) = .FALSE.
12956 ZUOST(I) = .FALSE.
12957 IF (I.LE.MAXVQU) THEN
12958 ZUOVP(I) = .FALSE.
12959 ZUOVT(I) = .FALSE.
12960 ENDIF
12961 30 CONTINUE
12962
12963* lower thresholds for x-selection
12964* sea-quarks (default: CSEA=0.2)
12965 IF (ECM.LT.10.0D0) THEN
12966**!!test
12967 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12968C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12969 NSEA = NSEATY
12970C XSTHR = ONE/ECM**2
12971 ELSE
12972**sr 30.3.98
12973C XSTHR = CSEA/ECM
12974 XSTHR = CSEA/ECM**2
12975C XSTHR = ONE/ECM**2
12976**
12977 IF ((IP.GE.150).AND.(IT.GE.150))
12978 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12979 NSEA = NSEATY
12980 ENDIF
12981* (default: SSMIMA=0.14) used for sea-diquarks (?)
12982 XSSTHR = SSMIMA/ECM
12983 BSQMA = SQMA/ECM
12984* valence-quarks (default: CVQ=1.0)
12985 XVTHR = CVQ/ECM
12986* valence-diquarks (default: CDQ=2.0)
12987 XDTHR = CDQ/ECM
12988
12989* maximum-x for sea-quarks
12990 XVCUT = XVTHR+XDTHR
12991 IF (XVCUT.GT.XVMAX) THEN
12992 XVCUT = XVMAX
12993 XVTHR = XVCUT/3.0D0
12994 XDTHR = XVCUT-XVTHR
12995 ENDIF
12996 XXSEAM = ONE-XVCUT
12997**sr 18.4. test: DPMJET
12998C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12999C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13000C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13001**
13002* maximum number of sea-pairs allowed kinematically
13003C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13004 RNSMAX = OHALF*XXSEAM/XSTHR
13005 IF (RNSMAX.GT.10000.0D0) THEN
13006 NSMAX = 10000
13007 ELSE
13008 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13009 ENDIF
13010* check kinematical limit for valence-x thresholds
13011* (should be obsolete now)
13012 IF (XVCUT.GT.XVMAX) THEN
13013 WRITE(LOUT,1000) XVCUT,ECM
13014 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13015 & ' thresholds not allowed (',2E9.3,')')
13016C XVTHR = XVMAX-XDTHR
13017C IF (XVTHR.LT.ZERO) STOP
13018 STOP
13019 ENDIF
13020
13021* set eta for valence-x sampling (BETREJ)
13022* (UNON per default, UNOM used for projectile mesons only)
13023 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13024 UNOPRV = UNOM
13025 ELSE
13026 UNOPRV = UNON
13027 ENDIF
13028
13029* (2) select parton x-values of interacting projectile nucleons
13030*-----------------------------------------------------------------------
13031
13032 IXPV = 0
13033 IXPS = 0
13034
13035 DO 100 IPP=1,IP
13036* get interacting projectile nucleon as sampled by Glauber
13037 IF (JSSH(IPP).NE.0) THEN
13038 IXSTMP = IXPS
13039 IXVTMP = IXPV
13040 99 CONTINUE
13041 IXPS = IXSTMP
13042 IXPV = IXVTMP
13043* JIPP is the actual number of sea-pairs sampled for this nucleon
13044 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13045 41 CONTINUE
13046 XXSEA = ZERO
13047 IF (JIPP.GT.0) THEN
13048 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13049*???
13050 IF (XSTHR.GE.XSMAX) THEN
13051 JIPP = JIPP-1
13052 GOTO 41
13053 ENDIF
13054
13055*>>>get x-values of sea-quark pairs
13056 NSCOUN = 0
13057 PLW = 0.5D0
13058 40 CONTINUE
13059* accumulator for sea x-values
13060 XXSEA = ZERO
13061 NSCOUN = NSCOUN+1
13062 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13063 IF (NSCOUN.GT.NSEA) THEN
13064* decrease the number of interactions after NSEA trials
13065 JIPP = JIPP-1
13066 NSCOUN = 0
13067 ENDIF
13068 DO 70 ISQ=1,JIPP
13069* sea-quarks
13070 IF (IPSQ(IXPS+1).LE.2) THEN
13071**sr 8.4.98 (1/sqrt(x))
13072C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13073C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13074 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13075**
13076 ELSE
13077 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13078 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13079 ELSE
13080**sr 8.4.98 (1/sqrt(x))
13081C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13082C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13083 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13084**
13085 ENDIF
13086 ENDIF
13087* sea-antiquarks
13088 IF (IPSAQ(IXPS+1).GE.-2) THEN
13089**sr 8.4.98 (1/sqrt(x))
13090C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13091C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13092 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13093**
13094 ELSE
13095 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13096 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13097 ELSE
13098**sr 8.4.98 (1/sqrt(x))
13099C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13100C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13101 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13102**
13103 ENDIF
13104 ENDIF
13105 XXSEA = XXSEA+XPSQI+XPSAQI
13106* check for maximum allowed sea x-value
13107 IF (XXSEA.GE.XXSEAM) THEN
13108 IXPS = IXPS-ISQ+1
13109 GOTO 40
13110 ENDIF
13111* accept this sea-quark pair
13112 IXPS = IXPS+1
13113 XPSQ(IXPS) = XPSQI
13114 XPSAQ(IXPS) = XPSAQI
13115 IFROSP(IXPS) = IPP
13116 ZUOSP(IXPS) = .TRUE.
13117 70 CONTINUE
13118 ENDIF
13119
13120*>>>get x-values of valence partons
13121* valence quark
13122 IF (XVTHR.GT.0.05D0) THEN
13123 XVHI = ONE-XXSEA-XDTHR
13124 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13125 ELSE
13126 90 CONTINUE
13127 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13128 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13129 & GOTO 90
13130 ENDIF
13131* valence diquark
13132 XPVDI = ONE-XPVQI-XXSEA
13133* reject according to x**1.5
13134 XDTMP = XPVDI**1.5D0
13135 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13136* accept these valence partons
13137 IXPV = IXPV+1
13138 XPVQ(IXPV) = XPVQI
13139 XPVD(IXPV) = XPVDI
13140 IFROVP(IXPV) = IPP
13141 ITOVP(IPP) = IXPV
13142 ZUOVP(IXPV) = .TRUE.
13143
13144 ENDIF
13145 100 CONTINUE
13146
13147* (3) select parton x-values of interacting target nucleons
13148*-----------------------------------------------------------------------
13149
13150 IXTV = 0
13151 IXTS = 0
13152
13153 DO 170 ITT=1,IT
13154* get interacting target nucleon as sampled by Glauber
13155 IF (JTSH(ITT).NE.0) THEN
13156 IXSTMP = IXTS
13157 IXVTMP = IXTV
13158 169 CONTINUE
13159 IXTS = IXSTMP
13160 IXTV = IXVTMP
13161* JITT is the actual number of sea-pairs sampled for this nucleon
13162 JITT = MIN(JTSH(ITT)-1,NSMAX)
13163 111 CONTINUE
13164 XXSEA = ZERO
13165 IF (JITT.GT.0) THEN
13166 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13167*???
13168 IF (XSTHR.GE.XSMAX) THEN
13169 JITT = JITT-1
13170 GOTO 111
13171 ENDIF
13172
13173*>>>get x-values of sea-quark pairs
13174 NSCOUN = 0
13175 PLW = 0.5D0
13176 110 CONTINUE
13177* accumulator for sea x-values
13178 XXSEA = ZERO
13179 NSCOUN = NSCOUN+1
13180 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13181 IF (NSCOUN.GT.NSEA)THEN
13182* decrease the number of interactions after NSEA trials
13183 JITT = JITT-1
13184 NSCOUN = 0
13185 ENDIF
13186 DO 140 ISQ=1,JITT
13187* sea-quarks
13188 IF (ITSQ(IXTS+1).LE.2) THEN
13189**sr 8.4.98 (1/sqrt(x))
13190C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13191C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13192 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13193**
13194 ELSE
13195 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13196 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13197 ELSE
13198**sr 8.4.98 (1/sqrt(x))
13199C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13200C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13201 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13202**
13203 ENDIF
13204 ENDIF
13205* sea-antiquarks
13206 IF (ITSAQ(IXTS+1).GE.-2) THEN
13207**sr 8.4.98 (1/sqrt(x))
13208C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13209C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13210 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13211**
13212 ELSE
13213 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13214 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13215 ELSE
13216**sr 8.4.98 (1/sqrt(x))
13217C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13218C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13219 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13220**
13221 ENDIF
13222 ENDIF
13223 XXSEA = XXSEA+XTSQI+XTSAQI
13224* check for maximum allowed sea x-value
13225 IF (XXSEA.GE.XXSEAM) THEN
13226 IXTS = IXTS-ISQ+1
13227 GOTO 110
13228 ENDIF
13229* accept this sea-quark pair
13230 IXTS = IXTS+1
13231 XTSQ(IXTS) = XTSQI
13232 XTSAQ(IXTS) = XTSAQI
13233 IFROST(IXTS) = ITT
13234 ZUOST(IXTS) = .TRUE.
13235 140 CONTINUE
13236 ENDIF
13237
13238*>>>get x-values of valence partons
13239* valence quark
13240 IF (XVTHR.GT.0.05D0) THEN
13241 XVHI = ONE-XXSEA-XDTHR
13242 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13243 ELSE
13244 160 CONTINUE
13245 XTVQI = DT_DBETAR(OHALF,UNON)
13246 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13247 & GOTO 160
13248 ENDIF
13249* valence diquark
13250 XTVDI = ONE-XTVQI-XXSEA
13251* reject according to x**1.5
13252 XDTMP = XTVDI**1.5D0
13253 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13254* accept these valence partons
13255 IXTV = IXTV+1
13256 XTVQ(IXTV) = XTVQI
13257 XTVD(IXTV) = XTVDI
13258 IFROVT(IXTV) = ITT
13259 ITOVT(ITT) = IXTV
13260 ZUOVT(IXTV) = .TRUE.
13261
13262 ENDIF
13263 170 CONTINUE
13264
13265* (4) get valence-valence chains
13266*-----------------------------------------------------------------------
13267
13268 NVV = 0
13269 DO 240 I=1,NN
13270 INTLO(I) = .TRUE.
13271 IPVAL = ITOVP(INTER1(I))
13272 ITVAL = ITOVT(INTER2(I))
13273 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13274 INTLO(I) = .FALSE.
13275 ZUOVP(IPVAL) = .FALSE.
13276 ZUOVT(ITVAL) = .FALSE.
13277 NVV = NVV+1
13278 ISKPCH(8,NVV) = 0
13279 INTVV1(NVV) = IPVAL
13280 INTVV2(NVV) = ITVAL
13281 ENDIF
13282 240 CONTINUE
13283
13284* (5) get sea-valence chains
13285*-----------------------------------------------------------------------
13286
13287 NSV = 0
13288 NDV = 0
13289 PLW = 0.5D0
13290 DO 270 I=1,NN
13291 IF (INTLO(I)) THEN
13292 IPVAL = ITOVP(INTER1(I))
13293 ITVAL = ITOVT(INTER2(I))
13294 DO 250 J=1,IXPS
13295 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13296 & ZUOVT(ITVAL)) THEN
13297 ZUOSP(J) = .FALSE.
13298 ZUOVT(ITVAL) = .FALSE.
13299 INTLO(I) = .FALSE.
13300 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13301* sample sea-diquark pair
13302 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13303 IF (IREJ1.EQ.0) GOTO 260
13304 ENDIF
13305 NSV = NSV+1
13306 ISKPCH(4,NSV) = 0
13307 INTSV1(NSV) = J
13308 INTSV2(NSV) = ITVAL
13309
13310*>>>correct chain kinematics according to minimum chain masses
13311* the actual chain masses
13312 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13313 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13314* get lower mass cuts
13315 IF (IPSQ(J).EQ.3) THEN
13316* q being s-quark
13317 AMCHK1 = AMAS
13318 AMCHK2 = AMIS
13319 ELSE
13320* q being u/d-quark
13321 AMCHK1 = AMAU
13322 AMCHK2 = AMIU
13323 ENDIF
13324* q-qq chain
13325* chain mass above minimum - resampling of sea-q x-value
13326 IF (AMSVQ1.GT.AMCHK1) THEN
13327 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13328**sr 8.4.98 (1/sqrt(x))
13329C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13330C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13331 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13332**
13333 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13334 XPSQ(J) = XPSQXX
13335* chain mass below minimum - reset sea-q x-value and correct
13336* diquark-x of the same nucleon
13337 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13338 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339 DXPSQ = XPSQW-XPSQ(J)
13340 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13341 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13342 XPSQ(J) = XPSQW
13343 ENDIF
13344 ENDIF
13345* aq-q chain
13346* chain mass below minimum - reset sea-aq x-value and correct
13347* diquark-x of the same nucleon
13348 IF (AMSVQ2.LT.AMCHK2) THEN
13349 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13350 DXPSQ = XPSQW-XPSAQ(J)
13351 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13353 XPSAQ(J) = XPSQW
13354 ENDIF
13355 ENDIF
13356*>>>end of chain mass correction
13357
13358 GOTO 260
13359 ENDIF
13360 250 CONTINUE
13361 ENDIF
13362 260 CONTINUE
13363 270 CONTINUE
13364
13365* (6) get valence-sea chains
13366*-----------------------------------------------------------------------
13367
13368 NVS = 0
13369 NVD = 0
13370 DO 300 I=1,NN
13371 IF (INTLO(I)) THEN
13372 IPVAL = ITOVP(INTER1(I))
13373 ITVAL = ITOVT(INTER2(I))
13374 DO 280 J=1,IXTS
13375 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13376 & (IFROST(J).EQ.INTER2(I))) THEN
13377 ZUOST(J) = .FALSE.
13378 ZUOVP(IPVAL) = .FALSE.
13379 INTLO(I) = .FALSE.
13380 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13381* sample sea-diquark pair
13382 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13383 IF (IREJ1.EQ.0) GOTO 290
13384 ENDIF
13385 NVS = NVS + 1
13386 ISKPCH(6,NVS) = 0
13387 INTVS1(NVS) = IPVAL
13388 INTVS2(NVS) = J
13389
13390*>>>correct chain kinematics according to minimum chain masses
13391* the actual chain masses
13392 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13393 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13394* get lower mass cuts
13395 IF (ITSQ(J).EQ.3) THEN
13396* q being s-quark
13397 AMCHK1 = AMIS
13398 AMCHK2 = AMAS
13399 ELSE
13400* q being u/d-quark
13401 AMCHK1 = AMIU
13402 AMCHK2 = AMAU
13403 ENDIF
13404* q-aq chain
13405* chain mass below minimum - reset sea-aq x-value and correct
13406* diquark-x of the same nucleon
13407 IF (AMVSQ1.LT.AMCHK1) THEN
13408 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13409 DXTSQ = XTSQW-XTSAQ(J)
13410 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13411 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13412 XTSAQ(J) = XTSQW
13413 ENDIF
13414 ENDIF
13415* qq-q chain
13416* chain mass above minimum - resampling of sea-q x-value
13417 IF (AMVSQ2.GT.AMCHK2) THEN
13418 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13419**sr 8.4.98 (1/sqrt(x))
13420C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13421C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13422 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13423**
13424 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13425 XTSQ(J) = XTSQXX
13426* chain mass below minimum - reset sea-q x-value and correct
13427* diquark-x of the same nucleon
13428 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13429 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430 DXTSQ = XTSQW-XTSQ(J)
13431 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13432 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13433 XTSQ(J) = XTSQW
13434 ENDIF
13435 ENDIF
13436*>>>end of chain mass correction
13437
13438 GOTO 290
13439 ENDIF
13440 280 CONTINUE
13441 ENDIF
13442 290 CONTINUE
13443 300 CONTINUE
13444
13445* (7) get sea-sea chains
13446*-----------------------------------------------------------------------
13447
13448 NSS = 0
13449 NDS = 0
13450 NSD = 0
13451 DO 420 I=1,NN
13452 IF (INTLO(I)) THEN
13453 IPVAL = ITOVP(INTER1(I))
13454 ITVAL = ITOVT(INTER2(I))
13455* loop over target partons not yet matched
13456 DO 400 J=1,IXTS
13457 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13458* loop over projectile partons not yet matched
13459 DO 390 JJ=1,IXPS
13460 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13461 ZUOSP(JJ) = .FALSE.
13462 ZUOST(J) = .FALSE.
13463 INTLO(I) = .FALSE.
13464 NSS = NSS+1
13465 ISKPCH(1,NSS) = 0
13466 INTSS1(NSS) = JJ
13467 INTSS2(NSS) = J
13468
13469*---->chain recombination option
13470 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13471 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13472 & THEN
13473* sea-sea chains may recombine with valence-valence chains
13474* only if they have the same projectile or target nucleon
13475 DO 4201 IVV=1,NVV
13476 IF (ISKPCH(8,IVV).NE.99) THEN
13477 IXVPR = INTVV1(IVV)
13478 IXVTA = INTVV2(IVV)
13479 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13480 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13481* recombination possible, drop old v-v and s-s chains
13482 ISKPCH(1,NSS) = 99
13483 ISKPCH(8,IVV) = 99
13484
13485* (a) assign new s-v chains
13486* ~~~~~~~~~~~~~~~~~~~~~~~~~
13487 IF (LSEADI.AND.
13488 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13489 & THEN
13490* sample sea-diquark pair
13491 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13492 & IREJ1)
13493 IF (IREJ1.EQ.0) GOTO 4202
13494 ENDIF
13495 NSV = NSV+1
13496 ISKPCH(4,NSV) = 0
13497 INTSV1(NSV) = JJ
13498 INTSV2(NSV) = IXVTA
13499*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13500* the actual chain masses
13501 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13502 & *ECM**2
13503 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13504 & *ECM**2
13505* get lower mass cuts
13506 IF (IPSQ(JJ).EQ.3) THEN
13507* q being s-quark
13508 AMCHK1 = AMAS
13509 AMCHK2 = AMIS
13510 ELSE
13511* q being u/d-quark
13512 AMCHK1 = AMAU
13513 AMCHK2 = AMIU
13514 ENDIF
13515* q-qq chain
13516* chain mass above minimum - resampling of sea-q x-value
13517 IF (AMSVQ1.GT.AMCHK1) THEN
13518 XPSQTH =
13519 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13520**sr 8.4.98 (1/sqrt(x))
13521 XPSQXX =
13522 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13523C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13524C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13525**
13526 XPVD(IPVAL) =
13527 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13528 XPSQ(JJ) = XPSQXX
13529* chain mass below minimum - reset sea-q x-value and correct
13530* diquark-x of the same nucleon
13531 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13532 XPSQW =
13533 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13534 DXPSQ = XPSQW-XPSQ(JJ)
13535 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13536 & THEN
13537 XPVD(IPVAL) =
13538 & XPVD(IPVAL)-DXPSQ
13539 XPSQ(JJ) = XPSQW
13540 ENDIF
13541 ENDIF
13542* aq-q chain
13543* chain mass below minimum - reset sea-aq x-value and correct
13544* diquark-x of the same nucleon
13545 IF (AMSVQ2.LT.AMCHK2) THEN
13546 XPSQW =
13547 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13548 DXPSQ = XPSQW-XPSAQ(JJ)
13549 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13550 & THEN
13551 XPVD(IPVAL) =
13552 & XPVD(IPVAL)-DXPSQ
13553 XPSAQ(JJ) = XPSQW
13554 ENDIF
13555 ENDIF
13556*>>>>>>>>>>>end of chain mass correction
13557 4202 CONTINUE
13558
13559* (b) assign new v-s chains
13560* ~~~~~~~~~~~~~~~~~~~~~~~~~
13561 IF (LSEADI.AND.(
13562 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13563 & THEN
13564* sample sea-diquark pair
13565 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13566 & IREJ1)
13567 IF (IREJ1.EQ.0) GOTO 4203
13568 ENDIF
13569 NVS = NVS+1
13570 ISKPCH(6,NVS) = 0
13571 INTVS1(NVS) = IXVPR
13572 INTVS2(NVS) = J
13573*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13574* the actual chain masses
13575 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13576 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13577* get lower mass cuts
13578 IF (ITSQ(J).EQ.3) THEN
13579* q being s-quark
13580 AMCHK1 = AMIS
13581 AMCHK2 = AMAS
13582 ELSE
13583* q being u/d-quark
13584 AMCHK1 = AMIU
13585 AMCHK2 = AMAU
13586 ENDIF
13587* q-aq chain
13588* chain mass below minimum - reset sea-aq x-value and correct
13589* diquark-x of the same nucleon
13590 IF (AMVSQ1.LT.AMCHK1) THEN
13591 XTSQW =
13592 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13593 DXTSQ = XTSQW-XTSAQ(J)
13594 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13595 & THEN
13596 XTVD(ITVAL) =
13597 & XTVD(ITVAL)-DXTSQ
13598 XTSAQ(J) = XTSQW
13599 ENDIF
13600 ENDIF
13601 IF (AMVSQ2.GT.AMCHK2) THEN
13602 XTSQTH =
13603 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13604**sr 8.4.98 (1/sqrt(x))
13605 XTSQXX =
13606 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13607C & DT_SAMSQX(XTSQTH,XTSQ(J))
13608C & DT_SAMPEX(XTSQTH,XTSQ(J))
13609**
13610 XTVD(ITVAL) =
13611 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13612 XTSQ(J) = XTSQXX
13613 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13614 XTSQW =
13615 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13616 DXTSQ = XTSQW-XTSQ(J)
13617 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13618 & THEN
13619 XTVD(ITVAL) =
13620 & XTVD(ITVAL)-DXTSQ
13621 XTSQ(J) = XTSQW
13622 ENDIF
13623 ENDIF
13624*>>>>>>>>>end of chain mass correction
13625 4203 CONTINUE
13626* jump out of s-s chain loop
13627 GOTO 420
13628 ENDIF
13629 ENDIF
13630 4201 CONTINUE
13631 ENDIF
13632*---->end of chain recombination option
13633
13634* sample sea-diquark pair (projectile)
13635 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13636 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13637 IF (IREJ1.EQ.0) THEN
13638 ISKPCH(1,NSS) = 99
13639 GOTO 410
13640 ENDIF
13641 ENDIF
13642* sample sea-diquark pair (target)
13643 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13644 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13645 IF (IREJ1.EQ.0) THEN
13646 ISKPCH(1,NSS) = 99
13647 GOTO 410
13648 ENDIF
13649 ENDIF
13650*>>>>>correct chain kinematics according to minimum chain masses
13651* the actual chain masses
13652 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13653 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13654* check for lower mass cuts
13655 IF ((SSMA1Q.LT.SSMIMQ).OR.
13656 & (SSMA2Q.LT.SSMIMQ)) THEN
13657 IPVAL = ITOVP(INTER1(I))
13658 ITVAL = ITOVT(INTER2(I))
13659 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13660 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13661* maximum allowed x values for sea quarks
13662 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13663 & 1.2D0*XSSTHR
13664 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13665 & 1.2D0*XSSTHR
13666* resampling of x values not possible - skip sea-sea chains
13667 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13668 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13669* resampling of x for projectile sea quark pair
13670 ICOUS = 0
13671 310 CONTINUE
13672 ICOUS = ICOUS+1
13673 IF (XSSTHR.GT.0.05D0) THEN
13674 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13675 & XSPMAX)
13676 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13677 & XSPMAX)
13678 ELSE
13679 320 CONTINUE
13680 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13681 IF ((XPSQI.LT.XSSTHR).OR.
13682 & (XPSQI.GT.XSPMAX)) GOTO 320
13683 330 CONTINUE
13684 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13685 IF ((XPSAQI.LT.XSSTHR).OR.
13686 & (XPSAQI.GT.XSPMAX)) GOTO 330
13687 ENDIF
13688* final test of remaining x for projectile diquark
13689 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13690 & +XPSQ(JJ)+XPSAQ(JJ)
13691 IF (XPVDCO.LE.XDTHR) THEN
13692*!!!
13693C IF (ICOUS.LT.5) GOTO 310
13694 IF (ICOUS.LT.0.5D0) GOTO 310
13695 GOTO 380
13696 ENDIF
13697* resampling of x for target sea quark pair
13698 ICOUS = 0
13699 350 CONTINUE
13700 ICOUS = ICOUS+1
13701 IF (XSSTHR.GT.0.05D0) THEN
13702 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13703 & XSTMAX)
13704 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13705 & XSTMAX)
13706 ELSE
13707 360 CONTINUE
13708 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13709 IF ((XTSQI.LT.XSSTHR).OR.
13710 & (XTSQI.GT.XSTMAX)) GOTO 360
13711 370 CONTINUE
13712 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13713 IF ((XTSAQI.LT.XSSTHR).OR.
13714 & (XTSAQI.GT.XSTMAX)) GOTO 370
13715 ENDIF
13716* final test of remaining x for target diquark
13717 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13718 & +XTSQ(J)+XTSAQ(J)
13719 IF (XTVDCO.LT.XDTHR) THEN
13720 IF (ICOUS.LT.5) GOTO 350
13721 GOTO 380
13722 ENDIF
13723 XPVD(IPVAL) = XPVDCO
13724 XTVD(ITVAL) = XTVDCO
13725 XPSQ(JJ) = XPSQI
13726 XPSAQ(JJ) = XPSAQI
13727 XTSQ(J) = XTSQI
13728 XTSAQ(J) = XTSAQI
13729*>>>>>end of chain mass correction
13730 GOTO 410
13731 ENDIF
13732* come here to discard s-s interaction
13733* resampling of x values not allowed or unsuccessful
13734 380 CONTINUE
13735 INTLO(I) = .FALSE.
13736 ZUOST(J) = .TRUE.
13737 ZUOSP(JJ) = .TRUE.
13738 NSS = NSS-1
13739 ENDIF
13740* consider next s-s interaction
13741 GOTO 410
13742 ENDIF
13743 390 CONTINUE
13744 ENDIF
13745 400 CONTINUE
13746 ENDIF
13747 410 CONTINUE
13748 420 CONTINUE
13749
13750* correct x-values of valence quarks for non-matching sea quarks
13751 DO 430 I=1,IXPS
13752 IF (ZUOSP(I)) THEN
13753 IPVAL = ITOVP(IFROSP(I))
13754 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13755 XPSQ(I) = ZERO
13756 XPSAQ(I) = ZERO
13757 ZUOSP(I) = .FALSE.
13758 ENDIF
13759 430 CONTINUE
13760 DO 440 I=1,IXTS
13761 IF (ZUOST(I)) THEN
13762 ITVAL = ITOVT(IFROST(I))
13763 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13764 XTSQ(I) = ZERO
13765 XTSAQ(I) = ZERO
13766 ZUOST(I) = .FALSE.
13767 ENDIF
13768 440 CONTINUE
13769 DO 450 I=1,IXPV
13770 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13771 450 CONTINUE
13772 DO 460 I=1,IXTV
13773 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13774 460 CONTINUE
13775
13776 RETURN
13777 END
13778
13779*$ CREATE DT_SAMSDQ.FOR
13780*COPY DT_SAMSDQ
13781*
13782*===samsdq=============================================================*
13783*
13784 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13785
13786************************************************************************
13787* SAMpling of Sea-DiQuarks *
13788* ECM cm-energy of the nucleon-nucleon system *
13789* IDX1,2 indices of x-values of the participating *
13790* partons (IDX2 is always the sea-q-pair to be *
13791* changed to sea-qq-pair) *
13792* MODE = 1 valence-q - sea-diq *
13793* = 2 sea-diq - valence-q *
13794* = 3 sea-q - sea-diq *
13795* = 4 sea-diq - sea-q *
13796* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13797* This version dated 17.10.95 is written by S. Roesler *
13798************************************************************************
13799
13800 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13801 SAVE
13802
13803 PARAMETER (ZERO=0.0D0)
13804
13805* threshold values for x-sampling (DTUNUC 1.x)
13806 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13807 & SSMIMQ,VVMTHR
13808
13809* various options for treatment of partons (DTUNUC 1.x)
13810* (chain recombination, Cronin,..)
13811 LOGICAL LCO2CR,LINTPT
13812 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13813 & LCO2CR,LINTPT
13814
13815 PARAMETER ( MAXNCL = 260,
13816
13817 & MAXVQU = MAXNCL,
13818 & MAXSQU = 20*MAXVQU,
13819 & MAXINT = MAXVQU+MAXSQU)
13820
13821* x-values of partons (DTUNUC 1.x)
13822 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13823 & XTVQ(MAXVQU),XTVD(MAXVQU),
13824 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13825 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13826
13827* flavors of partons (DTUNUC 1.x)
13828 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13829 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13830 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13831 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13832 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13833 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13834 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13835
13836* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13837 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13838 & IXPV,IXPS,IXTV,IXTS,
13839 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13840 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13841 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13842 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13843 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13844 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13845 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13846 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13847
13848* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13849 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13850 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13851
13852* auxiliary common for chain system storage (DTUNUC 1.x)
13853 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13854
13855 IREJ = 0
13856* threshold-x for valence diquarks
13857 XDTHR = CDQ/ECM
13858
13859 GOTO (1,2,3,4) MODE
13860
13861*---------------------------------------------------------------------
13862* proj. valence partons - targ. sea partons
13863* get x-values and flavors for target sea-diquark pair
13864
13865 1 CONTINUE
13866 IDXVP = IDX1
13867 IDXST = IDX2
13868
13869* index of corr. val-diquark-x in target nucleon
13870 IDXVT = ITOVT(IFROST(IDXST))
13871* available x above diquark thresholds for valence- and sea-diquarks
13872 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13873
13874 IF (XXD.GE.ZERO) THEN
13875* x-values for the three diquarks of the target nucleon
13876 RR1 = DT_RNDM(XXD)
13877 RR2 = DT_RNDM(RR1)
13878 RR3 = DT_RNDM(RR2)
13879 SR123 = RR1+RR2+RR3
13880 XXTV = XDTHR+RR1*XXD/SR123
13881 XXTSQ = XDTHR+RR2*XXD/SR123
13882 XXTSAQ = XDTHR+RR3*XXD/SR123
13883 ELSE
13884 XXTV = XTVD(IDXVT)
13885 XXTSQ = XTSQ(IDXST)
13886 XXTSAQ = XTSAQ(IDXST)
13887 ENDIF
13888* flavor of the second quarks in the sea-diquark pair
13889 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13890 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13891* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13892 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13893 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13894 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13895* ss-asas pair
13896 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13897 IREJ = 1
13898 RETURN
13899 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13900* at least one strange quark
13901 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13902 IREJ = 1
13903 RETURN
13904 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13905 IREJ = 1
13906 RETURN
13907 ENDIF
13908* accept the new sea-diquark
13909 XTVD(IDXVT) = XXTV
13910 XTSQ(IDXST) = XXTSQ
13911 XTSAQ(IDXST) = XXTSAQ
13912 NVD = NVD+1
13913 INTVD1(NVD) = IDXVP
13914 INTVD2(NVD) = IDXST
13915 ISKPCH(7,NVD) = 0
13916 RETURN
13917
13918*---------------------------------------------------------------------
13919* proj. sea partons - targ. valence partons
13920* get x-values and flavors for projectile sea-diquark pair
13921
13922 2 CONTINUE
13923 IDXSP = IDX2
13924 IDXVT = IDX1
13925
13926* index of corr. val-diquark-x in projectile nucleon
13927 IDXVP = ITOVP(IFROSP(IDXSP))
13928* available x above diquark thresholds for valence- and sea-diquarks
13929 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13930
13931 IF (XXD.GE.ZERO) THEN
13932* x-values for the three diquarks of the projectile nucleon
13933 RR1 = DT_RNDM(XXD)
13934 RR2 = DT_RNDM(RR1)
13935 RR3 = DT_RNDM(RR2)
13936 SR123 = RR1+RR2+RR3
13937 XXPV = XDTHR+RR1*XXD/SR123
13938 XXPSQ = XDTHR+RR2*XXD/SR123
13939 XXPSAQ = XDTHR+RR3*XXD/SR123
13940 ELSE
13941 XXPV = XPVD(IDXVP)
13942 XXPSQ = XPSQ(IDXSP)
13943 XXPSAQ = XPSAQ(IDXSP)
13944 ENDIF
13945* flavor of the second quarks in the sea-diquark pair
13946 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13947 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13948* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13949 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13950 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13951 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13952* ss-asas pair
13953 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13954 IREJ = 1
13955 RETURN
13956 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13957* at least one strange quark
13958 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13959 IREJ = 1
13960 RETURN
13961 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13962 IREJ = 1
13963 RETURN
13964 ENDIF
13965* accept the new sea-diquark
13966 XPVD(IDXVP) = XXPV
13967 XPSQ(IDXSP) = XXPSQ
13968 XPSAQ(IDXSP) = XXPSAQ
13969 NDV = NDV+1
13970 INTDV1(NDV) = IDXSP
13971 INTDV2(NDV) = IDXVT
13972 ISKPCH(5,NDV) = 0
13973 RETURN
13974
13975*---------------------------------------------------------------------
13976* proj. sea partons - targ. sea partons
13977* get x-values and flavors for target sea-diquark pair
13978
13979 3 CONTINUE
13980 IDXSP = IDX1
13981 IDXST = IDX2
13982
13983* index of corr. val-diquark-x in target nucleon
13984 IDXVT = ITOVT(IFROST(IDXST))
13985* available x above diquark thresholds for valence- and sea-diquarks
13986 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13987
13988 IF (XXD.GE.ZERO) THEN
13989* x-values for the three diquarks of the target nucleon
13990 RR1 = DT_RNDM(XXD)
13991 RR2 = DT_RNDM(RR1)
13992 RR3 = DT_RNDM(RR2)
13993 SR123 = RR1+RR2+RR3
13994 XXTV = XDTHR+RR1*XXD/SR123
13995 XXTSQ = XDTHR+RR2*XXD/SR123
13996 XXTSAQ = XDTHR+RR3*XXD/SR123
13997 ELSE
13998 XXTV = XTVD(IDXVT)
13999 XXTSQ = XTSQ(IDXST)
14000 XXTSAQ = XTSAQ(IDXST)
14001 ENDIF
14002* flavor of the second quarks in the sea-diquark pair
14003 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14004 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14005* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14006 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14007 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14008 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14009* ss-asas pair
14010 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14011 IREJ = 1
14012 RETURN
14013 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14014* at least one strange quark
14015 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14016 IREJ = 1
14017 RETURN
14018 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14019 IREJ = 1
14020 RETURN
14021 ENDIF
14022* accept the new sea-diquark
14023 XTVD(IDXVT) = XXTV
14024 XTSQ(IDXST) = XXTSQ
14025 XTSAQ(IDXST) = XXTSAQ
14026 NSD = NSD+1
14027 INTSD1(NSD) = IDXSP
14028 INTSD2(NSD) = IDXST
14029 ISKPCH(3,NSD) = 0
14030 RETURN
14031
14032*---------------------------------------------------------------------
14033* proj. sea partons - targ. sea partons
14034* get x-values and flavors for projectile sea-diquark pair
14035
14036 4 CONTINUE
14037 IDXSP = IDX2
14038 IDXST = IDX1
14039
14040* index of corr. val-diquark-x in projectile nucleon
14041 IDXVP = ITOVP(IFROSP(IDXSP))
14042* available x above diquark thresholds for valence- and sea-diquarks
14043 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14044
14045 IF (XXD.GE.ZERO) THEN
14046* x-values for the three diquarks of the projectile nucleon
14047 RR1 = DT_RNDM(XXD)
14048 RR2 = DT_RNDM(RR1)
14049 RR3 = DT_RNDM(RR2)
14050 SR123 = RR1+RR2+RR3
14051 XXPV = XDTHR+RR1*XXD/SR123
14052 XXPSQ = XDTHR+RR2*XXD/SR123
14053 XXPSAQ = XDTHR+RR3*XXD/SR123
14054 ELSE
14055 XXPV = XPVD(IDXVP)
14056 XXPSQ = XPSQ(IDXSP)
14057 XXPSAQ = XPSAQ(IDXSP)
14058 ENDIF
14059* flavor of the second quarks in the sea-diquark pair
14060 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14061 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14062* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14063 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14064 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14065 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14066* ss-asas pair
14067 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14068 IREJ = 1
14069 RETURN
14070 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14071* at least one strange quark
14072 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14073 IREJ = 1
14074 RETURN
14075 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14076 IREJ = 1
14077 RETURN
14078 ENDIF
14079* accept the new sea-diquark
14080 XPVD(IDXVP) = XXPV
14081 XPSQ(IDXSP) = XXPSQ
14082 XPSAQ(IDXSP) = XXPSAQ
14083 NDS = NDS+1
14084 INTDS1(NDS) = IDXSP
14085 INTDS2(NDS) = IDXST
14086 ISKPCH(2,NDS) = 0
14087 RETURN
14088 END
14089*$ CREATE DT_DIFEVT.FOR
14090*COPY DT_DIFEVT
14091*
14092*===difevt=============================================================*
14093*
14094 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14095 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14096
14097************************************************************************
14098* Interface to treatment of diffractive interactions. *
14099* (input) IFP1/2 PDG-indizes of projectile partons *
14100* (baryon: IFP2 - adiquark) *
14101* PP(4) projectile 4-momentum *
14102* IFT1/2 PDG-indizes of target partons *
14103* (baryon: IFT1 - adiquark) *
14104* PT(4) target 4-momentum *
14105* (output) JDIFF = 0 no diffraction *
14106* = 1/-1 LMSD/LMDD *
14107* = 2/-2 HMSD/HMDD *
14108* NCSY counter for two-chain systems *
14109* dumped to DTEVT1 *
14110* This version dated 14.02.95 is written by S. Roesler *
14111************************************************************************
14112
14113 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14114 SAVE
14115
14116 PARAMETER ( LINP = 10 ,
14117 & LOUT = 6 ,
14118 & LDAT = 9 )
14119
14120 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14121 & OHALF=0.5D0)
14122
14123* event history
14124
14125 PARAMETER (NMXHKK=200000)
14126
14127 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14128 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14129 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14130
14131* extended event history
14132 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14133 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14134 & IHIST(2,NMXHKK)
14135
14136* flags for diffractive interactions (DTUNUC 1.x)
14137 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14138
14139 DIMENSION PP(4),PT(4)
14140
14141 LOGICAL LFIRST
14142 DATA LFIRST /.TRUE./
14143
14144 IREJ = 0
14145 JDIFF = 0
14146 IFLAGD = JDIFF
14147
14148* cm. energy
14149 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14150 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14151* identities of projectile hadron / target nucleon
14152 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14153 KTARG = IDT_ICIHAD(IDHKK(MOT))
14154
14155* single diffractive xsections
14156 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14157* double diffractive xsections
14158**!! no double diff yet
14159C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14160 DDTOT = 0.0D0
14161 DDHM = 0.0D0
14162**!!
14163* total inelastic xsection
14164C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14165 DUMZER = ZERO
14166 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14167 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14168
14169* fraction of diffractive processes
14170 FRADIF = (SDTOT+DDTOT)/SIGIN
14171
14172 IF (LFIRST) THEN
14173 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14174 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14175 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14176 & F5.1,' mb',/)
14177 LFIRST = .FALSE.
14178 ENDIF
14179
14180 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14181 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14182* diffractive interaction requested by x-section or by user
14183 FRASD = SDTOT/(SDTOT+DDTOT)
14184 FRASDH = SDHM/SDTOT
14185**sr needs to be specified!!
14186C FRADDH = DDHM/DDTOT
14187 FRADDH = 1.0D0
14188**
14189 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14190* single diffraction
14191 KDIFF = 1
14192 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14193 KP = 2
14194 KT = 0
14195 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14196 & ISINGD.NE.3) THEN
14197 KP = 0
14198 KT = 2
14199 ENDIF
14200 ELSE
14201 KP = 1
14202 KT = 0
14203 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14204 & ISINGD.NE.3) THEN
14205 KP = 0
14206 KT = 1
14207 ENDIF
14208 ENDIF
14209 ELSE
14210* double diffraction
14211 KDIFF = -1
14212 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14213 KP = 2
14214 KT = 2
14215 ELSE
14216 KP = 1
14217 KT = 1
14218 ENDIF
14219 ENDIF
14220 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14221 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14222 IF (IREJ1.EQ.0) THEN
14223 IFLAGD = 2*KDIFF
14224 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14225 ELSE
14226 GOTO 9999
14227 ENDIF
14228 ENDIF
14229 JDIFF = IFLAGD
14230
14231 RETURN
14232
14233 9999 CONTINUE
14234 IREJ = 1
14235 RETURN
14236 END
14237
14238*$ CREATE DT_DIFFKI.FOR
14239*COPY DT_DIFFKI
14240*
14241*===difkin=============================================================*
14242*
14243 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14244 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14245
14246************************************************************************
14247* Kinematics of diffractive nucleon-nucleon interaction. *
14248* IFP1/2 PDG-indizes of projectile partons *
14249* (baryon: IFP2 - adiquark) *
14250* PP(4) projectile 4-momentum *
14251* IFT1/2 PDG-indizes of target partons *
14252* (baryon: IFT1 - adiquark) *
14253* PT(4) target 4-momentum *
14254* KP = 0 projectile quasi-elastically scattered *
14255* = 1 excited to low-mass diff. state *
14256* = 2 excited to high-mass diff. state *
14257* KT = 0 target quasi-elastically scattered *
14258* = 1 excited to low-mass diff. state *
14259* = 2 excited to high-mass diff. state *
14260* This version dated 12.02.95 is written by S. Roesler *
14261************************************************************************
14262
14263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14264 SAVE
14265
14266 PARAMETER ( LINP = 10 ,
14267 & LOUT = 6 ,
14268 & LDAT = 9 )
14269
14270 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14271
14272 LOGICAL LSTART
14273
14274* particle properties (BAMJET index convention)
14275 CHARACTER*8 ANAME
14276 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14277 & IICH(210),IIBAR(210),K1(210),K2(210)
14278
14279* flags for input different options
14280 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14281 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14282 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14283
14284* rejection counter
14285 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14286 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14287 & IREXCI(3),IRDIFF(2),IRINC
14288
14289* kinematics of diffractive interactions (DTUNUC 1.x)
14290 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14291 & PPF(4),PTF(4),
14292 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14293 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14294
14295 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14296 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14297
14298 DATA LSTART /.TRUE./
14299
14300 IF (LSTART) THEN
14301 WRITE(LOUT,2000)
14302 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14303 LSTART = .FALSE.
14304 ENDIF
14305
14306 IREJ = 0
14307
14308* initialize common /DTDIKI/
14309 CALL DT_DIFINI
14310* store momenta of initial incoming particles for emc-check
14311 IF (LEMCCK) THEN
14312 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14313 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14314 ENDIF
14315
14316* masses of initial particles
14317 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14318 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14319 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14320 XMP = SQRT(XMP2)
14321 XMT = SQRT(XMT2)
14322* check quark-input (used to adjust coherence cond. for M-selection)
14323 IBP = 0
14324 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14325 IBT = 0
14326 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14327
14328* parameter for Lorentz-transformation into nucleon-nucleon cms
14329 DO 3 K=1,4
14330 PITOT(K) = PP(K)+PT(K)
14331 3 CONTINUE
14332 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14333 IF (XMTOT2.LE.ZERO) THEN
14334 WRITE(LOUT,1000) XMTOT2
14335 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14336 & 'XMTOT2 = ',E12.3)
14337 GOTO 9999
14338 ENDIF
14339 XMTOT = SQRT(XMTOT2)
14340 DO 4 K=1,4
14341 BGTOT(K) = PITOT(K)/XMTOT
14342 4 CONTINUE
14343* transformation of nucleons into cms
14344 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14345 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14346 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14347 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14348* rotation angles
14349 COD = PP1(3)/PPTOT
14350C SID = SQRT((ONE-COD)*(ONE+COD))
14351 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14352 SID = PPT/PPTOT
14353 COF = ONE
14354 SIF = ZERO
14355 IF(PPTOT*SID.GT.TINY10) THEN
14356 COF = PP1(1)/(SID*PPTOT)
14357 SIF = PP1(2)/(SID*PPTOT)
14358 ANORF = SQRT(COF*COF+SIF*SIF)
14359 COF = COF/ANORF
14360 SIF = SIF/ANORF
14361 ENDIF
14362* check consistency
14363 DO 5 K=1,4
14364 DEV1(K) = ABS(PP1(K)+PT1(K))
14365 5 CONTINUE
14366 DEV1(4) = ABS(DEV1(4)-XMTOT)
14367 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14368 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14369 WRITE(LOUT,1001) DEV1
14370 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14371 & /,8X,4E12.3)
14372 GOTO 9999
14373 ENDIF
14374
14375* select x-fractions in high-mass diff. interactions
14376 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14377
14378* select diffractive masses
14379* - projectile
14380 IF (KP.EQ.1) THEN
14381 XMPF = DT_XMLMD(XMTOT)
14382 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14383 IF (IREJ1.GT.0) GOTO 9999
14384 ELSEIF (KP.EQ.2) THEN
14385 XMPF = DT_XMHMD(XMTOT,IBP,1)
14386 ELSE
14387 XMPF = XMP
14388 ENDIF
14389* - target
14390 IF (KT.EQ.1) THEN
14391 XMTF = DT_XMLMD(XMTOT)
14392 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14393 IF (IREJ1.GT.0) GOTO 9999
14394 ELSEIF (KT.EQ.2) THEN
14395 XMTF = DT_XMHMD(XMTOT,IBT,2)
14396 ELSE
14397 XMTF = XMT
14398 ENDIF
14399
14400* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14401 XMPF2 = XMPF**2
14402 XMTF2 = XMTF**2
14403 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14404 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14405
14406* select momentum transfer (all t-values used here are <0)
14407* minimum absolute value to produce diffractive masses
14408 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14409 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14410 IF (IREJ1.GT.0) GOTO 9999
14411
14412* longitudinal momentum of excited/elastically scattered projectile
14413 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14414* total transverse momentum due to t-selection
14415 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14416 IF (PPBLT2.LT.ZERO) THEN
14417 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14418 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14419 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14420 GOTO 9999
14421 ENDIF
14422 CALL DT_DSFECF(SINPHI,COSPHI)
14423 PPBLT = SQRT(PPBLT2)
14424 PPBLOB(1) = COSPHI*PPBLT
14425 PPBLOB(2) = SINPHI*PPBLT
14426
14427* rotate excited/elastically scattered projectile into n-n cms.
14428 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14429 & XX,YY,ZZ)
14430 PPBLOB(1) = XX
14431 PPBLOB(2) = YY
14432 PPBLOB(3) = ZZ
14433
14434* 4-momentum of excited/elastically scattered target and of exchanged
14435* Pomeron
14436 DO 6 K=1,4
14437 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14438 PPOM1(K) = PP1(K)-PPBLOB(K)
14439 6 CONTINUE
14440 PTBLOB(4) = XMTOT-PPBLOB(4)
14441
14442* Lorentz-transformation back into system of initial diff. collision
14443 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14444 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14445 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14446 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14447 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14448 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14449 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14450 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14451 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14452
14453* store 4-momentum of elastically scattered particle (in single diff.
14454* events)
14455 IF (KP.EQ.0) THEN
14456 DO 7 K=1,4
14457 PSC(K) = PPF(K)
14458 7 CONTINUE
14459 ELSEIF (KT.EQ.0) THEN
14460 DO 8 K=1,4
14461 PSC(K) = PTF(K)
14462 8 CONTINUE
14463 ENDIF
14464
14465* check consistency of kinematical treatment so far
14466 IF (LEMCCK) THEN
14467 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14468 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14469 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14470 IF (IREJ1.NE.0) GOTO 9999
14471 ENDIF
14472 DO 9 K=1,4
14473 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14474 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14475 9 CONTINUE
14476 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14477 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14478 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14479 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14480 WRITE(LOUT,1003) DEV1,DEV2
14481 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14482 & 2(/,8X,4E12.3))
14483 GOTO 9999
14484 ENDIF
14485
14486* kinematical treatment for low-mass diffraction
14487 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14488 IF (IREJ1.NE.0) GOTO 9999
14489
14490* dump diffractive chains into DTEVT1
14491 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14492 IF (IREJ1.NE.0) GOTO 9999
14493
14494 RETURN
14495
14496 9999 CONTINUE
14497 IRDIFF(1) = IRDIFF(1)+1
14498 IREJ = 1
14499 RETURN
14500 END
14501
14502*$ CREATE DT_XMHMD.FOR
14503*COPY DT_XMHMD
14504*
14505*===xmhmd==============================================================*
14506*
14507 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14508
14509************************************************************************
14510* Diffractive mass in high mass single/double diffractive events. *
14511* This version dated 11.02.95 is written by S. Roesler *
14512************************************************************************
14513
14514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14515 SAVE
14516
14517 PARAMETER ( LINP = 10 ,
14518 & LOUT = 6 ,
14519 & LDAT = 9 )
14520
14521 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14522
14523* kinematics of diffractive interactions (DTUNUC 1.x)
14524 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14525 & PPF(4),PTF(4),
14526 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14527 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14528
14529C DATA XCOLOW /0.05D0/
14530 DATA XCOLOW /0.15D0/
14531
14532 DT_XMHMD = ZERO
14533 XH = XPH(2)
14534 IF (MODE.EQ.2) XH = XTH(2)
14535
14536* minimum Pomeron-x for high-mass diffraction
14537* (adjusted to get a smooth transition between HM and LM component)
14538 R = DT_RNDM(XH)
14539 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14540 IF (ECM.LE.300.0D0) THEN
14541 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14542 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14543 ENDIF
14544* maximum Pomeron-x for high-mass diffraction
14545* (coherence condition, adjusted to fit to experimental data)
14546 IF (IB.NE.0) THEN
14547* baryon-diffraction
14548 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14549 ELSE
14550* meson-diffraction
14551 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14552 ENDIF
14553* check boundaries
14554 IF (XDIMIN.GE.XDIMAX) THEN
14555 XDIMIN = OHALF*XDIMAX
14556 ENDIF
14557
14558 KLOOP = 0
14559 1 CONTINUE
14560 KLOOP = KLOOP+1
14561 IF (KLOOP.GT.20) RETURN
14562* sample Pomeron-x from 1/x-distribution (critical Pomeron)
14563 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14564* corr. diffr. mass
14565 DT_XMHMD = ECM*SQRT(XDIFF)
14566 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14567
14568 RETURN
14569 END
14570
14571*$ CREATE DT_XMLMD.FOR
14572*COPY DT_XMLMD
14573*
14574*===xmlmd==============================================================*
14575*
14576 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14577
14578************************************************************************
14579* Diffractive mass in high mass single/double diffractive events. *
14580* This version dated 11.02.95 is written by S. Roesler *
14581************************************************************************
14582
14583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14584 SAVE
14585
14586 PARAMETER ( LINP = 10 ,
14587 & LOUT = 6 ,
14588 & LDAT = 9 )
14589
14590* minimum Pomeron-x for low-mass diffraction
14591C AMO = 1.5D0
14592 AMO = 2.0D0
14593* maximum Pomeron-x for low-mass diffraction
14594* (adjusted to get a smooth transition between HM and LM component)
14595 R = DT_RNDM(AMO)
14596 SAM = 1.0D0
14597 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14598 R = DT_RNDM(AMO)*SAM
14599 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14600 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14601
14602* selection of diffractive mass
14603* (adjusted to get a smooth transition between HM and LM component)
14604 R = DT_RNDM(AMU)
14605 IF (ECM.LE.50.0D0) THEN
14606 DT_XMLMD = AMO*(AMU/AMO)**R
14607 ELSE
14608 A = 0.7D0
14609 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14610 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14611 ENDIF
14612
14613 RETURN
14614 END
14615
14616*$ CREATE DT_TDIFF.FOR
14617*COPY DT_TDIFF
14618*
14619*===tdiff==============================================================*
14620*
14621 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14622
14623************************************************************************
14624* t-selection for single/double diffractive interactions. *
14625* ECM cm. energy *
14626* TMIN minimum momentum transfer to produce diff. masses *
14627* XM1/XM2 diffractively produced masses *
14628* (for single diffraction XM2 is obsolete) *
14629* K1/K2= 0 not excited *
14630* = 1 low-mass excitation *
14631* = 2 high-mass excitation *
14632* This version dated 11.02.95 is written by S. Roesler *
14633************************************************************************
14634
14635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14636 SAVE
14637
14638 PARAMETER ( LINP = 10 ,
14639 & LOUT = 6 ,
14640 & LDAT = 9 )
14641
14642 PARAMETER (ZERO=0.0D0)
14643
14644 PARAMETER ( BTP0 = 3.7D0,
14645 & ALPHAP = 0.24D0 )
14646
14647 IREJ = 0
14648 NCLOOP = 0
14649 DT_TDIFF = ZERO
14650
14651 IF (K1.GT.0) THEN
14652 XM1 = XM1I
14653 XM2 = XM2I
14654 ELSE
14655 XM1 = XM2I
14656 ENDIF
14657 XDI = (XM1/ECM)**2
14658 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14659* slope for single diffraction
14660 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14661 ELSE
14662* slope for double diffraction
14663 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14664 ENDIF
14665
14666 1 CONTINUE
14667 NCLOOP = NCLOOP+1
14668 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14669 Y = DT_RNDM(XDI)
14670 T = -LOG(1.0D0-Y)/SLOPE
14671 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14672 DT_TDIFF = -ABS(T)
14673
14674 RETURN
14675
14676 9999 CONTINUE
14677 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14678 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14679 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14680 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14681 IREJ = 1
14682 RETURN
14683 END
14684
14685*$ CREATE DT_XVALHM.FOR
14686*COPY DT_XVALHM
14687*
14688*===xvalhm=============================================================*
14689*
14690 SUBROUTINE DT_XVALHM(KP,KT)
14691
14692************************************************************************
14693* Sampling of parton x-values in high-mass diffractive interactions. *
14694* This version dated 12.02.95 is written by S. Roesler *
14695************************************************************************
14696
14697 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14698 SAVE
14699
14700 PARAMETER ( LINP = 10 ,
14701 & LOUT = 6 ,
14702 & LDAT = 9 )
14703
14704 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14705
14706* kinematics of diffractive interactions (DTUNUC 1.x)
14707 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14708 & PPF(4),PTF(4),
14709 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14710 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14711
14712* various options for treatment of partons (DTUNUC 1.x)
14713* (chain recombination, Cronin,..)
14714 LOGICAL LCO2CR,LINTPT
14715 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14716 & LCO2CR,LINTPT
14717
14718 DATA UNON,XVQTHR /2.0D0,0.8D0/
14719
14720 IF (KP.EQ.2) THEN
14721* x-fractions of projectile valence partons
14722 1 CONTINUE
14723 XPH(1) = DT_DBETAR(OHALF,UNON)
14724 IF (XPH(1).GE.XVQTHR) GOTO 1
14725 XPH(2) = ONE-XPH(1)
14726* x-fractions of Pomeron q-aq-pair
14727 XPOLO = TINY2
14728 XPOHI = ONE-TINY2
14729 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14730 XPPO(2) = ONE-XPPO(1)
14731* flavors of Pomeron q-aq-pair
14732 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14733 IFPPO(1) = IFLAV
14734 IFPPO(2) = -IFLAV
14735 IF (DT_RNDM(UNON).GT.OHALF) THEN
14736 IFPPO(1) = -IFLAV
14737 IFPPO(2) = IFLAV
14738 ENDIF
14739 ENDIF
14740
14741 IF (KT.EQ.2) THEN
14742* x-fractions of projectile target partons
14743 2 CONTINUE
14744 XTH(1) = DT_DBETAR(OHALF,UNON)
14745 IF (XTH(1).GE.XVQTHR) GOTO 2
14746 XTH(2) = ONE-XTH(1)
14747* x-fractions of Pomeron q-aq-pair
14748 XPOLO = TINY2
14749 XPOHI = ONE-TINY2
14750 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14751 XTPO(2) = ONE-XTPO(1)
14752* flavors of Pomeron q-aq-pair
14753 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14754 IFTPO(1) = IFLAV
14755 IFTPO(2) = -IFLAV
14756 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14757 IFTPO(1) = -IFLAV
14758 IFTPO(2) = IFLAV
14759 ENDIF
14760 ENDIF
14761
14762 RETURN
14763 END
14764
14765*$ CREATE DT_LM2RES.FOR
14766*COPY DT_LM2RES
14767*
14768*===lm2res=============================================================*
14769*
14770 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14771
14772************************************************************************
14773* Check low-mass diffractive excitation for resonance mass. *
14774* (input) IF1/2 PDG-indizes of valence partons *
14775* (in/out) XM diffractive mass requested/corrected *
14776* (output) IDR/IDXR id./BAMJET-index of resonance *
14777* This version dated 12.02.95 is written by S. Roesler *
14778************************************************************************
14779
14780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14781 SAVE
14782
14783 PARAMETER ( LINP = 10 ,
14784 & LOUT = 6 ,
14785 & LDAT = 9 )
14786
14787 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14788
14789* kinematics of diffractive interactions (DTUNUC 1.x)
14790 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14791 & PPF(4),PTF(4),
14792 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14793 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14794
14795 IREJ = 0
14796 IF1B = 0
14797 IF2B = 0
14798 XMI = XM
14799
14800* BAMJET indices of partons
14801 IF1A = IDT_IPDG2B(IF1,1,2)
14802 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14803 IF2A = IDT_IPDG2B(IF2,1,2)
14804 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14805
14806* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14807 IDCH = 2
14808 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14809
14810* check for resonance mass
14811 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14812 IF (IREJ1.NE.0) GOTO 9999
14813
14814 XM = XMN
14815 RETURN
14816
14817 9999 CONTINUE
14818 IREJ = 1
14819 RETURN
14820 END
14821
14822*$ CREATE DT_LMKINE.FOR
14823*COPY DT_LMKINE
14824*
14825*===lmkine=============================================================*
14826*
14827 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14828
14829************************************************************************
14830* Kinematical treatment of low-mass excitations. *
14831* This version dated 12.02.95 is written by S. Roesler *
14832************************************************************************
14833
14834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14835 SAVE
14836
14837 PARAMETER ( LINP = 10 ,
14838 & LOUT = 6 ,
14839 & LDAT = 9 )
14840
14841 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14842
14843* flags for input different options
14844 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14845 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14846 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14847
14848* kinematics of diffractive interactions (DTUNUC 1.x)
14849 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14850 & PPF(4),PTF(4),
14851 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14852 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14853
14854 DIMENSION P1(4),P2(4)
14855
14856 IREJ = 0
14857
14858 IF (KP.EQ.1) THEN
14859 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14860 POE = PPF(4)/PABS
14861 FAC1 = OHALF*(POE+ONE)
14862 FAC2 = -OHALF*(POE-ONE)
14863 DO 1 K=1,3
14864 PPLM1(K) = FAC1*PPF(K)
14865 PPLM2(K) = FAC2*PPF(K)
14866 1 CONTINUE
14867 PPLM1(4) = FAC1*PABS
14868 PPLM2(4) = -FAC2*PABS
14869 IF (IMSHL.EQ.1) THEN
14870
14871 XM1 = PYMASS(IFP1)
14872 XM2 = PYMASS(IFP2)
14873
14874 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14875 IF (IREJ1.NE.0) GOTO 9999
14876 DO 2 K=1,4
14877 PPLM1(K) = P1(K)
14878 PPLM2(K) = P2(K)
14879 2 CONTINUE
14880 ENDIF
14881 ENDIF
14882
14883 IF (KT.EQ.1) THEN
14884 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14885 POE = PTF(4)/PABS
14886 FAC1 = OHALF*(POE+ONE)
14887 FAC2 = -OHALF*(POE-ONE)
14888 DO 3 K=1,3
14889 PTLM2(K) = FAC1*PTF(K)
14890 PTLM1(K) = FAC2*PTF(K)
14891 3 CONTINUE
14892 PTLM2(4) = FAC1*PABS
14893 PTLM1(4) = -FAC2*PABS
14894 IF (IMSHL.EQ.1) THEN
14895
14896 XM1 = PYMASS(IFT1)
14897 XM2 = PYMASS(IFT2)
14898
14899 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14900 IF (IREJ1.NE.0) GOTO 9999
14901 DO 4 K=1,4
14902 PTLM1(K) = P1(K)
14903 PTLM2(K) = P2(K)
14904 4 CONTINUE
14905 ENDIF
14906 ENDIF
14907
14908 RETURN
14909
14910 9999 CONTINUE
14911 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14912 IREJ = 1
14913 RETURN
14914 END
14915
14916*$ CREATE DT_DIFINI.FOR
14917*COPY DT_DIFINI
14918*
14919*===difini=============================================================*
14920*
14921 SUBROUTINE DT_DIFINI
14922
14923************************************************************************
14924* Initialization of common /DTDIKI/ *
14925* This version dated 12.02.95 is written by S. Roesler *
14926************************************************************************
14927
14928 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14929 SAVE
14930
14931 PARAMETER ( LINP = 10 ,
14932 & LOUT = 6 ,
14933 & LDAT = 9 )
14934
14935 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14936
14937* kinematics of diffractive interactions (DTUNUC 1.x)
14938 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14939 & PPF(4),PTF(4),
14940 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14941 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14942
14943 DO 1 K=1,4
14944 PPOM(K) = ZERO
14945 PSC(K) = ZERO
14946 PPF(K) = ZERO
14947 PTF(K) = ZERO
14948 PPLM1(K) = ZERO
14949 PPLM2(K) = ZERO
14950 PTLM1(K) = ZERO
14951 PTLM2(K) = ZERO
14952 1 CONTINUE
14953 DO 2 K=1,2
14954 XPH(K) = ZERO
14955 XPPO(K) = ZERO
14956 XTH(K) = ZERO
14957 XTPO(K) = ZERO
14958 IFPPO(K) = 0
14959 IFTPO(K) = 0
14960 2 CONTINUE
14961 IDPR = 0
14962 IDXPR = 0
14963 IDTR = 0
14964 IDXTR = 0
14965
14966 RETURN
14967 END
14968
14969*$ CREATE DT_DIFPUT.FOR
14970*COPY DT_DIFPUT
14971*
14972*===difput=============================================================*
14973*
14974 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14975 & IREJ)
14976
14977************************************************************************
14978* Dump diffractive chains into DTEVT1 *
14979* This version dated 12.02.95 is written by S. Roesler *
14980************************************************************************
14981
14982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14983 SAVE
14984
14985 PARAMETER ( LINP = 10 ,
14986 & LOUT = 6 ,
14987 & LDAT = 9 )
14988
14989 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14990
14991 LOGICAL LCHK
14992
14993* kinematics of diffractive interactions (DTUNUC 1.x)
14994 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14995 & PPF(4),PTF(4),
14996 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14997 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14998
14999* event history
15000
15001 PARAMETER (NMXHKK=200000)
15002
15003 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15004 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15005 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15006
15007* extended event history
15008 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15009 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15010 & IHIST(2,NMXHKK)
15011
15012* rejection counter
15013 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15014 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15015 & IREXCI(3),IRDIFF(2),IRINC
15016
15017 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15018 & P1(4),P2(4),P3(4),P4(4)
15019
15020 IREJ = 0
15021
15022 IF (KP.EQ.1) THEN
15023 DO 1 K=1,4
15024 PCH(K) = PPLM1(K)+PPLM2(K)
15025 1 CONTINUE
15026 ID1 = IFP1
15027 ID2 = IFP2
15028 IF (DT_RNDM(PT).GT.OHALF) THEN
15029 ID1 = IFP2
15030 ID2 = IFP1
15031 ENDIF
15032 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15033 & PPLM1(4),0,0,0)
15034 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15035 & PPLM2(4),0,0,0)
15036 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15037 & IDPR,IDXPR,8)
15038 ELSEIF (KP.EQ.2) THEN
15039 DO 2 K=1,4
15040 PP1(K) = XPH(1)*PP(K)
15041 PP2(K) = XPH(2)*PP(K)
15042 PT1(K) = -XPPO(1)*PPOM(K)
15043 PT2(K) = -XPPO(2)*PPOM(K)
15044 2 CONTINUE
15045 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15046 XM1 = ZERO
15047 XM2 = ZERO
15048 IF (LCHK) THEN
15049 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15050 IF (IREJ1.NE.0) GOTO 9999
15051 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15052 IF (IREJ1.NE.0) GOTO 9999
15053 DO 3 K=1,4
15054 PP1(K) = P1(K)
15055 PT1(K) = P2(K)
15056 PP2(K) = P3(K)
15057 PT2(K) = P4(K)
15058 3 CONTINUE
15059 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15060 & 0,0,8)
15061 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15062 & PT1(4),0,0,8)
15063 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15064 & 0,0,8)
15065 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15066 & PT2(4),0,0,8)
15067 ELSE
15068 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15069 IF (IREJ1.NE.0) GOTO 9999
15070 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15071 IF (IREJ1.NE.0) GOTO 9999
15072 DO 4 K=1,4
15073 PP1(K) = P1(K)
15074 PT2(K) = P2(K)
15075 PP2(K) = P3(K)
15076 PT1(K) = P4(K)
15077 4 CONTINUE
15078 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15079 & 0,0,8)
15080 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15081 & PT2(4),0,0,8)
15082 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15083 & 0,0,8)
15084 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15085 & PT1(4),0,0,8)
15086 ENDIF
15087 NCSY = NCSY+1
15088 ELSE
15089 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15090 & 0,0,0)
15091 ENDIF
15092
15093 IF (KT.EQ.1) THEN
15094 DO 5 K=1,4
15095 PCH(K) = PTLM1(K)+PTLM2(K)
15096 5 CONTINUE
15097 ID1 = IFT1
15098 ID2 = IFT2
15099 IF (DT_RNDM(PT).GT.OHALF) THEN
15100 ID1 = IFT2
15101 ID2 = IFT1
15102 ENDIF
15103 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15104 & PTLM1(4),0,0,0)
15105 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15106 & PTLM2(4),0,0,0)
15107 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15108 & IDTR,IDXTR,8)
15109 ELSEIF (KT.EQ.2) THEN
15110 DO 6 K=1,4
15111 PP1(K) = XTPO(1)*PPOM(K)
15112 PP2(K) = XTPO(2)*PPOM(K)
15113 PT1(K) = XTH(2)*PT(K)
15114 PT2(K) = XTH(1)*PT(K)
15115 6 CONTINUE
15116 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15117 XM1 = ZERO
15118 XM2 = ZERO
15119 IF (LCHK) THEN
15120 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15121 IF (IREJ1.NE.0) GOTO 9999
15122 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15123 IF (IREJ1.NE.0) GOTO 9999
15124 DO 7 K=1,4
15125 PP1(K) = P1(K)
15126 PT1(K) = P2(K)
15127 PP2(K) = P3(K)
15128 PT2(K) = P4(K)
15129 7 CONTINUE
15130 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15131 & PP1(4),0,0,8)
15132 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15133 & 0,0,8)
15134 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15135 & PP2(4),0,0,8)
15136 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15137 & 0,0,8)
15138 ELSE
15139 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15140 IF (IREJ1.NE.0) GOTO 9999
15141 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15142 IF (IREJ1.NE.0) GOTO 9999
15143 DO 8 K=1,4
15144 PP1(K) = P1(K)
15145 PT2(K) = P2(K)
15146 PP2(K) = P3(K)
15147 PT1(K) = P4(K)
15148 8 CONTINUE
15149 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15150 & PP1(4),0,0,8)
15151 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15152 & 0,0,8)
15153 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15154 & PP2(4),0,0,8)
15155 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15156 & 0,0,8)
15157 ENDIF
15158 NCSY = NCSY+1
15159 ELSE
15160 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15161 & 0,0,0)
15162 ENDIF
15163
15164 RETURN
15165
15166 9999 CONTINUE
15167 IRDIFF(2) = IRDIFF(2)+1
15168 IREJ = 1
15169 RETURN
15170 END
15171*$ CREATE DT_EVTFRG.FOR
15172*COPY DT_EVTFRG
15173*
15174*===evtfrg=============================================================*
15175*
15176 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15177
15178************************************************************************
15179* Hadronization of chains in DTEVT1. *
15180* *
15181* Input: *
15182* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15183* = 2 hadronization of DTUNUC-chains (id=88xxx) *
15184* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15185* hadronized with one PYEXEC call *
15186* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15187* with one PYEXEC call *
15188* Output: *
15189* NPYMEM number of entries in JETSET-common after hadronization *
15190* IREJ rejection flag *
15191* *
15192* This version dated 17.09.00 is written by S. Roesler *
15193************************************************************************
15194
15195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15196 SAVE
15197
15198 PARAMETER ( LINP = 10 ,
15199 & LOUT = 6 ,
15200 & LDAT = 9 )
15201
15202 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15203 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15204
15205 LOGICAL LACCEP
15206
15207 PARAMETER (MXJOIN=200)
15208
15209* event history
15210
15211 PARAMETER (NMXHKK=200000)
15212
15213 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15214 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15215 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15216
15217* extended event history
15218 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15219 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15220 & IHIST(2,NMXHKK)
15221
15222* flags for input different options
15223 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15224 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15225 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15226
15227* statistics
15228 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15229 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15230 & ICEVTG(8,0:30)
15231
15232* flags for diffractive interactions (DTUNUC 1.x)
15233 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15234
15235* nucleon-nucleon event-generator
15236 CHARACTER*8 CMODEL
15237 LOGICAL LPHOIN
15238 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15239* phojet
15240
15241C model switches and parameters
15242 CHARACTER*8 MDLNA
15243 INTEGER ISWMDL,IPAMDL
15244 DOUBLE PRECISION PARMDL
15245 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15246* jetset
15247
15248 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15249 PARAMETER (MAXLND=4000)
15250 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15251
15252 INTEGER PYK
15253
15254 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15255
15256 MODE = KMODE
15257 ISTSTG = 7
15258 IF (MODE.NE.1) ISTSTG = 8
15259 IREJ = 0
15260
15261 IP = 0
15262 ISH = 0
15263 INIEMC = 1
15264 NEND = NHKK
15265 NACCEP = 0
15266 IFRG = 0
15267 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15268 DO 10 I=NPOINT(3),NEND
15269* sr 14.02.00: seems to be not necessary anymore, commented
15270C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15271C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15272 LACCEP = .TRUE.
15273* pick up chains from dtevt1
15274 IDCHK = IDHKK(I)/10000
15275 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15276 IF (IDCHK.EQ.7) THEN
15277 IPJE = IDHKK(I)-IDCHK*10000
15278 IF (IPJE.NE.IFRG) THEN
15279 IFRG = IPJE
15280 IF (IFRG.GT.NFRG) GOTO 16
15281 ENDIF
15282 ELSE
15283 IPJE = 1
15284 IFRG = IFRG+1
15285 IF (IFRG.GT.NFRG) THEN
15286 NFRG = -1
15287 GOTO 16
15288 ENDIF
15289 ENDIF
15290* statistics counter
15291c IF (IDCH(I).LE.8)
15292c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15293c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15294* special treatment for small chains already corrected to hadrons
15295 IF (IDRES(I).NE.0) THEN
15296 IF (IDRES(I).EQ.11) THEN
15297 ID = IDXRES(I)
15298 ELSE
15299 ID = IDT_IPDGHA(IDXRES(I))
15300 ENDIF
15301 IF (LEMCCK) THEN
15302 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15303 & PHKK(4,I),INIEMC,IDUM,IDUM)
15304 INIEMC = 2
15305 ENDIF
15306 IP = IP+1
15307 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15308 P(IP,1) = PHKK(1,I)
15309 P(IP,2) = PHKK(2,I)
15310 P(IP,3) = PHKK(3,I)
15311 P(IP,4) = PHKK(4,I)
15312 P(IP,5) = PHKK(5,I)
15313 K(IP,1) = 1
15314 K(IP,2) = ID
15315 K(IP,3) = 0
15316 K(IP,4) = 0
15317 K(IP,5) = 0
15318 IHIST(2,I) = 10000*IPJE+IP
15319 IF (IHIST(1,I).LE.-100) THEN
15320 ISH = ISH+1
15321 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15322 ISJOIN(ISH) = I
15323 ENDIF
15324 N = IP
15325 IHISMO(IP) = I
15326 ELSE
15327 IJ = 0
15328 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15329 IF (LEMCCK) THEN
15330 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15331 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15332 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15333 INIEMC = 2
15334 ENDIF
15335 ID = IDHKK(KK)
15336 IF (ID.EQ.0) ID = 21
15337c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15338c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15339
15340c AMRQ = PYMASS(ID)
15341
15342c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15343c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15344c & (ABS(IDIFF).EQ.0)) THEN
15345cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15346c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15347c PHKK(4,KK) = PHKK(4,KK)+DELTA
15348c PTOT1 = PTOT-DELTA
15349c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15350c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15351c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15352c PHKK(5,KK) = AMRQ
15353c ENDIF
15354 IP = IP+1
15355 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15356 P(IP,1) = PHKK(1,KK)
15357 P(IP,2) = PHKK(2,KK)
15358 P(IP,3) = PHKK(3,KK)
15359 P(IP,4) = PHKK(4,KK)
15360 P(IP,5) = PHKK(5,KK)
15361 K(IP,1) = 1
15362 K(IP,2) = ID
15363 K(IP,3) = 0
15364 K(IP,4) = 0
15365 K(IP,5) = 0
15366 IHIST(2,KK) = 10000*IPJE+IP
15367 IF (IHIST(1,KK).LE.-100) THEN
15368 ISH = ISH+1
15369 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15370 ISJOIN(ISH) = KK
15371 ENDIF
15372 IJ = IJ+1
15373 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15374 IJOIN(IJ) = IP
15375 IHISMO(IP) = I
15376 11 CONTINUE
15377 N = IP
15378* join the two-parton system
15379
15380 CALL PYJOIN(IJ,IJOIN)
15381
15382 ENDIF
15383 IDHKK(I) = 99999
15384 ENDIF
15385 10 CONTINUE
15386 16 CONTINUE
15387 N = IP
15388
15389 IF (IP.GT.0) THEN
15390
15391* final state parton shower
15392 DO 136 NPJE=1,IPJE
15393 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15394 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15395 DO 130 K1=1,ISH
15396 IF (ISJOIN(K1).EQ.0) GOTO 130
15397 I = ISJOIN(K1)
15398 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15399 & GOTO 130
15400 IH1 = IHIST(2,I)/10000
15401 IF (IH1.NE.NPJE) GOTO 130
15402 IH1 = IHIST(2,I)-IH1*10000
15403 DO 135 K2=K1+1,ISH
15404 IF (ISJOIN(K2).EQ.0) GOTO 135
15405 II = ISJOIN(K2)
15406 IH2 = IHIST(2,II)/10000
15407 IF (IH2.NE.NPJE) GOTO 135
15408 IH2 = IHIST(2,II)-IH2*10000
15409 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15410 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15411 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15412
15413 RQLUN = MIN(PT1,PT2)
15414 CALL PYSHOW(IH1,IH2,RQLUN)
15415
15416 ISJOIN(K1) = 0
15417 ISJOIN(K2) = 0
15418 GOTO 130
15419 ENDIF
15420 135 CONTINUE
15421 130 CONTINUE
15422 ENDIF
15423 ENDIF
15424 136 CONTINUE
15425
15426 CALL DT_INITJS(MODE)
15427* hadronization
15428
15429 CALL PYEXEC
15430
15431 IF (MSTU(24).NE.0) THEN
15432 WRITE(LOUT,*) ' JETSET-reject at event',
15433 & NEVHKK,MSTU(24),KMODE
15434C CALL DT_EVTOUT(4)
15435
15436C CALL PYLIST(2)
15437
15438 GOTO 9999
15439 ENDIF
15440
15441* number of entries in LUJETS
15442
15443 NLINES = PYK(0,1)
15444
15445 NPYMEM = NLINES
15446
15447 DO 12 I=1,NLINES
15448 IFLG(I) = 0
15449 12 CONTINUE
15450
15451 DO 13 II=1,NLINES
15452
15453 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15454
15455* pick up mother resonance if possible and put it together with
15456* their decay-products into the common
15457 IDXMOR = K(II,3)
15458 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15459 KFMOR = K(IDXMOR,2)
15460 ISMOR = K(IDXMOR,1)
15461 ELSE
15462 KFMOR = 91
15463 ISMOR = 1
15464 ENDIF
15465 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15466 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15467 ID = K(IDXMOR,2)
15468 MO = IHISMO(PYK(IDXMOR,15))
15469 PX = PYP(IDXMOR,1)
15470 PY = PYP(IDXMOR,2)
15471 PZ = PYP(IDXMOR,3)
15472 PE = PYP(IDXMOR,4)
15473
15474 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15475 IFLG(IDXMOR) = 1
15476 MO = NHKK
15477 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15478 IF (PYK(JDAUG,7).EQ.1) THEN
15479 ID = PYK(JDAUG,8)
15480 PX = PYP(JDAUG,1)
15481 PY = PYP(JDAUG,2)
15482 PZ = PYP(JDAUG,3)
15483 PE = PYP(JDAUG,4)
15484
15485 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15486 IF (LEMCCK) THEN
15487 PX = -PYP(JDAUG,1)
15488 PY = -PYP(JDAUG,2)
15489 PZ = -PYP(JDAUG,3)
15490 PE = -PYP(JDAUG,4)
15491
15492 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15493 ENDIF
15494 IFLG(JDAUG) = 1
15495 ENDIF
15496 15 CONTINUE
15497 ELSE
15498* there was no mother resonance
15499 MO = IHISMO(PYK(II,15))
15500 ID = PYK(II,8)
15501 PX = PYP(II,1)
15502 PY = PYP(II,2)
15503 PZ = PYP(II,3)
15504 PE = PYP(II,4)
15505
15506 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15507 IF (LEMCCK) THEN
15508 PX = -PYP(II,1)
15509 PY = -PYP(II,2)
15510 PZ = -PYP(II,3)
15511 PE = -PYP(II,4)
15512
15513 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15514 ENDIF
15515 ENDIF
15516 ENDIF
15517 13 CONTINUE
15518 IF (LEMCCK) THEN
15519 CHKLEV = TINY1
15520 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15521C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15522 ENDIF
15523
15524* global energy-momentum & flavor conservation check
15525**sr 16.5. this check is skipped in case of phojet-treatment
15526 IF (MCGENE.EQ.1)
15527 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15528
15529* update statistics-counter for diffraction
15530c IF (IFLAGD.NE.0) THEN
15531c ICDIFF(1) = ICDIFF(1)+1
15532c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15533c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15534c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15535c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15536c ENDIF
15537
15538 ENDIF
15539
15540 RETURN
15541
15542 9999 CONTINUE
15543 IREJ = 1
15544 RETURN
15545 END
15546
15547*$ CREATE DT_DECAYS.FOR
15548*COPY DT_DECAYS
15549*
15550*===decay==============================================================*
15551*
15552 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15553
15554************************************************************************
15555* Resonance-decay. *
15556* This subroutine replaces DDECAY/DECHKK. *
15557* PIN(4) 4-momentum of resonance (input) *
15558* IDXIN BAMJET-index of resonance (input) *
15559* POUT(20,4) 4-momenta of decay-products (output) *
15560* IDXOUT(20) BAMJET-indices of decay-products (output) *
15561* NSEC number of secondaries (output) *
15562* Adopted from the original version DECHKK. *
15563* This version dated 09.01.95 is written by S. Roesler *
15564************************************************************************
15565
15566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15567 SAVE
15568
15569 PARAMETER ( LINP = 10 ,
15570 & LOUT = 6 ,
15571 & LDAT = 9 )
15572
15573 PARAMETER (TINY17=1.0D-17)
15574
15575* HADRIN: decay channel information
15576 PARAMETER (IDMAX9=602)
15577 CHARACTER*8 ZKNAME
15578 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15579
15580* particle properties (BAMJET index convention)
15581 CHARACTER*8 ANAME
15582 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15583 & IICH(210),IIBAR(210),K1(210),K2(210)
15584
15585* flags for input different options
15586 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15587 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15588 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15589
15590 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15591 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15592 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15593
15594* ISTAB = 1 strong and weak decays
15595* = 2 strong decays only
15596* = 3 strong decays, weak decays for charmed particles and tau
15597* leptons only
15598 DATA ISTAB /2/
15599
15600 IREJ = 0
15601 NSEC = 0
15602* put initial resonance to stack
15603 NSTK = 1
15604 IDXSTK(NSTK) = IDXIN
15605 DO 5 I=1,4
15606 PI(NSTK,I) = PIN(I)
15607 5 CONTINUE
15608
15609* store initial configuration for energy-momentum cons. check
15610 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15611 & PI(NSTK,4),1,IDUM,IDUM)
15612
15613 100 CONTINUE
15614* get particle from stack
15615 IDXI = IDXSTK(NSTK)
15616* skip stable particles
15617 IF (ISTAB.EQ.1) THEN
15618 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15619 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15620 ELSEIF (ISTAB.EQ.2) THEN
15621 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15622 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15623 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15624 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15625 IF ( IDXI.EQ.109) GOTO 10
15626 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15627 ELSEIF (ISTAB.EQ.3) THEN
15628 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15629 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15630 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15631 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15632 ENDIF
15633
15634* calculate direction cosines and Lorentz-parameter of decaying part.
15635 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15636 PTOT = MAX(PTOT,TINY17)
15637 DO 1 I=1,3
15638 DCOS(I) = PI(NSTK,I)/PTOT
15639 1 CONTINUE
15640 GAM = PI(NSTK,4)/AAM(IDXI)
15641 BGAM = PTOT/AAM(IDXI)
15642
15643* get decay-channel
15644 KCHAN = K1(IDXI)-1
15645 2 CONTINUE
15646 KCHAN = KCHAN+1
15647 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15648
15649* identities of secondaries
15650 IDX(1) = NZK(KCHAN,1)
15651 IDX(2) = NZK(KCHAN,2)
15652 IF (IDX(2).LT.1) GOTO 9999
15653 IDX(3) = NZK(KCHAN,3)
15654
15655* handle decay in rest system of decaying particle
15656 IF (IDX(3).EQ.0) THEN
15657* two-particle decay
15658 NDEC = 2
15659 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15660 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15661 & AAM(IDX(1)),AAM(IDX(2)))
15662 ELSE
15663* three-particle decay
15664 NDEC = 3
15665 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15666 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15667 & CODF(3),COFF(3),SIFF(3),
15668 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15669 ENDIF
15670 NSTK = NSTK-1
15671
15672* transform decay products back
15673 DO 3 I=1,NDEC
15674 NSTK = NSTK+1
15675 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15676 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15677 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15678* add particle to stack
15679 IDXSTK(NSTK) = IDX(I)
15680 DO 4 J=1,3
15681 PI(NSTK,J) = DCOSF(J)*PFF(I)
15682 4 CONTINUE
15683 3 CONTINUE
15684 GOTO 100
15685
15686 10 CONTINUE
15687* stable particle, put to output-arrays
15688 NSEC = NSEC+1
15689 DO 6 I=1,4
15690 POUT(NSEC,I) = PI(NSTK,I)
15691 6 CONTINUE
15692 IDXOUT(NSEC) = IDXSTK(NSTK)
15693* store secondaries for energy-momentum conservation check
15694 IF (LEMCCK)
15695 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15696 & -POUT(NSEC,4),2,IDUM,IDUM)
15697 NSTK = NSTK-1
15698 IF (NSTK.GT.0) GOTO 100
15699
15700* check energy-momentum conservation
15701 IF (LEMCCK) THEN
15702 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15703 IF (IREJ1.NE.0) GOTO 9999
15704 ENDIF
15705
15706 RETURN
15707
15708 9999 CONTINUE
15709 IREJ = 1
15710 RETURN
15711 END
15712
15713*$ CREATE DT_DECAY1.FOR
15714*COPY DT_DECAY1
15715*
15716*===decay1=============================================================*
15717*
15718 SUBROUTINE DT_DECAY1
15719
15720************************************************************************
15721* Decay of resonances stored in DTEVT1. *
15722* This version dated 20.01.95 is written by S. Roesler *
15723************************************************************************
15724
15725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15726 SAVE
15727
15728 PARAMETER ( LINP = 10 ,
15729 & LOUT = 6 ,
15730 & LDAT = 9 )
15731
15732* event history
15733
15734 PARAMETER (NMXHKK=200000)
15735
15736 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15737 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15738 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15739
15740* extended event history
15741 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15742 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15743 & IHIST(2,NMXHKK)
15744
15745 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15746
15747 NEND = NHKK
15748C DO 1 I=NPOINT(5),NEND
15749 DO 1 I=NPOINT(4),NEND
15750 IF (ABS(ISTHKK(I)).EQ.1) THEN
15751 DO 2 K=1,4
15752 PIN(K) = PHKK(K,I)
15753 2 CONTINUE
15754 IDXIN = IDBAM(I)
15755 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15756 IF (NSEC.GT.1) THEN
15757 DO 3 N=1,NSEC
15758 IDHAD = IDT_IPDGHA(IDXOUT(N))
15759 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15760 & POUT(N,3),POUT(N,4),0,0,0)
15761 3 CONTINUE
15762 ENDIF
15763 ENDIF
15764 1 CONTINUE
15765
15766 RETURN
15767 END
15768
15769*$ CREATE DT_DECPI0.FOR
15770*COPY DT_DECPI0
15771*
15772*===decpi0=============================================================*
15773*
15774 SUBROUTINE DT_DECPI0
15775
15776************************************************************************
15777* Decay of pi0 handled with JETSET. *
15778* This version dated 18.02.96 is written by S. Roesler *
15779************************************************************************
15780
15781 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15782 SAVE
15783
15784 PARAMETER ( LINP = 10 ,
15785 & LOUT = 6 ,
15786 & LDAT = 9 )
15787
15788 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15789
15790* event history
15791
15792 PARAMETER (NMXHKK=200000)
15793
15794 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15795 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15796 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15797
15798* extended event history
15799 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15800 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15801 & IHIST(2,NMXHKK)
15802
15803 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15805 PARAMETER (MAXLND=4000)
15806 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15807
15808* flags for input different options
15809 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15810 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15811 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15812
15813 INTEGER PYCOMP,PYK
15814
15815 DIMENSION IHISMO(NMXHKK),P1(4)
15816
15817 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15818
15819 CALL DT_INITJS(2)
15820* allow pi0 decay
15821
15822 KC = PYCOMP(111)
15823
15824 MDCY(KC,1) = 1
15825
15826 NN = 0
15827 INI = 0
15828 DO 1 I=1,NHKK
15829 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15830 IF (INI.EQ.0) THEN
15831 INI = 1
15832 ELSE
15833 INI = 2
15834 ENDIF
15835 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15836 & PHKK(4,I),INI,IDUM,IDUM)
15837 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15838 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15839 COSTH = PHKK(3,I)/(PTOT+TINY10)
15840 IF (COSTH.GT.ONE) THEN
15841 THETA = ZERO
15842 ELSEIF (COSTH.LT.-ONE) THEN
15843 THETA = TWOPI/2.0D0
15844 ELSE
15845 THETA = ACOS(COSTH)
15846 ENDIF
15847 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15848 IF (PHKK(1,I).LT.0.0D0)
15849
15850 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15851
15852 ENER = PHKK(4,I)
15853 NN = NN+1
15854 KTEMP = MSTU(10)
15855 MSTU(10)= 1
15856 P(NN,5) = PHKK(5,I)
15857
15858 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15859
15860 MSTU(10) = KTEMP
15861 IHISMO(NN)= I
15862 ENDIF
15863 1 CONTINUE
15864 IF (NN.GT.0) THEN
15865
15866 CALL PYEXEC
15867
15868 NLINES = PYK(0,1)
15869
15870 DO 2 II=1,NLINES
15871
15872 IF (PYK(II,7).EQ.1) THEN
15873
15874 DO 3 KK=1,4
15875
15876 P1(KK) = PYP(II,KK)
15877
15878 3 CONTINUE
15879
15880 ID = PYK(II,8)
15881 MO = IHISMO(PYK(II,15))
15882
15883 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15884 IF (LEMCCK)
15885 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15886 & IDUM,IDUM)
15887*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15888 ISTHKK(MO) = -2
15889 ENDIF
15890 2 CONTINUE
15891 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15892 ENDIF
15893 MDCY(KC,1) = 0
15894
15895 RETURN
15896 END
15897
15898*$ CREATE DT_DTWOPD.FOR
15899*COPY DT_DTWOPD
15900*
15901*===dtwopd=============================================================*
15902*
15903 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15904 & COF2,SIF2,AM1,AM2)
15905
15906************************************************************************
15907* Two-particle decay. *
15908* UMO cm-energy of the decaying system (input) *
15909* AM1/AM2 masses of the decay products (input) *
15910* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15911* COD,COF,SIF direction cosines of the decay prod. (output) *
15912* Revised by S. Roesler, 20.11.95 *
15913************************************************************************
15914
15915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15916 SAVE
15917
15918 PARAMETER ( LINP = 10 ,
15919 & LOUT = 6 ,
15920 & LDAT = 9 )
15921
15922 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15923
15924 IF (UMO.LT.(AM1+AM2)) THEN
15925 WRITE(LOUT,1000) UMO,AM1,AM2
15926 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15927 & 3E12.3)
15928 STOP
15929 ENDIF
15930
15931 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15932 ECM2 = UMO-ECM1
15933 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15934 PCM2 = PCM1
15935 CALL DT_DSFECF(SIF1,COF1)
15936 COD1 = TWO*DT_RNDM(PCM2)-ONE
15937 COD2 = -COD1
15938 COF2 = -COF1
15939 SIF2 = -SIF1
15940
15941 RETURN
15942 END
15943
15944*$ CREATE DT_DTHREP.FOR
15945*COPY DT_DTHREP
15946*
15947*===dthrep=============================================================*
15948*
15949 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15950 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15951
15952************************************************************************
15953* Three-particle decay. *
15954* UMO cm-energy of the decaying system (input) *
15955* AM1/2/3 masses of the decay products (input) *
15956* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15957* COD,COF,SIF direction cosines of the decay prod. (output) *
15958* *
15959* Threpd89: slight revision by A. Ferrari *
15960* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15961* Revised by S. Roesler, 20.11.95 *
15962************************************************************************
15963
15964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15965 SAVE
15966
15967 PARAMETER ( LINP = 10 ,
15968 & LOUT = 6 ,
15969 & LDAT = 9 )
15970
15971 PARAMETER ( ANGLSQ = 2.5D-31 )
15972 PARAMETER ( AZRZRZ = 1.0D-30 )
15973 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15974 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15975 PARAMETER ( ONEONE = 1.D+00 )
15976 PARAMETER ( TWOTWO = 2.D+00 )
15977 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15978
15979 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15980
15981* flags for input different options
15982 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15983 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15984 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15985
15986 DIMENSION F(5),XX(5)
15987 DATA EPS /AZRZRZ/
15988
15989 UMOO=UMO+UMO
15990C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15991C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15992C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15993 UUMO=UMO
15994 AAM1=AM1
15995 AAM2=AM2
15996 AAM3=AM3
15997 GU=(AM2+AM3)**2
15998 GO=(UMO-AM1)**2
15999* UFAK=1.0000000000001D0
16000* IF (GU.GT.GO) UFAK=0.9999999999999D0
16001 IF (GU.GT.GO) THEN
16002 UFAK=ONEMNS
16003 ELSE
16004 UFAK=ONEPLS
16005 END IF
16006 OFAK=2.D0-UFAK
16007 GU=GU*UFAK
16008 GO=GO*OFAK
16009 DS2=(GO-GU)/99.D0
16010 AM11=AM1*AM1
16011 AM22=AM2*AM2
16012 AM33=AM3*AM3
16013 UMO2=UMO*UMO
16014 RHO2=0.D0
16015 S22=GU
16016 DO 124 I=1,100
16017 S21=S22
16018 S22=GU+(I-1.D0)*DS2
16019 RHO1=RHO2
16020 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16021 * (S22+EPS)
16022 IF(RHO2.LT.RHO1) GO TO 125
16023 124 CONTINUE
16024 125 S2SUP=(S22-S21)*.5D0+S21
16025 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16026 * (S2SUP+EPS)
16027 SUPRHO=SUPRHO*1.05D0
16028 XO=S21-DS2
16029 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16030 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16031 XX(1)=XO
16032 XX(3)=S22
16033 X1=(XO+S22)*0.5D0
16034 XX(2)=X1
16035 F(3)=RHO2
16036 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16037 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16038 DO 126 I=1,16
16039 X4=(XX(1)+XX(2))*0.5D0
16040 X5=(XX(2)+XX(3))*0.5D0
16041 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16042 * (X4+EPS)
16043 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16044 * (X5+EPS)
16045 XX(4)=X4
16046 XX(5)=X5
16047 DO 128 II=1,5
16048 IA=II
16049 DO 128 III=IA,5
16050 IF (F (II).GE.F (III)) GO TO 128
16051 FH=F(II)
16052 F(II)=F(III)
16053 F(III)=FH
16054 FH=XX(II)
16055 XX(II)=XX(III)
16056 XX(III)=FH
16057128 CONTINUE
16058 SUPRHO=F(1)
16059 S2SUP=XX(1)
16060 DO 129 II=1,3
16061 IA=II
16062 DO 129 III=IA,3
16063 IF (XX(II).GE.XX(III)) GO TO 129
16064 FH=F(II)
16065 F(II)=F(III)
16066 F(III)=FH
16067 FH=XX(II)
16068 XX(II)=XX(III)
16069 XX(III)=FH
16070129 CONTINUE
16071126 CONTINUE
16072 AM23=(AM2+AM3)**2
16073 ITH=0
16074 REDU=2.D0
16075 1 CONTINUE
16076 ITH=ITH+1
16077 IF (ITH.GT.200) REDU=-9.D0
16078 IF (ITH.GT.200) GO TO 400
16079 C=DT_RNDM(REDU)
16080* S2=AM23+C*((UMO-AM1)**2-AM23)
16081 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16082 Y=DT_RNDM(S2)
16083 Y=Y*SUPRHO
16084 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16085 IF(Y.GT.RHO) GO TO 1
16086C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16087 S1=DT_RNDM(S2)
16088 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16089 &RHO*.5D0
16090 S3=UMO2+AM11+AM22+AM33-S1-S2
16091 ECM1=(UMO2+AM11-S2)/UMOO
16092 ECM2=(UMO2+AM22-S3)/UMOO
16093 ECM3=(UMO2+AM33-S1)/UMOO
16094 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16095 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16096 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16097 CALL DT_DSFECF(SFE,CFE)
16098C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16099C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16100 PCM12 = PCM1 * PCM2
16101 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16102 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16103 GO TO 300
16104 200 CONTINUE
16105 UW=DT_RNDM(S1)
16106 COSTH=(UW-0.5D+00)*2.D+00
16107 300 CONTINUE
16108* IF(ABS(COSTH).GT.0.9999999999999999D0)
16109* &COSTH=SIGN(0.9999999999999999D0,COSTH)
16110 IF(ABS(COSTH).GT.ONEONE)
16111 &COSTH=SIGN(ONEONE,COSTH)
16112 IF (REDU.LT.1.D+00) RETURN
16113 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16114* IF(ABS(COSTH2).GT.0.9999999999999999D0)
16115* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16116 IF(ABS(COSTH2).GT.ONEONE)
16117 &COSTH2=SIGN(ONEONE,COSTH2)
16118 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16119 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16120 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16121 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16122C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16123C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16124C***THE DIRECTION OF PARTICLE 3
16125C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16126 CX11=-COSTH1
16127 CY11=SINTH1*CFE
16128 CZ11=SINTH1*SFE
16129 CX22=-COSTH2
16130 CY22=-SINTH2*CFE
16131 CZ22=-SINTH2*SFE
16132 CALL DT_DSFECF(SIF3,COF3)
16133 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16134 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16135 2 FORMAT(5F20.15)
16136 COD1=CX11*COD3+CZ11*SID3
16137 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16138 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16139 &CX11,CZ11
16140 SID1=SQRT(CHLP)
16141 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16142 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16143 COD2=CX22*COD3+CZ22*SID3
16144 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16145 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16146 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16147 400 CONTINUE
16148* === Energy conservation check: === *
16149 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16150* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16151* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16152* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16153 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16154 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16155 & + PCM3 * COF3 * SID3
16156 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16157 & + PCM3 * SIF3 * SID3
16158 EOCMPR = 1.D-12 * UMO
16159 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16160 & .GT. EOCMPR ) THEN
16161**sr 5.5.95 output-unit changed
16162 IF (IOULEV(1).GT.0) THEN
16163 WRITE(LOUT,*)
16164 & ' *** Threpd: energy/momentum conservation failure! ***',
16165 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16166 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16167 ENDIF
16168**
16169 END IF
16170 RETURN
16171 END
16172
16173*$ CREATE DT_DBKLAS.FOR
16174*COPY DT_DBKLAS
16175*
16176*===dbklas=============================================================*
16177*
16178 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16179
16180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16181 SAVE
16182
16183 PARAMETER ( LINP = 10 ,
16184 & LOUT = 6 ,
16185 & LDAT = 9 )
16186
16187* quark-content to particle index conversion (DTUNUC 1.x)
16188 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16189 & IA08(6,21),IA10(6,21)
16190
16191 IF (I) 20,20,10
16192* baryons
16193 10 CONTINUE
16194 CALL DT_INDEXD(J,K,IND)
16195 I8 = IB08(I,IND)
16196 I10 = IB10(I,IND)
16197 IF (I8.LE.0) I8 = I10
16198 RETURN
16199* antibaryons
16200 20 CONTINUE
16201 II = IABS(I)
16202 JJ = IABS(J)
16203 KK = IABS(K)
16204 CALL DT_INDEXD(JJ,KK,IND)
16205 I8 = IA08(II,IND)
16206 I10 = IA10(II,IND)
16207 IF (I8.LE.0) I8 = I10
16208
16209 RETURN
16210 END
16211
16212*$ CREATE DT_INDEXD.FOR
16213*COPY DT_INDEXD
16214*
16215*===indexd=============================================================*
16216*
16217 SUBROUTINE DT_INDEXD(KA,KB,IND)
16218
16219 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16220 SAVE
16221
16222 PARAMETER ( LINP = 10 ,
16223 & LOUT = 6 ,
16224 & LDAT = 9 )
16225
16226 KP = KA*KB
16227 KS = KA+KB
16228 IF (KP.EQ.1) IND=1
16229 IF (KP.EQ.2) IND=2
16230 IF (KP.EQ.3) IND=3
16231 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16232 IF (KP.EQ.5) IND=5
16233 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16234 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16235 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16236 IF (KP.EQ.8) IND=9
16237 IF (KP.EQ.10) IND=10
16238 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16239 IF (KP.EQ.9) IND=12
16240 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16241 IF (KP.EQ.15) IND=14
16242 IF (KP.EQ.18) IND=15
16243 IF (KP.EQ.16) IND=16
16244 IF (KP.EQ.20) IND=17
16245 IF (KP.EQ.24) IND=18
16246 IF (KP.EQ.25) IND=19
16247 IF (KP.EQ.30) IND=20
16248 IF (KP.EQ.36) IND=21
16249
16250 RETURN
16251 END
16252
16253*$ CREATE DT_DCHANT.FOR
16254*COPY DT_DCHANT
16255*
16256*===dchant=============================================================*
16257*
16258 SUBROUTINE DT_DCHANT
16259
16260 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16261 SAVE
16262
16263 PARAMETER ( LINP = 10 ,
16264 & LOUT = 6 ,
16265 & LDAT = 9 )
16266
16267 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16268
16269* HADRIN: decay channel information
16270 PARAMETER (IDMAX9=602)
16271 CHARACTER*8 ZKNAME
16272 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16273
16274* particle properties (BAMJET index convention)
16275 CHARACTER*8 ANAME
16276 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16277 & IICH(210),IIBAR(210),K1(210),K2(210)
16278
16279 DIMENSION HWT(IDMAX9)
16280
16281* change of weights wt from absolut values into the sum of wt of a dec.
16282 DO 10 J=1,IDMAX9
16283 HWT(J) = ZERO
16284 10 CONTINUE
16285C DO 999 KKK=1,210
16286C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16287C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16288C & K1(KKK),K2(KKK)
16289C 999 CONTINUE
16290C STOP
16291 DO 30 I=1,210
16292 IK1 = K1(I)
16293 IK2 = K2(I)
16294 HV = ZERO
16295 DO 20 J=IK1,IK2
16296 HV = HV+WT(J)
16297 HWT(J) = HV
16298**sr 13.1.95
16299 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16300 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16301 20 CONTINUE
16302 30 CONTINUE
16303 DO 40 J=1,IDMAX9
16304 WT(J) = HWT(J)
16305 40 CONTINUE
16306
16307 RETURN
16308 END
16309
16310*$ CREATE DT_DDATAR.FOR
16311*COPY DT_DDATAR
16312*
16313*===ddatar=============================================================*
16314*
16315 SUBROUTINE DT_DDATAR
16316
16317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16318 SAVE
16319
16320 PARAMETER ( LINP = 10 ,
16321 & LOUT = 6 ,
16322 & LDAT = 9 )
16323
16324 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16325
16326* quark-content to particle index conversion (DTUNUC 1.x)
16327 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16328 & IA08(6,21),IA10(6,21)
16329
16330 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16331
16332 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16333 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16334 & 128,129,14*0/
16335 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16336 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16337 & 121,122,14*0/
16338 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16339 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16340 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16341 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16342 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16343 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16344 & 0, 0, 0,140,137,138,146, 0, 0,142,
16345 & 139,147, 0, 0,145,148, 50*0/
16346 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16347 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16348 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16349 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16350 & 0, 0,104,105,107,164, 0, 0,106,108,
16351 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16352 & 0, 0, 0,161,162,164,167, 0, 0,163,
16353 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16354 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16355 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16356 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16357 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16358 & 0, 0, 99,100,102,150, 0, 0,101,103,
16359 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16360 & 0, 0, 0,152,149,150,158, 0, 0,154,
16361 & 151,159, 0, 0,157,160, 50*0/
16362 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16363 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16364 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16365 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16366 & 0, 0,110,111,113,174, 0, 0,112,114,
16367 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16368 & 0, 0, 0,171,172,174,177, 0, 0,173,
16369 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16370
16371 L=0
16372 DO 2 I=1,6
16373 DO 1 J=1,6
16374 L = L+1
16375 IMPS(I,J) = IP(L)
16376 IMVE(I,J) = IV(L)
16377 1 CONTINUE
16378 2 CONTINUE
16379 L=0
16380 DO 4 I=1,6
16381 DO 3 J=1,21
16382 L = L+1
16383 IB08(I,J) = IB(L)
16384 IB10(I,J) = IBB(L)
16385 IA08(I,J) = IA(L)
16386 IA10(I,J) = IAA(L)
16387 3 CONTINUE
16388 4 CONTINUE
16389C A1 = 0.88D0
16390C B1 = 3.0D0
16391C B2 = 3.0D0
16392C B3 = 8.0D0
16393C LT = 0
16394C LB = 0
16395C BET = 12.0D0
16396C AS = 0.25D0
16397C B8 = 0.33D0
16398C AME = 0.95D0
16399C DIQ = 0.375D0
16400C ISU = 4
16401
16402 RETURN
16403 END
16404
16405*$ CREATE DT_INITJS.FOR
16406*COPY DT_INITJS
16407*
16408*===initjs=============================================================*
16409*
16410 SUBROUTINE DT_INITJS(MODE)
16411
16412************************************************************************
16413* Initialize JETSET paramters. *
16414* MODE = 0 default settings *
16415* = 1 PHOJET settings *
16416* = 2 DTUNUC settings *
16417* This version dated 16.02.96 is written by S. Roesler *
16418* *
16419* Last change 27.12.2006 by S. Roesler. *
16420************************************************************************
16421
16422 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16423 SAVE
16424
16425 PARAMETER ( LINP = 10 ,
16426 & LOUT = 6 ,
16427 & LDAT = 9 )
16428
16429 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16430
16431 LOGICAL LFIRST,LFIRDT,LFIRPH
16432
16433* INCLUDE '(DIMPAR)'
16434* DIMPAR taken from FLUKA
16435 PARAMETER ( MXXRGN =20000 )
16436 PARAMETER ( MXXMDF = 710 )
16437 PARAMETER ( MXXMDE = 702 )
16438 PARAMETER ( MFSTCK =40000 )
16439 PARAMETER ( MESTCK = 100 )
16440 PARAMETER ( MOSTCK = 2000 )
16441 PARAMETER ( MXPRSN = 100 )
16442 PARAMETER ( MXPDPM = 800 )
16443 PARAMETER ( MXPSCS =30000 )
16444 PARAMETER ( MXGLWN = 300 )
16445 PARAMETER ( MXOUTU = 50 )
16446 PARAMETER ( NALLWP = 64 )
16447 PARAMETER ( NELEMX = 80 )
16448 PARAMETER ( MPDPDX = 18 )
16449 PARAMETER ( MXHTTR = 260 )
16450 PARAMETER ( MXSEAX = 20 )
16451 PARAMETER ( MXHTNC = MXSEAX + 1 )
16452 PARAMETER ( ICOMAX = 2400 )
16453 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16454 PARAMETER ( NSTBIS = 304 )
16455 PARAMETER ( NQSTIS = 46 )
16456 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16457 PARAMETER ( MXPABL = 120 )
16458 PARAMETER ( IDMAXP = 450 )
16459 PARAMETER ( IDMXDC = 2000 )
16460 PARAMETER ( MXMCIN = 410 )
16461 PARAMETER ( IHYPMX = 4 )
16462 PARAMETER ( MKBMX1 = 11 )
16463 PARAMETER ( MKBMX2 = 11 )
16464 PARAMETER ( MXIRRD = 2500 )
16465 PARAMETER ( MXTRDC = 1500 )
16466 PARAMETER ( NKTL = 17 )
16467 PARAMETER ( NBLNMX = 40000000 )
16468
16469* INCLUDE '(PART)'
16470* PART taken from FLUKA
16471 PARAMETER ( KPETA0 = 31 )
16472 PARAMETER ( KPRHOP = 32 )
16473 PARAMETER ( KPRHO0 = 33 )
16474 PARAMETER ( KPRHOM = 34 )
16475 PARAMETER ( KPOME0 = 35 )
16476 PARAMETER ( KPPHI0 = 96 )
16477 PARAMETER ( KPDEPP = 53 )
16478 PARAMETER ( KPDELP = 54 )
16479 PARAMETER ( KPDEL0 = 55 )
16480 PARAMETER ( KPDELM = 56 )
16481 PARAMETER ( KPN14P = 91 )
16482 PARAMETER ( KPN140 = 92 )
16483* Low mass diffraction partners:
16484 PARAMETER ( KDETA0 = 0 )
16485 PARAMETER ( KDRHOP = 0 )
16486 PARAMETER ( KDRHO0 = 210 )
16487 PARAMETER ( KDRHOM = 0 )
16488 PARAMETER ( KDOME0 = 210 )
16489 PARAMETER ( KDPHI0 = 210 )
16490 PARAMETER ( KDDEPP = 0 )
16491 PARAMETER ( KDDELP = 0 )
16492 PARAMETER ( KDDEL0 = 0 )
16493 PARAMETER ( KDDELM = 0 )
16494 PARAMETER ( KDN14P = 0 )
16495 PARAMETER ( KDN140 = 0 )
16496*
16497 CHARACTER*8 ANAME
16498 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16499 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16500 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16501 & ATXN14, ATMN14, RNRN14 (-10:10),
16502 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16503 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16504 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16505 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16506 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16507 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16508
16509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16511 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
16512
16513* flags for particle decays
16514 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16515 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16516 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16517
16518* flags for input different options
16519 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16520 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16521 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16522
16523 INTEGER PYCOMP
16524
16525 DIMENSION IDXSTA(40)
16526 DATA IDXSTA
16527* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16528 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16529* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16530 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16531* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16532 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16533* Ksic0 aKsic+aKsic0 sig0 asig0
16534 & 4132,-4232,-4132, 3212,-3212, 5*0/
16535
16536 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16537
16538 IF (LFIRST) THEN
16539* save default settings
16540 PDEF1 = PARJ(1)
16541 PDEF2 = PARJ(2)
16542 PDEF3 = PARJ(3)
16543 PDEF5 = PARJ(5)
16544 PDEF6 = PARJ(6)
16545 PDEF7 = PARJ(7)
16546 PDEF18 = PARJ(18)
16547 PDEF19 = PARJ(19)
16548 PDEF21 = PARJ(21)
16549 PDEF42 = PARJ(42)
16550 MDEF12 = MSTJ(12)
16551* LUJETS / PYJETS array-dimensions
16552
16553 MSTU(4) = 4000
16554
16555* increase maximum number of JETSET-error prints
16556 MSTU(22) = 50000
16557* prevent particles decaying
16558 DO 1 I=1,35
16559 IF (I.LT.34) THEN
16560
16561 KC = PYCOMP(IDXSTA(I))
16562
16563 IF (KC.GT.0) THEN
16564 IF (I.EQ.2) THEN
16565* pi0 decay
16566C MDCY(KC,1) = 1
16567 MDCY(KC,1) = 0
16568**cr mode
16569C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16570C & (I.EQ.8).OR.(I.EQ.10)) THEN
16571C ELSEIF (I.EQ.4) THEN
16572C MDCY(KC,1) = 1
16573**
16574 ELSE
16575 MDCY(KC,1) = 0
16576 ENDIF
16577 ENDIF
16578 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16579
16580 KC = PYCOMP(IDXSTA(I))
16581
16582 IF (KC.GT.0) THEN
16583 MDCY(KC,1) = 0
16584 ENDIF
16585 ENDIF
16586 1 CONTINUE
16587*
16588
16589* as Fluka event-generator: allow only paprop particles to be stable
16590* and let all other particles decay (i.e. those with strong decays)
16591 IF (ITRSPT.EQ.1) THEN
16592 DO 5 I=1,IDMAXP
16593 IF (KPTOIP(I).NE.0) THEN
16594 IDPDG = MPDGHA(I)
16595
16596 KC = PYCOMP(IDPDG)
16597
16598 IF (KC.GT.0) THEN
16599 IF (MDCY(KC,1).EQ.1) THEN
16600 WRITE(LOUT,*)
16601 & ' DT_INITJS: Decay flag for FLUKA-',
16602 & 'transport : particle should not ',
16603 & 'decay : ',IDPDG,' ',ANAME(I)
16604 MDCY(KC,1) = 0
16605 ENDIF
16606 ENDIF
16607 ENDIF
16608 5 CONTINUE
16609 DO 6 KC=1,500
16610 IDPDG = KCHG(KC,4)
16611 KP = MCIHAD(IDPDG)
16612 IF (KP.GT.0) THEN
16613 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16614 & (ANAME(KP).NE.'BLANK ').AND.
16615 & (ANAME(KP).NE.'RNDFLV ')) THEN
16616 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16617 & 'transport: particle should decay ',
16618 & ': ',IDPDG,' ',ANAME(KP)
16619 MDCY(KC,1) = 1
16620 ENDIF
16621 ENDIF
16622 6 CONTINUE
16623 ENDIF
16624
16625*
16626* popcorn:
16627 IF (PDB.LE.ZERO) THEN
16628* no popcorn-mechanism
16629 MSTJ(12) = 1
16630 ELSE
16631 MSTJ(12) = 3
16632 PARJ(5) = PDB
16633 ENDIF
16634* set JETSET-parameter requested by input cards
16635 IF (NMSTU.GT.0) THEN
16636 DO 2 I=1,NMSTU
16637 MSTU(IMSTU(I)) = MSTUX(I)
16638 2 CONTINUE
16639 ENDIF
16640 IF (NMSTJ.GT.0) THEN
16641 DO 3 I=1,NMSTJ
16642 MSTJ(IMSTJ(I)) = MSTJX(I)
16643 3 CONTINUE
16644 ENDIF
16645 IF (NPARU.GT.0) THEN
16646 DO 4 I=1,NPARU
16647 PARU(IPARU(I)) = PARUX(I)
16648 4 CONTINUE
16649 ENDIF
16650 LFIRST = .FALSE.
16651 ENDIF
16652*
16653* PARJ(1) suppression of qq-aqaq pair prod. compared to
16654* q-aq pair prod. (default: 0.1)
16655* PARJ(2) strangeness suppression (default: 0.3)
16656* PARJ(3) extra suppression of strange diquarks (default: 0.4)
16657* PARJ(6) extra suppression of sas-pair shared by B and
16658* aB in BMaB (default: 0.5)
16659* PARJ(7) extra suppression of strange meson M in BMaB
16660* configuration (default: 0.5)
16661* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16662* PARJ(21) width sigma in Gaussian p_x, p_y transverse
16663* momentum distrib. for prim. hadrons (default: 0.35)
16664* PARJ(42) b-parameter for symmetric Lund-fragmentation
16665* function (default: 0.9 GeV^-2)
16666*
16667* PHOJET settings
16668 IF (MODE.EQ.1) THEN
16669* JETSET default
16670C PARJ(1) = PDEF1
16671C PARJ(2) = PDEF2
16672C PARJ(3) = PDEF3
16673C PARJ(6) = PDEF6
16674C PARJ(7) = PDEF7
16675C PARJ(18) = PDEF18
16676C PARJ(21) = PDEF21
16677C PARJ(42) = PDEF42
16678**sr 18.11.98 parameter tuning
16679C PARJ(1) = 0.092D0
16680C PARJ(2) = 0.25D0
16681C PARJ(3) = 0.45D0
16682C PARJ(19) = 0.3D0
16683C PARJ(21) = 0.45D0
16684C PARJ(42) = 1.0D0
16685**sr 28.04.99 parameter tuning (May 99 minor modifications)
16686 PARJ(1) = 0.085D0
16687 PARJ(2) = 0.26D0
16688 PARJ(3) = 0.8D0
16689 PARJ(11) = 0.38D0
16690 PARJ(18) = 0.3D0
16691 PARJ(19) = 0.4D0
16692 PARJ(21) = 0.36D0
16693 PARJ(41) = 0.3D0
16694 PARJ(42) = 0.86D0
16695 IF (NPARJ.GT.0) THEN
16696 DO 10 I=1,NPARJ
16697 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16698 10 CONTINUE
16699 ENDIF
16700 IF (LFIRPH) THEN
16701 WRITE(LOUT,'(1X,A)')
16702 & 'DT_INITJS: JETSET-parameter for PHOJET'
16703 CALL DT_JSPARA(0)
16704 LFIRPH = .FALSE.
16705 ENDIF
16706* DTUNUC settings
16707 ELSEIF (MODE.EQ.2) THEN
16708 IF (IFRAG(2).EQ.1) THEN
16709**sr parameters before 9.3.96
16710C PARJ(2) = 0.27D0
16711C PARJ(3) = 0.6D0
16712C PARJ(6) = 0.75D0
16713C PARJ(7) = 0.75D0
16714C PARJ(21) = 0.55D0
16715C PARJ(42) = 1.3D0
16716**sr 18.11.98 parameter tuning
16717C PARJ(1) = 0.05D0
16718C PARJ(2) = 0.27D0
16719C PARJ(3) = 0.4D0
16720C PARJ(19) = 0.2D0
16721C PARJ(21) = 0.45D0
16722C PARJ(42) = 1.0D0
16723**sr 28.04.99 parameter tuning
16724 PARJ(1) = 0.11D0
16725 PARJ(2) = 0.36D0
16726 PARJ(3) = 0.8D0
16727 PARJ(19) = 0.2D0
16728 PARJ(21) = 0.3D0
16729 PARJ(41) = 0.3D0
16730 PARJ(42) = 0.58D0
16731 IF (NPARJ.GT.0) THEN
16732 DO 20 I=1,NPARJ
16733 IF (IPARJ(I).LT.0) THEN
16734 IDX = ABS(IPARJ(I))
16735 PARJ(IDX) = PARJX(I)
16736 ENDIF
16737 20 CONTINUE
16738 ENDIF
16739 IF (LFIRDT) THEN
16740 WRITE(LOUT,'(1X,A)')
16741 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16742 CALL DT_JSPARA(0)
16743 LFIRDT = .FALSE.
16744 ENDIF
16745 ELSEIF (IFRAG(2).EQ.2) THEN
16746 PARJ(1) = 0.11D0
16747 PARJ(2) = 0.27D0
16748 PARJ(3) = 0.3D0
16749 PARJ(6) = 0.35D0
16750 PARJ(7) = 0.45D0
16751 PARJ(18) = 0.66D0
16752C PARJ(21) = 0.55D0
16753C PARJ(42) = 1.0D0
16754 PARJ(21) = 0.60D0
16755 PARJ(42) = 1.3D0
16756 ELSE
16757 PARJ(1) = PDEF1
16758 PARJ(2) = PDEF2
16759 PARJ(3) = PDEF3
16760 PARJ(6) = PDEF6
16761 PARJ(7) = PDEF7
16762 PARJ(18) = PDEF18
16763 PARJ(21) = PDEF21
16764 PARJ(42) = PDEF42
16765 ENDIF
16766 ELSE
16767 PARJ(1) = PDEF1
16768 PARJ(2) = PDEF2
16769 PARJ(3) = PDEF3
16770 PARJ(5) = PDEF5
16771 PARJ(6) = PDEF6
16772 PARJ(7) = PDEF7
16773 PARJ(18) = PDEF18
16774 PARJ(19) = PDEF19
16775 PARJ(21) = PDEF21
16776 PARJ(42) = PDEF42
16777 MSTJ(12) = MDEF12
16778 ENDIF
16779
16780 RETURN
16781 END
16782
16783*$ CREATE DT_JSPARA.FOR
16784*COPY DT_JSPARA
16785*
16786*===jspara=============================================================*
16787*
16788 SUBROUTINE DT_JSPARA(MODE)
16789
16790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16791 SAVE
16792
16793 PARAMETER ( LINP = 10 ,
16794 & LOUT = 6 ,
16795 & LDAT = 9 )
16796
16797 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16798 & ONE=1.0D0,ZERO=0.0D0)
16799
16800 LOGICAL LFIRST
16801
16802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16803
16804 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16805
16806 DATA LFIRST /.TRUE./
16807
16808* save the default JETSET-parameter on the first call
16809 IF (LFIRST) THEN
16810 DO 1 I=1,200
16811 ISTU(I) = MSTU(I)
16812 QARU(I) = PARU(I)
16813 ISTJ(I) = MSTJ(I)
16814 QARJ(I) = PARJ(I)
16815 1 CONTINUE
16816 LFIRST = .FALSE.
16817 ENDIF
16818
16819 WRITE(LOUT,1000)
16820 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16821
16822* compare the default JETSET-parameter with the present values
16823 DO 2 I=1,200
16824 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16825 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16826C ISTU(I) = MSTU(I)
16827 ENDIF
16828 DIFF = ABS(PARU(I)-QARU(I))
16829 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16830 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16831C QARU(I) = PARU(I)
16832 ENDIF
16833 IF (MSTJ(I).NE.ISTJ(I)) THEN
16834 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16835C ISTJ(I) = MSTJ(I)
16836 ENDIF
16837 DIFF = ABS(PARJ(I)-QARJ(I))
16838 IF (DIFF.GE.1.0D-5) THEN
16839 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16840C QARJ(I) = PARJ(I)
16841 ENDIF
16842 2 CONTINUE
16843 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16844 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16845
16846 RETURN
16847 END
16848*$ CREATE DT_FOZOCA.FOR
16849*COPY DT_FOZOCA
16850*
16851*===fozoca=============================================================*
16852*
16853 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16854
16855************************************************************************
16856* This subroutine treats the complete FOrmation ZOne supressed intra- *
16857* nuclear CAscade. *
16858* LFZC = .true. cascade has been treated *
16859* = .false. cascade skipped *
16860* This is a completely revised version of the original FOZOKL. *
16861* This version dated 18.11.95 is written by S. Roesler *
16862************************************************************************
16863
16864 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16865 SAVE
16866
16867 PARAMETER ( LINP = 10 ,
16868 & LOUT = 6 ,
16869 & LDAT = 9 )
16870
16871 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16872 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16873
16874 LOGICAL LSTART,LCAS,LFZC
16875
16876* event history
16877
16878 PARAMETER (NMXHKK=200000)
16879
16880 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16881 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16882 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16883
16884* extended event history
16885 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16886 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16887 & IHIST(2,NMXHKK)
16888
16889* rejection counter
16890 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16891 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16892 & IREXCI(3),IRDIFF(2),IRINC
16893
16894* properties of interacting particles
16895 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16896
16897* Glauber formalism: collision properties
16898 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16899 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16900
16901* flags for input different options
16902 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16903 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16904 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16905
16906* final state after intranuclear cascade step
16907 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16908
16909* parameter for intranuclear cascade
16910 LOGICAL LPAULI
16911 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16912
16913 DIMENSION NCWOUN(2)
16914
16915 DATA LSTART /.TRUE./
16916
16917 LFZC = .TRUE.
16918 IREJ = 0
16919
16920* skip cascade if hadron-hadron interaction or if supressed by user
16921 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16922* skip cascade if not all possible chains systems are hadronized
16923 DO 1 I=1,8
16924 IF (.NOT.LHADRO(I)) GOTO 9999
16925 1 CONTINUE
16926
16927 IF (LSTART) THEN
16928 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16929 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16930 & 'maximum of',I4,' generations',/,10X,'formation time ',
16931 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16932 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16933 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16934 1001 FORMAT(10X,'p_t dependent formation zone',/)
16935 1002 FORMAT(10X,'constant formation zone',/)
16936 LSTART = .FALSE.
16937 ENDIF
16938
16939* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16940* which may interact with final state particles are stored in a seperate
16941* array - here all proj./target nucleon-indices (just for simplicity)
16942 NOINC = 0
16943 DO 9 I=1,NPOINT(1)-1
16944 NOINC = NOINC+1
16945 IDXINC(NOINC) = I
16946 9 CONTINUE
16947
16948* initialize Pauli-principle treatment (find wounded nucleons)
16949 NWOUND(1) = 0
16950 NWOUND(2) = 0
16951 NCWOUN(1) = 0
16952 NCWOUN(2) = 0
16953 DO 2 J=1,NPOINT(1)
16954 DO 3 I=1,2
16955 IF (ISTHKK(J).EQ.10+I) THEN
16956 NWOUND(I) = NWOUND(I)+1
16957 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16958 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16959 ENDIF
16960 3 CONTINUE
16961 2 CONTINUE
16962
16963* modify nuclear potential for wounded nucleons
16964 IPRCL = IP -NWOUND(1)
16965 IPZRCL = IPZ-NCWOUN(1)
16966 ITRCL = IT -NWOUND(2)
16967 ITZRCL = ITZ-NCWOUN(2)
16968 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16969
16970 NSTART = NPOINT(4)
16971 NEND = NHKK
16972
16973 7 CONTINUE
16974 DO 8 I=NSTART,NEND
16975
16976 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16977* select nucleus the cascade starts first (proj. - 1, target - -1)
16978 NCAS = 1
16979* projectile/target with probab. 1/2
16980 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16981 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16982* in the nucleus with highest mass
16983 ELSEIF (INCMOD.EQ.2) THEN
16984 IF (IP.GT.IT) THEN
16985 NCAS = -NCAS
16986 ELSEIF (IP.EQ.IT) THEN
16987 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16988 ENDIF
16989* the nucleus the cascade starts first is requested to be the one
16990* moving in the direction of the secondary
16991 ELSEIF (INCMOD.EQ.3) THEN
16992 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16993 ENDIF
16994* check that the selected "nucleus" is not a hadron
16995 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16996 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16997
16998* treat intranuclear cascade in the nucleus selected first
16999 LCAS = .FALSE.
17000 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17001 IF (IREJ1.NE.0) GOTO 9998
17002* treat intranuclear cascade in the other nucleus if this isn't a had.
17003 NCAS = -NCAS
17004 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17005 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17006 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17007 IF (IREJ1.NE.0) GOTO 9998
17008 ENDIF
17009
17010 ENDIF
17011
17012 8 CONTINUE
17013 NSTART = NEND+1
17014 NEND = NHKK
17015 IF (NSTART.LE.NEND) GOTO 7
17016
17017 RETURN
17018
17019 9998 CONTINUE
17020* reject this event
17021 IRINC = IRINC+1
17022 IREJ = 1
17023
17024 9999 CONTINUE
17025* intranucl. cascade not treated because of interaction properties or
17026* it is supressed by user or it was rejected or...
17027 LFZC = .FALSE.
17028* reset flag characterizing direction of motion in n-n-cms
17029**sr14-11-95
17030C DO 9990 I=NPOINT(5),NHKK
17031C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17032C9990 CONTINUE
17033
17034 RETURN
17035 END
17036
17037*$ CREATE DT_INUCAS.FOR
17038*COPY DT_INUCAS
17039*
17040*===inucas=============================================================*
17041*
17042 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17043
17044************************************************************************
17045* Formation zone supressed IntraNUclear CAScade for one final state *
17046* particle. *
17047* IT, IP mass numbers of target, projectile nuclei *
17048* IDXCAS index of final state particle in DTEVT1 *
17049* NCAS = 1 intranuclear cascade in projectile *
17050* = -1 intranuclear cascade in target *
17051* This version dated 18.11.95 is written by S. Roesler *
17052************************************************************************
17053
17054 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17055 SAVE
17056
17057 PARAMETER ( LINP = 10 ,
17058 & LOUT = 6 ,
17059 & LDAT = 9 )
17060
17061 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17062 & OHALF=0.5D0,ONE=1.0D0)
17063 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17064 PARAMETER (TWOPI=6.283185307179586454D+00)
17065 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17066
17067 LOGICAL LABSOR,LCAS
17068
17069* event history
17070
17071 PARAMETER (NMXHKK=200000)
17072
17073 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17074 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17075 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17076
17077* extended event history
17078 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17079 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17080 & IHIST(2,NMXHKK)
17081
17082* final state after inc step
17083 PARAMETER (MAXFSP=10)
17084 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17085
17086* flags for input different options
17087 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17088 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17089 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17090
17091* particle properties (BAMJET index convention)
17092 CHARACTER*8 ANAME
17093 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17094 & IICH(210),IIBAR(210),K1(210),K2(210)
17095
17096* Glauber formalism: collision properties
17097 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17098 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17099
17100* nuclear potential
17101 LOGICAL LFERMI
17102 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17103 & EBINDP(2),EBINDN(2),EPOT(2,210),
17104 & ETACOU(2),ICOUL,LFERMI
17105
17106* parameter for intranuclear cascade
17107 LOGICAL LPAULI
17108 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17109
17110* final state after intranuclear cascade step
17111 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17112
17113* nucleon-nucleon event-generator
17114 CHARACTER*8 CMODEL
17115 LOGICAL LPHOIN
17116 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17117
17118* statistics: residual nuclei
17119 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17120 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17121 & NINCST(2,4),NINCEV(2),
17122 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17123 & NRESPB(2),NRESCH(2),NRESEV(4),
17124 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17125 & NEVAFI(2,2)
17126
17127 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17128 & PCAS1(5),PNUC(5),BGTA(4),
17129 & BGCAS(2),GACAS(2),BECAS(2),
17130 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17131
17132 DATA PDIF /0.545D0/
17133
17134 IREJ = 0
17135
17136* update counter
17137 IF (NINCEV(1).NE.NEVHKK) THEN
17138 NINCEV(1) = NEVHKK
17139 NINCEV(2) = NINCEV(2)+1
17140 ENDIF
17141
17142* "BAMJET-index" of this hadron
17143 IDCAS = IDBAM(IDXCAS)
17144 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17145
17146* skip gammas, electrons, etc..
17147 IF (AAM(IDCAS).LT.TINY2) RETURN
17148
17149* Lorentz-trsf. into projectile rest system
17150 IF (IP.GT.1) THEN
17151 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17152 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17153 & PCAS(1,4),IDCAS,-2)
17154 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17155 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17156 IF (PCAS(1,5).GT.ZERO) THEN
17157 PCAS(1,5) = SQRT(PCAS(1,5))
17158 ELSE
17159 PCAS(1,5) = AAM(IDCAS)
17160 ENDIF
17161 DO 20 K=1,3
17162 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17163 20 CONTINUE
17164* Lorentz-parameters
17165* particle rest system --> projectile rest system
17166 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17167 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17168 BECAS(1) = BGCAS(1)/GACAS(1)
17169 ELSE
17170 DO 21 K=1,5
17171 PCAS(1,K) = ZERO
17172 IF (K.LE.3) COSCAS(1,K) = ZERO
17173 21 CONTINUE
17174 PTOCAS(1) = ZERO
17175 BGCAS(1) = ZERO
17176 GACAS(1) = ZERO
17177 BECAS(1) = ZERO
17178 ENDIF
17179* Lorentz-trsf. into target rest system
17180 IF (IT.GT.1) THEN
17181* LEPTO: final state particles are already in target rest frame
17182C IF (MCGENE.EQ.3) THEN
17183C PCAS(2,1) = PHKK(1,IDXCAS)
17184C PCAS(2,2) = PHKK(2,IDXCAS)
17185C PCAS(2,3) = PHKK(3,IDXCAS)
17186C PCAS(2,4) = PHKK(4,IDXCAS)
17187C ELSE
17188 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17189 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17190 & PCAS(2,4),IDCAS,-3)
17191C ENDIF
17192 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17193 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17194 IF (PCAS(2,5).GT.ZERO) THEN
17195 PCAS(2,5) = SQRT(PCAS(2,5))
17196 ELSE
17197 PCAS(2,5) = AAM(IDCAS)
17198 ENDIF
17199 DO 22 K=1,3
17200 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17201 22 CONTINUE
17202* Lorentz-parameters
17203* particle rest system --> target rest system
17204 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17205 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17206 BECAS(2) = BGCAS(2)/GACAS(2)
17207 ELSE
17208 DO 23 K=1,5
17209 PCAS(2,K) = ZERO
17210 IF (K.LE.3) COSCAS(2,K) = ZERO
17211 23 CONTINUE
17212 PTOCAS(2) = ZERO
17213 BGCAS(2) = ZERO
17214 GACAS(2) = ZERO
17215 BECAS(2) = ZERO
17216 ENDIF
17217
17218* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17219* potential (see CONUCL)
17220 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17221 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17222* impact parameter (the projectile moving along z)
17223 BIMPC(1) = ZERO
17224 BIMPC(2) = BIMPAC*FM2MM
17225
17226* get position of initial hadron in projectile/target rest-syst.
17227 DO 3 K=1,4
17228 VTXCAS(1,K) = WHKK(K,IDXCAS)
17229 VTXCAS(2,K) = VHKK(K,IDXCAS)
17230 3 CONTINUE
17231
17232 ICAS = 1
17233 I2 = 2
17234 IF (NCAS.EQ.-1) THEN
17235 ICAS = 2
17236 I2 = 1
17237 ENDIF
17238
17239 IF (PTOCAS(ICAS).LT.TINY10) THEN
17240 WRITE(LOUT,1000) PTOCAS
17241 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17242 & ' hadron ',/,20X,2E12.4)
17243 GOTO 9999
17244 ENDIF
17245
17246* reset spectator flags
17247 NSPE = 0
17248 IDXSPE(1) = 0
17249 IDXSPE(2) = 0
17250 IDSPE(1) = 0
17251 IDSPE(2) = 0
17252
17253* formation length (in fm)
17254C IF (LCAS) THEN
17255C DEL0 = ZERO
17256C ELSE
17257 DEL0 = TAUFOR*BGCAS(ICAS)
17258 IF (ITAUVE.EQ.1) THEN
17259 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17260 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17261 ENDIF
17262C ENDIF
17263* sample from exp(-del/del0)
17264 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17265* save formation time
17266 TAUSA1 = DEL1/BGCAS(ICAS)
17267 REL1 = TAUSA1*BGCAS(I2)
17268
17269 DEL = DEL1
17270 TAUSAM = DEL/BGCAS(ICAS)
17271 REL = TAUSAM*BGCAS(I2)
17272
17273* special treatment for negative particles unable to escape
17274* nuclear potential (implemented for ap, pi-, K- only)
17275 LABSOR = .FALSE.
17276 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17277* threshold energy = nuclear potential + Coulomb potential
17278* (nuclear potential for hadron-nucleus interactions only)
17279 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17280 IF (PCAS(ICAS,4).LT.ETHR) THEN
17281 DO 4 K=1,5
17282 PCAS1(K) = PCAS(ICAS,K)
17283 4 CONTINUE
17284* "absorb" negative particle in nucleus
17285 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17286 IF (IREJ1.NE.0) GOTO 9999
17287 IF (NSPE.GE.1) LABSOR = .TRUE.
17288 ENDIF
17289 ENDIF
17290
17291* if the initial particle has not been absorbed proceed with
17292* "normal" cascade
17293 IF (.NOT.LABSOR) THEN
17294
17295* calculate coordinates of hadron at the end of the formation zone
17296* transport-time and -step in the rest system where this step is
17297* treated
17298 DSTEP = DEL*FM2MM
17299 DTIME = DSTEP/BECAS(ICAS)
17300 RSTEP = REL*FM2MM
17301 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17302 RTIME = RSTEP/BECAS(I2)
17303 ELSE
17304 RTIME = ZERO
17305 ENDIF
17306* save step whithout considering the overlapping region
17307 DSTEP1 = DEL1*FM2MM
17308 DTIME1 = DSTEP1/BECAS(ICAS)
17309 RSTEP1 = REL1*FM2MM
17310 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17311 RTIME1 = RSTEP1/BECAS(I2)
17312 ELSE
17313 RTIME1 = ZERO
17314 ENDIF
17315* transport to the end of the formation zone in this system
17316 DO 5 K=1,3
17317 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17318 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17319 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17320 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17321 5 CONTINUE
17322 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17323 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17324 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17325 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17326
17327 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17328 XCAS = VTXCAS(ICAS,1)
17329 YCAS = VTXCAS(ICAS,2)
17330 XNCLTA = BIMPAC*FM2MM
17331 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17332 RNCLTA = (RTARG+RNUCLE)*FM2MM
17333C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17334C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17335C RNCLPR = (RPROJ)*FM2MM
17336C RNCLTA = (RTARG)*FM2MM
17337 RCASPR = SQRT( XCAS**2 +YCAS**2)
17338 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17339 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17340 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17341 ENDIF
17342 ENDIF
17343
17344* check if particle is already outside of the corresp. nucleus
17345 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17346 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17347 IF (RDIST.GE.RNUC(ICAS)) THEN
17348* here: IDCH is the generation of the final state part. starting
17349* with zero for hadronization products
17350* flag particles of generation 0 being outside the nuclei after
17351* formation time (to be used for excitation energy calculation)
17352 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17353 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17354 GOTO 9997
17355 ENDIF
17356 DIST = DLARGE
17357 DISTP = DLARGE
17358 DISTN = DLARGE
17359 IDXP = 0
17360 IDXN = 0
17361
17362* already here: skip particles being outside HADRIN "energy-window"
17363* to avoid wasting of time
17364 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17365 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17366 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17367C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17368C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17369C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17370C & E12.4,', above or below HADRIN-thresholds',I6)
17371 NSPE = 0
17372 GOTO 9997
17373 ENDIF
17374
17375 DO 7 IDXHKK=1,NOINC
17376 I = IDXINC(IDXHKK)
17377* scan DTEVT1 for unwounded or excited nucleons
17378 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17379 DO 8 K=1,3
17380 IF (ICAS.EQ.1) THEN
17381 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17382 ELSEIF (ICAS.EQ.2) THEN
17383 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17384 ENDIF
17385 8 CONTINUE
17386 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17387 & VTXDST(2)*COSCAS(ICAS,2)+
17388 & VTXDST(3)*COSCAS(ICAS,3)
17389* check if nucleon is situated in forward direction
17390 IF (POSNUC.GT.ZERO) THEN
17391* distance between hadron and this nucleon
17392 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17393 & VTXDST(3)**2)
17394* impact parameter
17395 BIMNU2 = DISTNU**2-POSNUC**2
17396 IF (BIMNU2.LT.ZERO) THEN
17397 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17398 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17399 & ' parameter ',/,20X,3E12.4)
17400 GOTO 7
17401 ENDIF
17402 BIMNU = SQRT(BIMNU2)
17403* maximum impact parameter to have interaction
17404 IDNUC = IDT_ICIHAD(IDHKK(I))
17405 IDNUC1 = IDT_MCHAD(IDNUC)
17406 IDCAS1 = IDT_MCHAD(IDCAS)
17407 DO 19 K=1,5
17408 PCAS1(K) = PCAS(ICAS,K)
17409 PNUC(K) = PHKK(K,I)
17410 19 CONTINUE
17411* Lorentz-parameter for trafo into rest-system of target
17412 DO 18 K=1,4
17413 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17414 18 CONTINUE
17415* transformation of projectile into rest-system of target
17416 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17417 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17418 & PPTOT,PX,PY,PZ,PE)
17419**
17420C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17421C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17422 DUMZER = ZERO
17423 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17424 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17425 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17426 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17427 SIGIN = SIGTOT-SIGEL-SIGAB
17428C SIGTOT = SIGIN+SIGEL+SIGAB
17429**
17430 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17431* check if interaction is possible
17432 IF (BIMNU.LE.BIMMAX) THEN
17433* get nucleon with smallest distance and kind of interaction
17434* (elastic/inelastic)
17435 IF (DISTNU.LT.DIST) THEN
17436 DIST = DISTNU
17437 BINT = BIMNU
17438 IF (IDNUC.NE.IDSPE(1)) THEN
17439 IDSPE(2) = IDSPE(1)
17440 IDXSPE(2) = IDXSPE(1)
17441 IDSPE(1) = IDNUC
17442 ENDIF
17443 IDXSPE(1) = I
17444 NSPE = 1
17445**sr
17446 SELA = SIGEL
17447 SABS = SIGAB
17448 STOT = SIGTOT
17449C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17450C SELA = SIGEL
17451C STOT = SIGIN+SIGEL
17452C ELSE
17453C SELA = SIGEL+0.75D0*SIGIN
17454C STOT = 0.25D0*SIGIN+SELA
17455C ENDIF
17456**
17457 ENDIF
17458 ENDIf
17459 ENDIF
17460 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17461 & VTXDST(3)**2)
17462 IDNUC = IDT_ICIHAD(IDHKK(I))
17463 IF (IDNUC.EQ.1) THEN
17464 IF (DISTNU.LT.DISTP) THEN
17465 DISTP = DISTNU
17466 IDXP = I
17467 POSP = POSNUC
17468 ENDIF
17469 ELSEIF (IDNUC.EQ.8) THEN
17470 IF (DISTNU.LT.DISTN) THEN
17471 DISTN = DISTNU
17472 IDXN = I
17473 POSN = POSNUC
17474 ENDIF
17475 ENDIF
17476 ENDIF
17477 7 CONTINUE
17478
17479* there is no nucleon for a secondary interaction
17480 IF (NSPE.EQ.0) GOTO 9997
17481
17482C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17483C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17484 IF (IDXSPE(2).EQ.0) THEN
17485 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17486C DO 80 K=1,3
17487C IF (ICAS.EQ.1) THEN
17488C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17489C ELSEIF (ICAS.EQ.2) THEN
17490C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17491C ENDIF
17492C 80 CONTINUE
17493C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17494C & VTXDST(3)**2)
17495C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17496 IDXSPE(2) = IDXN
17497 IDSPE(2) = 8
17498C ELSE
17499C STOT = STOT-SABS
17500C SABS = ZERO
17501C ENDIF
17502 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17503C DO 81 K=1,3
17504C IF (ICAS.EQ.1) THEN
17505C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17506C ELSEIF (ICAS.EQ.2) THEN
17507C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17508C ENDIF
17509C 81 CONTINUE
17510C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17511C & VTXDST(3)**2)
17512C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17513 IDXSPE(2) = IDXP
17514 IDSPE(2) = 1
17515C ELSE
17516C STOT = STOT-SABS
17517C SABS = ZERO
17518C ENDIF
17519 ELSE
17520 STOT = STOT-SABS
17521 SABS = ZERO
17522 ENDIF
17523 ENDIF
17524 RR = DT_RNDM(DIST)
17525 IF (RR.LT.SELA/STOT) THEN
17526 IPROC = 2
17527 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17528 IPROC = 3
17529 ELSE
17530 IPROC = 1
17531 ENDIF
17532
17533 DO 9 K=1,5
17534 PCAS1(K) = PCAS(ICAS,K)
17535 PNUC(K) = PHKK(K,IDXSPE(1))
17536 9 CONTINUE
17537 IF (IPROC.EQ.3) THEN
17538* 2-nucleon absorption of pion
17539 NSPE = 2
17540 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17541 IF (IREJ1.NE.0) GOTO 9999
17542 IF (NSPE.GE.1) LABSOR = .TRUE.
17543 ELSE
17544* sample secondary interaction
17545 IDNUC = IDBAM(IDXSPE(1))
17546 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17547 IF (IREJ1.EQ.1) GOTO 9999
17548 IF (IREJ1.GT.1) GOTO 9998
17549 ENDIF
17550 ENDIF
17551
17552* update arrays to include Pauli-principle
17553 DO 10 I=1,NSPE
17554 IF (NWOUND(ICAS).LE.299) THEN
17555 NWOUND(ICAS) = NWOUND(ICAS)+1
17556 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17557 ENDIF
17558 10 CONTINUE
17559
17560* dump initial hadron for energy-momentum conservation check
17561 IF (LEMCCK)
17562 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17563 & PCAS(ICAS,4),1,IDUM,IDUM)
17564
17565* dump final state particles into DTEVT1
17566
17567* check if Pauli-principle is fulfilled
17568 NPAULI = 0
17569 NWTMP(1) = NWOUND(1)
17570 NWTMP(2) = NWOUND(2)
17571 DO 111 I=1,NFSP
17572 NPAULI = 0
17573 J1 = 2
17574 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17575 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17576 DO 117 J=1,J1
17577 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17578 IF (J.EQ.1) THEN
17579 IDX = ICAS
17580 PE = PFSP(4,I)
17581 ELSE
17582 IDX = I2
17583 MODE = 1
17584 IF (IDX.EQ.1) MODE = -1
17585 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17586 ENDIF
17587* first check if cascade step is forbidden due to Pauli-principle
17588* (in case of absorpion this step is forced)
17589 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17590 & (IDFSP(I).EQ.8))) THEN
17591* get nuclear potential barrier
17592 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17593 IF (IDFSP(I).EQ.1) THEN
17594 POTLOW = POT-EBINDP(IDX)
17595 ELSE
17596 POTLOW = POT-EBINDN(IDX)
17597 ENDIF
17598* final state particle not able to escape nucleus
17599 IF (PE.LE.POTLOW) THEN
17600* check if there are wounded nucleons
17601 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17602 & EWOUND(IDX,NWOUND(IDX)))) THEN
17603 NPAULI = NPAULI+1
17604 NWOUND(IDX) = NWOUND(IDX)-1
17605 ELSE
17606* interaction prohibited by Pauli-principle
17607 NWOUND(1) = NWTMP(1)
17608 NWOUND(2) = NWTMP(2)
17609 GOTO 9997
17610 ENDIF
17611 ENDIF
17612 ENDIF
17613 117 CONTINUE
17614 111 CONTINUE
17615
17616 NPAULI = 0
17617 NWOUND(1) = NWTMP(1)
17618 NWOUND(2) = NWTMP(2)
17619
17620 DO 11 I=1,NFSP
17621
17622 IST = ISTHKK(IDXCAS)
17623
17624 NPAULI = 0
17625 J1 = 2
17626 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17627 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17628 DO 17 J=1,J1
17629 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17630 IDX = ICAS
17631 PE = PFSP(4,I)
17632 IF (J.EQ.2) THEN
17633 IDX = I2
17634 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17635 ENDIF
17636* first check if cascade step is forbidden due to Pauli-principle
17637* (in case of absorpion this step is forced)
17638 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17639 & (IDFSP(I).EQ.8))) THEN
17640* get nuclear potential barrier
17641 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17642 IF (IDFSP(I).EQ.1) THEN
17643 POTLOW = POT-EBINDP(IDX)
17644 ELSE
17645 POTLOW = POT-EBINDN(IDX)
17646 ENDIF
17647* final state particle not able to escape nucleus
17648 IF (PE.LE.POTLOW) THEN
17649* check if there are wounded nucleons
17650 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17651 & EWOUND(IDX,NWOUND(IDX)))) THEN
17652 NWOUND(IDX) = NWOUND(IDX)-1
17653 NPAULI = NPAULI+1
17654 IST = 14+IDX
17655 ELSE
17656* interaction prohibited by Pauli-principle
17657 NWOUND(1) = NWTMP(1)
17658 NWOUND(2) = NWTMP(2)
17659 GOTO 9997
17660 ENDIF
17661**sr
17662c ELSEIF (PE.LE.POT) THEN
17663cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17664cC NWOUND(IDX) = NWOUND(IDX)-1
17665c**
17666c NPAULI = NPAULI+1
17667c IST = 14+IDX
17668 ENDIF
17669 ENDIF
17670 17 CONTINUE
17671
17672* dump final state particles for energy-momentum conservation check
17673 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17674 & -PFSP(4,I),2,IDUM,IDUM)
17675
17676 PX = PFSP(1,I)
17677 PY = PFSP(2,I)
17678 PZ = PFSP(3,I)
17679 PE = PFSP(4,I)
17680 IF (ABS(IST).EQ.1) THEN
17681* transform particles back into n-n cms
17682* LEPTO: leave final state particles in target rest frame
17683C IF (MCGENE.EQ.3) THEN
17684C PFSP(1,I) = PX
17685C PFSP(2,I) = PY
17686C PFSP(3,I) = PZ
17687C PFSP(4,I) = PE
17688C ELSE
17689 IMODE = ICAS+1
17690 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17691 & PFSP(4,I),IDFSP(I),IMODE)
17692C ENDIF
17693 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17694* target cascade but fsp got stuck in proj. --> transform it into
17695* proj. rest system
17696 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17697 & PFSP(4,I),IDFSP(I),-1)
17698 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17699* proj. cascade but fsp got stuck in target --> transform it into
17700* target rest system
17701 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702 & PFSP(4,I),IDFSP(I),1)
17703 ENDIF
17704
17705* dump final state particles into DTEVT1
17706 IGEN = IDCH(IDXCAS)+1
17707 ID = IDT_IPDGHA(IDFSP(I))
17708 IXR = 0
17709 IF (LABSOR) IXR = 99
17710 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17711 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17712
17713* update the counter for particles which got stuck inside the nucleus
17714 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17715 NOINC = NOINC+1
17716 IDXINC(NOINC) = NHKK
17717 ENDIF
17718 IF (LABSOR) THEN
17719* in case of absorption the spatial treatment is an approximate
17720* solution anyway (the positions of the nucleons which "absorb" the
17721* cascade particle are not taken into consideration) therefore the
17722* particles are produced at the position of the cascade particle
17723 DO 12 K=1,4
17724 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17725 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17726 12 CONTINUE
17727 ELSE
17728* DDISTL - distance the cascade particle moves to the intera. point
17729* (the position where impact-parameter = distance to the interacting
17730* nucleon), DIST - distance to the interacting nucleon at the time of
17731* formation of the cascade particle, BINT - impact-parameter of this
17732* cascade-interaction
17733 DDISTL = SQRT(DIST**2-BINT**2)
17734 DTIME = DDISTL/BECAS(ICAS)
17735 DTIMEL = DDISTL/BGCAS(ICAS)
17736 RDISTL = DTIMEL*BGCAS(I2)
17737 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17738 RTIME = RDISTL/BECAS(I2)
17739 ELSE
17740 RTIME = ZERO
17741 ENDIF
17742* RDISTL, RTIME are this step and time in the rest system of the other
17743* nucleus
17744 DO 13 K=1,3
17745 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17746 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17747 13 CONTINUE
17748 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17749 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17750* position of particle production is half the impact-parameter to
17751* the interacting nucleon
17752 DO 14 K=1,3
17753 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17754 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17755 14 CONTINUE
17756* time of production of secondary = time of interaction
17757 WHKK(4,NHKK) = VTXCA1(1,4)
17758 VHKK(4,NHKK) = VTXCA1(2,4)
17759 ENDIF
17760
17761 11 CONTINUE
17762
17763* modify status and position of cascade particle (the latter for
17764* statistics reasons only)
17765 ISTHKK(IDXCAS) = 2
17766 IF (LABSOR) ISTHKK(IDXCAS) = 19
17767 IF (.NOT.LABSOR) THEN
17768 DO 15 K=1,4
17769 WHKK(K,IDXCAS) = VTXCA1(1,K)
17770 VHKK(K,IDXCAS) = VTXCA1(2,K)
17771 15 CONTINUE
17772 ENDIF
17773
17774 DO 16 I=1,NSPE
17775 IS = IDXSPE(I)
17776* dump interacting nucleons for energy-momentum conservation check
17777 IF (LEMCCK)
17778 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17779 & 2,IDUM,IDUM)
17780* modify entry for interacting nucleons
17781 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17782 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17783 IF (I.GE.2) THEN
17784 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17785 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17786 ENDIF
17787 16 CONTINUE
17788
17789* check energy-momentum conservation
17790 IF (LEMCCK) THEN
17791 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17792 IF (IREJ1.NE.0) GOTO 9999
17793 ENDIF
17794
17795* update counter
17796 IF (LABSOR) THEN
17797 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17798 ELSE
17799 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17800 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17801 ENDIF
17802
17803 RETURN
17804
17805 9997 CONTINUE
17806 9998 CONTINUE
17807* transport-step but no cascade step due to configuration (i.e. there
17808* is no nucleon for interaction etc.)
17809 IF (LCAS) THEN
17810 DO 100 K=1,4
17811C WHKK(K,IDXCAS) = VTXCAS(1,K)
17812C VHKK(K,IDXCAS) = VTXCAS(2,K)
17813 WHKK(K,IDXCAS) = VTXCA1(1,K)
17814 VHKK(K,IDXCAS) = VTXCA1(2,K)
17815 100 CONTINUE
17816 ENDIF
17817
17818C9998 CONTINUE
17819* no cascade-step because of configuration
17820* (i.e. hadron outside nucleus etc.)
17821 LCAS = .TRUE.
17822 RETURN
17823
17824 9999 CONTINUE
17825* rejection
17826 IREJ = 1
17827 RETURN
17828 END
17829
17830*$ CREATE DT_ABSORP.FOR
17831*COPY DT_ABSORP
17832*
17833*===absorp=============================================================*
17834*
17835 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17836
17837************************************************************************
17838* Two-nucleon absorption of antiprotons, pi-, and K-. *
17839* Antiproton absorption is handled by HADRIN. *
17840* The following channels for meson-absorption are considered: *
17841* pi- + p + p ---> n + p *
17842* pi- + p + n ---> n + n *
17843* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17844* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17845* K- + p + p ---> sigma- + n *
17846* IDCAS, PCAS identity, momentum of particle to be absorbed *
17847* NCAS = 1 intranuclear cascade in projectile *
17848* = -1 intranuclear cascade in target *
17849* NSPE number of spectator nucleons involved *
17850* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17851* Revised version of the original STOPIK written by HJM and J. Ranft. *
17852* This version dated 24.02.95 is written by S. Roesler *
17853************************************************************************
17854
17855 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17856 SAVE
17857
17858 PARAMETER ( LINP = 10 ,
17859 & LOUT = 6 ,
17860 & LDAT = 9 )
17861
17862 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17863 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17864
17865* event history
17866
17867 PARAMETER (NMXHKK=200000)
17868
17869 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17870 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17871 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17872
17873* extended event history
17874 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17875 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17876 & IHIST(2,NMXHKK)
17877
17878* flags for input different options
17879 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17880 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17881 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17882
17883* final state after inc step
17884 PARAMETER (MAXFSP=10)
17885 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17886
17887* particle properties (BAMJET index convention)
17888 CHARACTER*8 ANAME
17889 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17890 & IICH(210),IIBAR(210),K1(210),K2(210)
17891
17892 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17893 & PTOT3P(4),BG3P(4),
17894 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17895
17896 IREJ = 0
17897 NFSP = 0
17898
17899* skip particles others than ap, pi-, K- for mode=0
17900 IF ((MODE.EQ.0).AND.
17901 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17902* skip particles others than pions for mode=1
17903* (2-nucleon absorption in intranuclear cascade)
17904 IF ((MODE.EQ.1).AND.
17905 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17906
17907 NUCAS = NCAS
17908 IF (NUCAS.EQ.-1) NUCAS = 2
17909
17910 IF (MODE.EQ.0) THEN
17911* scan spectator nucleons for nucleons being able to "absorb"
17912 NSPE = 0
17913 IDXSPE(1) = 0
17914 IDXSPE(2) = 0
17915 DO 1 I=1,NHKK
17916 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17917 NSPE = NSPE+1
17918 IDXSPE(NSPE) = I
17919 IDSPE(NSPE) = IDBAM(I)
17920 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17921 IF (NSPE.EQ.2) THEN
17922 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17923 & (IDSPE(2).EQ.8)) THEN
17924* there is no pi-+n+n channel
17925 NSPE = 1
17926 GOTO 1
17927 ELSE
17928 GOTO 2
17929 ENDIF
17930 ENDIF
17931 ENDIF
17932 1 CONTINUE
17933
17934 2 CONTINUE
17935 ENDIF
17936* transform excited projectile nucleons (status=15) into proj. rest s.
17937 DO 3 I=1,NSPE
17938 DO 4 K=1,5
17939 PSPE(I,K) = PHKK(K,IDXSPE(I))
17940 4 CONTINUE
17941 3 CONTINUE
17942
17943* antiproton absorption
17944 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17945 DO 5 K=1,5
17946 PSPE1(K) = PSPE(1,K)
17947 5 CONTINUE
17948 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17949 IF (IREJ1.NE.0) GOTO 9999
17950
17951* meson absorption
17952 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17953 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17954 IF (IDCAS.EQ.14) THEN
17955* pi- absorption
17956 IDFSP(1) = 8
17957 IDFSP(2) = 8
17958 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17959 ELSEIF (IDCAS.EQ.13) THEN
17960* pi+ absorption
17961 IDFSP(1) = 1
17962 IDFSP(2) = 1
17963 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17964 ELSEIF (IDCAS.EQ.23) THEN
17965* pi0 absorption
17966 IDFSP(1) = IDSPE(1)
17967 IDFSP(2) = IDSPE(2)
17968 ELSEIF (IDCAS.EQ.16) THEN
17969* K- absorption
17970 R = DT_RNDM(PCAS)
17971 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17972 IF (R.LT.ONETHI) THEN
17973 IDFSP(1) = 21
17974 IDFSP(2) = 8
17975 ELSEIF (R.LT.TWOTHI) THEN
17976 IDFSP(1) = 17
17977 IDFSP(2) = 1
17978 ELSE
17979 IDFSP(1) = 22
17980 IDFSP(2) = 1
17981 ENDIF
17982 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17983 IDFSP(1) = 20
17984 IDFSP(2) = 8
17985 ELSE
17986 IF (R.LT.ONETHI) THEN
17987 IDFSP(1) = 20
17988 IDFSP(2) = 1
17989 ELSEIF (R.LT.TWOTHI) THEN
17990 IDFSP(1) = 17
17991 IDFSP(2) = 8
17992 ELSE
17993 IDFSP(1) = 22
17994 IDFSP(2) = 8
17995 ENDIF
17996 ENDIF
17997 ENDIF
17998* dump initial particles for energy-momentum cons. check
17999 IF (LEMCCK) THEN
18000 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18001 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18002 & IDUM,IDUM)
18003 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18004 & IDUM,IDUM)
18005 ENDIF
18006* get Lorentz-parameter of 3 particle initial state
18007 DO 6 K=1,4
18008 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18009 6 CONTINUE
18010 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18011 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18012 DO 7 K=1,4
18013 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18014 7 CONTINUE
18015* 2-particle decay of the 3-particle compound system
18016 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18017 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18018 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18019 DO 8 I=1,2
18020 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18021 PX = PCMF(I)*COFF(I)*SDF
18022 PY = PCMF(I)*SIFF(I)*SDF
18023 PZ = PCMF(I)*CODF(I)
18024 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18025 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18026 & PFSP(4,I))
18027 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18028* check consistency of kinematics
18029 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18030 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18031 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18032 & ' tree-particle kinematics',/,20X,'id: ',I3,
18033 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18034 ENDIF
18035* dump final state particles for energy-momentum cons. check
18036 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18037 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18038 8 CONTINUE
18039 NFSP = 2
18040 IF (LEMCCK) THEN
18041 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18042 IF (IREJ1.NE.0) THEN
18043 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18044 & AM3P
18045 GOTO 9999
18046 ENDIF
18047 ENDIF
18048 ELSE
18049 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18050 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18051 & ' impossible',/,20X,'too few spectators (',I2,')')
18052 NSPE = 0
18053 ENDIF
18054
18055 RETURN
18056
18057 9999 CONTINUE
18058 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18059 IREJ = 1
18060 RETURN
18061 END
18062
18063*$ CREATE DT_HADRIN.FOR
18064*COPY DT_HADRIN
18065*
18066*===hadrin=============================================================*
18067*
18068 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18069
18070************************************************************************
18071* Interface to the HADRIN-routines for inelastic and elastic *
18072* scattering. *
18073* IDPR,PPR(5) identity, momentum of projectile *
18074* IDTA,PTA(5) identity, momentum of target *
18075* MODE = 1 inelastic interaction *
18076* = 2 elastic interaction *
18077* Revised version of the original FHAD. *
18078* This version dated 27.10.95 is written by S. Roesler *
18079************************************************************************
18080
18081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18082 SAVE
18083
18084 PARAMETER ( LINP = 10 ,
18085 & LOUT = 6 ,
18086 & LDAT = 9 )
18087
18088 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18089 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18090
18091 LOGICAL LCORR,LMSSG
18092
18093* flags for input different options
18094 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18095 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18096 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18097
18098* final state after inc step
18099 PARAMETER (MAXFSP=10)
18100 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18101
18102* particle properties (BAMJET index convention)
18103 CHARACTER*8 ANAME
18104 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18105 & IICH(210),IIBAR(210),K1(210),K2(210)
18106* output-common for DHADRI/ELHAIN
18107
18108* final state from HADRIN interaction
18109 PARAMETER (MAXFIN=10)
18110 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18111 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18112
18113 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18114 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18115
18116 DATA LMSSG /.TRUE./
18117
18118 IREJ = 0
18119 NFSP = 0
18120 KCORR = 0
18121 IMCORR(1) = 0
18122 IMCORR(2) = 0
18123 LCORR = .FALSE.
18124
18125* dump initial particles for energy-momentum cons. check
18126 IF (LEMCCK) THEN
18127 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18128 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18129 ENDIF
18130
18131 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18132 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18133 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18134 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18135 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18136 IF (LMSSG.AND.(IOULEV(3).GT.0))
18137 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18138 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18139 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18140 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18141 LMSSG = .FALSE.
18142 LCORR = .TRUE.
18143 ENDIF
18144
18145* convert initial state particles into particles which can be
18146* handled by HADRIN
18147 IDHPR = IDPR
18148 IDHTA = IDTA
18149 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18150 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18151 DO 1 K=1,4
18152 P1IN(K) = PPR(K)
18153 P2IN(K) = PTA(K)
18154 1 CONTINUE
18155 XM1 = AAM(IDHPR)
18156 XM2 = AAM(IDHTA)
18157 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18158 IF (IREJ1.GT.0) THEN
18159 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18160 GOTO 9999
18161 ENDIF
18162 DO 2 K=1,4
18163 PPR(K) = P1OUT(K)
18164 PTA(K) = P2OUT(K)
18165 2 CONTINUE
18166 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18167 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18168 ENDIF
18169
18170* Lorentz-parameter for trafo into rest-system of target
18171 DO 3 K=1,4
18172 BGTA(K) = PTA(K)/PTA(5)
18173 3 CONTINUE
18174* transformation of projectile into rest-system of target
18175 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18176 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18177 & PPR1(4))
18178
18179* direction cosines of projectile in target rest system
18180 CX = PPR1(1)/PPRTO1
18181 CY = PPR1(2)/PPRTO1
18182 CZ = PPR1(3)/PPRTO1
18183
18184* sample inelastic interaction
18185 IF (MODE.EQ.1) THEN
18186 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18187 IF (IRH.EQ.1) GOTO 9998
18188* sample elastic interaction
18189 ELSEIF (MODE.EQ.2) THEN
18190 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18191 IF (IREJ1.NE.0) THEN
18192 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18193 GOTO 9999
18194 ENDIF
18195 IF (IRH.EQ.1) GOTO 9998
18196 ELSE
18197 WRITE(LOUT,1001) MODE,INTHAD
18198 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18199 & I4,' (INTHAD =',I4,')')
18200 GOTO 9999
18201 ENDIF
18202
18203* transform final state particles back into Lab.
18204 DO 4 I=1,IRH
18205 NFSP = NFSP+1
18206 PX = CXRH(I)*PLRH(I)
18207 PY = CYRH(I)*PLRH(I)
18208 PZ = CZRH(I)*PLRH(I)
18209 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18210 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18211 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18212 IDFSP(NFSP) = ITRH(I)
18213 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18214 & PFSP(3,NFSP)**2
18215 IF (AMFSP2.LT.-TINY3) THEN
18216 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18217 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18218 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18219 & I2,') with negative mass^2',/,1X,5E12.4)
18220 GOTO 9999
18221 ELSE
18222 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18223 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18224 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18225 & PFSP(5,NFSP)
18226 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18227 & ' (id = ',I2,') with inconsistent mass',/,1X,
18228 & 2E12.4)
18229 KCORR = KCORR+1
18230 IF (KCORR.GT.2) GOTO 9999
18231 IMCORR(KCORR) = NFSP
18232 ENDIF
18233 ENDIF
18234* dump final state particles for energy-momentum cons. check
18235 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18236 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18237 4 CONTINUE
18238
18239* transform momenta on mass shell in case of inconsistencies in
18240* HADRIN
18241 IF (KCORR.GT.0) THEN
18242 IF (KCORR.EQ.2) THEN
18243 I1 = IMCORR(1)
18244 I2 = IMCORR(2)
18245 ELSE
18246 IF (IMCORR(1).EQ.1) THEN
18247 I1 = 1
18248 I2 = 2
18249 ELSE
18250 I1 = 1
18251 I2 = IMCORR(1)
18252 ENDIF
18253 ENDIF
18254 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18255 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18256 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18257 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18258 DO 5 K=1,4
18259 P1IN(K) = PFSP(K,I1)
18260 P2IN(K) = PFSP(K,I2)
18261 5 CONTINUE
18262 XM1 = AAM(IDFSP(I1))
18263 XM2 = AAM(IDFSP(I2))
18264 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18265 IF (IREJ1.GT.0) THEN
18266 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18267C GOTO 9999
18268 ENDIF
18269 DO 6 K=1,4
18270 PFSP(K,I1) = P1OUT(K)
18271 PFSP(K,I2) = P2OUT(K)
18272 6 CONTINUE
18273 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18274 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18275 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18276 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18277* dump final state particles for energy-momentum cons. check
18278 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18279 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18280 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18281 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18282 ENDIF
18283
18284* check energy-momentum conservation
18285 IF (LEMCCK) THEN
18286 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18287 IF (IREJ1.NE.0) GOTO 9999
18288 ENDIF
18289
18290 RETURN
18291
18292 9998 CONTINUE
18293 IREJ = 2
18294 RETURN
18295
18296 9999 CONTINUE
18297 IREJ = 1
18298 RETURN
18299 END
18300
18301*$ CREATE DT_HADCOL.FOR
18302*COPY DT_HADCOL
18303*
18304*===hadcol=============================================================*
18305*
18306 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18307
18308************************************************************************
18309* Interface to the HADRIN-routines for inelastic and elastic *
18310* scattering. This subroutine samples hadron-nucleus interactions *
18311* below DPM-threshold. *
18312* IDPROJ BAMJET-index of projectile hadron *
18313* PPN projectile momentum in target rest frame *
18314* IDXTAR DTEVT1-index of target nucleon undergoing *
18315* interaction with projectile hadron *
18316* This subroutine replaces HADHAD. *
18317* This version dated 5.5.95 is written by S. Roesler *
18318************************************************************************
18319
18320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18321 SAVE
18322
18323 PARAMETER ( LINP = 10 ,
18324 & LOUT = 6 ,
18325 & LDAT = 9 )
18326
18327 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18328
18329 LOGICAL LSTART
18330
18331* event history
18332
18333 PARAMETER (NMXHKK=200000)
18334
18335 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18336 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18337 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18338
18339* extended event history
18340 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18341 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18342 & IHIST(2,NMXHKK)
18343
18344* nuclear potential
18345 LOGICAL LFERMI
18346 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18347 & EBINDP(2),EBINDN(2),EPOT(2,210),
18348 & ETACOU(2),ICOUL,LFERMI
18349
18350* interface HADRIN-DPM
18351 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18352
18353* parameter for intranuclear cascade
18354 LOGICAL LPAULI
18355 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18356
18357* final state after inc step
18358 PARAMETER (MAXFSP=10)
18359 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18360
18361* particle properties (BAMJET index convention)
18362 CHARACTER*8 ANAME
18363 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18364 & IICH(210),IIBAR(210),K1(210),K2(210)
18365
18366 DIMENSION PPROJ(5),PNUC(5)
18367
18368 DATA LSTART /.TRUE./
18369
18370 IREJ = 0
18371
18372 NPOINT(1) = NHKK+1
18373
18374 TAUSAV = TAUFOR
18375**sr 6/9/01 commented
18376C TAUFOR = TAUFOR/2.0D0
18377**
18378 IF (LSTART) THEN
18379 WRITE(LOUT,1000)
18380 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18381 WRITE(LOUT,1001) TAUFOR
18382 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18383 & F5.1,' fm/c')
18384 LSTART = .FALSE.
18385 ENDIF
18386
18387 IDNUC = IDBAM(IDXTAR)
18388 IDNUC1 = IDT_MCHAD(IDNUC)
18389 IDPRO1 = IDT_MCHAD(IDPROJ)
18390
18391 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18392 IPROC = INTHAD
18393 ELSE
18394**
18395C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18396C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18397 DUMZER = ZERO
18398 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18399 SIGIN = SIGTOT-SIGEL
18400C SIGTOT = SIGIN+SIGEL
18401**
18402 IPROC = 1
18403 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18404 ENDIF
18405
18406 PPROJ(1) = ZERO
18407 PPROJ(2) = ZERO
18408 PPROJ(3) = PPN
18409 PPROJ(5) = AAM(IDPROJ)
18410 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18411 DO 1 K=1,5
18412 PNUC(K) = PHKK(K,IDXTAR)
18413 1 CONTINUE
18414
18415 ILOOP = 0
18416 2 CONTINUE
18417 ILOOP = ILOOP+1
18418 IF (ILOOP.GT.100) GOTO 9999
18419
18420 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18421 IF (IREJ1.EQ.1) GOTO 9999
18422
18423 IF (IREJ1.GT.1) THEN
18424* no interaction possible
18425* require Pauli blocking
18426 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18427 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18428 IF ((IIBAR(IDPROJ).NE.1).AND.
18429 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18430* store incoming particle as final state particle
18431 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18432 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18433 NPOINT(4) = NHKK
18434 ELSE
18435* require Pauli blocking for final state nucleons
18436 DO 4 I=1,NFSP
18437 IF ((IDFSP(I).EQ.1).AND.
18438 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18439 IF ((IDFSP(I).EQ.8).AND.
18440 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18441 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18442 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18443 4 CONTINUE
18444* store final state particles
18445 DO 5 I=1,NFSP
18446 IST = 1
18447 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18448 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18449 IDHAD = IDT_IPDGHA(IDFSP(I))
18450 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18451 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18452 & PCMS,ECMS,0,0,0)
18453 IF (I.EQ.1) NPOINT(4) = NHKK
18454 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18455 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18456 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18457 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18458 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18459 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18460 WHKK(3,NHKK) = WHKK(3,1)
18461 WHKK(4,NHKK) = WHKK(4,1)
18462 5 CONTINUE
18463 ENDIF
18464 TAUFOR = TAUSAV
18465 RETURN
18466
18467 9999 CONTINUE
18468 IREJ = 1
18469 TAUFOR = TAUSAV
18470 RETURN
18471 END
18472*$ CREATE DT_GETEMU.FOR
18473*COPY DT_GETEMU
18474*
18475*===getemu=============================================================*
18476*
18477 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18478
18479************************************************************************
18480* Sampling of emulsion component to be considered as target-nucleus. *
18481* This version dated 6.5.95 is written by S. Roesler. *
18482************************************************************************
18483
18484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18485 SAVE
18486
18487 PARAMETER ( LINP = 10 ,
18488 & LOUT = 6 ,
18489 & LDAT = 9 )
18490
18491 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18492
18493 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18494
18495* emulsion treatment
18496 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18497 & NCOMPO,IEMUL
18498
18499* Glauber formalism: flags and parameters for statistics
18500 LOGICAL LPROD
18501 CHARACTER*8 CGLB
18502 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18503
18504 IF (MODE.EQ.0) THEN
18505 SUMFRA = ZERO
18506 RR = DT_RNDM(SUMFRA)
18507 IT = 0
18508 ITZ = 0
18509 DO 1 ICOMP=1,NCOMPO
18510 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18511 IF (SUMFRA.GT.RR) THEN
18512 IT = IEMUMA(ICOMP)
18513 ITZ = IEMUCH(ICOMP)
18514 KKMAT = ICOMP
18515 GOTO 2
18516 ENDIF
18517 1 CONTINUE
18518 2 CONTINUE
18519 IF (IT.LE.0) THEN
18520 WRITE(LOUT,'(1X,A,E12.3)')
18521 & 'Warning! norm. failure within emulsion fractions',
18522 & SUMFRA
18523 STOP
18524 ENDIF
18525 ELSEIF (MODE.EQ.1) THEN
18526 NDIFF = 10000
18527 DO 3 I=1,NCOMPO
18528 IDIFF = ABS(IT-IEMUMA(I))
18529 IF (IDIFF.LT.NDIFF) THEN
18530 KKMAT = I
18531 NDIFF = IDIFF
18532 ENDIF
18533 3 CONTINUE
18534 ELSE
18535 STOP 'DT_GETEMU'
18536 ENDIF
18537
18538* bypass for variable projectile/target/energy runs: the correct
18539* Glauber data will be always loaded on kkmat=1
18540 IF (IOGLB.EQ.100) THEN
18541 KKMAT = 1
18542 ENDIF
18543
18544 RETURN
18545 END
18546
18547*$ CREATE DT_NCLPOT.FOR
18548*COPY DT_NCLPOT
18549*
18550*===nclpot=============================================================*
18551*
18552 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18553
18554************************************************************************
18555* Calculation of Coulomb and nuclear potential for a given configurat. *
18556* IPZ, IP charge/mass number of proj. *
18557* ITZ, IT charge/mass number of targ. *
18558* AFERP,AFERT factors modifying proj./target pot. *
18559* if =0, FERMOD is used *
18560* MODE = 0 calculation of binding energy *
18561* = 1 pre-calculated binding energy is used *
18562* This version dated 16.11.95 is written by S. Roesler. *
18563* *
18564* Last change 28.12.2006 by S. Roesler. *
18565************************************************************************
18566
18567 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18568 SAVE
18569
18570 PARAMETER ( LINP = 10 ,
18571 & LOUT = 6 ,
18572 & LDAT = 9 )
18573
18574 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18575 & TINY10=1.0D-10)
18576
18577 LOGICAL LSTART
18578
18579* particle properties (BAMJET index convention)
18580 CHARACTER*8 ANAME
18581 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18582 & IICH(210),IIBAR(210),K1(210),K2(210)
18583
18584* nuclear potential
18585 LOGICAL LFERMI
18586 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18587 & EBINDP(2),EBINDN(2),EPOT(2,210),
18588 & ETACOU(2),ICOUL,LFERMI
18589
18590 DIMENSION IDXPOT(14)
18591* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18592 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18593* asig0 asig+ atet0 atet+
18594 & 100, 101, 102, 103/
18595
18596 DATA AN /0.4D0/
18597 DATA LSTART /.TRUE./
18598
18599 IF (MODE.EQ.0) THEN
18600 EBINDP(1) = ZERO
18601 EBINDN(1) = ZERO
18602 EBINDP(2) = ZERO
18603 EBINDN(2) = ZERO
18604 ENDIF
18605 AIP = DBLE(IP)
18606 AIPZ = DBLE(IPZ)
18607 AIT = DBLE(IT)
18608 AITZ = DBLE(ITZ)
18609
18610 FERMIP = AFERP
18611 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18612 FERMIT = AFERT
18613 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18614
18615* Fermi momenta and binding energy for projectile
18616 IF ((IP.GT.1).AND.LFERMI) THEN
18617 IF (MODE.EQ.0) THEN
18618C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18619C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18620 BIP = AIP -ONE
18621 BIPZ = AIPZ-ONE
18622
18623C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18624C & -ENERGY(AIP,AIPZ))
18625 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18626 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18627 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18628
18629 IF (AIP.LE.AIPZ) THEN
18630 EBINDN(1) = EBINDP(1)
18631 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18632 ELSE
18633
18634C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18635C & -ENERGY(AIP,AIPZ))
18636 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18637 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18638 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18639
18640 ENDIF
18641 ENDIF
18642 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18643 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18644 ELSE
18645 PFERMP(1) = ZERO
18646 PFERMN(1) = ZERO
18647 ENDIF
18648* effective nuclear potential for projectile
18649C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18650C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18651 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18652 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18653
18654* Fermi momenta and binding energy for target
18655 IF ((IT.GT.1).AND.LFERMI) THEN
18656 IF (MODE.EQ.0) THEN
18657C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18658C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18659 BIT = AIT -ONE
18660 BITZ = AITZ-ONE
18661
18662C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18663C & -ENERGY(AIT,AITZ))
18664 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18665 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18666 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18667
18668 IF (AIT.LE.AITZ) THEN
18669 EBINDN(2) = EBINDP(2)
18670 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18671 ELSE
18672
18673C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18674C & -ENERGY(AIT,AITZ))
18675 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18676 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18677 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18678
18679 ENDIF
18680 ENDIF
18681 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18682 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18683 ELSE
18684 PFERMP(2) = ZERO
18685 PFERMN(2) = ZERO
18686 ENDIF
18687* effective nuclear potential for target
18688C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18689C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18690 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18691 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18692
18693 DO 2 I=1,14
18694 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18695 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18696 2 CONTINUE
18697
18698* Coulomb energy
18699 ETACOU(1) = ZERO
18700 ETACOU(2) = ZERO
18701 IF (ICOUL.EQ.1) THEN
18702 IF (IP.GT.1)
18703 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18704 IF (IT.GT.1)
18705 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18706 ENDIF
18707
18708 IF (LSTART) THEN
18709 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18710 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18711 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18712 & FERMOD,ETACOU
18713 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18714 & ,' effects',/,12X,'---------------------------',
18715 & '----------------',/,/,38X,'projectile',
18716 & ' target',/,/,1X,'Mass number / charge',
18717 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18718 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18719 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18720 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18721 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18722 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18723 LSTART = .FALSE.
18724 ENDIF
18725
18726 RETURN
18727 END
18728
18729*$ CREATE DT_RESNCL.FOR
18730*COPY DT_RESNCL
18731*
18732*===resncl=============================================================*
18733*
18734 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18735
18736************************************************************************
18737* Treatment of residual nuclei and nuclear effects. *
18738* MODE = 1 initializations *
18739* = 2 treatment of final state *
18740* This version dated 16.11.95 is written by S. Roesler. *
18741* *
18742* Last change 05.01.2007 by S. Roesler. *
18743************************************************************************
18744
18745 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18746 SAVE
18747
18748 PARAMETER ( LINP = 10 ,
18749 & LOUT = 6 ,
18750 & LDAT = 9 )
18751
18752 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18753 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18754 & ONETHI=ONE/THREE)
18755 PARAMETER (AMUAMU = 0.93149432D0,
18756 & FM2MM = 1.0D-12,
18757 & RNUCLE = 1.12D0)
18758 PARAMETER ( EMVGEV = 1.0 D-03 )
18759 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18760 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18761 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18762 PARAMETER ( AMELCT = 0.51099906 D-03 )
18763 PARAMETER ( HLFHLF = 0.5D+00 )
18764 PARAMETER ( FERTHO = 14.33 D-09 )
18765 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18766 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18767 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18768
18769* event history
18770
18771 PARAMETER (NMXHKK=200000)
18772
18773 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18774 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18775 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18776
18777* extended event history
18778 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18779 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18780 & IHIST(2,NMXHKK)
18781
18782* particle properties (BAMJET index convention)
18783 CHARACTER*8 ANAME
18784 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18785 & IICH(210),IIBAR(210),K1(210),K2(210)
18786
18787* flags for input different options
18788 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18789 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18790 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18791
18792* nuclear potential
18793 LOGICAL LFERMI
18794 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18795 & EBINDP(2),EBINDN(2),EPOT(2,210),
18796 & ETACOU(2),ICOUL,LFERMI
18797
18798* properties of interacting particles
18799 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18800
18801* properties of photon/lepton projectiles
18802 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18803
18804* Lorentz-parameters of the current interaction
18805 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18806 & UMO,PPCM,EPROJ,PPROJ
18807
18808* treatment of residual nuclei: wounded nucleons
18809 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18810
18811* treatment of residual nuclei: 4-momenta
18812 LOGICAL LRCLPR,LRCLTA
18813 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18814 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18815
18816 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18817 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18818 & IDXCOR(15000),IDXOTH(NMXHKK)
18819
18820 GOTO (1,2) MODE
18821
18822*------- initializations
18823 1 CONTINUE
18824
18825* initialize arrays for residual nuclei
18826 DO 10 K=1,5
18827 IF (K.LE.4) THEN
18828 PFSP(K) = ZERO
18829 ENDIF
18830 PINIPR(K) = ZERO
18831 PINITA(K) = ZERO
18832 PRCLPR(K) = ZERO
18833 PRCLTA(K) = ZERO
18834 TRCLPR(K) = ZERO
18835 TRCLTA(K) = ZERO
18836 10 CONTINUE
18837 SCPOT = ONE
18838 NLOOP = 0
18839
18840* correction of projectile 4-momentum for effective target pot.
18841* and Coulomb-energy (in case of hadron-nucleus interaction only)
18842 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18843 EPNI = EPN
18844* Coulomb-energy:
18845* positively charged hadron - check energy for Coloumb pot.
18846 IF (IICH(IJPROJ).EQ.1) THEN
18847 THRESH = ETACOU(2)+AAM(IJPROJ)
18848 IF (EPNI.LE.THRESH) THEN
18849 WRITE(LOUT,1000)
18850 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18851 & ' below Coulomb threshold - event rejected',/)
18852 ISTHKK(1) = 1
18853 RETURN
18854 ENDIF
18855* negatively charged hadron - increase energy by Coulomb energy
18856 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18857 EPNI = EPNI+ETACOU(2)
18858 ENDIF
18859 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18860* Effective target potential
18861*sr 6.6. binding energy only (to avoid negative exc. energies)
18862C EPNI = EPNI+EPOT(2,IJPROJ)
18863 EBIPOT = EBINDP(2)
18864 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18865 & EBIPOT = EBINDN(2)
18866 EPNI = EPNI+ABS(EBIPOT)
18867* re-initialization of DTLTRA
18868 DUM1 = ZERO
18869 DUM2 = ZERO
18870 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18871 ENDIF
18872 ENDIF
18873
18874* projectile in n-n cms
18875 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18876 PMASS1 = AAM(IJPROJ)
18877C* VDM assumption
18878C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18879 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18880 PMASS2 = AAM(1)
18881 PM1 = SIGN(PMASS1**2,PMASS1)
18882 PM2 = SIGN(PMASS2**2,PMASS2)
18883 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18884 PINIPR(5) = PMASS1
18885 IF (PMASS1.GT.ZERO) THEN
18886 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18887 & *(PINIPR(4)+PINIPR(5)))
18888 ELSE
18889 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18890 ENDIF
18891 AIT = DBLE(IT)
18892 AITZ = DBLE(ITZ)
18893
18894C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18895 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18896
18897 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18898 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18899 PMASS1 = AAM(1)
18900 PMASS2 = AAM(IJTARG)
18901 PM1 = SIGN(PMASS1**2,PMASS1)
18902 PM2 = SIGN(PMASS2**2,PMASS2)
18903 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18904 PINITA(5) = PMASS2
18905 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18906 & *(PINITA(4)+PINITA(5)))
18907 AIP = DBLE(IP)
18908 AIPZ = DBLE(IPZ)
18909
18910C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18911 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18912
18913 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18914 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18915 AIP = DBLE(IP)
18916 AIPZ = DBLE(IPZ)
18917
18918C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18919 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18920
18921 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18922 AIT = DBLE(IT)
18923 AITZ = DBLE(ITZ)
18924
18925C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18926 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18927
18928 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18929 ENDIF
18930
18931 RETURN
18932
18933*------- treatment of final state
18934 2 CONTINUE
18935
18936 NLOOP = NLOOP+1
18937 IF (NLOOP.GT.1) SCPOT = 0.10D0
18938C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18939
18940 JPW = NPW
18941 JPCW = NPCW
18942 JTW = NTW
18943 JTCW = NTCW
18944 DO 40 K=1,4
18945 PFSP(K) = ZERO
18946 40 CONTINUE
18947
18948 NOB = 0
18949 NOM = 0
18950 DO 900 I=NPOINT(4),NHKK
18951 IDXOTH(I) = -1
18952 IF (ISTHKK(I).EQ.1) THEN
18953 IF (IDBAM(I).EQ.7) GOTO 900
18954 IPOT = 0
18955 IOTHER = 0
18956* particle moving into forward direction
18957 IF (PHKK(3,I).GE.ZERO) THEN
18958* most likely to be effected by projectile potential
18959 IPOT = 1
18960* there is no projectile nucleus, try target
18961 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18962 IPOT = 2
18963 IF (IP.GT.1) IOTHER = 1
18964* there is no target nucleus --> skip
18965 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18966 ENDIF
18967* particle moving into backward direction
18968 ELSE
18969* most likely to be effected by target potential
18970 IPOT = 2
18971* there is no target nucleus, try projectile
18972 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18973 IPOT = 1
18974 IF (IT.GT.1) IOTHER = 1
18975* there is no projectile nucleus --> skip
18976 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18977 ENDIF
18978 ENDIF
18979 IFLG = -IPOT
18980* nobam=3: particle is in overlap-region or neither inside proj. nor target
18981* =1: particle is not in overlap-region AND is inside target (2)
18982* =2: particle is not in overlap-region AND is inside projectile (1)
18983* flag particles which are inside the nucleus ipot but not in its
18984* overlap region
18985 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18986 IF (IDBAM(I).NE.0) THEN
18987* baryons: keep all nucleons and all others where flag is set
18988 IF (IIBAR(IDBAM(I)).NE.0) THEN
18989 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18990 & THEN
18991 NOB = NOB+1
18992 PMOMB(NOB) = PHKK(3,I)
18993 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18994 & +1000000*IOTHER+I,IFLG)
18995 ENDIF
18996* mesons: keep only those mesons where flag is set
18997 ELSE
18998 IF (IFLG.GT.0) THEN
18999 NOM = NOM+1
19000 PMOMM(NOM) = PHKK(3,I)
19001 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19002 ENDIF
19003 ENDIF
19004 ENDIF
19005 ENDIF
19006 900 CONTINUE
19007*
19008* sort particles in the arrays according to increasing long. momentum
19009 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19010 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19011*
19012* shuffle indices into one and the same array according to the later
19013* sequence of correction
19014 NCOR = 0
19015 IF (IT.GT.1) THEN
19016 DO 910 I=1,NOB
19017 IF (PMOMB(I).GT.ZERO) GOTO 911
19018 NCOR = NCOR+1
19019 IDXCOR(NCOR) = IDXB(I)
19020 910 CONTINUE
19021 911 CONTINUE
19022 IF (IP.GT.1) THEN
19023 DO 912 J=1,NOB
19024 I = NOB+1-J
19025 IF (PMOMB(I).LT.ZERO) GOTO 913
19026 NCOR = NCOR+1
19027 IDXCOR(NCOR) = IDXB(I)
19028 912 CONTINUE
19029 913 CONTINUE
19030 ELSE
19031 DO 914 I=1,NOB
19032 IF (PMOMB(I).GT.ZERO) THEN
19033 NCOR = NCOR+1
19034 IDXCOR(NCOR) = IDXB(I)
19035 ENDIF
19036 914 CONTINUE
19037 ENDIF
19038 ELSE
19039 DO 915 J=1,NOB
19040 I = NOB+1-J
19041 NCOR = NCOR+1
19042 IDXCOR(NCOR) = IDXB(I)
19043 915 CONTINUE
19044 ENDIF
19045 DO 925 I=1,NOM
19046 IF (PMOMM(I).GT.ZERO) GOTO 926
19047 NCOR = NCOR+1
19048 IDXCOR(NCOR) = IDXM(I)
19049 925 CONTINUE
19050 926 CONTINUE
19051 DO 927 J=1,NOM
19052 I = NOM+1-J
19053 IF (PMOMM(I).LT.ZERO) GOTO 928
19054 NCOR = NCOR+1
19055 IDXCOR(NCOR) = IDXM(I)
19056 927 CONTINUE
19057 928 CONTINUE
19058*
19059C IF (NEVHKK.EQ.484) THEN
19060C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19061C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19062C WRITE(LOUT,9001) NOB,NOM,NCOR
19063C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19064C WRITE(LOUT,'(/,A)') ' baryons '
19065C DO 950 I=1,NOB
19066CC J = IABS(IDXB(I))
19067CC INDEX = J-IABS(J/10000000)*10000000
19068C IPOT = IABS(IDXB(I))/10000000
19069C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19070C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19071C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19072C 950 CONTINUE
19073C WRITE(LOUT,'(/,A)') ' mesons '
19074C DO 951 I=1,NOM
19075CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19076C IPOT = IABS(IDXM(I))/10000000
19077C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19078C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19079C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19080C 951 CONTINUE
19081C 9002 FORMAT(1X,4I14,E14.5)
19082C WRITE(LOUT,'(/,A)') ' all '
19083C DO 952 I=1,NCOR
19084CC J = IABS(IDXCOR(I))
19085CC INDEX = J-IABS(J/10000000)*10000000
19086CC IPOT = IABS(IDXCOR(I))/10000000
19087C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19088C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19089C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19090C 952 CONTINUE
19091C 9003 FORMAT(1X,4I14)
19092C ENDIF
19093*
19094 DO 20 ICOR=1,NCOR
19095 IPOT = IABS(IDXCOR(ICOR))/10000000
19096 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19097 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19098 IDXOTH(I) = 1
19099
19100 IDSEC = IDBAM(I)
19101
19102* reduction of particle momentum by corresponding nuclear potential
19103* (this applies only if Fermi-momenta are requested)
19104
19105 IF (LFERMI) THEN
19106
19107* Lorentz-transformation into the rest system of the selected nucleus
19108 IMODE = -IPOT-1
19109 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19110 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19111 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19112 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19113 JPMOD = 0
19114
19115 CHKLEV = TINY3
19116 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19117 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19118 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19119 IF (IOULEV(3).GT.0)
19120 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19121 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19122 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19123 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19124 GOTO 23
19125 ENDIF
19126
19127 DO 21 K=1,4
19128 PSEC0(K) = PSEC(K)
19129 21 CONTINUE
19130
19131* the correction for nuclear potential effects is applied to as many
19132* p/n as many nucleons were wounded; the momenta of other final state
19133* particles are corrected only if they materialize inside the corresp.
19134* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19135* = 3 part. outside proj. and targ., >=10 in overlapping region)
19136 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19137 IF (IPOT.EQ.1) THEN
19138 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19139* this is most likely a wounded nucleon
19140**test
19141C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19142C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19143C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19144C RAD = RNUCLE*DBLE(IP)**ONETHI
19145C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19146C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19147**
19148 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19149 JPW = JPW-1
19150 JPMOD = 1
19151 ELSE
19152* correct only if part. was materialized inside nucleus
19153* and if it is ouside the overlapping region
19154 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19155 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19156 JPMOD = 1
19157 ENDIF
19158 ENDIF
19159 ELSEIF (IPOT.EQ.2) THEN
19160 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19161* this is most likely a wounded nucleon
19162**test
19163C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19164C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19165C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19166C RAD = RNUCLE*DBLE(IT)**ONETHI
19167C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19168C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19169**
19170 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19171 JTW = JTW-1
19172 JPMOD = 1
19173 ELSE
19174* correct only if part. was materialized inside nucleus
19175 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19176 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19177 JPMOD = 1
19178 ENDIF
19179 ENDIF
19180 ENDIF
19181 ELSE
19182 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19183 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19184 JPMOD = 1
19185 ENDIF
19186 ENDIF
19187
19188 IF (NLOOP.EQ.1) THEN
19189* Coulomb energy correction:
19190* the treatment of Coulomb potential correction is similar to the
19191* one for nuclear potential
19192 IF (IDSEC.EQ.1) THEN
19193 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19194 JPCW = JPCW-1
19195 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19196 JTCW = JTCW-1
19197 ELSE
19198 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19199 ENDIF
19200 ELSE
19201 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19202 ENDIF
19203 IF (IICH(IDSEC).EQ.1) THEN
19204* pos. particles: check if they are able to escape Coulomb potential
19205 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19206 ISTHKK(I) = 14+IPOT
19207 IF (ISTHKK(I).EQ.15) THEN
19208 DO 26 K=1,4
19209 PHKK(K,I) = PSEC0(K)
19210 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19211 26 CONTINUE
19212 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19213 IF (IDSEC.EQ.1) NPCW = NPCW-1
19214 ELSEIF (ISTHKK(I).EQ.16) THEN
19215 DO 27 K=1,4
19216 PHKK(K,I) = PSEC0(K)
19217 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19218 27 CONTINUE
19219 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19220 IF (IDSEC.EQ.1) NTCW = NTCW-1
19221 ENDIF
19222 GOTO 20
19223 ENDIF
19224 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19225* neg. particles: decrease energy by Coulomb-potential
19226 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19227 JPMOD = 1
19228 ENDIF
19229 ENDIF
19230
19231 25 CONTINUE
19232
19233 IF (PSEC(4).LT.AMSEC) THEN
19234 IF (IOULEV(6).GT.0)
19235 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19236 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19237 & ' is not allowed to escape nucleus',/,
19238 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19239 & ' mass: ',E12.3)
19240 ISTHKK(I) = 14+IPOT
19241 IF (ISTHKK(I).EQ.15) THEN
19242 DO 28 K=1,4
19243 PHKK(K,I) = PSEC0(K)
19244 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19245 28 CONTINUE
19246 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19247 IF (IDSEC.EQ.1) NPCW = NPCW-1
19248 ELSEIF (ISTHKK(I).EQ.16) THEN
19249 DO 29 K=1,4
19250 PHKK(K,I) = PSEC0(K)
19251 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19252 29 CONTINUE
19253 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19254 IF (IDSEC.EQ.1) NTCW = NTCW-1
19255 ENDIF
19256 GOTO 20
19257 ENDIF
19258
19259 IF (JPMOD.EQ.1) THEN
19260 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19261* 4-momentum after correction for nuclear potential
19262 DO 22 K=1,3
19263 PSEC(K) = PSEC(K)*PSECN/PSECO
19264 22 CONTINUE
19265
19266* store recoil momentum from particles escaping the nuclear potentials
19267 DO 30 K=1,4
19268 IF (IPOT.EQ.1) THEN
19269 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19270 ELSEIF (IPOT.EQ.2) THEN
19271 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19272 ENDIF
19273 30 CONTINUE
19274
19275* transform momentum back into n-n cms
19276 IMODE = IPOT+1
19277 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19278 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19279 & IDSEC,IMODE)
19280 ENDIF
19281
19282 ENDIF
19283
19284 23 CONTINUE
19285 DO 31 K=1,4
19286 PFSP(K) = PFSP(K)+PHKK(K,I)
19287 31 CONTINUE
19288
19289 20 CONTINUE
19290
19291 DO 33 I=NPOINT(4),NHKK
19292 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19293 PFSP(1) = PFSP(1)+PHKK(1,I)
19294 PFSP(2) = PFSP(2)+PHKK(2,I)
19295 PFSP(3) = PFSP(3)+PHKK(3,I)
19296 PFSP(4) = PFSP(4)+PHKK(4,I)
19297 ENDIF
19298 33 CONTINUE
19299
19300 DO 34 K=1,5
19301 PRCLPR(K) = TRCLPR(K)
19302 PRCLTA(K) = TRCLTA(K)
19303 34 CONTINUE
19304
19305 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19306* hadron-nucleus interactions: get residual momentum from energy-
19307* momentum conservation
19308 DO 32 K=1,4
19309 PRCLPR(K) = ZERO
19310 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19311 32 CONTINUE
19312 ELSE
19313* nucleus-hadron, nucleus-nucleus: get residual momentum from
19314* accumulated recoil momenta of particles leaving the spectators
19315* transform accumulated recoil momenta of residual nuclei into
19316* n-n cms
19317 PZI = PRCLPR(3)
19318 PEI = PRCLPR(4)
19319 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19320 PZI = PRCLTA(3)
19321 PEI = PRCLTA(4)
19322 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19323C IF (IP.GT.1) THEN
19324 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19325 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19326C ENDIF
19327 IF (IT.GT.1) THEN
19328 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19329 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19330 ENDIF
19331 ENDIF
19332
19333* check momenta of residual nuclei
19334 IF (LEMCCK) THEN
19335 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19336 & 1,IDUM,IDUM)
19337 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19338 & 2,IDUM,IDUM)
19339 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19340 & 2,IDUM,IDUM)
19341 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19342 & 2,IDUM,IDUM)
19343 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19344**sr 19.12. changed to avoid output when used with phojet
19345C CHKLEV = TINY3
19346 CHKLEV = TINY1
19347 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19348C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19349C & CALL DT_EVTOUT(4)
19350 IF (IREJ1.GT.0) RETURN
19351 ENDIF
19352
19353 RETURN
19354 END
19355
19356*$ CREATE DT_SCN4BA.FOR
19357*COPY DT_SCN4BA
19358*
19359*===scn4ba=============================================================*
19360*
19361 SUBROUTINE DT_SCN4BA
19362
19363************************************************************************
19364* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19365* This version dated 12.12.95 is written by S. Roesler. *
19366************************************************************************
19367
19368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19369 SAVE
19370
19371 PARAMETER ( LINP = 10 ,
19372 & LOUT = 6 ,
19373 & LDAT = 9 )
19374
19375 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19376 & TINY10=1.0D-10)
19377
19378* event history
19379
19380 PARAMETER (NMXHKK=200000)
19381
19382 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19383 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19384 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19385
19386* extended event history
19387 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19388 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19389 & IHIST(2,NMXHKK)
19390
19391* particle properties (BAMJET index convention)
19392 CHARACTER*8 ANAME
19393 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19394 & IICH(210),IIBAR(210),K1(210),K2(210)
19395
19396* properties of interacting particles
19397 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19398
19399* nuclear potential
19400 LOGICAL LFERMI
19401 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19402 & EBINDP(2),EBINDN(2),EPOT(2,210),
19403 & ETACOU(2),ICOUL,LFERMI
19404
19405* treatment of residual nuclei: wounded nucleons
19406 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19407
19408* treatment of residual nuclei: 4-momenta
19409 LOGICAL LRCLPR,LRCLTA
19410 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19411 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19412
19413 DIMENSION PLAB(2,5),PCMS(4)
19414
19415 IREJ = 0
19416
19417* get number of wounded nucleons
19418 NPW = 0
19419 NPW0 = 0
19420 NPCW = 0
19421 NPSTCK = 0
19422 NTW = 0
19423 NTW0 = 0
19424 NTCW = 0
19425 NTSTCK = 0
19426
19427 ISGLPR = 0
19428 ISGLTA = 0
19429 LRCLPR = .FALSE.
19430 LRCLTA = .FALSE.
19431
19432C DO 2 I=1,NHKK
19433 DO 2 I=1,NPOINT(1)
19434* projectile nucleons wounded in primary interaction and in fzc
19435 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19436 NPW = NPW+1
19437 IPW(NPW) = I
19438 NPSTCK = NPSTCK+1
19439 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19440 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19441C IF (IP.GT.1) THEN
19442 DO 5 K=1,4
19443 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19444 5 CONTINUE
19445C ENDIF
19446* target nucleons wounded in primary interaction and in fzc
19447 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19448 NTW = NTW+1
19449 ITW(NTW) = I
19450 NTSTCK = NTSTCK+1
19451 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19452 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19453 IF (IT.GT.1) THEN
19454 DO 6 K=1,4
19455 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19456 6 CONTINUE
19457 ENDIF
19458 ELSEIF (ISTHKK(I).EQ.13) THEN
19459 ISGLPR = I
19460 ELSEIF (ISTHKK(I).EQ.14) THEN
19461 ISGLTA = I
19462 ENDIF
19463 2 CONTINUE
19464
19465 DO 11 I=NPOINT(4),NHKK
19466* baryons which are unable to escape the nuclear potential of proj.
19467 IF (ISTHKK(I).EQ.15) THEN
19468 ISGLPR = I
19469 NPSTCK = NPSTCK-1
19470 IF (IIBAR(IDBAM(I)).NE.0) THEN
19471 NPW = NPW-1
19472 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19473 ENDIF
19474 DO 7 K=1,4
19475 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19476 7 CONTINUE
19477* baryons which are unable to escape the nuclear potential of targ.
19478 ELSEIF (ISTHKK(I).EQ.16) THEN
19479 ISGLTA = I
19480 NTSTCK = NTSTCK-1
19481 IF (IIBAR(IDBAM(I)).NE.0) THEN
19482 NTW = NTW-1
19483 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19484 ENDIF
19485 DO 8 K=1,4
19486 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19487 8 CONTINUE
19488 ENDIF
19489 11 CONTINUE
19490
19491* residual nuclei so far
19492 IRESP = IP-NPSTCK
19493 IREST = IT-NTSTCK
19494
19495* ckeck for "residual nuclei" consisting of one nucleon only
19496* treat it as final state particle
19497 IF (IRESP.EQ.1) THEN
19498 ID = IDBAM(ISGLPR)
19499 IST = ISTHKK(ISGLPR)
19500 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19501 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19502 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19503 IF (IST.EQ.13) THEN
19504 ISTHKK(ISGLPR) = 11
19505 ELSE
19506 ISTHKK(ISGLPR) = 2
19507 ENDIF
19508 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19509 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19510 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19511 NOBAM(NHKK) = NOBAM(ISGLPR)
19512 JDAHKK(1,ISGLPR) = NHKK
19513 DO 21 K=1,4
19514 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19515 21 CONTINUE
19516 ENDIF
19517 IF (IREST.EQ.1) THEN
19518 ID = IDBAM(ISGLTA)
19519 IST = ISTHKK(ISGLTA)
19520 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19521 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19522 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19523 IF (IST.EQ.14) THEN
19524 ISTHKK(ISGLTA) = 12
19525 ELSE
19526 ISTHKK(ISGLTA) = 2
19527 ENDIF
19528 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19529 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19530 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19531 NOBAM(NHKK) = NOBAM(ISGLTA)
19532 JDAHKK(1,ISGLTA) = NHKK
19533 DO 22 K=1,4
19534 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19535 22 CONTINUE
19536 ENDIF
19537
19538* get nuclear potential corresp. to the residual nucleus
19539 IPRCL = IP -NPW
19540 IPZRCL = IPZ-NPCW
19541 ITRCL = IT -NTW
19542 ITZRCL = ITZ-NTCW
19543 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19544
19545* baryons unable to escape the nuclear potential are treated as
19546* excited nucleons (ISTHKK=15,16)
19547 DO 3 I=NPOINT(4),NHKK
19548 IF (ISTHKK(I).EQ.1) THEN
19549 ID = IDBAM(I)
19550 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19551* final state n and p not being outside of both nuclei are considered
19552 NPOTP = 1
19553 NPOTT = 1
19554 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19555 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19556* Lorentz-trsf. into proj. rest sys. for those being inside proj.
19557 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19558 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19559 & PLAB(1,4),ID,-2)
19560 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19561 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19562 & (PLAB(1,4)+PLABT) ))
19563 EKIN = PLAB(1,4)-PLAB(1,5)
19564 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19565 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19566 ENDIF
19567 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19568 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19569* Lorentz-trsf. into targ. rest sys. for those being inside targ.
19570 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19571 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19572 & PLAB(2,4),ID,-3)
19573 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19574 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19575 & (PLAB(2,4)+PLABT) ))
19576 EKIN = PLAB(2,4)-PLAB(2,5)
19577 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19578 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19579 ENDIF
19580 IF (PHKK(3,I).GE.ZERO) THEN
19581 ISTHKK(I) = NPOTT
19582 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19583 ELSE
19584 ISTHKK(I) = NPOTP
19585 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19586 ENDIF
19587 IF (ISTHKK(I).NE.1) THEN
19588 J = ISTHKK(I)-14
19589 DO 4 K=1,5
19590 PHKK(K,I) = PLAB(J,K)
19591 4 CONTINUE
19592 IF (ISTHKK(I).EQ.15) THEN
19593 NPW = NPW-1
19594 IF (ID.EQ.1) NPCW = NPCW-1
19595 DO 9 K=1,4
19596 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19597 9 CONTINUE
19598 ELSEIF (ISTHKK(I).EQ.16) THEN
19599 NTW = NTW-1
19600 IF (ID.EQ.1) NTCW = NTCW-1
19601 DO 10 K=1,4
19602 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19603 10 CONTINUE
19604 ENDIF
19605 ENDIF
19606 ENDIF
19607 ENDIF
19608 3 CONTINUE
19609
19610* again: get nuclear potential corresp. to the residual nucleus
19611 IPRCL = IP -NPW
19612 IPZRCL = IPZ-NPCW
19613 ITRCL = IT -NTW
19614 ITZRCL = ITZ-NTCW
19615c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19616cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19617c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19618C AFERP = 0.0D0
19619c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19620cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19621c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19622C AFERT = 0.0D0
19623C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19624C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19625C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19626C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19627 AFERP = FERMOD+0.1D0
19628 AFERT = FERMOD+0.1D0
19629
19630 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19631
19632 RETURN
19633 END
19634
19635*$ CREATE DT_FICONF.FOR
19636*COPY DT_FICONF
19637*
19638*===ficonf=============================================================*
19639*
19640 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19641
19642************************************************************************
19643* Treatment of FInal CONFiguration including evaporation, fission and *
19644* Fermi-break-up (for light nuclei only). *
19645* Adopted from the original routine FINALE and extended to residual *
19646* projectile nuclei. *
19647* This version dated 12.12.95 is written by S. Roesler. *
19648* *
19649* Last change 27.12.2006 by S. Roesler. *
19650************************************************************************
19651
19652 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19653 SAVE
19654
19655 PARAMETER ( LINP = 10 ,
19656 & LOUT = 6 ,
19657 & LDAT = 9 )
19658
19659 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19660 PARAMETER (ANGLGB=5.0D-16)
19661
19662* event history
19663
19664 PARAMETER (NMXHKK=200000)
19665
19666 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19667 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19668 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19669
19670* extended event history
19671 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19672 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19673 & IHIST(2,NMXHKK)
19674
19675* rejection counter
19676 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19677 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19678 & IREXCI(3),IRDIFF(2),IRINC
19679
19680* central particle production, impact parameter biasing
19681 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19682
19683* particle properties (BAMJET index convention)
19684 CHARACTER*8 ANAME
19685 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19686 & IICH(210),IIBAR(210),K1(210),K2(210)
19687
19688* treatment of residual nuclei: 4-momenta
19689 LOGICAL LRCLPR,LRCLTA
19690 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19691 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19692
19693* treatment of residual nuclei: properties of residual nuclei
19694 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19695 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19696 & NTOTFI(2),NPROFI(2)
19697
19698* statistics: residual nuclei
19699 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19700 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19701 & NINCST(2,4),NINCEV(2),
19702 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19703 & NRESPB(2),NRESCH(2),NRESEV(4),
19704 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19705 & NEVAFI(2,2)
19706
19707* flags for input different options
19708 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19709 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19710 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19711
19712* INCLUDE '(DIMPAR)'
19713* DIMPAR taken from FLUKA
19714 PARAMETER ( MXXRGN =20000 )
19715 PARAMETER ( MXXMDF = 710 )
19716 PARAMETER ( MXXMDE = 702 )
19717 PARAMETER ( MFSTCK =40000 )
19718 PARAMETER ( MESTCK = 100 )
19719 PARAMETER ( MOSTCK = 2000 )
19720 PARAMETER ( MXPRSN = 100 )
19721 PARAMETER ( MXPDPM = 800 )
19722 PARAMETER ( MXPSCS =30000 )
19723 PARAMETER ( MXGLWN = 300 )
19724 PARAMETER ( MXOUTU = 50 )
19725 PARAMETER ( NALLWP = 64 )
19726 PARAMETER ( NELEMX = 80 )
19727 PARAMETER ( MPDPDX = 18 )
19728 PARAMETER ( MXHTTR = 260 )
19729 PARAMETER ( MXSEAX = 20 )
19730 PARAMETER ( MXHTNC = MXSEAX + 1 )
19731 PARAMETER ( ICOMAX = 2400 )
19732 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19733 PARAMETER ( NSTBIS = 304 )
19734 PARAMETER ( NQSTIS = 46 )
19735 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19736 PARAMETER ( MXPABL = 120 )
19737 PARAMETER ( IDMAXP = 450 )
19738 PARAMETER ( IDMXDC = 2000 )
19739 PARAMETER ( MXMCIN = 410 )
19740 PARAMETER ( IHYPMX = 4 )
19741 PARAMETER ( MKBMX1 = 11 )
19742 PARAMETER ( MKBMX2 = 11 )
19743 PARAMETER ( MXIRRD = 2500 )
19744 PARAMETER ( MXTRDC = 1500 )
19745 PARAMETER ( NKTL = 17 )
19746 PARAMETER ( NBLNMX = 40000000 )
19747
19748* INCLUDE '(GENSTK)'
19749* GENSTK taken from FLUKA
19750 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19751 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19752 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19753 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19754 & TVRECL, TVHEAV, TVBIND,
19755 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19756
19757* INCLUDE '(RESNUC)'
19758* RESNUC from FLUKA
19759 LOGICAL LRNFSS, LFRAGM
19760 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19761 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19762 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19763 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19764 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19765 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19766 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19767 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19768 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19769 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19770 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19771 & LRNFSS, LFRAGM
19772
19773 PARAMETER ( EMVGEV = 1.0 D-03 )
19774 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19775 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19776 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19777 PARAMETER ( AMELCT = 0.51099906 D-03 )
19778 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19779 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19780 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19781 & * 1.D-09 )
19782 PARAMETER ( HLFHLF = 0.5D+00 )
19783 PARAMETER ( FERTHO = 14.33 D-09 )
19784 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19785 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19786 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19787
19788* INCLUDE '(NUCDAT)'
19789* Taken from FLUKA
19790 PARAMETER ( AMUAMU = AMUGEV )
19791 PARAMETER ( AMPROT = AMPRTN )
19792 PARAMETER ( AMNEUT = AMNTRN )
19793 PARAMETER ( AMELEC = AMELCT )
19794 PARAMETER ( R0NUCL = 1.12 D+00 )
19795 PARAMETER ( RCCOUL = 1.7 D+00 )
19796 PARAMETER ( COULPR = COUGFM )
19797 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19798 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19799 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19800 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19801 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19802* Gammin : threshold for deexcitation gammas production, set to 1 keV
19803* (this means that up to 1 keV of energy unbalancing can occur
19804* during an event)
19805 PARAMETER ( GAMMIN = 1.0D-06 )
19806 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19807* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19808 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19809*
19810 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19811 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19812 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19813 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19814 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19815 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19816 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19817 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19818 & ELBNDE (0:110)
19819
19820* INCLUDE '(PAREVT)'
19821* Taken from FLUKA
19822 PARAMETER ( FRDIFF = 0.2D+00 )
19823 PARAMETER ( ETHSEA = 1.0D+00 )
19824*
19825 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19826 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19827 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19828 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19829 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19830 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19831 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19832 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19833 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19834 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19835
19836* INCLUDE '(FHEAVY)'
19837* Taken from FLUKA
19838 PARAMETER ( MXHEAV = 100 )
19839 PARAMETER ( KXHEAV = 30 )
19840 CHARACTER*8 ANHEAV
19841 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19842 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19843 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19844 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19845 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19846 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19847 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19848 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19849 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19850 COMMON / FHEAVC / ANHEAV (KXHEAV)
19851
19852* event flag
19853 COMMON /DTEVNO/ NEVENT,ICASCA
19854
19855 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19856 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19857 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19858
19859 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19860 LOGICAL LLCPOT
19861 DATA EXC,NEXC /520*ZERO,520*0/
19862 DATA EXPNUC /4.0D-3,4.0D-3/
19863
19864 IREJ = 0
19865 LRCLPR = .FALSE.
19866 LRCLTA = .FALSE.
19867
19868* skip residual nucleus treatment if not requested or in case
19869* of central collisions
19870 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19871
19872 DO 1 K=1,2
19873 IDPAR(K) = 0
19874 IDXPAR(K)= 0
19875 NTOT(K) = 0
19876 NTOTFI(K)= 0
19877 NPRO(K) = 0
19878 NPROFI(K)= 0
19879 NN(K) = 0
19880 NH(K) = 0
19881 NHPOS(K) = 0
19882 NQ(K) = 0
19883 EEXC(K) = ZERO
19884 MO1(K) = 0
19885 MO2(K) = 0
19886 DO 2 I=1,4
19887 VRCL(K,I) = ZERO
19888 WRCL(K,I) = ZERO
19889 2 CONTINUE
19890 1 CONTINUE
19891 NFSP = 0
19892 INUC(1) = IP
19893 INUC(2) = IT
19894
19895 DO 3 I=1,NHKK
19896
19897* number of final state particles
19898 IF (ABS(ISTHKK(I)).EQ.1) THEN
19899 NFSP = NFSP+1
19900 IDFSP = IDBAM(I)
19901 ENDIF
19902
19903* properties of remaining nucleon configurations
19904 KF = 0
19905 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19906 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19907 IF (KF.GT.0) THEN
19908 IF (MO1(KF).EQ.0) MO1(KF) = I
19909 MO2(KF) = I
19910* position of residual nucleus = average position of nucleons
19911 DO 4 K=1,4
19912 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19913 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19914 4 CONTINUE
19915* total number of particles contributing to each residual nucleus
19916 NTOT(KF) = NTOT(KF)+1
19917 IDTMP = IDBAM(I)
19918 IDXTMP = I
19919* total charge of residual nuclei
19920 NQ(KF) = NQ(KF)+IICH(IDTMP)
19921* number of protons
19922 IF (IDHKK(I).EQ.2212) THEN
19923 NPRO(KF) = NPRO(KF)+1
19924* number of neutrons
19925 ELSEIF (IDHKK(I).EQ.2112) THEN
19926 NN(KF) = NN(KF)+1
19927 ELSE
19928* number of baryons other than n, p
19929 IF (IIBAR(IDTMP).EQ.1) THEN
19930 NH(KF) = NH(KF)+1
19931 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19932 ELSE
19933* any other mesons (status set to 1)
19934C WRITE(LOUT,1002) KF,IDTMP
19935C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19936C & ' containing meson ',I4,', status set to 1')
19937 ISTHKK(I) = 1
19938 IDTMP = IDPAR(KF)
19939 IDXTMP = IDXPAR(KF)
19940 NTOT(KF) = NTOT(KF)-1
19941 ENDIF
19942 ENDIF
19943 IDPAR(KF) = IDTMP
19944 IDXPAR(KF) = IDXTMP
19945 ENDIF
19946 3 CONTINUE
19947
19948* reject elastic events (def: one final state particle = projectile)
19949 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19950 IREXCI(3) = IREXCI(3)+1
19951 GOTO 9999
19952C RETURN
19953 ENDIF
19954
19955* check if one nucleus disappeared..
19956C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19957C DO 5 K=1,4
19958C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19959C PRCLPR(K) = ZERO
19960C 5 CONTINUE
19961C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19962C DO 6 K=1,4
19963C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19964C PRCLTA(K) = ZERO
19965C 6 CONTINUE
19966C ENDIF
19967
19968 ICOR = 0
19969 INORCL = 0
19970 DO 7 I=1,2
19971 DO 8 K=1,4
19972* get the average of the nucleon positions
19973 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19974 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19975 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19976 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19977 8 CONTINUE
19978* mass number and charge of residual nuclei
19979 AIF(I) = DBLE(NTOT(I))
19980 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19981 IF (NTOT(I).GT.1) THEN
19982* masses of residual nuclei in ground state
19983
19984C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19985 AMRCL0(I) = AIF(I)*AMUC12
19986 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19987
19988* masses of residual nuclei
19989 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19990 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19991 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19992*
19993* M_res^2 < 0 : configuration not allowed
19994*
19995* a) re-calculate E_exc with scaled nuclear potential
19996* (conditional jump to label 9998)
19997* b) or reject event if N_loop(max) is exceeded
19998* (conditional jump to label 9999)
19999*
20000 IF (AMRCL(I).LE.ZERO) THEN
20001 IF (IOULEV(3).GT.0)
20002 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20003 & PRCL(I,4),NTOT
20004 1000 FORMAT(1X,'warning! negative excitation energy',/,
20005 & I4,4E15.4,2I4)
20006 AMRCL(I) = ZERO
20007 EEXC(I) = ZERO
20008 IF (NLOOP.LE.500) THEN
20009 GOTO 9998
20010 ELSE
20011 IREXCI(2) = IREXCI(2)+1
20012 GOTO 9999
20013 ENDIF
20014*
20015* 0 < M_res < M_res0 : mass below ground-state mass
20016*
20017* a) we had residual nuclei with mass N_tot and reasonable E_exc
20018* before- assign average E_exc of those configurations to this
20019* one ( Nexc(i,N_tot) > 0 )
20020* b) or (and this applies always if run in transport codes) go up
20021* one mass number and
20022* i) if mass now larger than proj/targ mass or if run in
20023* transport codes assign average E_exc per wounded nucleon
20024* x number of wounded nucleons (Inuc-Ntot)
20025* ii) or assign average E_exc of those configurations to this
20026* one ( Nexc(i,m) > 0 )
20027*
20028 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20029 & THEN
20030 M = MIN(NTOT(I),260)
20031 IF (NEXC(I,M).GT.0) THEN
20032 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20033 ELSE
20034 70 CONTINUE
20035 M = M+1
20036**sr corrected 27.12.06
20037* IF (M.GE.INUC(I)) THEN
20038* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20039 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20040 IF ( INUC (I) .GT. NTOT (I) ) THEN
20041 AMRCL(I) = AMRCL0(I)
20042 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20043 ELSE
20044 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20045 END IF
20046**
20047 ELSE
20048 IF (NEXC(I,M).GT.0) THEN
20049 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20050 ELSE
20051 GOTO 70
20052 ENDIF
20053 ENDIF
20054 ENDIF
20055 EEXC(I) = AMRCL(I)-AMRCL0(I)
20056 ICOR = ICOR+I
20057*
20058* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20059*
20060* a) re-calculate E_exc with scaled nuclear potential
20061* (conditional jump to label 9998)
20062* b) or reject event if N_loop(max) is exceeded
20063* (conditional jump to label 9999)
20064*
20065*
20066 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20067 IF (IOULEV(3).GT.0)
20068 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20069 1004 FORMAT(1X,'warning! too high excitation energy',/,
20070 & I4,1P,2E15.4,3I5)
20071 AMRCL(I) = ZERO
20072 EEXC(I) = ZERO
20073 IF (NLOOP.LE.500) THEN
20074 GOTO 9998
20075 ELSE
20076 IREXCI(2) = IREXCI(2)+1
20077 GOTO 9999
20078 ENDIF
20079*
20080* Otherwise (reasonable E_exc) :
20081* E_exc = M_res - M_res0
20082* in addition: calculate and save E_exc per wounded nucleon as
20083* well as E_exc in <E_exc> counter
20084*
20085 ELSE
20086* excitation energies of residual nuclei
20087 EEXC(I) = AMRCL(I)-AMRCL0(I)
20088**sr 27.12.06 new excitation energy correction by A.F.
20089*
20090* all parts with Ilcopt<3 commented since not used
20091*
20092* still to be done/decided:
20093* Increase Icor and put back both residual nuclei on mass shell
20094* with the exciting correction further below.
20095* For the moment the modification in the excitation energy is simply
20096* corrected by scaling the energy of the residual nucleus.
20097*
20098 LLCPOT = .TRUE.
20099 ILCOPT = 3
20100 IF ( LLCPOT ) THEN
20101 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20102 IF ( ILCOPT .LE. 2 ) THEN
20103C* Patch for Fermi momentum reduction correlated with impact parameter:
20104C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20105C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20106C AKPRHO = ONE - DLKPRH
20107C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20108C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20109C & 0.05D+00 )
20110C* REDORI = 0.75D+00
20111C* REDORI = ONE
20112C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20113 ELSE
20114 DLKPRH = ZERO
20115 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20116* Take out roughly one/half of the skin:
20117 RDCORE = RDCORE - 0.5D+00
20118 FRCFLL = RDCORE**3
20119 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20120 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20121 FRCFLL = ONE - PRSKIN
20122 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20123 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20124 END IF
20125 IF ( NNCHIT .GT. 0 ) THEN
20126C IF ( ILCOPT .EQ. 1 ) THEN
20127C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20128C DO 1220 NCH = 1, 10
20129C ETAETA = ( ONE - SKINRH**INUC(I)
20130C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20131C & * ( ONE - SKINRH ) )
20132C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20133C & * ( ONE - FRCFLL) * SKINRH )
20134C SKINRH = SKINRH * ( ONE + ETAETA )
20135C 1220 CONTINUE
20136C PRSKIN = SKINRH**(NNCHIT-1)
20137C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20138C PRSKIN = ONE - FRCFLL
20139C END IF
20140 REDCTN = ZERO
20141 DO 1230 NCH = 1, NNCHIT
20142 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20143 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20144 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20145 ELSE
20146 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20147 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20148 END IF
20149 REDCTN = REDCTN + PRFRMI**2
20150 1230 CONTINUE
20151 REDCTN = REDCTN / DBLE (NNCHIT)
20152 ELSE
20153 REDCTN = 0.5D+00
20154 END IF
20155 EEXC (I) = EEXC (I) * REDCTN / REDORI
20156 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20157 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20158 END IF
20159**
20160 IF (ICASCA.EQ.0) THEN
20161 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20162 M = MIN(NTOT(I),260)
20163 EXC(I,M) = EXC(I,M)+EEXC(I)
20164 NEXC(I,M) = NEXC(I,M)+1
20165 ENDIF
20166 ENDIF
20167 ELSEIF (NTOT(I).EQ.1) THEN
20168 WRITE(LOUT,1003) I
20169 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20170 GOTO 9999
20171 ELSE
20172 AMRCL0(I) = ZERO
20173 AMRCL(I) = ZERO
20174 EEXC(I) = ZERO
20175 INORCL = INORCL+I
20176 ENDIF
20177 7 CONTINUE
20178
20179 PRCLPR(5) = AMRCL(1)
20180 PRCLTA(5) = AMRCL(2)
20181
20182 IF (ICOR.GT.0) THEN
20183 IF (INORCL.EQ.0) THEN
20184* one or both residual nuclei consist of one nucleon only, transform
20185* this nucleon on mass shell
20186 DO 9 K=1,4
20187 P1IN(K) = PRCL(1,K)
20188 P2IN(K) = PRCL(2,K)
20189 9 CONTINUE
20190 XM1 = AMRCL(1)
20191 XM2 = AMRCL(2)
20192 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20193 IF (IREJ1.GT.0) THEN
20194 WRITE(LOUT,*) 'ficonf-mashel rejection'
20195 GOTO 9999
20196 ENDIF
20197 DO 10 K=1,4
20198 PRCL(1,K) = P1OUT(K)
20199 PRCL(2,K) = P2OUT(K)
20200 PRCLPR(K) = P1OUT(K)
20201 PRCLTA(K) = P2OUT(K)
20202 10 CONTINUE
20203 PRCLPR(5) = AMRCL(1)
20204 PRCLTA(5) = AMRCL(2)
20205 ELSE
20206 IF (IOULEV(3).GT.0)
20207 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20208 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20209 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20210 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20211 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20212 & ' correction',/,11X,'at event',I8,
20213 & ', nucleon config. 1:',2I4,' 2:',2I4,
20214 & 2(/,11X,3E12.3))
20215 IF (NLOOP.LE.500) THEN
20216 GOTO 9998
20217 ELSE
20218 IREXCI(1) = IREXCI(1)+1
20219 ENDIF
20220 ENDIF
20221 ENDIF
20222
20223* update counter
20224C IF (NRESEV(1).NE.NEVHKK) THEN
20225C NRESEV(1) = NEVHKK
20226C NRESEV(2) = NRESEV(2)+1
20227C ENDIF
20228 NRESEV(2) = NRESEV(2)+1
20229 DO 15 I=1,2
20230 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20231 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20232 NRESTO(I) = NRESTO(I)+NTOT(I)
20233 NRESPR(I) = NRESPR(I)+NPRO(I)
20234 NRESNU(I) = NRESNU(I)+NN(I)
20235 NRESBA(I) = NRESBA(I)+NH(I)
20236 NRESPB(I) = NRESPB(I)+NHPOS(I)
20237 NRESCH(I) = NRESCH(I)+NQ(I)
20238 15 CONTINUE
20239
20240* evaporation
20241 IF (LEVPRT) THEN
20242 DO 13 I=1,2
20243* initialize evaporation counter
20244 EEXCFI(I) = ZERO
20245 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20246 & (EEXC(I).GT.ZERO)) THEN
20247* put residual nuclei into DTEVT1
20248 IDRCL = 80000
20249 JMASS = INT( AIF(I))
20250 JCHAR = INT(AIZF(I))
20251* the following patch is required to transmit the correct excitation
20252* energy to Eventd
20253 IF (ITRSPT.EQ.1) THEN
20254 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20255 & (IOULEV(3).GT.0))
20256 & WRITE(LOUT,*)
20257 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20258 & AMRCL(I),AMRCL0(I),EEXC(I)
20259 PRCL0 = PRCL(I,4)
20260 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20261 & +PRCL(I,3)**2)
20262 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20263 WRITE(LOUT,*)
20264 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20265 ENDIF
20266 ENDIF
20267 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20268 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20269**sr 22.6.97
20270 NOBAM(NHKK) = I
20271**
20272 DO 14 J=1,4
20273 VHKK(J,NHKK) = VRCL(I,J)
20274 WHKK(J,NHKK) = WRCL(I,J)
20275 14 CONTINUE
20276* interface to evaporation module - fill final residual nucleus into
20277* common FKRESN
20278* fill resnuc only if code is not used as event generator in Fluka
20279 IF (ITRSPT.NE.1) THEN
20280 PXRES = PRCL(I,1)
20281 PYRES = PRCL(I,2)
20282 PZRES = PRCL(I,3)
20283 IBRES = NPRO(I)+NN(I)+NH(I)
20284 ICRES = NPRO(I)+NHPOS(I)
20285 ANOW = DBLE(IBRES)
20286 ZNOW = DBLE(ICRES)
20287 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20288* ground state mass of the residual nucleus (should be equal to AM0T)
20289
20290 AMNRES = AMRCL0(I)
20291 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20292
20293* common FKFINU
20294 TV = ZERO
20295* kinetic energy of residual nucleus
20296 TVRECL = PRCL(I,4)-AMRCL(I)
20297* excitation energy of residual nucleus
20298 TVCMS = EEXC(I)
20299 PTOLD = PTRES
20300 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20301 & 2.0D0*(AMMRES+TVCMS))))
20302 IF (PTOLD.LT.ANGLGB) THEN
20303 CALL DT_RACO(PXRES,PYRES,PZRES)
20304 PTOLD = ONE
20305 ENDIF
20306 PXRES = PXRES*PTRES/PTOLD
20307 PYRES = PYRES*PTRES/PTOLD
20308 PZRES = PZRES*PTRES/PTOLD
20309* zero counter of secondaries from evaporation
20310 NP = 0
20311* evaporation
20312 WE = ONE
20313
20314 NPHEAV = 0
20315 LRNFSS = .FALSE.
20316 LFRAGM = .FALSE.
20317 CALL EVEVAP(WE)
20318
20319* put evaporated particles and residual nuclei to DTEVT1
20320 MO = NHKK
20321 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20322 ENDIF
20323 EEXCFI(I) = EXCITF
20324 EXCEVA(I) = EXCEVA(I)+EXCITF
20325 ENDIF
20326 13 CONTINUE
20327 ENDIF
20328
20329 RETURN
20330
20331C9998 IREXCI(1) = IREXCI(1)+1
20332 9998 IREJ = IREJ+1
20333 9999 CONTINUE
20334 LRCLPR = .TRUE.
20335 LRCLTA = .TRUE.
20336 IREJ = IREJ+1
20337 RETURN
20338 END
20339
20340*$ CREATE DT_EVA2HE.FOR
20341*COPY DT_EVA2HE
20342* *
20343*====eva2he============================================================*
20344* *
20345 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20346
20347************************************************************************
20348* Interface between common's of evaporation module (FKFINU,FKFHVY) *
20349* and DTEVT1. *
20350* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20351* EEXCF exitation energy of residual nucleus after evaporation *
20352* IRCL = 1 projectile residual nucleus *
20353* = 2 target residual nucleus *
20354* This version dated 19.04.95 is written by S. Roesler. *
20355* *
20356* Last change 27.12.2006 by S. Roesler. *
20357************************************************************************
20358
20359 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20360 SAVE
20361
20362 PARAMETER ( LINP = 10 ,
20363 & LOUT = 6 ,
20364 & LDAT = 9 )
20365
20366 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20367
20368* event history
20369
20370 PARAMETER (NMXHKK=200000)
20371
20372 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20373 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20374 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20375* Note: DTEVT2 - special use for heavy fragments !
20376* (IDRES(I) = mass number, IDXRES(I) = charge)
20377
20378* extended event history
20379 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20380 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20381 & IHIST(2,NMXHKK)
20382
20383* particle properties (BAMJET index convention)
20384 CHARACTER*8 ANAME
20385 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20386 & IICH(210),IIBAR(210),K1(210),K2(210)
20387
20388* flags for input different options
20389 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20390 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20391 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20392
20393* statistics: residual nuclei
20394 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20395 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20396 & NINCST(2,4),NINCEV(2),
20397 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20398 & NRESPB(2),NRESCH(2),NRESEV(4),
20399 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20400 & NEVAFI(2,2)
20401
20402* treatment of residual nuclei: properties of residual nuclei
20403 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20404 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20405 & NTOTFI(2),NPROFI(2)
20406
20407* INCLUDE '(DIMPAR)'
20408* Taken from FLUKA
20409 PARAMETER ( MXXRGN =20000 )
20410 PARAMETER ( MXXMDF = 710 )
20411 PARAMETER ( MXXMDE = 702 )
20412 PARAMETER ( MFSTCK =40000 )
20413 PARAMETER ( MESTCK = 100 )
20414 PARAMETER ( MOSTCK = 2000 )
20415 PARAMETER ( MXPRSN = 100 )
20416 PARAMETER ( MXPDPM = 800 )
20417 PARAMETER ( MXPSCS =30000 )
20418 PARAMETER ( MXGLWN = 300 )
20419 PARAMETER ( MXOUTU = 50 )
20420 PARAMETER ( NALLWP = 64 )
20421 PARAMETER ( NELEMX = 80 )
20422 PARAMETER ( MPDPDX = 18 )
20423 PARAMETER ( MXHTTR = 260 )
20424 PARAMETER ( MXSEAX = 20 )
20425 PARAMETER ( MXHTNC = MXSEAX + 1 )
20426 PARAMETER ( ICOMAX = 2400 )
20427 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20428 PARAMETER ( NSTBIS = 304 )
20429 PARAMETER ( NQSTIS = 46 )
20430 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20431 PARAMETER ( MXPABL = 120 )
20432 PARAMETER ( IDMAXP = 450 )
20433 PARAMETER ( IDMXDC = 2000 )
20434 PARAMETER ( MXMCIN = 410 )
20435 PARAMETER ( IHYPMX = 4 )
20436 PARAMETER ( MKBMX1 = 11 )
20437 PARAMETER ( MKBMX2 = 11 )
20438 PARAMETER ( MXIRRD = 2500 )
20439 PARAMETER ( MXTRDC = 1500 )
20440 PARAMETER ( NKTL = 17 )
20441 PARAMETER ( NBLNMX = 40000000 )
20442
20443* INCLUDE '(GENSTK)'
20444* Taken from FLUKA
20445 PARAMETER ( MXP = MXPSCS )
20446*
20447 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20448 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20449 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20450 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20451 & TVRECL, TVHEAV, TVBIND,
20452 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20453
20454* INCLUDE '(RESNUC)'
20455 LOGICAL LRNFSS, LFRAGM
20456 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20457 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20458 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20459 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20460 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20461 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20462 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20463 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20464 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20465 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20466 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20467 & LRNFSS, LFRAGM
20468* Taken from FLUKA
20469
20470* INCLUDE '(FHEAVY)'
20471* Taken from FLUKA
20472 PARAMETER ( MXHEAV = 100 )
20473 PARAMETER ( KXHEAV = 30 )
20474 CHARACTER*8 ANHEAV
20475 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20476 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20477 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20478 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20479 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20480 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20481 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20482 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20483 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20484 COMMON / FHEAVC / ANHEAV (KXHEAV)
20485
20486 DIMENSION IPTOKP(39)
20487 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20488 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20489 & 100, 101, 97, 102, 98, 103, 109, 115 /
20490
20491 IREJ = 0
20492
20493* skip if evaporation package is not included
20494 IF (.NOT.LEVAPO) RETURN
20495
20496* update counter
20497 IF (NRESEV(3).NE.NEVHKK) THEN
20498 NRESEV(3) = NEVHKK
20499 NRESEV(4) = NRESEV(4)+1
20500 ENDIF
20501
20502 IF (LEMCCK)
20503 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20504 & IDUM,IDUM)
20505* mass number/charge of residual nucleus before evaporation
20506 IBTOT = IDRES(MO)
20507 IZTOT = IDXRES(MO)
20508
20509* protons/neutrons/gammas
20510 DO 1 I=1,NP
20511 PX = CXR(I)*PLR(I)
20512 PY = CYR(I)*PLR(I)
20513 PZ = CZR(I)*PLR(I)
20514 ID = IPTOKP(KPART(I))
20515 IDPDG = IDT_IPDGHA(ID)
20516 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20517 & (2.0D0*MAX(TKI(I),TINY10))
20518 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20519 WRITE(LOUT,1000) ID,AM,AAM(ID)
20520 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20521 & 'particle',I3,2E10.3)
20522 ENDIF
20523 PE = TKI(I)+AM
20524 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20525 NOBAM(NHKK) = IRCL
20526 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20527 IBTOT = IBTOT-IIBAR(ID)
20528 IZTOT = IZTOT-IICH(ID)
20529 1 CONTINUE
20530
20531* heavy fragments
20532 DO 2 I=1,NPHEAV
20533 PX = CXHEAV(I)*PHEAVY(I)
20534 PY = CYHEAV(I)*PHEAVY(I)
20535 PZ = CZHEAV(I)*PHEAVY(I)
20536 IDHEAV = 80000
20537 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20538 & (2.0D0*MAX(TKHEAV(I),TINY10))
20539 PE = TKHEAV(I)+AM
20540 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20541 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20542 NOBAM(NHKK) = IRCL
20543 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20544 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20545 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20546 2 CONTINUE
20547
20548 IF (IBRES.GT.0) THEN
20549* residual nucleus after evaporation
20550 IDNUC = 80000
20551 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20552 & IBRES,ICRES,0)
20553 NOBAM(NHKK) = IRCL
20554 ENDIF
20555 EEXCF = TVCMS
20556 NTOTFI(IRCL) = IBRES
20557 NPROFI(IRCL) = ICRES
20558 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20559 IBTOT = IBTOT-IBRES
20560 IZTOT = IZTOT-ICRES
20561
20562* count events with fission
20563 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20564 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20565
20566* energy-momentum conservation check
20567 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20568C IF (IREJ.GT.0) THEN
20569C CALL DT_EVTOUT(4)
20570C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20571C ENDIF
20572* baryon-number/charge conservation check
20573 IF (IBTOT+IZTOT.NE.0) THEN
20574 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20575 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20576 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20577 ENDIF
20578
20579 RETURN
20580 END
20581
20582*$ CREATE DT_EBIND.FOR
20583*COPY DT_EBIND
20584*
20585*===ebind==============================================================*
20586*
20587 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20588
20589************************************************************************
20590* Binding energy for nuclei. *
20591* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20592* IA mass number *
20593* IZ atomic number *
20594* This version dated 5.5.95 is updated by S. Roesler. *
20595************************************************************************
20596
20597 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20598 SAVE
20599
20600 PARAMETER ( LINP = 10 ,
20601 & LOUT = 6 ,
20602 & LDAT = 9 )
20603
20604 PARAMETER (ZERO=0.0D0)
20605
20606 DATA A1, A2, A3, A4, A5
20607 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20608
20609 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20610 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20611 DT_EBIND = ZERO
20612 RETURN
20613 ENDIF
20614 AA = IA
20615 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20616 & -A4*(IA-2*IZ)**2/AA
20617 IF (MOD(IA,2).EQ.1) THEN
20618 IA5 = 0
20619 ELSEIF (MOD(IZ,2).EQ.1) THEN
20620 IA5 = 1
20621 ELSE
20622 IA5 = -1
20623 ENDIF
20624 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20625
20626 RETURN
20627 END
20628
20629************************************************************************
20630* *
20631* DPMJET 3.0: cross section routines *
20632* *
20633************************************************************************
20634*
20635*
20636* SUBROUTINE DT_SHNDIF
20637* diffractive cross sections (all energies)
20638* SUBROUTINE DT_PHOXS
20639* total and inel. cross sections from PHOJET interpol. tables
20640* SUBROUTINE DT_XSHN
20641* total and el. cross sections for all energies
20642* SUBROUTINE DT_SIHNAB
20643* pion 2-nucleon absorption cross sections
20644* SUBROUTINE DT_SIGEMU
20645* cross section for target "compounds"
20646* SUBROUTINE DT_SIGGA
20647* photon nucleus cross sections
20648* SUBROUTINE DT_SIGGAT
20649* photon nucleus cross sections from tables
20650* SUBROUTINE DT_SANO
20651* anomalous hard photon-nucleon cross sections from tables
20652* SUBROUTINE DT_SIGGP
20653* photon nucleon cross sections
20654* SUBROUTINE DT_SIGVEL
20655* quasi-elastic vector meson prod. cross sections
20656* DOUBLE PRECISION FUNCTION DT_SIGVP
20657* sigma_VN(tilde)
20658* DOUBLE PRECISION FUNCTION DT_RRM2
20659* DOUBLE PRECISION FUNCTION DT_RM2
20660* DOUBLE PRECISION FUNCTION DT_SAM2
20661* SUBROUTINE DT_CKMT
20662* SUBROUTINE DT_CKMTX
20663* SUBROUTINE DT_PDF0
20664* SUBROUTINE DT_CKMTQ0
20665* SUBROUTINE DT_CKMTDE
20666* SUBROUTINE DT_CKMTPR
20667* FUNCTION DT_CKMTFF
20668*
20669* SUBROUTINE DT_FLUINI
20670* total nucleon cross section fluctuation treatment
20671*
20672* SUBROUTINE DT_SIGTBL
20673* pre-tabulation of low-energy elastic x-sec. using SIHNEL
20674* SUBROUTINE DT_XSTABL
20675* service routines
20676*
20677*
20678*$ CREATE DT_SHNDIF.FOR
20679*COPY DT_SHNDIF
20680*
20681*===shndif===============================================================*
20682*
20683 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20684
20685**********************************************************************
20686* Single diffractive hadron-nucleon cross sections *
20687* S.Roesler 14/1/93 *
20688* *
20689* The cross sections are calculated from extrapolated single *
20690* diffractive antiproton-proton cross sections (DTUJET92) using *
20691* scaling relations between total and single diffractive cross *
20692* sections. *
20693**********************************************************************
20694
20695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20696 SAVE
20697 PARAMETER (ZERO=0.0D0)
20698
20699* particle properties (BAMJET index convention)
20700 CHARACTER*8 ANAME
20701 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20702 & IICH(210),IIBAR(210),K1(210),K2(210)
20703*
20704 CSD1 = 4.201483727D0
20705 CSD4 = -0.4763103556D-02
20706 CSD5 = 0.4324148297D0
20707*
20708 CHMSD1 = 0.8519297242D0
20709 CHMSD4 = -0.1443076599D-01
20710 CHMSD5 = 0.4014954567D0
20711*
20712 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20713 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20714*
20715 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20716 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20717 FRAC = SHMSD/SDIAPP
20718*
20719 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20720 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20721 & 10, 10, 20, 20, 20) KPROJ
20722*
20723 10 CONTINUE
20724*---------------------------- p - p , n - p , sigma0+- - p ,
20725* Lambda - p
20726 CSD1 = 6.004476070D0
20727 CSD4 = -0.1257784606D-03
20728 CSD5 = 0.2447335720D0
20729 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20730 SIGDIH = FRAC*SIGDIF
20731 RETURN
20732*
20733 20 CONTINUE
20734*
20735 KPSCAL = 2
20736 KTSCAL = 1
20737C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20738 DUMZER = ZERO
20739 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20740 F = SDIAPP/SIGTO
20741 KT = 1
20742C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20743 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20744 SIGDIF = SIGTO*F
20745 SIGDIH = FRAC*SIGDIF
20746 RETURN
20747*
20748 999 CONTINUE
20749*-------------------------- leptons..
20750 SIGDIF = 1.D-10
20751 SIGDIH = 1.D-10
20752 RETURN
20753 END
20754
20755*$ CREATE DT_PHOXS.FOR
20756*COPY DT_PHOXS
20757*
20758*===phoxs================================================================*
20759*
20760 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20761
20762************************************************************************
20763* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20764* interpolation tables. *
20765* This version dated 05.11.97 is written by S. Roesler *
20766************************************************************************
20767
20768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20769 SAVE
20770
20771 PARAMETER ( LINP = 10 ,
20772 & LOUT = 6 ,
20773 & LDAT = 9 )
20774
20775 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20776 PARAMETER (TWOPI = 6.283185307179586454D+00,
20777 & PI = TWOPI/TWO,
20778 & GEV2MB = 0.38938D0)
20779
20780 LOGICAL LFIRST
20781 DATA LFIRST /.TRUE./
20782
20783* nucleon-nucleon event-generator
20784 CHARACTER*8 CMODEL
20785 LOGICAL LPHOIN
20786 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20787
20788* particle properties (BAMJET index convention)
20789 CHARACTER*8 ANAME
20790 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20791 & IICH(210),IIBAR(210),K1(210),K2(210)
20792
20793**PHOJET105a
20794C PARAMETER (IEETAB=10)
20795C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20796**PHOJET110
20797
20798C energy-interpolation table
20799 INTEGER IEETA2
20800 PARAMETER ( IEETA2 = 20 )
20801 INTEGER ISIMAX
20802 DOUBLE PRECISION SIGTAB,SIGECM
20803 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20804**
20805
20806 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20807 WRITE(LOUT,*) MCGENE
20808 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20809 STOP
20810 ENDIF
20811
20812 IF (ECM.LE.ZERO) THEN
20813 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20814 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20815 ENDIF
20816
20817 IF (MODE.EQ.1) THEN
20818* DL
20819 DELDL = 0.0808D0
20820 EPSDL = -0.4525D0
20821 S = ECM*ECM
20822 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20823 ALPHAP= 0.25D0
20824 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20825 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20826 SINE = STOT-SIGEL
20827 SDIF1 = ZERO
20828 ELSE
20829* Phojet
20830 IP = 1
20831 IF(ECM.LE.SIGECM(IP,1)) THEN
20832 I1 = 1
20833 I2 = 1
20834 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20835 DO 1 I=2,ISIMAX
20836 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20837 1 CONTINUE
20838 2 CONTINUE
20839 I1 = I-1
20840 I2 = I
20841 ELSE
20842 IF (LFIRST) THEN
20843 WRITE(LOUT,'(/1X,A,2E12.3)')
20844 & 'PHOXS: warning! energy above initialization limit (',
20845 & ECM,SIGECM(IP,ISIMAX)
20846 LFIRST = .FALSE.
20847 ENDIF
20848 I1 = ISIMAX
20849 I2 = ISIMAX
20850 ENDIF
20851 FAC2 = ZERO
20852 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20853 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20854 FAC1 = ONE-FAC2
20855 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20856 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20857 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20858 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20859 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20860 ENDIF
20861
20862 RETURN
20863 END
20864
20865*$ CREATE DT_XSHN.FOR
20866*COPY DT_XSHN
20867*
20868*===xshn===============================================================*
20869*
20870 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20871
20872************************************************************************
20873* Total and elastic hadron-nucleon cross section. *
20874* Below 500GeV cross sections are based on the '98 data compilation *
20875* of the PDG. At higher energies PHOJET results are used (patched to *
20876* the low energy data at 500GeV). *
20877* IP projectile index (BAMJET numbering scheme) *
20878* (should be in the range 1..25) *
20879* IT target index (BAMJET numbering scheme) *
20880* (1 = proton, 8 = neutron) *
20881* PL laboratory momentum *
20882* ECM cm. energy (ignored if PL>0) *
20883* STOT total cross section *
20884* SELA elastic cross section *
20885* Last change: 24.4.99 by S. Roesler *
20886************************************************************************
20887
20888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20889 SAVE
20890
20891 PARAMETER ( LINP = 10 ,
20892 & LOUT = 6 ,
20893 & LDAT = 9 )
20894
20895 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20896
20897 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20898 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20899 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20900
20901 LOGICAL LFIRST
20902
20903* particle properties (BAMJET index convention)
20904 CHARACTER*8 ANAME
20905 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20906 & IICH(210),IIBAR(210),K1(210),K2(210)
20907
20908* nucleon-nucleon event-generator
20909 CHARACTER*8 CMODEL
20910 LOGICAL LPHOIN
20911 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20912**PHOJET105a
20913C PARAMETER (IEETAB=10)
20914C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20915**PHOJET110
20916
20917C energy-interpolation table
20918 INTEGER IEETA2
20919 PARAMETER ( IEETA2 = 20 )
20920 INTEGER ISIMAX
20921 DOUBLE PRECISION SIGTAB,SIGECM
20922 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20923
20924 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20925 DIMENSION IDXDAT(25,2)
20926*
20927 DATA APL /
20928 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20929 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20930 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20931 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20932 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20933 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20934 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20935*
20936* total cross sections:
20937* p p
20938 DATA (ASIGTO(1,K),K=1,NPOINT) /
20939 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20940 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20941 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20942 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20943 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20944 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20945 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20946* pbar p
20947 DATA (ASIGTO(2,K),K=1,NPOINT) /
20948 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20949 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20950 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20951 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20952 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20953 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20954 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20955* n p
20956 DATA (ASIGTO(3,K),K=1,NPOINT) /
20957 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20958 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20959 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20960 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20961 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20962 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20963 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20964* pi+ p
20965 DATA (ASIGTO(4,K),K=1,NPOINT) /
20966 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20967 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20968 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20969 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20970 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20971 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20972 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20973* pi- p
20974 DATA (ASIGTO(5,K),K=1,NPOINT) /
20975 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20976 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20977 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20978 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20979 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20980 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20981 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20982* K+ p
20983 DATA (ASIGTO(6,K),K=1,NPOINT) /
20984 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20985 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20986 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20987 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20988 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
20989 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
20990 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
20991* K- p
20992 DATA (ASIGTO(7,K),K=1,NPOINT) /
20993 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
20994 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
20995 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
20996 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
20997 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
20998 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
20999 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21000* K+ n
21001 DATA (ASIGTO(8,K),K=1,NPOINT) /
21002 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21003 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21004 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21005 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21006 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21007 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21008 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21009* K- n
21010 DATA (ASIGTO(9,K),K=1,NPOINT) /
21011 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21012 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21013 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21014 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21015 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21016 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21017 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21018* Lambda p
21019 DATA (ASIGTO(10,K),K=1,NPOINT) /
21020 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21021 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21022 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21023 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21024 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21025 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21026 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21027*
21028* elastic cross sections:
21029* p p
21030 DATA (ASIGEL(1,K),K=1,NPOINT) /
21031 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21032 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21033 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21034 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21035 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21036 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21037 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21038* pbar p
21039 DATA (ASIGEL(2,K),K=1,NPOINT) /
21040 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21041 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21042 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21043 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21044 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21045 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21046 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21047* n p
21048 DATA (ASIGEL(3,K),K=1,NPOINT) /
21049 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21050 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21051 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21052 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21053 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21054 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21055 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21056* pi+ p
21057 DATA (ASIGEL(4,K),K=1,NPOINT) /
21058 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21059 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21060 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21061 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21062 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21063 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21064 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21065* pi- p
21066 DATA (ASIGEL(5,K),K=1,NPOINT) /
21067 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21068 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21069 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21070 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21071 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21072 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21073 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21074* K+ p
21075 DATA (ASIGEL(6,K),K=1,NPOINT) /
21076 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21077 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21078 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21079 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21080 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21081 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21082 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21083* K- p
21084 DATA (ASIGEL(7,K),K=1,NPOINT) /
21085 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21086 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21087 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21088 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21089 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21090 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21091 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21092* K+ n
21093 DATA (ASIGEL(8,K),K=1,NPOINT) /
21094 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21095 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21096 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21097 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21098 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21099 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21100 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21101* K- n
21102 DATA (ASIGEL(9,K),K=1,NPOINT) /
21103 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21104 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21105 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21106 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21107 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21108 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21109 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21110* Lambda p
21111 DATA (ASIGEL(10,K),K=1,NPOINT) /
21112 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21113 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21114 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21115 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21116 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21117 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21118 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21119
21120 DATA (IDXDAT(K,1),K=1,25) /
21121 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21122 & 1, 3,45, 8, 9/
21123 DATA (IDXDAT(K,2),K=1,25) /
21124 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21125 & 3, 1,45, 6, 7/
21126
21127 DATA LFIRST /.TRUE./
21128
21129 IF (LFIRST) THEN
21130 APLABL = LOG10(PLABLO)
21131 APLABH = LOG10(PLABHI)
21132 APTHRE = LOG10(PTHRE)
21133 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21134 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21135 DUM0 = ZERO
21136 PHOPLA = PLABHI
21137 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21138 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21139 IF (MCGENE.EQ.2) THEN
21140 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21141 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21142 ELSE
21143 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21144 ENDIF
21145 ELSE
21146 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21147 ENDIF
21148 PHOSEL = PHOSTO-PHOSIN
21149 APHOST = LOG10(PHOSTO)
21150 APHOSE = LOG10(PHOSEL)
21151 LFIRST = .FALSE.
21152 ENDIF
21153 STOT = ZERO
21154 SELA = ZERO
21155 PLAB = PL
21156 ECMS = ECM
21157 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21158 WRITE(LOUT,1000) IP,IT
21159 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21160 & 'proj/target',2I4)
21161 STOP
21162 ENDIF
21163
21164 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21165 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21166 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21167 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21168 WRITE(LOUT,1001) PLAB,ECMS
21169 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21170 STOP
21171 ENDIF
21172
21173* index of spectrum
21174 IDXP = IP
21175 IF (IP.GT.25) THEN
21176 IF (AAM(IP).GT.ZERO) THEN
21177 IF (ABS(IIBAR(IP)).GT.0) THEN
21178 IDXP = 1
21179 ELSE
21180 IDXP = 13
21181 ENDIF
21182 ELSE
21183 IDXP = 7
21184 ENDIF
21185 ENDIF
21186 IDXT = 1
21187 IF (IT.EQ.8) IDXT = 2
21188 IDXS = IDXDAT(IDXP,IDXT)
21189 IF (IDXS.EQ.0) RETURN
21190
21191* compute momentum bin indices
21192 IF (PLAB.LT.PLABLO) THEN
21193 IDX0 = 1
21194 IDX1 = 1
21195 ELSEIF (PLAB.GE.PLABHI) THEN
21196 IDX0 = NPOINT
21197 IDX1 = NPOINT
21198 ELSE
21199 APLAB = LOG10(PLAB)
21200 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21201 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21202 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21203 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21204 ENDIF
21205 IDX1 = IDX0+1
21206 ENDIF
21207
21208* interpolate cross section
21209 IF (IDXS.GT.10) THEN
21210 IDXS1 = IDXS/10
21211 IDXS2 = IDXS-10*IDXS1
21212 IF (IDX0.EQ.IDX1) THEN
21213 IF (IDX0.EQ.1) THEN
21214 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21215 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21216 ELSE
21217 DUM0 = ZERO
21218 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21219 PHOSEL = PHOSTO-PHOSIN
21220 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21221 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21222 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21223 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21224 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21225 ASELA = 0.5D0*(ASELA1+ASELA2)
21226 ENDIF
21227 ELSE
21228 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21229 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21230 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21231 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21232 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21233 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21234 ASELA1 = ASIGEL(IDXS1,IDX0)+
21235 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21236 ASELA2 = ASIGEL(IDXS2,IDX0)+
21237 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21238 ASELA = 0.5D0*(ASELA1+ASELA2)
21239 ENDIF
21240 ELSE
21241 IF (IDX0.EQ.IDX1) THEN
21242 IF (IDX0.EQ.1) THEN
21243 ASTOT = ASIGTO(IDXS,IDX0)
21244 ASELA = ASIGEL(IDXS,IDX0)
21245 ELSE
21246 DUM0 = ZERO
21247 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21248 PHOSEL = PHOSTO-PHOSIN
21249 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21250 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21251 ENDIF
21252 ELSE
21253 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21254 ASTOT = ASIGTO(IDXS,IDX0)+
21255 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21256 ASELA = ASIGEL(IDXS,IDX0)+
21257 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21258 ENDIF
21259 ENDIF
21260 STOT = 10.0D0**ASTOT
21261 SELA = 10.0D0**ASELA
21262
21263 RETURN
21264 END
21265
21266*$ CREATE DT_SIHNAB.FOR
21267*COPY DT_SIHNAB
21268*
21269*===sihnab===============================================================*
21270*
21271 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21272
21273**********************************************************************
21274* Pion 2-nucleon absorption cross sections. *
21275* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21276* taken from Ritchie PRC 28 (1983) 926 ) *
21277* This version dated 18.05.96 is written by S. Roesler *
21278**********************************************************************
21279
21280 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21281 SAVE
21282 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21283 PARAMETER (AMPR = 938.0D0,
21284 & AMPI = 140.0D0,
21285 & AMDE = TWO*AMPR,
21286 & A = -1.2D0,
21287 & B = 3.5D0,
21288 & C = 7.4D0,
21289 & D = 5600.0D0,
21290 & ER = 2136.0D0)
21291
21292 SIGABS = ZERO
21293 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21294 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21295 PTOT = PLAB*1.0D3
21296 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21297 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21298 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21299 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21300* approximate 3N-abs., I=1-abs. etc.
21301 SIGABS = SIGABS/0.40D0
21302* pi0-absorption (rough approximation!!)
21303 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21304
21305 RETURN
21306 END
21307
21308*$ CREATE DT_SIGEMU.FOR
21309*COPY DT_SIGEMU
21310*
21311*===sigemu=============================================================*
21312*
21313 SUBROUTINE DT_SIGEMU
21314
21315************************************************************************
21316* Combined cross section for target compounds. *
21317* This version dated 6.4.98 is written by S. Roesler *
21318************************************************************************
21319
21320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21321 SAVE
21322
21323 PARAMETER ( LINP = 10 ,
21324 & LOUT = 6 ,
21325 & LDAT = 9 )
21326
21327 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21328 & OHALF=0.5D0,ONE=1.0D0)
21329
21330 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21331
21332* Glauber formalism: cross sections
21333 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21334 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21335 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21336 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21337 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21338 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21339 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21340 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21341 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21342 & BSLOPE,NEBINI,NQBINI
21343
21344* emulsion treatment
21345 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21346 & NCOMPO,IEMUL
21347
21348* nucleon-nucleon event-generator
21349 CHARACTER*8 CMODEL
21350 LOGICAL LPHOIN
21351 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21352
21353 IF (MCGENE.NE.4) THEN
21354 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21355 WRITE(LOUT,'(15X,A)') '-----------------------'
21356 ENDIF
21357 DO 1 IE=1,NEBINI
21358 DO 2 IQ=1,NQBINI
21359 SIGTOT = ZERO
21360 SIGELA = ZERO
21361 SIGQEP = ZERO
21362 SIGQET = ZERO
21363 SIGQE2 = ZERO
21364 SIGPRO = ZERO
21365 SIGDEL = ZERO
21366 SIGDQE = ZERO
21367 ERRTOT = ZERO
21368 ERRELA = ZERO
21369 ERRQEP = ZERO
21370 ERRQET = ZERO
21371 ERRQE2 = ZERO
21372 ERRPRO = ZERO
21373 ERRDEL = ZERO
21374 ERRDQE = ZERO
21375 IF (NCOMPO.GT.0) THEN
21376 DO 3 IC=1,NCOMPO
21377 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21378 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21379 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21380 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21381 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21382 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21383 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21384 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21385 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21386 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21387 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21388 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21389 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21390 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21391 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21392 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21393 3 CONTINUE
21394 ERRTOT = SQRT(ERRTOT)
21395 ERRELA = SQRT(ERRELA)
21396 ERRQEP = SQRT(ERRQEP)
21397 ERRQET = SQRT(ERRQET)
21398 ERRQE2 = SQRT(ERRQE2)
21399 ERRPRO = SQRT(ERRPRO)
21400 ERRDEL = SQRT(ERRDEL)
21401 ERRDQE = SQRT(ERRDQE)
21402 ELSE
21403 SIGTOT = XSTOT(IE,IQ,1)
21404 SIGELA = XSELA(IE,IQ,1)
21405 SIGQEP = XSQEP(IE,IQ,1)
21406 SIGQET = XSQET(IE,IQ,1)
21407 SIGQE2 = XSQE2(IE,IQ,1)
21408 SIGPRO = XSPRO(IE,IQ,1)
21409 SIGDEL = XSDEL(IE,IQ,1)
21410 SIGDQE = XSDQE(IE,IQ,1)
21411 ERRTOT = XETOT(IE,IQ,1)
21412 ERRELA = XEELA(IE,IQ,1)
21413 ERRQEP = XEQEP(IE,IQ,1)
21414 ERRQET = XEQET(IE,IQ,1)
21415 ERRQE2 = XEQE2(IE,IQ,1)
21416 ERRPRO = XEPRO(IE,IQ,1)
21417 ERRDEL = XEDEL(IE,IQ,1)
21418 ERRDQE = XEDQE(IE,IQ,1)
21419 ENDIF
21420 IF (MCGENE.NE.4) THEN
21421 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21422 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21423 WRITE(LOUT,1001) SIGTOT,ERRTOT
21424 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21425 WRITE(LOUT,1002) SIGELA,ERRELA
21426 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21427 WRITE(LOUT,1003) SIGQEP,ERRQEP
21428 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21429 & F11.5,' mb')
21430 WRITE(LOUT,1004) SIGQET,ERRQET
21431 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21432 & F11.5,' mb')
21433 WRITE(LOUT,1005) SIGQE2,ERRQE2
21434 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21435 & ' +-',F11.5,' mb')
21436 WRITE(LOUT,1006) SIGPRO,ERRPRO
21437 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21438 WRITE(LOUT,1007) SIGDEL,ERRDEL
21439 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21440 WRITE(LOUT,1008) SIGDQE,ERRDQE
21441 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21442 ENDIF
21443
21444 2 CONTINUE
21445 1 CONTINUE
21446
21447 RETURN
21448 END
21449
21450*$ CREATE DT_SIGGA.FOR
21451*COPY DT_SIGGA
21452*
21453*===sigga==============================================================*
21454*
21455 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21456
21457************************************************************************
21458* Total/inelastic photon-nucleus cross sections. *
21459* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21460* production runs !!!! *
21461* This version dated 27.03.96 is written by S. Roesler *
21462************************************************************************
21463
21464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21465 SAVE
21466
21467 PARAMETER ( LINP = 10 ,
21468 & LOUT = 6 ,
21469 & LDAT = 9 )
21470
21471 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21472 & OHALF=0.5D0,ONE=1.0D0)
21473 PARAMETER (AMPROT = 0.938D0)
21474
21475 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21476
21477* Glauber formalism: cross sections
21478 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21479 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21480 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21481 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21482 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21483 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21484 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21485 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21486 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21487 & BSLOPE,NEBINI,NQBINI
21488
21489 NT = NTI
21490 X = XI
21491 Q2 = Q2I
21492 ECM = ECMI
21493 XNU = XNUI
21494 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21495 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21496 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21497 STOT = XSTOT(1,1,1)
21498 ETOT = XETOT(1,1,1)
21499 SIN = XSPRO(1,1,1)
21500 EIN = XEPRO(1,1,1)
21501
21502 RETURN
21503 END
21504
21505*$ CREATE DT_SIGGAT.FOR
21506*COPY DT_SIGGAT
21507*
21508*===siggat=============================================================*
21509*
21510 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21511
21512************************************************************************
21513* Total/inelastic photon-nucleus cross sections. *
21514* Uses pre-tabulated cross section. *
21515* This version dated 29.07.96 is written by S. Roesler *
21516************************************************************************
21517
21518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21519 SAVE
21520
21521 PARAMETER ( LINP = 10 ,
21522 & LOUT = 6 ,
21523 & LDAT = 9 )
21524
21525 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21526 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21527
21528 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21529
21530* Glauber formalism: cross sections
21531 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21532 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21533 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21534 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21535 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21536 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21537 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21538 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21539 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21540 & BSLOPE,NEBINI,NQBINI
21541
21542 NTARG = ABS(NT)
21543 I1 = 1
21544 I2 = 1
21545 RATE = ONE
21546 IF (NEBINI.GT.1) THEN
21547 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21548 I1 = NEBINI
21549 I2 = NEBINI
21550 RATE = ONE
21551 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21552 DO 1 I=2,NEBINI
21553 IF (ECMI.LT.ECMNN(I)) THEN
21554 I1 = I-1
21555 I2 = I
21556 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21557 GOTO 2
21558 ENDIF
21559 1 CONTINUE
21560 2 CONTINUE
21561 ENDIF
21562 ENDIF
21563 J1 = 1
21564 J2 = 1
21565 RATQ = ONE
21566 IF (NQBINI.GT.1) THEN
21567 IF (Q2I.GE.Q2G(NQBINI)) THEN
21568 J1 = NQBINI
21569 J2 = NQBINI
21570 RATQ = ONE
21571 ELSEIF (Q2I.GT.Q2G(1)) THEN
21572 DO 3 I=2,NQBINI
21573 IF (Q2I.LT.Q2G(I)) THEN
21574 J1 = I-1
21575 J2 = I
21576 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21577 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21578C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21579 GOTO 4
21580 ENDIF
21581 3 CONTINUE
21582 4 CONTINUE
21583 ENDIF
21584 ENDIF
21585
21586 STOT = XSTOT(I1,J1,NTARG)+
21587 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21588 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21589 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21590 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21591
21592 RETURN
21593 END
21594
21595*$ CREATE DT_SANO.FOR
21596*COPY DT_SANO
21597*
21598*===sigano=============================================================*
21599*
21600 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21601
21602************************************************************************
21603* This version dated 31.07.96 is written by S. Roesler *
21604************************************************************************
21605
21606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21607 SAVE
21608
21609 PARAMETER ( LINP = 10 ,
21610 & LOUT = 6 ,
21611 & LDAT = 9 )
21612
21613 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21614 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21615 PARAMETER (NE = 8)
21616
21617* VDM parameter for photon-nucleus interactions
21618 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21619
21620* properties of interacting particles
21621 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21622
21623 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21624 DATA ECMANO /
21625 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21626 & 0.100D+04,0.200D+04,0.500D+04
21627 & /
21628* fixed cut (3 GeV/c)
21629 DATA FRAANO /
21630 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21631 & 0.062D+00,0.054D+00,0.042D+00
21632 & /
21633 DATA SIGHRD /
21634 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21635 & 3.3086D-01,7.6255D-01,2.1319D+00
21636 & /
21637* running cut (based on obsolete Phojet-caluclations, bugs..)
21638C DATA FRAANO /
21639C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21640C & 0.167E+00,0.150E+00,0.131E+00
21641C & /
21642C DATA SIGHRD /
21643C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21644C & 2.5736E-01,4.5593E-01,8.2550E-01
21645C & /
21646
21647 DT_SANO = ZERO
21648 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21649 J1 = 0
21650 J2 = 0
21651 RATE = ONE
21652 IF (ECM.GE.ECMANO(NE)) THEN
21653 J1 = NE
21654 J2 = NE
21655 ELSEIF (ECM.GT.ECMANO(1)) THEN
21656 DO 1 IE=2,NE
21657 IF (ECM.LT.ECMANO(IE)) THEN
21658 J1 = IE-1
21659 J2 = IE
21660 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21661 GOTO 2
21662 ENDIF
21663 1 CONTINUE
21664 2 CONTINUE
21665 ENDIF
21666 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21667 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21668 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21669 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21670 ENDIF
21671
21672 RETURN
21673 END
21674
21675*$ CREATE DT_SIGGP.FOR
21676*COPY DT_SIGGP
21677*
21678*===siggp==============================================================*
21679*
21680 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21681
21682************************************************************************
21683* Total/inelastic photon-nucleon cross sections. *
21684* This version dated 30.04.96 is written by S. Roesler *
21685************************************************************************
21686
21687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21688 SAVE
21689
21690 PARAMETER ( LINP = 10 ,
21691 & LOUT = 6 ,
21692 & LDAT = 9 )
21693
21694 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21695 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21696 & PI = TWOPI/TWO,
21697 & GEV2MB = 0.38938D0,
21698 & ALPHEM = ONE/137.0D0)
21699
21700* particle properties (BAMJET index convention)
21701 CHARACTER*8 ANAME
21702 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21703 & IICH(210),IIBAR(210),K1(210),K2(210)
21704
21705* VDM parameter for photon-nucleus interactions
21706 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21707
21708**PHOJET105a
21709C CHARACTER*8 MDLNA
21710C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21711C PARAMETER (IEETAB=10)
21712C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21713**PHOJET110
21714
21715C model switches and parameters
21716 CHARACTER*8 MDLNA
21717 INTEGER ISWMDL,IPAMDL
21718 DOUBLE PRECISION PARMDL
21719 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21720
21721C energy-interpolation table
21722 INTEGER IEETA2
21723 PARAMETER ( IEETA2 = 20 )
21724 INTEGER ISIMAX
21725 DOUBLE PRECISION SIGTAB,SIGECM
21726 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21727**
21728
21729C PARAMETER (NPOINT=80)
21730 PARAMETER (NPOINT=16)
21731 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21732
21733 STOT = ZERO
21734 SINE = ZERO
21735 SDIR = ZERO
21736
21737 W2 = ECMI**2
21738 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21739 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21740 Q2 = Q2I
21741 X = XI
21742* photoprod.
21743 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21744 Q2 = 0.0001D0
21745 X = Q2/(W2+Q2-AAM(1)**2)
21746* DIS
21747 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21748 X = Q2/(W2+Q2-AAM(1)**2)
21749 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21750 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21751 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21752 W2 = Q2*(ONE-X)/X+AAM(1)**2
21753 ELSE
21754 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21755 STOP
21756 ENDIF
21757 ECM = SQRT(W2)
21758
21759 IF (MODEGA.EQ.1) THEN
21760 SCALE = SQRT(Q2)
21761 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21762 & IDPDF)
21763C W = SQRT(W2)
21764
21765C ALLMF2 = PHO_ALLM97(Q2,W)
21766
21767C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21768 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21769 SINE = ZERO
21770 SDIR = ZERO
21771 ELSEIF (MODEGA.EQ.2) THEN
21772 IF (INTRGE(1).EQ.1) THEN
21773 AMLO2 = (3.0D0*AAM(13))**2
21774 ELSEIF (INTRGE(1).EQ.2) THEN
21775 AMLO2 = AAM(33)**2
21776 ELSE
21777 AMLO2 = AAM(96)**2
21778 ENDIF
21779 IF (INTRGE(2).EQ.1) THEN
21780 AMHI2 = W2/TWO
21781 ELSEIF (INTRGE(2).EQ.2) THEN
21782 AMHI2 = W2/4.0D0
21783 ELSE
21784 AMHI2 = W2
21785 ENDIF
21786 AMHI20 = (ECM-AAM(1))**2
21787 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21788 XAMLO = LOG( AMLO2+Q2 )
21789 XAMHI = LOG( AMHI2+Q2 )
21790**PHOJET105a
21791C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21792**PHOJET112
21793
21794 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21795
21796**
21797 SUM = ZERO
21798 DO 1 J=1,NPOINT
21799 AM2 = EXP(ABSZX(J))-Q2
21800 IF (AM2.LT.16.0D0) THEN
21801 R = TWO
21802 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21803 R = 10.0D0/3.0D0
21804 ELSE
21805 R = 11.0D0/3.0D0
21806 ENDIF
21807C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21808 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21809 & * (ONE+EPSPOL*Q2/AM2)
21810 SUM = SUM+WEIGHT(J)*FAC
21811 1 CONTINUE
21812 SINE = SUM
21813 SDIR = DT_SIGVP(X,Q2)
21814 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21815 SDIR = SDIR/(0.588D0+RL2+Q2)
21816C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21817 ELSEIF (MODEGA.EQ.3) THEN
21818 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21819 ELSEIF (MODEGA.EQ.4) THEN
21820* load cross sections from PHOJET interpolation table
21821 IP = 1
21822 IF(ECM.LE.SIGECM(IP,1)) THEN
21823 I1 = 1
21824 I2 = 1
21825 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21826 DO 2 I=2,ISIMAX
21827 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21828 2 CONTINUE
21829 3 CONTINUE
21830 I1 = I-1
21831 I2 = I
21832 ELSE
21833 WRITE(LOUT,'(/1X,A,2E12.3)')
21834 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21835 I1 = ISIMAX
21836 I2 = ISIMAX
21837 ENDIF
21838 FAC2 = ZERO
21839 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21840 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21841 FAC1 = ONE-FAC2
21842* cross section dependence on photon virtuality
21843 FSUP1 = ZERO
21844 DO 4 I=1,3
21845 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21846 & /(1.D0+Q2/PARMDL(30+I))**2
21847 4 CONTINUE
21848 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21849 FAC1 = FAC1*FSUP1
21850 FAC2 = FAC2*FSUP1
21851 FSUP2 = 1.0D0
21852 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21853 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21854 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21855**re:
21856 STOT = STOT-SDIR
21857**
21858 SDIR = SDIR/(FSUP1*FSUP2)
21859**re:
21860 STOT = STOT+SDIR
21861**
21862 ENDIF
21863
21864 RETURN
21865 END
21866
21867*$ CREATE DT_SIGVEL.FOR
21868*COPY DT_SIGVEL
21869*
21870*===sigvel=============================================================*
21871*
21872 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21873
21874************************************************************************
21875* Cross section for elastic vector meson production *
21876* This version dated 10.05.96 is written by S. Roesler *
21877************************************************************************
21878
21879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21880 SAVE
21881
21882 PARAMETER ( LINP = 10 ,
21883 & LOUT = 6 ,
21884 & LDAT = 9 )
21885
21886 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21887 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21888 & PI = TWOPI/TWO,
21889 & GEV2MB = 0.38938D0,
21890 & ALPHEM = ONE/137.0D0)
21891
21892* particle properties (BAMJET index convention)
21893 CHARACTER*8 ANAME
21894 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21895 & IICH(210),IIBAR(210),K1(210),K2(210)
21896
21897* VDM parameter for photon-nucleus interactions
21898 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21899
21900 W2 = ECMI**2
21901 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21902 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21903 Q2 = Q2I
21904 X = XI
21905* photoprod.
21906 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21907 Q2 = 0.0001D0
21908 X = Q2/(W2+Q2-AAM(1)**2)
21909* DIS
21910 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21911 X = Q2/(W2+Q2-AAM(1)**2)
21912 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21913 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21914 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21915 W2 = Q2*(ONE-X)/X+AAM(1)**2
21916 ELSE
21917 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21918 STOP
21919 ENDIF
21920 ECM = SQRT(W2)
21921
21922 AMV = AAM(IDXV)
21923 AMV2 = AMV**2
21924
21925 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21926 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21927 ROSH = 0.1D0
21928 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21929 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21930
21931 IF (IDXV.EQ.33) THEN
21932 COUPL = 0.00365D0
21933 ELSE
21934 STOP
21935 ENDIF
21936 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21937 SIG2 = SELVP
21938 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21939 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21940
21941 RETURN
21942 END
21943
21944*$ CREATE DT_SIGVP.FOR
21945*COPY DT_SIGVP
21946*
21947*===sigvp==============================================================*
21948*
21949 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21950
21951************************************************************************
21952* sigma_Vp *
21953************************************************************************
21954
21955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21956 SAVE
21957
21958 PARAMETER ( LINP = 10 ,
21959 & LOUT = 6 ,
21960 & LDAT = 9 )
21961
21962 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21963 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21964 & PI = TWOPI/TWO,
21965 & GEV2MB = 0.38938D0,
21966 & AMPROT = 0.938D0,
21967 & ALPHEM = ONE/137.0D0)
21968
21969* VDM parameter for photon-nucleus interactions
21970 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21971
21972 X = XI
21973 Q2 = Q2I
21974 IF (XI.LE.ZERO) X = 0.0001D0
21975 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21976
21977 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21978
21979 SCALE = SQRT(Q2)
21980 IF (MODEGA.EQ.1) THEN
21981 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21982 & IDPDF)
21983C W = ECM
21984
21985C ALLMF2 = PHO_ALLM97(Q2,W)
21986
21987C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21988C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21989C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
21990 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
21991 ELSEIF (MODEGA.EQ.4) THEN
21992 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
21993C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
21994 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
21995 ELSE
21996 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
21997 ENDIF
21998
21999 RETURN
22000
22001 END
22002
22003*$ CREATE DT_RRM2.FOR
22004*COPY DT_RRM2
22005*
22006*===RRM2===============================================================*
22007*
22008 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22009
22010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22011 SAVE
22012
22013 PARAMETER ( LINP = 10 ,
22014 & LOUT = 6 ,
22015 & LDAT = 9 )
22016
22017 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22018 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22019 & PI = TWOPI/TWO,
22020 & GEV2MB = 0.38938D0)
22021
22022* particle properties (BAMJET index convention)
22023 CHARACTER*8 ANAME
22024 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22025 & IICH(210),IIBAR(210),K1(210),K2(210)
22026
22027* VDM parameter for photon-nucleus interactions
22028 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22029
22030 S = Q2*(ONE-X)/X+AAM(1)**2
22031 ECM = SQRT(S)
22032
22033 IF (INTRGE(1).EQ.1) THEN
22034 AMLO2 = (3.0D0*AAM(13))**2
22035 ELSEIF (INTRGE(1).EQ.2) THEN
22036 AMLO2 = AAM(33)**2
22037 ELSE
22038 AMLO2 = AAM(96)**2
22039 ENDIF
22040 IF (INTRGE(2).EQ.1) THEN
22041 AMHI2 = S/TWO
22042 ELSEIF (INTRGE(2).EQ.2) THEN
22043 AMHI2 = S/4.0D0
22044 ELSE
22045 AMHI2 = S
22046 ENDIF
22047 AMHI20 = (ECM-AAM(1))**2
22048 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22049
22050 AM1C2 = 16.0D0
22051 AM2C2 = 121.0D0
22052 IF (AMHI2.LE.AM1C2) THEN
22053 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22054 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22055 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22056 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22057 ELSE
22058 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22059 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22060 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22061 ENDIF
22062
22063 RETURN
22064 END
22065
22066*$ CREATE DT_RM2.FOR
22067*COPY DT_RM2
22068*
22069*===RM2================================================================*
22070*
22071 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22072
22073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22074 SAVE
22075
22076 PARAMETER ( LINP = 10 ,
22077 & LOUT = 6 ,
22078 & LDAT = 9 )
22079
22080 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22081 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22082 & PI = TWOPI/TWO,
22083 & GEV2MB = 0.38938D0)
22084
22085* VDM parameter for photon-nucleus interactions
22086 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22087
22088 IF (RL2.LE.ZERO) THEN
22089 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22090 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22091 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22092 ELSE
22093 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22094 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22095 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22096 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22097 & +EPSPOL*(
22098 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22099 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22100 ENDIF
22101
22102 RETURN
22103 END
22104
22105*$ CREATE DT_SAM2.FOR
22106*COPY DT_SAM2
22107*
22108*===SAM2===============================================================*
22109*
22110 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22111
22112 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22113 SAVE
22114
22115 PARAMETER ( LINP = 10 ,
22116 & LOUT = 6 ,
22117 & LDAT = 9 )
22118
22119 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22120 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22121 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22122 & PI = TWOPI/TWO,
22123 & GEV2MB = 0.38938D0)
22124
22125* particle properties (BAMJET index convention)
22126 CHARACTER*8 ANAME
22127 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22128 & IICH(210),IIBAR(210),K1(210),K2(210)
22129
22130* VDM parameter for photon-nucleus interactions
22131 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22132
22133 S = ECM**2
22134 IF (INTRGE(1).EQ.1) THEN
22135 AMLO2 = (3.0D0*AAM(13))**2
22136 ELSEIF (INTRGE(1).EQ.2) THEN
22137 AMLO2 = AAM(33)**2
22138 ELSE
22139 AMLO2 = AAM(96)**2
22140 ENDIF
22141 IF (INTRGE(2).EQ.1) THEN
22142 AMHI2 = S/TWO
22143 ELSEIF (INTRGE(2).EQ.2) THEN
22144 AMHI2 = S/4.0D0
22145 ELSE
22146 AMHI2 = S
22147 ENDIF
22148 AMHI20 = (ECM-AAM(1))**2
22149 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22150
22151 AM1C2 = 16.0D0
22152 AM2C2 = 121.0D0
22153 YLO = LOG(AMLO2+Q2)
22154 YC1 = LOG(AM1C2+Q2)
22155 YC2 = LOG(AM2C2+Q2)
22156 YHI = LOG(AMHI2+Q2)
22157 IF (AMHI2.LE.AM1C2) THEN
22158 FACHI = TWO
22159 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22160 FACHI = TENTRD
22161 ELSE
22162 FACHI = ELVTRD
22163 ENDIF
22164
22165 1 CONTINUE
22166 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22167 IF (YSAM2.LE.YC1) THEN
22168 FAC = TWO
22169 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22170 FAC = TENTRD
22171 ELSE
22172 FAC = ELVTRD
22173 ENDIF
22174 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22175 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22176 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22177
22178 DT_SAM2 = EXP(YSAM2)-Q2
22179
22180 RETURN
22181 END
22182
22183*$ CREATE DT_CKMT.FOR
22184*COPY DT_CKMT
22185*
22186*===ckmt===============================================================*
22187*
22188 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22189 & F2,IPAR)
22190
22191************************************************************************
22192* This version dated 31.01.96 is written by S. Roesler *
22193************************************************************************
22194
22195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22196 SAVE
22197
22198 PARAMETER ( LINP = 10 ,
22199 & LOUT = 6 ,
22200 & LDAT = 9 )
22201
22202 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22203
22204 PARAMETER (Q02 = 2.0D0,
22205 & DQ2 = 10.05D0,
22206 & Q12 = Q02+DQ2)
22207
22208 DIMENSION PD(-6:6),SEA(3),VAL(2)
22209
22210 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22211 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22212 ADQ2 = LOG10(Q12)-LOG10(Q02)
22213 F2P = (F2Q1-F2Q0)/ADQ2
22214 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22215 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22216 F2PP = (F2PQ1-F2PQ0)/ADQ2
22217 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22218
22219 Q2 = MAX(SCALE**2.0D0,TINY10)
22220 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22221 IF (Q2.LT.Q02) THEN
22222 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22223 UPV = VAL(1)
22224 DNV = VAL(2)
22225 USEA = SEA(1)
22226 DSEA = SEA(2)
22227 STR = SEA(3)
22228 CHM = 0.0D0
22229 BOT = 0.0D0
22230 TOP = 0.0D0
22231 GL = GLU
22232 ELSE
22233 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22234 F2 = F2*SMOOTH
22235 UPV = PD(2)-PD(3)
22236 DNV = PD(1)-PD(3)
22237 USEA = PD(3)
22238 DSEA = PD(3)
22239 STR = PD(3)
22240 CHM = PD(4)
22241 BOT = PD(5)
22242 TOP = PD(6)
22243 GL = PD(0)
22244C UPV = UPV*SMOOTH
22245C DNV = DNV*SMOOTH
22246C USEA = USEA*SMOOTH
22247C DSEA = DSEA*SMOOTH
22248C STR = STR*SMOOTH
22249C CHM = CHM*SMOOTH
22250C GL = GL*SMOOTH
22251 ENDIF
22252
22253 RETURN
22254 END
22255C
22256
22257*$ CREATE DT_CKMTX.FOR
22258*COPY DT_CKMTX
22259 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22260C**********************************************************************
22261C
22262C PDF based on Regge theory, evolved with .... by ....
22263C
22264C input: IPAR 2212 proton (not installed)
22265C 45 Pomeron
22266C 100 Deuteron
22267C
22268C output: PD(-6:6) x*f(x) parton distribution functions
22269C (PDFLIB convention: d = PD(1), u = PD(2) )
22270C
22271C**********************************************************************
22272
22273 SAVE
22274 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22275
22276 PARAMETER ( LINP = 10 ,
22277 & LOUT = 6 ,
22278 & LDAT = 9 )
22279
22280 DIMENSION QQ(7)
22281C
22282 Q2=SNGL(SCALE2)
22283 Q1S=Q2
22284 XX=SNGL(X)
22285C QCD lambda for evolution
22286 OWLAM = 0.23D0
22287 OWLAM2=OWLAM**2
22288C Q0**2 for evolution
22289 Q02 = 2.D0
22290C
22291C
22292C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22293C q(6)=x*charm, q(7)=x*gluon
22294C
22295 SB=0.
22296 IF(Q2-Q02) 1,1,2
22297 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22298 1 CONTINUE
22299 IF(IPAR.EQ.2212) THEN
22300 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22301 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22302 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22303 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22304 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22305 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22306 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22307C ELSEIF (IPAR.EQ.45) THEN
22308C CALL CKMTPO(1,0,XX,SB,QQ(1))
22309C CALL CKMTPO(2,0,XX,SB,QQ(2))
22310C CALL CKMTPO(3,0,XX,SB,QQ(3))
22311C CALL CKMTPO(4,0,XX,SB,QQ(4))
22312C CALL CKMTPO(5,0,XX,SB,QQ(5))
22313C CALL CKMTPO(8,0,XX,SB,QQ(6))
22314C CALL CKMTPO(7,0,XX,SB,QQ(7))
22315 ELSEIF (IPAR.EQ.100) THEN
22316 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22317 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22318 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22319 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22320 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22321 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22322 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22323 ELSE
22324 WRITE(LOUT,'(1X,A,I4,A)')
22325 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22326 STOP
22327 ENDIF
22328C
22329 PD(-6) = 0.D0
22330 PD(-5) = 0.D0
22331 PD(-4) = DBLE(QQ(6))
22332 PD(-3) = DBLE(QQ(3))
22333 PD(-2) = DBLE(QQ(4))
22334 PD(-1) = DBLE(QQ(5))
22335 PD(0) = DBLE(QQ(7))
22336 PD(1) = DBLE(QQ(2))
22337 PD(2) = DBLE(QQ(1))
22338 PD(3) = DBLE(QQ(3))
22339 PD(4) = DBLE(QQ(6))
22340 PD(5) = 0.D0
22341 PD(6) = 0.D0
22342 IF(IPAR.EQ.45) THEN
22343 CDN = (PD(1)-PD(-1))/2.D0
22344 CUP = (PD(2)-PD(-2))/2.D0
22345 PD(-1) = PD(-1) + CDN
22346 PD(-2) = PD(-2) + CUP
22347 PD(1) = PD(-1)
22348 PD(2) = PD(-2)
22349 ENDIF
22350 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22351 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22352 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22353 END
22354C
22355
22356*$ CREATE DT_PDF0.FOR
22357*COPY DT_PDF0
22358*
22359*===pdf0===============================================================*
22360*
22361 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22362
22363************************************************************************
22364* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22365* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22366* IPAR = 2212 proton *
22367* = 100 deuteron *
22368* This version dated 31.01.96 is written by S. Roesler *
22369************************************************************************
22370
22371 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22372 SAVE
22373
22374 PARAMETER ( LINP = 10 ,
22375 & LOUT = 6 ,
22376 & LDAT = 9 )
22377
22378 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22379
22380 PARAMETER (
22381 & AA = 0.1502D0,
22382 & BBDEU = 1.2D0,
22383 & BUD = 0.754D0,
22384 & BDD = 0.4495D0,
22385 & BUP = 1.2064D0,
22386 & BDP = 0.1798D0,
22387 & DELTA0 = 0.07684D0,
22388 & D = 1.117D0,
22389 & C = 3.5489D0,
22390 & A = 0.2631D0,
22391 & B = 0.6452D0,
22392 & ALPHAR = 0.415D0,
22393 & E = 0.1D0
22394 & )
22395
22396 PARAMETER (NPOINT=16)
22397C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22398 DIMENSION SEA(3),VAL(2)
22399
22400 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22401 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22402* proton, deuteron
22403 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22404 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22405 SEA(1) = 0.75D0*SEA0
22406 SEA(2) = SEA(1)
22407 SEA(3) = SEA(1)
22408 VAL(1) = 9.0D0/4.0D0*VALU0
22409 VAL(2) = 9.0D0*VALD0
22410 GLU0 = SEA(1)/(1.0D0-X)
22411 F2 = SEA0+VALU0+VALD0
22412 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22413 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22414 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22415 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22416 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22417 STOP
22418 ENDIF
22419**PHOJET105a
22420C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22421**PHOJET112
22422
22423C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22424
22425**
22426C SUMQ = ZERO
22427C SUMG = ZERO
22428C DO 1 J=1,NPOINT
22429C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22430C VALU0 = 9.0D0/4.0D0*VALU0
22431C VALD0 = 9.0D0*VALD0
22432C SEA0 = 0.75D0*SEA0
22433C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22434C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22435C 1 CONTINUE
22436C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22437 ELSE
22438 WRITE(LOUT,'(1X,A,I4,A)')
22439 & 'PDF0: IPAR =',IPAR,' not implemented!'
22440 STOP
22441 ENDIF
22442
22443 RETURN
22444 END
22445
22446*$ CREATE DT_CKMTQ0.FOR
22447*COPY DT_CKMTQ0
22448*
22449*===ckmtq0=============================================================*
22450*
22451 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22452
22453************************************************************************
22454* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22455* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22456* IPAR = 2212 proton *
22457* = 100 deuteron *
22458* This version dated 31.01.96 is written by S. Roesler *
22459************************************************************************
22460
22461 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22462 SAVE
22463
22464 PARAMETER ( LINP = 10 ,
22465 & LOUT = 6 ,
22466 & LDAT = 9 )
22467
22468 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22469
22470 PARAMETER (
22471 & AA = 0.1502D0,
22472 & BBDEU = 1.2D0,
22473 & BUD = 0.754D0,
22474 & BDD = 0.4495D0,
22475 & BUP = 1.2064D0,
22476 & BDP = 0.1798D0,
22477 & DELTA0 = 0.07684D0,
22478 & D = 1.117D0,
22479 & C = 3.5489D0,
22480 & A = 0.2631D0,
22481 & B = 0.6452D0,
22482 & ALPHAR = 0.415D0,
22483 & E = 0.1D0
22484 & )
22485
22486 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22487 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22488* proton, deuteron
22489 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22490 IF (IPAR.EQ.2212) THEN
22491 BU = BUP
22492 BD = BDP
22493 ELSE
22494 BU = BUD
22495 BD = BDD
22496 ENDIF
22497 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22498 & (Q2/(Q2+A))**(1.0D0+DELTA)
22499 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22500 & (Q2/(Q2+B))**(ALPHAR)
22501 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22502 & (Q2/(Q2+B))**(ALPHAR)
22503 ELSE
22504 WRITE(LOUT,'(1X,A,I4,A)')
22505 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22506 STOP
22507 ENDIF
22508 RETURN
22509 END
22510C
22511C
22512
22513*$ CREATE DT_CKMTDE.FOR
22514*COPY DT_CKMTDE
22515 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22516C
22517C**********************************************************************
22518C Deuteron - PDFs
22519C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22520C ANS = PDF(I)
22521C This version by S. Roesler, 30.01.96
22522C**********************************************************************
22523
22524 SAVE
22525 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22526 EQUIVALENCE (GF(1,1,1),DL(1))
22527 DATA DELTA/.13/
22528C
22529 DATA (DL(K),K= 1, 85) /
22530 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22531 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22532 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22533 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22534 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22535 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22536 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22537 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22538 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22539 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22540 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22541 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22542 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22543 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22544 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22545 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22546 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22547 DATA (DL(K),K= 86, 170) /
22548 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22549 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22550 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22551 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22552 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22553 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22554 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22555 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22556 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22557 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22559 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22560 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22561 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22562 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22563 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22564 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22565 DATA (DL(K),K= 171, 255) /
22566 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22567 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22568 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22569 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22570 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22571 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22572 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22573 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22574 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22575 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22576 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22577 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22578 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22579 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22580 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22581 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22582 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22583 DATA (DL(K),K= 256, 340) /
22584 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22585 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22586 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22587 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22588 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22589 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22590 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22591 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22593 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22594 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22595 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22596 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22597 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22598 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22599 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22600 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22601 DATA (DL(K),K= 341, 425) /
22602 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22603 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22604 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22605 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22606 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22607 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22608 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22609 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22610 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22611 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22612 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22613 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22614 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22615 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22616 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22617 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22618 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22619 DATA (DL(K),K= 426, 510) /
22620 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22621 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22622 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22623 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22624 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22625 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22628 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22630 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22631 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22632 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22633 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22634 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22635 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22636 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22637 DATA (DL(K),K= 511, 595) /
22638 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22639 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22640 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22641 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22642 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22643 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22644 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22645 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22646 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22647 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22648 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22649 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22650 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22651 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22652 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22653 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22654 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22655 DATA (DL(K),K= 596, 680) /
22656 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22657 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22658 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22659 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22660 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22661 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22662 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22663 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22664 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22665 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22666 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22667 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22668 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22669 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22670 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22671 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22672 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22673 DATA (DL(K),K= 681, 765) /
22674 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22675 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22676 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22677 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22678 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22679 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22680 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22681 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22682 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22683 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22684 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22685 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22686 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22687 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22688 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22689 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22691 DATA (DL(K),K= 766, 850) /
22692 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22693 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22694 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22696 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22698 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22699 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22700 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22701 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22702 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22703 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22704 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22705 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22706 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22707 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22708 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22709 DATA (DL(K),K= 851, 935) /
22710 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22711 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22712 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22713 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22714 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22715 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22716 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22717 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22718 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22719 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22720 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22721 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22722 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22723 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22724 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22725 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22726 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22727 DATA (DL(K),K= 936, 1020) /
22728 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22729 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22730 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22731 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22732 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22733 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22734 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22735 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22736 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22737 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22738 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22739 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22740 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22741 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22742 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22743 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22744 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22745 DATA (DL(K),K= 1021, 1105) /
22746 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22747 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22748 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22749 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22750 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22751 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22752 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22753 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22754 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22755 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22756 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22757 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22758 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22759 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22760 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22761 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22762 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22763 DATA (DL(K),K= 1106, 1190) /
22764 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22765 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22766 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22767 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22768 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22769 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22770 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22771 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22772 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22773 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22774 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22775 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22776 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22777 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22778 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22779 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22780 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22781 DATA (DL(K),K= 1191, 1275) /
22782 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22783 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22784 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22785 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22786 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22787 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22788 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22789 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22790 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22791 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22792 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22793 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22794 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22795 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22796 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22797 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22798 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22799 DATA (DL(K),K= 1276, 1360) /
22800 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22801 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22802 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22803 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22804 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22805 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22806 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22807 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22808 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22809 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22810 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22811 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22812 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22813 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22814 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22815 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22816 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22817 DATA (DL(K),K= 1361, 1445) /
22818 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22819 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22820 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22821 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22822 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22823 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22824 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22825 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22826 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22827 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22828 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22829 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22830 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22831 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22832 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22833 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22834 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22835 DATA (DL(K),K= 1446, 1530) /
22836 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22837 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22838 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22839 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22840 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22841 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22842 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22843 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22844 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22845 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22846 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22847 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22848 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22849 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22850 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22851 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22852 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22853 DATA (DL(K),K= 1531, 1615) /
22854 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22855 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22856 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22857 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22858 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22859 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22860 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22861 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22862 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22863 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22864 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22865 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22866 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22867 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22868 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22869 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22870 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22871 DATA (DL(K),K= 1616, 1700) /
22872 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22873 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22874 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22875 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22876 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22877 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22878 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22879 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22880 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22881 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22882 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22883 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22884 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22885 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22886 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22887 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22888 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22889 DATA (DL(K),K= 1701, 1785) /
22890 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22891 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22892 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22893 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22894 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22895 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22896 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22897 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22898 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22899 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22900 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22901 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22902 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22903 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22904 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22905 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22906 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22907 DATA (DL(K),K= 1786, 1870) /
22908 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22909 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22910 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22911 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22912 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22913 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22914 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22915 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22916 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22917 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22918 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22919 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22920 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22921 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22922 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22923 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22924 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22925 DATA (DL(K),K= 1871, 1955) /
22926 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22927 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22928 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22929 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22930 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22931 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22932 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22933 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22934 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22935 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22936 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22937 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22938 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22939 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22940 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22941 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22942 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22943 DATA (DL(K),K= 1956, 2040) /
22944 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22945 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22946 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22947 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22948 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22949 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22950 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22951 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22952 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22953 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22954 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22955 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22956 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22957 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22958 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22959 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22960 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22961 DATA (DL(K),K= 2041, 2125) /
22962 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22963 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22964 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22965 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22966 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22967 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22968 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22969 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22970 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22971 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22972 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22973 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22974 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22975 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22976 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22977 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22978 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22979 DATA (DL(K),K= 2126, 2210) /
22980 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22981 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22982 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22983 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22984 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22985 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22986 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22987 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22988 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
22989 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
22990 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
22991 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
22992 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
22993 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
22994 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
22995 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22996 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22997 DATA (DL(K),K= 2211, 2295) /
22998 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22999 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23000 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23001 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23002 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23003 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23004 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23005 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23006 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23007 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23008 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23009 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23010 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23011 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23012 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23013 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23014 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23015 DATA (DL(K),K= 2296, 2380) /
23016 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23017 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23018 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23019 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23020 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23021 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23022 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23023 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23024 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23025 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23026 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23027 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23028 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23029 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23030 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23031 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23032 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23033 DATA (DL(K),K= 2381, 2465) /
23034 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23035 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23036 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23037 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23038 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23039 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23040 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23041 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23042 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23043 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23044 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23045 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23046 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23047 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23048 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23049 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23050 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23051 DATA (DL(K),K= 2466, 2550) /
23052 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23053 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23054 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23055 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23056 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23057 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23058 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23059 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23060 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23061 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23062 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23063 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23064 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23065 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23066 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23067 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23068 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23069 DATA (DL(K),K= 2551, 2635) /
23070 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23071 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23072 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23073 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23074 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23075 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23076 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23077 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23078 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23079 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23080 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23081 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23082 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23083 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23084 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23085 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23086 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23087 DATA (DL(K),K= 2636, 2720) /
23088 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23089 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23090 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23091 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23092 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23093 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23094 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23095 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23096 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23097 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23098 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23099 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23100 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23101 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23102 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23103 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23104 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23105 DATA (DL(K),K= 2721, 2805) /
23106 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23107 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23108 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23109 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23110 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23111 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23112 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23113 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23114 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23115 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23116 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23117 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23118 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23119 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23120 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23121 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23122 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23123 DATA (DL(K),K= 2806, 2890) /
23124 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23125 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23126 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23127 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23128 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23129 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23130 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23131 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23132 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23133 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23134 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23135 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23136 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23137 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23138 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23139 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23140 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23141 DATA (DL(K),K= 2891, 2975) /
23142 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23143 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23144 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23145 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23146 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23147 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23148 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23149 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23150 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23151 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23152 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23153 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23154 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23155 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23156 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23157 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23158 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23159 DATA (DL(K),K= 2976, 3060) /
23160 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23161 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23162 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23163 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23164 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23165 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23166 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23167 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23168 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23169 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23170 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23171 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23172 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23173 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23174 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23175 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23176 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23177 DATA (DL(K),K= 3061, 3145) /
23178 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23179 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23180 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23181 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23182 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23183 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23184 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23185 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23186 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23187 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23188 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23189 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23190 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23191 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23192 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23193 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23194 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23195 DATA (DL(K),K= 3146, 3230) /
23196 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23197 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23198 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23199 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23200 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23201 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23202 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23203 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23204 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23205 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23206 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23207 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23208 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23209 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23210 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23211 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23212 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23213 DATA (DL(K),K= 3231, 3315) /
23214 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23215 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23216 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23217 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23218 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23219 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23220 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23221 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23222 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23223 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23224 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23225 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23226 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23227 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23228 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23229 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23230 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23231 DATA (DL(K),K= 3316, 3400) /
23232 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23233 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23234 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23235 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23236 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23237 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23238 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23239 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23240 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23241 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23242 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23243 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23244 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23245 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23246 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23247 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23248 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23249 DATA (DL(K),K= 3401, 3485) /
23250 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23251 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23252 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23253 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23254 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23255 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23256 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23257 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23258 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23259 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23260 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23261 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23262 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23263 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23264 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23265 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23266 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23267 DATA (DL(K),K= 3486, 3570) /
23268 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23269 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23270 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23271 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23272 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23273 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23274 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23275 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23276 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23277 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23278 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23279 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23280 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23281 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23282 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23283 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23284 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23285 DATA (DL(K),K= 3571, 3655) /
23286 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23287 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23288 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23289 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23290 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23291 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23292 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23293 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23294 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23295 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23296 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23297 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23298 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23299 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23300 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23301 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23302 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23303 DATA (DL(K),K= 3656, 3740) /
23304 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23305 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23306 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23307 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23309 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23310 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23311 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23312 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23313 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23314 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23315 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23316 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23317 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23318 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23319 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23320 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23321 DATA (DL(K),K= 3741, 3825) /
23322 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23323 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23324 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23325 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23326 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23327 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23328 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23329 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23330 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23331 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23332 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23333 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23334 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23335 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23336 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23337 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23338 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23339 DATA (DL(K),K= 3826, 3910) /
23340 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23341 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23342 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23344 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23345 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23346 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23347 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23348 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23349 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23350 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23351 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23352 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23353 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23354 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23355 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23356 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23357 DATA (DL(K),K= 3911, 3995) /
23358 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23359 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23360 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23361 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23362 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23363 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23364 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23365 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23366 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23367 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23368 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23369 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23370 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23371 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23372 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23373 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23374 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23375 DATA (DL(K),K= 3996, 4000) /
23376 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23377C
23378 ANS = 0.
23379 IF (X.GT.0.9985) RETURN
23380 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23381C
23382 IS = S/DELTA+1
23383 IS1 = IS+1
23384 DO 1 L=1,25
23385 KL = L+NDRV*25
23386 F1(L) = GF(I,IS,KL)
23387 F2(L) = GF(I,IS1,KL)
23388 1 CONTINUE
23389 A1 = DT_CKMTFF(X,F1)
23390 A2 = DT_CKMTFF(X,F2)
23391C A1=ALOG(A1)
23392C A2=ALOG(A2)
23393 S1 = (IS-1)*DELTA
23394 S2 = S1+DELTA
23395 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23396C ANS=EXP(ANS)
23397 RETURN
23398 END
23399C
23400C
23401
23402*$ CREATE DT_CKMTPR.FOR
23403*COPY DT_CKMTPR
23404 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23405C
23406C**********************************************************************
23407C Proton - PDFs
23408C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23409C ANS = PDF(I)
23410C This version by S. Roesler, 31.01.96
23411C**********************************************************************
23412
23413 SAVE
23414 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23415 EQUIVALENCE (GF(1,1,1),DL(1))
23416 DATA DELTA/.10/
23417C
23418 DATA (DL(K),K= 1, 85) /
23419 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23420 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23421 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23422 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23423 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23424 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23425 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23426 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23427 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23428 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23429 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23430 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23431 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23432 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23433 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23434 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23435 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23436 DATA (DL(K),K= 86, 170) /
23437 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23438 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23439 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23440 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23441 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23442 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23443 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23444 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23445 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23446 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23447 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23448 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23449 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23450 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23451 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23453 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23454 DATA (DL(K),K= 171, 255) /
23455 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23456 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23457 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23458 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23459 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23460 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23461 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23462 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23463 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23464 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23465 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23466 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23467 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23468 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23469 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23470 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23471 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23472 DATA (DL(K),K= 256, 340) /
23473 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23474 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23475 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23476 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23477 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23478 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23479 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23480 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23481 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23482 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23483 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23484 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23485 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23487 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23488 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23489 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23490 DATA (DL(K),K= 341, 425) /
23491 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23492 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23493 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23494 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23495 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23496 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23497 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23498 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23499 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23500 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23501 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23502 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23503 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23504 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23505 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23506 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23507 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23508 DATA (DL(K),K= 426, 510) /
23509 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23510 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23511 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23512 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23513 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23514 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23515 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23516 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23517 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23518 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23521 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23522 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23523 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23524 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23525 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23526 DATA (DL(K),K= 511, 595) /
23527 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23528 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23529 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23530 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23531 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23532 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23533 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23534 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23535 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23536 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23537 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23538 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23539 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23540 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23541 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23542 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23543 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23544 DATA (DL(K),K= 596, 680) /
23545 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23546 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23547 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23548 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23549 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23550 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23551 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23552 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23555 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23556 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23557 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23558 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23559 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23560 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23561 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23562 DATA (DL(K),K= 681, 765) /
23563 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23564 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23565 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23566 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23567 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23568 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23569 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23570 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23571 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23572 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23573 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23574 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23575 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23576 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23577 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23578 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23579 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23580 DATA (DL(K),K= 766, 850) /
23581 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23582 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23583 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23584 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23585 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23586 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23589 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23590 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23591 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23592 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23593 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23594 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23595 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23596 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23597 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23598 DATA (DL(K),K= 851, 935) /
23599 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23600 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23601 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23602 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23603 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23604 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23605 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23606 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23607 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23608 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23609 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23610 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23611 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23612 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23613 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23614 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23615 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23616 DATA (DL(K),K= 936, 1020) /
23617 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23618 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23619 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23620 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23623 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23624 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23625 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23626 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23627 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23628 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23629 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23630 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23631 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23632 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23633 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23634 DATA (DL(K),K= 1021, 1105) /
23635 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23636 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23637 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23638 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23639 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23640 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23641 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23642 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23643 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23644 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23645 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23646 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23647 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23648 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23649 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23650 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23651 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23652 DATA (DL(K),K= 1106, 1190) /
23653 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23654 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23657 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23658 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23659 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23660 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23661 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23662 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23663 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23664 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23665 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23666 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23667 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23668 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23669 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23670 DATA (DL(K),K= 1191, 1275) /
23671 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23672 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23673 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23674 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23675 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23676 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23677 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23678 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23679 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23680 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23681 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23682 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23683 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23684 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23685 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23686 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23687 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23688 DATA (DL(K),K= 1276, 1360) /
23689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23691 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23692 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23693 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23694 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23695 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23696 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23697 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23698 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23699 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23700 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23701 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23702 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23703 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23704 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23705 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23706 DATA (DL(K),K= 1361, 1445) /
23707 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23708 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23709 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23710 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23711 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23712 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23713 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23714 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23715 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23716 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23717 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23718 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23719 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23720 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23721 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23722 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23723 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23724 DATA (DL(K),K= 1446, 1530) /
23725 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23726 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23727 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23728 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23729 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23730 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23731 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23732 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23733 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23734 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23735 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23736 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23737 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23738 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23739 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23740 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23741 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23742 DATA (DL(K),K= 1531, 1615) /
23743 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23744 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23745 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23746 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23747 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23748 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23749 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23750 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23751 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23752 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23753 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23754 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23755 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23756 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23757 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23758 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23759 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23760 DATA (DL(K),K= 1616, 1700) /
23761 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23762 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23763 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23764 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23765 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23766 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23767 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23768 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23769 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23770 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23771 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23772 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23773 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23774 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23775 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23776 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23777 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23778 DATA (DL(K),K= 1701, 1785) /
23779 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23780 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23781 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23782 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23783 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23784 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23785 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23786 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23787 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23788 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23789 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23790 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23791 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23792 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23793 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23794 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23795 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23796 DATA (DL(K),K= 1786, 1870) /
23797 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23798 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23799 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23800 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23801 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23802 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23803 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23804 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23805 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23806 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23807 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23808 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23809 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23810 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23811 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23812 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23813 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23814 DATA (DL(K),K= 1871, 1955) /
23815 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23816 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23817 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23818 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23819 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23820 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23821 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23822 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23823 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23824 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23825 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23826 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23827 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23828 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23829 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23830 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23831 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23832 DATA (DL(K),K= 1956, 2040) /
23833 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23834 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23835 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23836 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23837 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23838 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23839 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23840 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23841 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23842 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23843 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23844 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23845 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23846 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23847 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23848 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23849 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23850 DATA (DL(K),K= 2041, 2125) /
23851 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23852 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23853 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23854 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23855 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23856 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23857 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23858 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23859 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23860 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23861 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23862 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23863 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23864 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23865 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23866 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23867 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23868 DATA (DL(K),K= 2126, 2210) /
23869 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23870 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23871 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23872 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23873 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23874 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23875 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23876 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23877 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23878 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23879 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23880 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23881 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23882 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23883 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23884 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23885 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23886 DATA (DL(K),K= 2211, 2295) /
23887 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23888 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23889 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23890 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23891 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23892 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23893 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23894 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23895 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23896 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23897 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23898 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23899 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23900 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23901 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23902 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23903 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23904 DATA (DL(K),K= 2296, 2380) /
23905 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23906 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23907 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23908 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23909 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23910 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23911 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23912 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23913 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23914 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23915 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23916 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23917 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23918 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23919 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23920 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23921 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23922 DATA (DL(K),K= 2381, 2465) /
23923 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23924 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23925 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23926 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23927 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23928 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23929 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23930 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23931 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23932 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23933 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23934 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23935 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23936 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23937 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23938 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23939 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23940 DATA (DL(K),K= 2466, 2550) /
23941 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23942 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23943 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23944 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23945 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23946 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23947 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23948 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23949 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23950 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23951 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23952 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23953 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23954 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23955 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23956 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23957 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23958 DATA (DL(K),K= 2551, 2635) /
23959 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23960 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23961 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23962 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23963 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23964 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23965 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23966 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23967 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23968 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23969 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23970 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23971 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23972 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23973 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23974 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23975 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23976 DATA (DL(K),K= 2636, 2720) /
23977 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23978 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23979 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23980 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23981 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23982 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23983 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23984 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23985 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23986 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23987 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23988 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
23989 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
23990 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
23991 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
23992 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23993 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23994 DATA (DL(K),K= 2721, 2805) /
23995 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
23996 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
23997 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
23998 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
23999 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24000 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24001 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24002 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24003 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24004 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24005 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24006 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24007 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24008 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24009 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24010 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24011 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24012 DATA (DL(K),K= 2806, 2890) /
24013 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24014 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24015 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24016 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24017 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24018 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24019 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24020 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24021 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24022 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24023 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24024 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24025 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24026 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24027 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24028 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24029 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24030 DATA (DL(K),K= 2891, 2975) /
24031 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24032 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24033 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24034 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24035 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24036 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24037 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24038 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24039 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24040 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24041 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24042 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24043 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24044 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24045 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24046 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24047 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24048 DATA (DL(K),K= 2976, 3060) /
24049 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24050 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24051 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24052 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24053 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24054 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24055 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24056 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24057 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24058 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24059 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24060 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24061 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24062 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24063 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24064 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24065 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24066 DATA (DL(K),K= 3061, 3145) /
24067 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24068 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24069 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24070 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24071 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24072 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24073 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24074 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24075 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24076 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24077 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24078 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24079 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24080 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24081 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24082 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24083 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24084 DATA (DL(K),K= 3146, 3230) /
24085 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24086 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24087 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24088 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24089 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24090 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24091 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24092 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24093 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24094 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24095 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24096 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24097 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24098 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24099 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24100 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24101 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24102 DATA (DL(K),K= 3231, 3315) /
24103 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24104 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24105 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24106 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24107 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24108 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24109 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24110 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24111 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24112 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24113 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24114 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24115 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24116 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24117 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24118 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24119 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24120 DATA (DL(K),K= 3316, 3400) /
24121 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24122 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24123 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24124 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24125 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24126 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24127 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24128 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24129 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24130 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24131 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24132 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24133 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24134 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24135 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24136 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24137 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24138 DATA (DL(K),K= 3401, 3485) /
24139 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24140 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24141 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24142 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24143 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24144 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24145 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24146 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24147 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24148 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24149 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24150 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24151 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24152 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24153 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24154 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24155 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24156 DATA (DL(K),K= 3486, 3570) /
24157 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24158 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24159 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24160 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24161 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24162 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24163 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24164 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24165 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24166 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24167 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24168 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24169 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24170 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24171 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24172 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24173 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24174 DATA (DL(K),K= 3571, 3655) /
24175 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24176 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24177 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24178 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24179 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24180 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24181 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24182 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24183 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24184 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24185 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24186 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24187 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24188 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24189 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24190 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24191 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24192 DATA (DL(K),K= 3656, 3740) /
24193 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24194 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24195 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24196 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24197 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24198 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24199 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24200 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24201 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24202 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24203 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24204 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24205 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24206 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24207 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24208 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24209 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24210 DATA (DL(K),K= 3741, 3825) /
24211 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24212 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24213 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24214 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24215 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24216 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24217 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24218 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24219 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24220 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24221 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24222 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24223 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24224 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24225 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24226 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24227 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24228 DATA (DL(K),K= 3826, 3910) /
24229 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24230 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24231 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24232 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24233 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24234 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24235 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24236 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24237 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24238 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24239 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24240 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24241 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24242 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24243 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24244 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24245 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24246 DATA (DL(K),K= 3911, 3995) /
24247 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24248 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24249 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24250 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24251 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24252 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24253 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24254 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24255 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24256 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24257 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24258 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24259 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24260 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24261 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24262 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24263 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24264 DATA (DL(K),K= 3996, 4000) /
24265 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24266C
24267 ANS = 0.
24268 IF (X.GT.0.9985) RETURN
24269 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24270C
24271 IS = S/DELTA+1
24272 IS1 = IS+1
24273 DO 1 L=1,25
24274 KL = L+NDRV*25
24275 F1(L) = GF(I,IS,KL)
24276 F2(L) = GF(I,IS1,KL)
24277 1 CONTINUE
24278 A1 = DT_CKMTFF(X,F1)
24279 A2 = DT_CKMTFF(X,F2)
24280C A1=ALOG(A1)
24281C A2=ALOG(A2)
24282 S1 = (IS-1)*DELTA
24283 S2 = S1+DELTA
24284 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24285C ANS=EXP(ANS)
24286 RETURN
24287 END
24288C
24289
24290*$ CREATE DT_CKMTFF.FOR
24291*COPY DT_CKMTFF
24292 FUNCTION DT_CKMTFF(X,FVL)
24293C**********************************************************************
24294C
24295C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24296C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24297C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24298C IN MAIN ROUTINE.
24299C
24300C**********************************************************************
24301
24302 SAVE
24303 DIMENSION FVL(25),XGRID(25)
24304 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24305 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24306C
24307 DT_CKMTFF=0.
24308 DO 1 I=1,NX
24309 IF(X.LT.XGRID(I)) GO TO 2
24310 1 CONTINUE
24311 2 I=I-1
24312 IF(I.EQ.0) THEN
24313 I=I+1
24314 ELSE IF(I.GT.23) THEN
24315 I=23
24316 ENDIF
24317 J=I+1
24318 K=J+1
24319 AXI=LOG(XGRID(I))
24320 BXI=LOG(1.-XGRID(I))
24321 AXJ=LOG(XGRID(J))
24322 BXJ=LOG(1.-XGRID(J))
24323 AXK=LOG(XGRID(K))
24324 BXK=LOG(1.-XGRID(K))
24325 FI=LOG(ABS(FVL(I)) +1.E-15)
24326 FJ=LOG(ABS(FVL(J)) +1.E-16)
24327 FK=LOG(ABS(FVL(K)) +1.E-17)
24328 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24329 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24330 $ BXI))/DET
24331 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24332 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24333 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24334 1RETURN
24335C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24336C WRITE(6,2001) X,FVL
24337C 2001 FORMAT(8E12.4)
24338C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24339C ENDIF
24340 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24341 RETURN
24342 END
24343
24344*$ CREATE DT_FLUINI.FOR
24345*COPY DT_FLUINI
24346*
24347*===fluini=============================================================*
24348*
24349 SUBROUTINE DT_FLUINI
24350
24351************************************************************************
24352* Initialisation of the nucleon-nucleon cross section fluctuation *
24353* treatment. The original version by J. Ranft. *
24354* This version dated 21.04.95 is revised by S. Roesler. *
24355************************************************************************
24356
24357 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24358 SAVE
24359
24360 PARAMETER ( LINP = 10 ,
24361 & LOUT = 6 ,
24362 & LDAT = 9 )
24363
24364 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24365
24366 PARAMETER ( A = 0.1D0,
24367 & B = 0.893D0,
24368 & OM = 1.1D0,
24369 & N = 6,
24370 & DX = 0.003D0)
24371
24372* n-n cross section fluctuations
24373 PARAMETER (NBINS = 1000)
24374 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24375 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24376
24377 WRITE(LOUT,1000)
24378 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24379 & 'treated')
24380
24381 FLUSU = ZERO
24382 FLUSUU = ZERO
24383
24384 DO 1 I=1,NBINS
24385 X = DBLE(I)*DX
24386 FLUIX(I) = X
24387 FLUS = ((X-B)/(OM*B))**N
24388 IF (FLUS.LE.20.0D0) THEN
24389 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24390 ELSE
24391 FLUSI(I) = ZERO
24392 ENDIF
24393 FLUSU = FLUSU+FLUSI(I)
24394 1 CONTINUE
24395 DO 2 I=1,NBINS
24396 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24397 FLUSI(I) = FLUSUU
24398 2 CONTINUE
24399
24400C WRITE(LOUT,1001)
24401C1001 FORMAT(1X,'FLUCTUATIONS')
24402C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24403
24404 DO 3 I=1,NBINS
24405 AF = DBLE(I)*0.001D0
24406 DO 4 J=1,NBINS
24407 IF (AF.LE.FLUSI(J)) THEN
24408 FLUIXX(I) = FLUIX(J)
24409 GOTO 5
24410 ENDIF
24411 4 CONTINUE
24412 5 CONTINUE
24413 3 CONTINUE
24414 FLUIXX(1) = FLUIX(1)
24415 FLUIXX(NBINS) = FLUIX(NBINS)
24416
24417 RETURN
24418 END
24419
24420*$ CREATE DT_SIGTBL.FOR
24421*COPY DT_SIGTBL
24422*
24423*===sigtab=============================================================*
24424*
24425 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24426
24427************************************************************************
24428* This version dated 18.11.95 is written by S. Roesler *
24429************************************************************************
24430
24431 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24432 SAVE
24433
24434 PARAMETER ( LINP = 10 ,
24435 & LOUT = 6 ,
24436 & LDAT = 9 )
24437
24438 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24439 & OHALF=0.5D0,ONE=1.0D0)
24440 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24441
24442 LOGICAL LINIT
24443
24444* particle properties (BAMJET index convention)
24445 CHARACTER*8 ANAME
24446 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24447 & IICH(210),IIBAR(210),K1(210),K2(210)
24448
24449 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24450 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24451 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24452 & 0, 0, 5/
24453 DATA LINIT /.FALSE./
24454
24455* precalculation and tabulation of elastic cross sections
24456 IF (ABS(MODE).EQ.1) THEN
24457 IF (MODE.EQ.1)
24458 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24459 PLABLX = LOG10(PLO)
24460 PLABHX = LOG10(PHI)
24461 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24462 DO 1 I=1,NBINS+1
24463 PLAB = PLABLX+DBLE(I-1)*DPLAB
24464 PLAB = 10**PLAB
24465 DO 2 IPROJ=1,23
24466 IDX = IDSIG(IPROJ)
24467 IF (IDX.GT.0) THEN
24468C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24469C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24470 DUMZER = ZERO
24471 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24472 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24473 ENDIF
24474 2 CONTINUE
24475 IF (MODE.EQ.1) THEN
24476 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24477 & (SIGEN(IDX,I),IDX=1,5)
24478 1000 FORMAT(F5.1,10F7.2)
24479 ENDIF
24480 1 CONTINUE
24481 IF (MODE.EQ.1) CLOSE(LDAT)
24482 LINIT = .TRUE.
24483 ELSE
24484 SIGE = -ONE
24485 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24486 & .AND.(PTOT.LE.PHI) ) THEN
24487 IDX = IDSIG(JP)
24488 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24489 PLABX = LOG10(PTOT)
24490 IF (PLABX.LE.PLABLX) THEN
24491 I1 = 1
24492 I2 = 1
24493 ELSEIF (PLABX.GE.PLABHX) THEN
24494 I1 = NBINS+1
24495 I2 = NBINS+1
24496 ELSE
24497 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24498 I2 = I1+1
24499 ENDIF
24500 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24501 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24502 PBIN = PLAB2X-PLAB1X
24503 IF (PBIN.GT.TINY10) THEN
24504 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24505 ELSE
24506 RATX = ZERO
24507 ENDIF
24508 IF (JT.EQ.1) THEN
24509 SIG1 = SIGEP(IDX,I1)
24510 SIG2 = SIGEP(IDX,I2)
24511 ELSE
24512 SIG1 = SIGEN(IDX,I1)
24513 SIG2 = SIGEN(IDX,I2)
24514 ENDIF
24515 SIGE = SIG1+RATX*(SIG2-SIG1)
24516 ENDIF
24517 ENDIF
24518 ENDIF
24519
24520 RETURN
24521 END
24522
24523*$ CREATE DT_XSTABL.FOR
24524*COPY DT_XSTABL
24525*
24526*===xstabl=============================================================*
24527*
24528 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24529
24530 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24531 SAVE
24532
24533 PARAMETER ( LINP = 10 ,
24534 & LOUT = 6 ,
24535 & LDAT = 9 )
24536
24537 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24538 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24539 LOGICAL LLAB,LELOG,LQLOG
24540
24541* particle properties (BAMJET index convention)
24542 CHARACTER*8 ANAME
24543 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24544 & IICH(210),IIBAR(210),K1(210),K2(210)
24545
24546* properties of interacting particles
24547 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24548
24549 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24550
24551* Glauber formalism: cross sections
24552 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24553 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24554 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24555 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24556 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24557 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24558 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24559 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24560 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24561 & BSLOPE,NEBINI,NQBINI
24562
24563* emulsion treatment
24564 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24565 & NCOMPO,IEMUL
24566
24567 DIMENSION WHAT(6)
24568
24569 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24570 ELO = ABS(WHAT(1))
24571 EHI = ABS(WHAT(2))
24572 IF (ELO.GT.EHI) ELO = EHI
24573 LELOG = WHAT(3).LT.ZERO
24574 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24575 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24576 IF (LELOG) THEN
24577 AELO = LOG10(ELO)
24578 AEHI = LOG10(EHI)
24579 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24580 ENDIF
24581 Q2LO = WHAT(4)
24582 Q2HI = WHAT(5)
24583 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24584 LQLOG = WHAT(6).LT.ZERO
24585 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24586 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24587 IF (LQLOG) THEN
24588 AQ2LO = LOG10(Q2LO)
24589 AQ2HI = LOG10(Q2HI)
24590 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24591 ENDIF
24592
24593 IF ( ELO.EQ. EHI) NEBINS = 0
24594 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24595
24596 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24597 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24598 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24599 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24600 & ' A_p = ',I3,' A_t = ',I3,/)
24601
24602C IF (IJPROJ.NE.7) THEN
24603 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24604* normalize fractions of emulsion components
24605 IF (NCOMPO.GT.0) THEN
24606 SUMFRA = ZERO
24607 DO 10 I=1,NCOMPO
24608 SUMFRA = SUMFRA+EMUFRA(I)
24609 10 CONTINUE
24610 IF (SUMFRA.GT.ZERO) THEN
24611 DO 11 I=1,NCOMPO
24612 EMUFRA(I) = EMUFRA(I)/SUMFRA
24613 11 CONTINUE
24614 ENDIF
24615 ENDIF
24616C ELSE
24617C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24618C ENDIF
24619 DO 1 I=1,NEBINS+1
24620 IF (LELOG) THEN
24621 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24622 ELSE
24623 E = ELO+DBLE(I-1)*DEBINS
24624 ENDIF
24625 DO 2 J=1,NQBINS+1
24626 IF (LQLOG) THEN
24627 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24628 ELSE
24629 Q2 = Q2LO+DBLE(J-1)*DQBINS
24630 ENDIF
24631c IF (IJPROJ.NE.7) THEN
24632 IF (LLAB) THEN
24633 PLAB = ZERO
24634 ECM = ZERO
24635 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24636 ELSE
24637 ECM = E
24638 ENDIF
24639 XI = ZERO
24640 Q2I = ZERO
24641 IF (IJPROJ.EQ.7) Q2I = Q2
24642 IF (NCOMPO.GT.0) THEN
24643 DO 20 IC=1,NCOMPO
24644 IIT = IEMUMA(IC)
24645 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24646 20 CONTINUE
24647 ELSE
24648 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24649C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24650 ENDIF
24651 IF (NCOMPO.GT.0) THEN
24652 XTOT = ZERO
24653 ETOT = ZERO
24654 XELA = ZERO
24655 EELA = ZERO
24656 XQEP = ZERO
24657 EQEP = ZERO
24658 XQET = ZERO
24659 EQET = ZERO
24660 XQE2 = ZERO
24661 EQE2 = ZERO
24662 XPRO = ZERO
24663 EPRO = ZERO
24664 XPRO1= ZERO
24665 XDEL = ZERO
24666 EDEL = ZERO
24667 XDQE = ZERO
24668 EDQE = ZERO
24669 DO 21 IC=1,NCOMPO
24670 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24671 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24672 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24673 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24674 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24675 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24676 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24677 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24678 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24679 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24680 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24681 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24682 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24683 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24684 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24685 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24686 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24687 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24688 & -XSQE2(1,1,IC)
24689 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24690 21 CONTINUE
24691 ETOT = SQRT(ETOT)
24692 EELA = SQRT(EELA)
24693 EQEP = SQRT(EQEP)
24694 EQET = SQRT(EQET)
24695 EQE2 = SQRT(EQE2)
24696 EPRO = SQRT(EPRO)
24697 EDEL = SQRT(EDEL)
24698 EDQE = SQRT(EDQE)
24699 WRITE(LOUT,'(8E9.3)')
24700 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24701C WRITE(LOUT,'(4E9.3)')
24702C & E,XDEL,XDQE,XDEL+XDQE
24703 ELSE
24704 WRITE(LOUT,'(11E10.3)')
24705 & E,
24706 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24707 & XSQE2(1,1,1),XSPRO(1,1,1),
24708 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24709 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24710 & XSDEL(1,1,1)+XSDQE(1,1,1)
24711C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24712C & XSDEL(1,1,1)+XSDQE(1,1,1)
24713 ENDIF
24714c ELSE
24715c IF (LLAB) THEN
24716c IF (IT.GT.1) THEN
24717c IF (IXSQEL.EQ.0) THEN
24718cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24719cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24720c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24721c & STOT,ETOT,SIN,EIN,STOT0)
24722c IF (IRATIO.EQ.1) THEN
24723c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24724cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24725cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24726c*!! save cross sections
24727c STOTA = STOT
24728c ETOTA = ETOT
24729c STOTP = STGP
24730c*!!
24731c STOT = STOT/(DBLE(IT)*STGP)
24732c SIN = SIN/(DBLE(IT)*SIGP)
24733c STOT0 = STGP
24734c ETOT = ZERO
24735c EIN = ZERO
24736c ENDIF
24737c ELSE
24738c WRITE(LOUT,*)
24739c & ' XSTABL: qel. xs. not implemented for nuclei'
24740c STOP
24741c ENDIF
24742c ELSE
24743c ETOT = ZERO
24744c EIN = ZERO
24745c STOT0= ZERO
24746c IF (IXSQEL.EQ.0) THEN
24747c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24748c ELSE
24749c SIN = ZERO
24750c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24751c ENDIF
24752c ENDIF
24753c ELSE
24754c IF (IT.GT.1) THEN
24755c IF (IXSQEL.EQ.0) THEN
24756c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24757c & STOT,ETOT,SIN,EIN,STOT0)
24758c IF (IRATIO.EQ.1) THEN
24759c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24760c*!! save cross sections
24761c STOTA = STOT
24762c ETOTA = ETOT
24763c STOTP = STGP
24764c*!!
24765c STOT = STOT/(DBLE(IT)*STGP)
24766c SIN = SIN/(DBLE(IT)*SIGP)
24767c STOT0 = STGP
24768c ETOT = ZERO
24769c EIN = ZERO
24770c ENDIF
24771c ELSE
24772c WRITE(LOUT,*)
24773c & ' XSTABL: qel. xs. not implemented for nuclei'
24774c STOP
24775c ENDIF
24776c ELSE
24777c ETOT = ZERO
24778c EIN = ZERO
24779c STOT0= ZERO
24780c IF (IXSQEL.EQ.0) THEN
24781c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24782c ELSE
24783c SIN = ZERO
24784c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24785c ENDIF
24786c ENDIF
24787c ENDIF
24788cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24789cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24790cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24791c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24792c ENDIF
24793 2 CONTINUE
24794 1 CONTINUE
24795
24796 RETURN
24797 END
24798
24799*$ CREATE DT_TESTXS.FOR
24800*COPY DT_TESTXS
24801*
24802*===testxs=============================================================*
24803*
24804 SUBROUTINE DT_TESTXS
24805
24806 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24807 SAVE
24808
24809 DIMENSION XSTOT(26,2),XSELA(26,2)
24810
24811 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24812 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24813 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24814 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24815 DUMECM = 0.0D0
24816 PLABL = 0.01D0
24817 PLABH = 10000.0D0
24818 NBINS = 120
24819 APLABL = LOG10(PLABL)
24820 APLABH = LOG10(PLABH)
24821 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24822 DO 1 I=1,NBINS+1
24823 ADP = APLABL+DBLE(I-1)*ADPLAB
24824 P = 10.0D0**ADP
24825 DO 2 J=1,26
24826 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24827 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24828 2 CONTINUE
24829 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24830 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24831 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24832 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24833 1 CONTINUE
24834 1000 FORMAT(F8.3,26F9.3)
24835
24836 RETURN
24837 END
24838************************************************************************
24839* *
24840* DTUNUC 2.0: library routines *
24841* processed by S. Roesler, 6.5.95 *
24842* *
24843************************************************************************
24844*
24845* 1) Handling of parton momenta
24846* SUBROUTINE MASHEL
24847* SUBROUTINE DFERMI
24848*
24849* 2) Handling of parton flavors and particle indices
24850* INTEGER FUNCTION IPDG2B
24851* INTEGER FUNCTION IB2PDG
24852* INTEGER FUNCTION IQUARK
24853* INTEGER FUNCTION IBJQUA
24854* INTEGER FUNCTION ICIHAD
24855* INTEGER FUNCTION IPDGHA
24856* INTEGER FUNCTION MCHAD
24857* SUBROUTINE FLAHAD
24858*
24859* 3) Energy-momentum and quantum number conservation check routines
24860* SUBROUTINE EMC1
24861* SUBROUTINE EMC2
24862* SUBROUTINE EVTEMC
24863* SUBROUTINE EVTFLC
24864* SUBROUTINE EVTCHG
24865*
24866* 4) Transformations
24867* SUBROUTINE LTINI
24868* SUBROUTINE LTRANS
24869* SUBROUTINE LTNUC
24870* SUBROUTINE DALTRA
24871* SUBROUTINE DTRAFO
24872* SUBROUTINE STTRAN
24873* SUBROUTINE MYTRAN
24874* SUBROUTINE LT2LAO
24875* SUBROUTINE LT2LAB
24876*
24877* 5) Sampling from distributions
24878* INTEGER FUNCTION NPOISS
24879* DOUBLE PRECISION FUNCTION SAMPXB
24880* DOUBLE PRECISION FUNCTION SAMPEX
24881* DOUBLE PRECISION FUNCTION SAMSQX
24882* DOUBLE PRECISION FUNCTION BETREJ
24883* DOUBLE PRECISION FUNCTION DGAMRN
24884* DOUBLE PRECISION FUNCTION DBETAR
24885* SUBROUTINE RANNOR
24886* SUBROUTINE DPOLI
24887* SUBROUTINE DSFECF
24888* SUBROUTINE RACO
24889*
24890* 6) Special functions, algorithms and service routines
24891* DOUBLE PRECISION FUNCTION YLAMB
24892* SUBROUTINE SORT
24893* SUBROUTINE SORT1
24894* SUBROUTINE DT_XTIME
24895*
24896* 7) Random number generator package
24897* DOUBLE PRECISION FUNCTION DT_RNDM
24898* SUBROUTINE DT_RNDMST
24899* SUBROUTINE DT_RNDMIN
24900* SUBROUTINE DT_RNDMOU
24901* SUBROUTINE DT_RNDMTE
24902*
24903************************************************************************
24904* *
24905* 1) Handling of parton momenta *
24906* *
24907************************************************************************
24908*$ CREATE DT_MASHEL.FOR
24909*COPY DT_MASHEL
24910*
24911*===mashel=============================================================*
24912*
24913 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24914
24915************************************************************************
24916* *
24917* rescaling of momenta of two partons to put both *
24918* on mass shell *
24919* *
24920* input: PA1,PA2 input momentum vectors *
24921* XM1,2 desired masses of particles afterwards *
24922* P1,P2 changed momentum vectors *
24923* *
24924* The original version is written by R. Engel. *
24925* This version dated 12.12.94 is modified by S. Roesler. *
24926************************************************************************
24927
24928 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24929 SAVE
24930
24931 PARAMETER ( LINP = 10 ,
24932 & LOUT = 6 ,
24933 & LDAT = 9 )
24934
24935 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24936
24937 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24938
24939 IREJ = 0
24940
24941* Lorentz transformation into system CMS
24942 PX = PA1(1)+PA2(1)
24943 PY = PA1(2)+PA2(2)
24944 PZ = PA1(3)+PA2(3)
24945 EE = PA1(4)+PA2(4)
24946 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24947 XMS = (EE-XPTOT)*(EE+XPTOT)
24948 IF(XMS.LT.(XM1+XM2)**2) THEN
24949C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24950 GOTO 9999
24951 ENDIF
24952 XMS = SQRT(XMS)
24953 BGX = PX/XMS
24954 BGY = PY/XMS
24955 BGZ = PZ/XMS
24956 GAM = EE/XMS
24957 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24958 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24959* rotation angles
24960 COD = P1(3)/PTOT1
24961C SID = SQRT((ONE-COD)*(ONE+COD))
24962 PPT = SQRT(P1(1)**2+P1(2)**2)
24963 SID = PPT/PTOT1
24964 COF = ONE
24965 SIF = ZERO
24966 IF(PTOT1*SID.GT.TINY10) THEN
24967 COF = P1(1)/(SID*PTOT1)
24968 SIF = P1(2)/(SID*PTOT1)
24969 ANORF = SQRT(COF*COF+SIF*SIF)
24970 COF = COF/ANORF
24971 SIF = SIF/ANORF
24972 ENDIF
24973* new CM momentum and energies (for masses XM1,XM2)
24974 XM12 = SIGN(XM1**2,XM1)
24975 XM22 = SIGN(XM2**2,XM2)
24976 SS = XMS**2
24977 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24978 EE1 = SQRT(XM12+PCMP**2)
24979 EE2 = XMS-EE1
24980* back rotation
24981 MODE = 1
24982 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24983 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24984 & PTOT1,P1(1),P1(2),P1(3),P1(4))
24985 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24986 & PTOT2,P2(1),P2(2),P2(3),P2(4))
24987* check consistency
24988 DEL = XMS*0.0001D0
24989 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
24990 IDEV = 1
24991 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
24992 IDEV = 2
24993 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
24994 IDEV = 3
24995 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
24996 IDEV = 4
24997 ELSE
24998 IDEV = 0
24999 ENDIF
25000 IF (IDEV.NE.0) THEN
25001 WRITE(LOUT,'(/1X,A,I3)')
25002 & 'MASHEL: inconsistent transformation',IDEV
25003 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25004 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25005 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25006 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25007 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25008 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25009 ENDIF
25010 RETURN
25011
25012 9999 CONTINUE
25013 IREJ = 1
25014 RETURN
25015 END
25016
25017*$ CREATE DT_DFERMI.FOR
25018*COPY DT_DFERMI
25019*
25020*===dfermi=============================================================*
25021*
25022 SUBROUTINE DT_DFERMI(GPART)
25023
25024************************************************************************
25025* Find largest of three random numbers. *
25026************************************************************************
25027
25028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25029 SAVE
25030
25031 DIMENSION G(3)
25032
25033 DO 10 I=1,3
25034 G(I)=DT_RNDM(GPART)
25035 10 CONTINUE
25036 IF (G(3).LT.G(2)) GOTO 40
25037 IF (G(3).LT.G(1)) GOTO 30
25038 GPART = G(3)
25039 20 RETURN
25040 30 GPART = G(1)
25041 GOTO 20
25042 40 IF (G(2).LT.G(1)) GOTO 30
25043 GPART = G(2)
25044 GOTO 20
25045
25046 END
25047
25048************************************************************************
25049* *
25050* 2) Handling of parton flavors and particle indices *
25051* *
25052************************************************************************
25053*$ CREATE IDT_IPDG2B.FOR
25054*COPY IDT_IPDG2B
25055*
25056*===ipdg2b=============================================================*
25057*
25058 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25059
25060************************************************************************
25061* *
25062* conversion of quark numbering scheme *
25063* *
25064* input: PDG parton numbering *
25065* for diquarks: NN number of the constituent quark *
25066* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25067* *
25068* output: BAMJET particle codes *
25069* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25070* 2 d 8 a-d -2 a-d *
25071* 3 s 9 a-s -3 a-s *
25072* 4 c 10 a-c -4 a-c *
25073* *
25074* This is a modified version of ICONV2 written by R. Engel. *
25075* This version dated 13.12.94 is written by S. Roesler. *
25076************************************************************************
25077
25078 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25079 SAVE
25080
25081 PARAMETER ( LINP = 10 ,
25082 & LOUT = 6 ,
25083 & LDAT = 9 )
25084
25085 IDA = ABS(ID)
25086* diquarks
25087 IF (IDA.GT.6) THEN
25088 KF = 3
25089 IF (IDA.GE.1000) KF = 4
25090 IDA = IDA/(10**(KF-NN))
25091 IDA = MOD(IDA,10)
25092 ENDIF
25093* exchange up and dn quarks
25094 IF (IDA.EQ.1) THEN
25095 IDA = 2
25096 ELSEIF (IDA.EQ.2) THEN
25097 IDA = 1
25098 ENDIF
25099* antiquarks
25100 IF (ID.LT.0) THEN
25101 IF (MODE.EQ.1) THEN
25102 IDA = IDA+6
25103 ELSE
25104 IDA = -IDA
25105 ENDIF
25106 ENDIF
25107 IDT_IPDG2B = IDA
25108
25109 RETURN
25110 END
25111
25112*$ CREATE IDT_IB2PDG.FOR
25113*COPY IDT_IB2PDG
25114*
25115*===ib2pdg=============================================================*
25116*
25117 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25118
25119************************************************************************
25120* *
25121* conversion of quark numbering scheme *
25122* *
25123* input: BAMJET particle codes *
25124* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25125* 2 d 8 a-d -2 a-d *
25126* 3 s 9 a-s -3 a-s *
25127* 4 c 10 a-c -4 a-c *
25128* *
25129* output: PDG parton numbering *
25130* *
25131* This version dated 13.12.94 is written by S. Roesler. *
25132************************************************************************
25133
25134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25135 SAVE
25136
25137 PARAMETER ( LINP = 10 ,
25138 & LOUT = 6 ,
25139 & LDAT = 9 )
25140
25141 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25142 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25143 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25144 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25145 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25146
25147 IDA = ID1
25148 IDB = ID2
25149 IF (MODE.EQ.1) THEN
25150 IF (ID1.GT.6) IDA = -(ID1-6)
25151 IF (ID2.GT.6) IDB = -(ID2-6)
25152 ENDIF
25153 IF (ID2.EQ.0) THEN
25154 IDT_IB2PDG = IHKKQ(IDA)
25155 ELSE
25156 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25157 ENDIF
25158
25159 RETURN
25160 END
25161
25162*$ CREATE IDT_IQUARK.FOR
25163*COPY IDT_IQUARK
25164*
25165*===ipdgqu=============================================================*
25166*
25167 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25168
25169************************************************************************
25170* *
25171* quark contents according to PDG conventions *
25172* (random selection in case of quark mixing) *
25173* *
25174* input: IDBAMJ BAMJET particle code *
25175* K 1..3 quark number *
25176* *
25177* output: 1 d (anti --> neg.) *
25178* 2 u *
25179* 3 s *
25180* 4 c *
25181* *
25182* This version written by R. Engel. *
25183************************************************************************
25184
25185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25186 SAVE
25187
25188 IQ = IDT_IBJQUA(K,IDBAMJ)
25189* quark-antiquark
25190 IF (IQ.GT.6) THEN
25191 IQ = 6-IQ
25192 ENDIF
25193* exchange of up and down
25194 IF (ABS(IQ).EQ.1) THEN
25195 IQ = SIGN(2,IQ)
25196 ELSEIF (ABS(IQ).EQ.2) THEN
25197 IQ = SIGN(1,IQ)
25198 ENDIF
25199 IDT_IQUARK = IQ
25200
25201 RETURN
25202 END
25203
25204*$ CREATE IDT_IBJQUA.FOR
25205*COPY IDT_IBJQUA
25206*
25207*===ibamq==============================================================*
25208*
25209 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25210
25211************************************************************************
25212* *
25213* quark contents according to BAMJET conventions *
25214* (random selection in case of quark mixing) *
25215* *
25216* input: IDBAMJ BAMJET particle code *
25217* K 1..3 quark number *
25218* *
25219* output: 1 u 7 u bar *
25220* 2 d 8 d bar *
25221* 3 s 9 s bar *
25222* 4 c 10 c bar *
25223* *
25224* This version written by R. Engel. *
25225************************************************************************
25226
25227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25228 SAVE
25229
25230 DIMENSION ITAB(3,210)
25231 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25232 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25233 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25234 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25235*sr 10.1.94
25236C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25237 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25238*
25239 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25240*sr 10.1.94
25241C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25242 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25243*sr 10.1.94
25244C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25245 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25246*
25247 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25248 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25249 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25250 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25251 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25252 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25253 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25254 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25255 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25256 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25257 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25258 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25259 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25260 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25261 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25262 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25263 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25264 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25265 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25266 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25267 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25268 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25269 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25270 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25271 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25272 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25274 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25275 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25276 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25277 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25278 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25279 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25280 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25281 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25282 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25283 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25284 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25285 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25286 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25287 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25288 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25289 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25290 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25291 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25292 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25293 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25294 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25295 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25296 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25297 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25298 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25299 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25300 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25301 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25302 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25303 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25304 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25305 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25306 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25307 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25308 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25309 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25310 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25311 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25312 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25313 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25314 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25315 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25316 DATA IDOLD /0/
25317
25318 ONE = 1.0D0
25319 IF (ITAB(1,IDBAMJ).LE.200) THEN
25320 ID = ITAB(K,IDBAMJ)
25321 ELSE
25322 IF(IDOLD.NE.IDBAMJ) THEN
25323 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25324 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25325 ELSE
25326 IDOLD = 0
25327 ENDIF
25328 ID = ITAB(K,IT)
25329 ENDIF
25330 IDOLD = IDBAMJ
25331 IDT_IBJQUA = ID
25332
25333 RETURN
25334 END
25335
25336*$ CREATE IDT_ICIHAD.FOR
25337*COPY IDT_ICIHAD
25338*
25339*===icihad=============================================================*
25340*
25341 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25342
25343************************************************************************
25344* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25345* This is a completely new version dated 25.10.95. *
25346* Renamed to be not in conflict with the modified PHOJET-version *
25347************************************************************************
25348
25349 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25350 SAVE
25351
25352* hadron index conversion (BAMJET <--> PDG)
25353 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25354 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25355 & IAMCIN(210)
25356
25357 IDT_ICIHAD = 0
25358 KPDG = ABS(MCIND)
25359 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25360 IF (MCIND.LT.0) THEN
25361 JSIGN = 1
25362 ELSE
25363 JSIGN = 2
25364 ENDIF
25365 IF (KPDG.GE.10000) THEN
25366 DO 1 I=1,19
25367 IDT_ICIHAD = IBAM5(JSIGN,I)
25368 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25369 IDT_ICIHAD = 0
25370 1 CONTINUE
25371 ELSEIF (KPDG.GE.1000) THEN
25372 DO 2 I=1,29
25373 IDT_ICIHAD = IBAM4(JSIGN,I)
25374 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25375 IDT_ICIHAD = 0
25376 2 CONTINUE
25377 ELSEIF (KPDG.GE.100) THEN
25378 DO 3 I=1,22
25379 IDT_ICIHAD = IBAM3(JSIGN,I)
25380 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25381 IDT_ICIHAD = 0
25382 3 CONTINUE
25383 ELSEIF (KPDG.GE.10) THEN
25384 DO 4 I=1,7
25385 IDT_ICIHAD = IBAM2(JSIGN,I)
25386 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25387 IDT_ICIHAD = 0
25388 4 CONTINUE
25389 ENDIF
25390 5 CONTINUE
25391
25392 RETURN
25393 END
25394
25395*$ CREATE IDT_IPDGHA.FOR
25396*COPY IDT_IPDGHA
25397*
25398*===ipdgha=============================================================*
25399*
25400 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25401
25402************************************************************************
25403* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25404* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25405* Renamed to be not in conflict with the modified PHOJET-version *
25406************************************************************************
25407
25408 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25409 SAVE
25410
25411* hadron index conversion (BAMJET <--> PDG)
25412 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25413 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25414 & IAMCIN(210)
25415
25416 IDT_IPDGHA = IAMCIN(MCIND)
25417
25418 RETURN
25419 END
25420
25421*$ CREATE DT_FLAHAD.FOR
25422*COPY DT_FLAHAD
25423*
25424*===flahad=============================================================*
25425*
25426 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25427
25428************************************************************************
25429* sampling of FLAvor composition for HADrons/photons *
25430* ID BAMJET-id of hadron *
25431* IF1,2,3 flavor content *
25432* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25433* Note: - u,d numbering as in BAMJET *
25434* - ID .le. 30 !! *
25435* This version dated 12.03.96 is written by S. Roesler *
25436************************************************************************
25437
25438 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25439 SAVE
25440
25441* auxiliary common for reggeon exchange (DTUNUC 1.x)
25442 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25443 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25444 & IQTCHR(-6:6),MQUARK(3,39)
25445
25446 DIMENSION JSEL(3,6)
25447 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25448
25449 ONE = 1.0D0
25450 IF (ID.EQ.7) THEN
25451* photon (charge dependent flavour sampling)
25452 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25453 IF (K.LE.4) THEN
25454 IF1 = 2
25455 IF2 = -2
25456 ELSE IF(K.EQ.5) THEN
25457 IF1 = 1
25458 IF2 = -1
25459 ELSE
25460 IF1 = 3
25461 IF2 = -3
25462 ENDIF
25463 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25464 K = IF1
25465 IF1 = IF2
25466 IF2 = K
25467 ENDIF
25468 IF3 = 0
25469 ELSE
25470* hadron
25471 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25472 IF1 = MQUARK(JSEL(1,IX),ID)
25473 IF2 = MQUARK(JSEL(2,IX),ID)
25474 IF3 = MQUARK(JSEL(3,IX),ID)
25475 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25476 IF1 = IF3
25477 IF3 = 0
25478 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25479 IF2 = IF3
25480 IF3 = 0
25481 ENDIF
25482 ENDIF
25483
25484 RETURN
25485 END
25486
25487*$ CREATE IDT_MCHAD.FOR
25488*COPY IDT_MCHAD
25489*
25490*===mchad==============================================================*
25491*
25492 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25493
25494************************************************************************
25495* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25496* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25497* *
25498* Last change 28.12.2006 by S. Roesler. *
25499************************************************************************
25500
25501 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25502 SAVE
25503
25504 DIMENSION ITRANS(210)
25505 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25506 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25507 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25508 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25509 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25510 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25511 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25512
25513 IF ( ITDTU .GT. 0 ) THEN
25514 IDT_MCHAD = ITRANS(ITDTU)
25515 ELSE
25516 IDT_MCHAD = -1
25517 END IF
25518
25519 RETURN
25520 END
25521
25522************************************************************************
25523* *
25524* 3) Energy-momentum and quantum number conservation check routines *
25525* *
25526************************************************************************
25527*$ CREATE DT_EMC1.FOR
25528*COPY DT_EMC1
25529*
25530*===emc1===============================================================*
25531*
25532 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25533
25534************************************************************************
25535* This version dated 15.12.94 is written by S. Roesler *
25536************************************************************************
25537
25538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25539 SAVE
25540
25541 PARAMETER ( LINP = 10 ,
25542 & LOUT = 6 ,
25543 & LDAT = 9 )
25544
25545 PARAMETER (TINY10=1.0D-10)
25546
25547 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25548
25549 IREJ = 0
25550
25551 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25552 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25553
25554 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25555 IF (MODE.EQ.1) THEN
25556 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25557 ELSEIF (MODE.EQ.2) THEN
25558 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25559 ENDIF
25560 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25561 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25562 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25563 ELSEIF (MODE.LT.0) THEN
25564 IF (MODE.EQ.-1) THEN
25565 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25566 ELSEIF (MODE.EQ.-2) THEN
25567 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25568 ENDIF
25569 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25570 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25571 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25572 ENDIF
25573
25574 IF (ABS(MODE).EQ.3) THEN
25575 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25576 IF (IREJ1.NE.0) GOTO 9999
25577 ENDIF
25578 RETURN
25579
25580 9999 CONTINUE
25581 IREJ = 1
25582 RETURN
25583 END
25584
25585*$ CREATE DT_EMC2.FOR
25586*COPY DT_EMC2
25587*
25588*===emc2===============================================================*
25589*
25590 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25591 & MODE,IPOS,IREJ)
25592
25593************************************************************************
25594* MODE = 1 energy-momentum cons. check *
25595* = 2 flavor-cons. check *
25596* = 3 energy-momentum & flavor cons. check *
25597* = 4 energy-momentum & charge cons. check *
25598* = 5 energy-momentum & flavor & charge cons. check *
25599* This version dated 16.01.95 is written by S. Roesler *
25600************************************************************************
25601
25602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25603 SAVE
25604
25605 PARAMETER ( LINP = 10 ,
25606 & LOUT = 6 ,
25607 & LDAT = 9 )
25608
25609 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25610
25611* event history
25612
25613 PARAMETER (NMXHKK=200000)
25614
25615 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25616 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25617 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25618
25619* extended event history
25620 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25621 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25622 & IHIST(2,NMXHKK)
25623
25624 IREJ = 0
25625 IREJ1 = 0
25626 IREJ2 = 0
25627 IREJ3 = 0
25628
25629 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25630 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25631 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25632 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25633 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25634 DO 1 I=1,NHKK
25635 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25636 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25637 & (ISTHKK(I).EQ.IP5)) THEN
25638 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25639 & .OR.(MODE.EQ.5))
25640 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25641 & 2,IDUM,IDUM)
25642 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25644 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25645 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25646 ENDIF
25647 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25648 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25649 & (ISTHKK(I).EQ.IN5)) THEN
25650 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25651 & .OR.(MODE.EQ.5))
25652 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25653 & 2,IDUM,IDUM)
25654 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25655 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25656 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25657 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25658 ENDIF
25659 1 CONTINUE
25660 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25661 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25662 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25663 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25664 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25665 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25666
25667 RETURN
25668
25669 9999 CONTINUE
25670 IREJ = 1
25671 RETURN
25672 END
25673
25674*$ CREATE DT_EVTEMC.FOR
25675*COPY DT_EVTEMC
25676*
25677*===evtemc=============================================================*
25678*
25679 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25680
25681************************************************************************
25682* This version dated 13.12.94 is written by S. Roesler *
25683************************************************************************
25684
25685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25686 SAVE
25687
25688 PARAMETER ( LINP = 10 ,
25689 & LOUT = 6 ,
25690 & LDAT = 9 )
25691
25692 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25693 & ZERO=0.0D0)
25694
25695* event history
25696
25697 PARAMETER (NMXHKK=200000)
25698
25699 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25700 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25701 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25702
25703* flags for input different options
25704 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25705 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25706 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25707
25708 IREJ = 0
25709
25710 MODE = IMODE
25711 CHKLEV = TINY10
25712 IF (MODE.EQ.4) THEN
25713 CHKLEV = TINY2
25714 MODE = 3
25715 ELSEIF (MODE.EQ.5) THEN
25716 CHKLEV = TINY1
25717 MODE = 3
25718 ELSEIF (MODE.EQ.-1) THEN
25719 CHKLEV = EIO
25720 MODE = 3
25721 ENDIF
25722
25723 IF (ABS(MODE).EQ.3) THEN
25724 PXDEV = PX
25725 PYDEV = PY
25726 PZDEV = PZ
25727 EDEV = E
25728 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25729 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25730 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25731 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25732 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25733 & ' event ',NEVHKK,
25734 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25735 PX = 0.0D0
25736 PY = 0.0D0
25737 PZ = 0.0D0
25738 E = 0.0D0
25739 GOTO 9999
25740 ENDIF
25741 PX = 0.0D0
25742 PY = 0.0D0
25743 PZ = 0.0D0
25744 E = 0.0D0
25745 RETURN
25746 ENDIF
25747
25748 IF (MODE.EQ.1) THEN
25749 PX = 0.0D0
25750 PY = 0.0D0
25751 PZ = 0.0D0
25752 E = 0.0D0
25753 ENDIF
25754
25755 PX = PX+PXIO
25756 PY = PY+PYIO
25757 PZ = PZ+PZIO
25758 E = E+EIO
25759
25760 RETURN
25761
25762 9999 CONTINUE
25763 IREJ = 1
25764 RETURN
25765 END
25766
25767*$ CREATE DT_EVTFLC.FOR
25768*COPY DT_EVTFLC
25769*
25770*===evtflc=============================================================*
25771*
25772 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25773
25774************************************************************************
25775* Flavor conservation check. *
25776* ID identity of particle *
25777* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25778* = 2 ID for particle/resonance in BAMJET numbering scheme *
25779* = 3 ID for particle/resonance in PDG numbering scheme *
25780* MODE = 1 initialization and add ID *
25781* =-1 initialization and subtract ID *
25782* = 2 add ID *
25783* =-2 subtract ID *
25784* = 3 check flavor cons. *
25785* IPOS flag to give position of call of EVTFLC to output *
25786* unit in case of violation *
25787* This version dated 10.01.95 is written by S. Roesler *
25788************************************************************************
25789
25790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25791 SAVE
25792
25793 PARAMETER ( LINP = 10 ,
25794 & LOUT = 6 ,
25795 & LDAT = 9 )
25796
25797 PARAMETER (TINY10=1.0D-10)
25798
25799 IREJ = 0
25800
25801 IF (MODE.EQ.3) THEN
25802 IF (IFL.NE.0) THEN
25803 WRITE(LOUT,'(1X,A,I3,A,I3)')
25804 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25805 & ' ! IFL = ',IFL
25806 IFL = 0
25807 GOTO 9999
25808 ENDIF
25809 IFL = 0
25810 RETURN
25811 ENDIF
25812
25813 IF (MODE.EQ.1) IFL = 0
25814 IF (ID.EQ.0) RETURN
25815
25816 IF (ID1.EQ.1) THEN
25817 IDD = ABS(ID)
25818 NQ = 1
25819 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25820 IF (IDD.GE.1000) NQ = 3
25821 DO 1 I=1,NQ
25822 IFBAM = IDT_IPDG2B(ID,I,2)
25823 IF (ABS(IFBAM).EQ.1) THEN
25824 IFBAM = SIGN(2,IFBAM)
25825 ELSEIF (ABS(IFBAM).EQ.2) THEN
25826 IFBAM = SIGN(1,IFBAM)
25827 ENDIF
25828 IF (MODE.GT.0) THEN
25829 IFL = IFL+IFBAM
25830 ELSE
25831 IFL = IFL-IFBAM
25832 ENDIF
25833 1 CONTINUE
25834 RETURN
25835 ENDIF
25836
25837 IDD = ID
25838 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25839 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25840 DO 2 I=1,3
25841 IF (MODE.GT.0) THEN
25842 IFL = IFL+IDT_IQUARK(I,IDD)
25843 ELSE
25844 IFL = IFL-IDT_IQUARK(I,IDD)
25845 ENDIF
25846 2 CONTINUE
25847 ENDIF
25848 RETURN
25849
25850 9999 CONTINUE
25851 IREJ = 1
25852 RETURN
25853 END
25854
25855*$ CREATE DT_EVTCHG.FOR
25856*COPY DT_EVTCHG
25857*
25858*===evtchg=============================================================*
25859*
25860 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25861
25862************************************************************************
25863* Charge conservation check. *
25864* ID identity of particle (PDG-numbering scheme) *
25865* MODE = 1 initialization *
25866* =-2 subtract ID-charge *
25867* = 2 add ID-charge *
25868* = 3 check charge cons. *
25869* IPOS flag to give position of call of EVTCHG to output *
25870* unit in case of violation *
25871* This version dated 10.01.95 is written by S. Roesler *
25872* Last change: s.r. 21.01.01 *
25873************************************************************************
25874
25875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25876 SAVE
25877
25878 PARAMETER ( LINP = 10 ,
25879 & LOUT = 6 ,
25880 & LDAT = 9 )
25881
25882* event history
25883
25884 PARAMETER (NMXHKK=200000)
25885
25886 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25887 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25888 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25889
25890* particle properties (BAMJET index convention)
25891 CHARACTER*8 ANAME
25892 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25893 & IICH(210),IIBAR(210),K1(210),K2(210)
25894
25895 IREJ = 0
25896
25897 IF (MODE.EQ.1) THEN
25898 ICH = 0
25899 IBAR = 0
25900 RETURN
25901 ENDIF
25902
25903 IF (MODE.EQ.3) THEN
25904 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25905 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25906 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25907 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25908 ICH = 0
25909 IBAR = 0
25910 GOTO 9999
25911 ENDIF
25912 ICH = 0
25913 IBAR = 0
25914 RETURN
25915 ENDIF
25916
25917 IF (ID.EQ.0) RETURN
25918
25919 IDD = IDT_ICIHAD(ID)
25920* modification 21.1.01: use intrinsic phojet-functions to determine charge
25921* and baryon number
25922C IF (IDD.GT.0) THEN
25923C IF (MODE.EQ.2) THEN
25924C ICH = ICH+IICH(IDD)
25925C IBAR = IBAR+IIBAR(IDD)
25926C ELSEIF (MODE.EQ.-2) THEN
25927C ICH = ICH-IICH(IDD)
25928C IBAR = IBAR-IIBAR(IDD)
25929C ENDIF
25930C ELSE
25931C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25932C CALL DT_EVTOUT(4)
25933C STOP
25934C ENDIF
25935 IF (MODE.EQ.2) THEN
25936 ICH = ICH+IPHO_CHR3(ID,1)/3
25937 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25938 ELSEIF (MODE.EQ.-2) THEN
25939 ICH = ICH-IPHO_CHR3(ID,1)/3
25940 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25941 ENDIF
25942
25943 RETURN
25944
25945 9999 CONTINUE
25946 IREJ = 1
25947 RETURN
25948 END
25949
25950************************************************************************
25951* *
25952* 4) Transformations *
25953* *
25954************************************************************************
25955*$ CREATE DT_LTINI.FOR
25956*COPY DT_LTINI
25957*
25958*===ltini==============================================================*
25959*
25960 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25961
25962************************************************************************
25963* Initializations of Lorentz-transformations, calculation of Lorentz- *
25964* parameters. *
25965* This version dated 13.11.95 is written by S. Roesler. *
25966************************************************************************
25967
25968 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25969 SAVE
25970
25971 PARAMETER ( LINP = 10 ,
25972 & LOUT = 6 ,
25973 & LDAT = 9 )
25974
25975 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25976 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25977
25978* Lorentz-parameters of the current interaction
25979 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25980 & UMO,PPCM,EPROJ,PPROJ
25981
25982* properties of photon/lepton projectiles
25983 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25984
25985* particle properties (BAMJET index convention)
25986 CHARACTER*8 ANAME
25987 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25988 & IICH(210),IIBAR(210),K1(210),K2(210)
25989
25990* nucleon-nucleon event-generator
25991 CHARACTER*8 CMODEL
25992 LOGICAL LPHOIN
25993 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
25994
25995 Q2 = VIRT
25996 IDP = IDPR
25997 IF (MCGENE.NE.3) THEN
25998* lepton-projectiles and PHOJET: initialize real photon instead
25999 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26000 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26001 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26002 IDP = 7
26003 Q2 = ZERO
26004 ENDIF
26005 ENDIF
26006 IDT = IDTA
26007 EPN = EPN0
26008 PPN = PPN0
26009 ECM = ECM0
26010 AMP = AAM(IDP)-SQRT(ABS(Q2))
26011 AMT = AAM(IDT)
26012 AMP2 = SIGN(AMP**2,AMP)
26013 AMT2 = AMT**2
26014 IF (ECM0.GT.ZERO) THEN
26015 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26016 IF (AMP2.GT.ZERO) THEN
26017 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26018 ELSE
26019 PPN = SQRT(EPN**2-AMP2)
26020 ENDIF
26021 ELSE
26022 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26023 IF (IDP.EQ.7) EPN = ABS(EPN)
26024 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26025 IF (AMP2.GT.ZERO) THEN
26026 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26027 ELSE
26028 PPN = SQRT(EPN**2-AMP2)
26029 ENDIF
26030 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26031 IF (AMP2.GT.ZERO) THEN
26032 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26033 ELSE
26034 EPN = SQRT(PPN**2+AMP2)
26035 ENDIF
26036 ENDIF
26037 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26038 ENDIF
26039 UMO = ECM
26040 EPROJ = EPN
26041 PPROJ = PPN
26042 IF (AMP2.GT.ZERO) THEN
26043 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26044 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26045 ELSE
26046 ETARG = TINY10
26047 PTARG = TINY10
26048 ENDIF
26049* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26050 IF (IDP.EQ.7) THEN
26051 PGAMM(1) = ZERO
26052 PGAMM(2) = ZERO
26053 AMGAM = AMP
26054 AMGAM2 = AMP2
26055 IF (ECM0.GT.ZERO) THEN
26056 S = ECM0**2
26057 ELSE
26058 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26059 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26060 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26061 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26062 ENDIF
26063 ENDIF
26064 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26065 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26066 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26067 IF (MODE.EQ.1) THEN
26068 PNUCL(1) = ZERO
26069 PNUCL(2) = ZERO
26070 PNUCL(3) = -PGAMM(3)
26071 PNUCL(4) = SQRT(S)-PGAMM(4)
26072 ENDIF
26073 ENDIF
26074 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26075 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26076 PLEPT0(1) = ZERO
26077 PLEPT0(2) = ZERO
26078* neglect lepton masses
26079C AMLPT2 = AAM(IDPR)**2
26080 AMLPT2 = ZERO
26081*
26082 IF (ECM0.GT.ZERO) THEN
26083 S = ECM0**2
26084 ELSE
26085 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26086 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26087 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26088 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26089 ENDIF
26090 ENDIF
26091 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26092 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26093 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26094 PNUCL(1) = ZERO
26095 PNUCL(2) = ZERO
26096 PNUCL(3) = -PLEPT0(3)
26097 PNUCL(4) = SQRT(S)-PLEPT0(4)
26098 ENDIF
26099* Lorentz-parameter for transformation Lab. - projectile rest system
26100 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26101 GALAB = TINY10
26102 BGLAB = TINY10
26103 BLAB = TINY10
26104 ELSE
26105 GALAB = EPROJ/AMP
26106 BGLAB = PPROJ/AMP
26107 BLAB = BGLAB/GALAB
26108 ENDIF
26109* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26110 IF (IDP.EQ.7) THEN
26111 GACMS(1) = TINY10
26112 BGCMS(1) = TINY10
26113 ELSE
26114 GACMS(1) = (ETARG+AMP)/UMO
26115 BGCMS(1) = PTARG/UMO
26116 ENDIF
26117* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26118 GACMS(2) = (EPROJ+AMT)/UMO
26119 BGCMS(2) = PPROJ/UMO
26120 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26121
26122 EPN0 = EPN
26123 PPN0 = PPN
26124 ECM0 = ECM
26125
26126 RETURN
26127 END
26128
26129*$ CREATE DT_LTRANS.FOR
26130*COPY DT_LTRANS
26131*
26132*===ltrans=============================================================*
26133*
26134 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26135
26136************************************************************************
26137* Lorentz-transformations. *
26138* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26139* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26140* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26141* This version dated 01.11.95 is written by S. Roesler. *
26142************************************************************************
26143
26144 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26145 SAVE
26146
26147 PARAMETER ( LINP = 10 ,
26148 & LOUT = 6 ,
26149 & LDAT = 9 )
26150
26151 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26152
26153 PARAMETER (SQTINF=1.0D+15)
26154
26155* particle properties (BAMJET index convention)
26156 CHARACTER*8 ANAME
26157 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26158 & IICH(210),IIBAR(210),K1(210),K2(210)
26159
26160 PXO = PXI
26161 PYO = PYI
26162 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26163
26164* check particle mass for consistency (numerical rounding errors)
26165 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26166 AMO2 = (PEO-PO)*(PEO+PO)
26167 AMORQ2 = AAM(ID)**2
26168 AMDIF2 = ABS(AMO2-AMORQ2)
26169 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26170 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26171 PEO = PEO+DELTA
26172 PO1 = PO -DELTA
26173 PXO = PXO*PO1/PO
26174 PYO = PYO*PO1/PO
26175 PZO = PZO*PO1/PO
26176C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26177 ENDIF
26178
26179 RETURN
26180 END
26181
26182*$ CREATE DT_LTNUC.FOR
26183*COPY DT_LTNUC
26184*
26185*===ltnuc==============================================================*
26186*
26187 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26188
26189************************************************************************
26190* Lorentz-transformations. *
26191* PIN longitudnal momentum (input) *
26192* EIN energy (input) *
26193* POUT transformed long. momentum (output) *
26194* EOUT transformed energy (output) *
26195* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26196* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26197* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26198* This version dated 01.11.95 is written by S. Roesler. *
26199************************************************************************
26200
26201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26202 SAVE
26203
26204 PARAMETER ( LINP = 10 ,
26205 & LOUT = 6 ,
26206 & LDAT = 9 )
26207
26208 PARAMETER (ZERO=0.0D0)
26209
26210* Lorentz-parameters of the current interaction
26211 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26212 & UMO,PPCM,EPROJ,PPROJ
26213
26214 BDUM1 = ZERO
26215 BDUM2 = ZERO
26216 PDUM1 = ZERO
26217 PDUM2 = ZERO
26218 IF (ABS(MODE).EQ.1) THEN
26219 BG = -SIGN(BGLAB,DBLE(MODE))
26220 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26221 & DUM1,DUM2,DUM3,POUT,EOUT)
26222 ELSEIF (ABS(MODE).EQ.2) THEN
26223 BG = SIGN(BGCMS(1),DBLE(MODE))
26224 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26225 & DUM1,DUM2,DUM3,POUT,EOUT)
26226 ELSEIF (ABS(MODE).EQ.3) THEN
26227 BG = -SIGN(BGCMS(2),DBLE(MODE))
26228 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26229 & DUM1,DUM2,DUM3,POUT,EOUT)
26230 ELSE
26231 WRITE(LOUT,1000) MODE
26232 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26233 EOUT = EIN
26234 POUT = PIN
26235 ENDIF
26236
26237 RETURN
26238 END
26239
26240*$ CREATE DT_DALTRA.FOR
26241*COPY DT_DALTRA
26242*
26243*===daltra=============================================================*
26244*
26245 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26246
26247************************************************************************
26248* Arbitrary Lorentz-transformation. *
26249* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26250************************************************************************
26251
26252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26253 SAVE
26254 PARAMETER (ONE=1.0D0)
26255
26256 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26257 PE = EP/(GA+ONE)+EC
26258 PX = PCX+BGX*PE
26259 PY = PCY+BGY*PE
26260 PZ = PCZ+BGZ*PE
26261 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26262 E = GA*EC+EP
26263
26264 RETURN
26265 END
26266
26267*$ CREATE DT_DTRAFO.FOR
26268*COPY DT_DTRAFO
26269*
26270*====dtrafo============================================================*
26271*
26272 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26273 & PL,CXL,CYL,CZL,EL)
26274
26275C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26276
26277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26278 SAVE
26279
26280 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26281 SID = SQRT(1.D0-COD*COD)
26282 PLX = P*SID*COF
26283 PLY = P*SID*SIF
26284 PCMZ = P*COD
26285 PLZ = GAM*PCMZ+BGAM*ECM
26286 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26287 EL = GAM*ECM+BGAM*PCMZ
26288C ROTATION INTO THE ORIGINAL DIRECTION
26289 COZ = PLZ/PL
26290 SIZ = SQRT(1.D0-COZ**2)
26291 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26292
26293 RETURN
26294 END
26295
26296*$ CREATE DT_STTRAN.FOR
26297*COPY DT_STTRAN
26298*
26299*====sttran============================================================*
26300*
26301 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26302
26303 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26304 SAVE
26305 DATA ANGLSQ/1.D-30/
26306************************************************************************
26307* VERSION BY J. RANFT *
26308* LEIPZIG *
26309* *
26310* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26311* *
26312* INPUT VARIABLES: *
26313* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26314* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26315* ANGLE OF "SCATTERING" *
26316* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26317* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26318* OF "SCATTERING" *
26319* *
26320* OUTPUT VARIABLES: *
26321* X,Y,Z = NEW DIRECTION COSINES *
26322* *
26323* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26324************************************************************************
26325*
26326*
26327* Changed by A. Ferrari
26328*
26329* IF (ABS(XO)-0.0001D0) 1,1,2
26330* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26331* 3 CONTINUE
26332 A = XO**2 + YO**2
26333 IF ( A .LT. ANGLSQ ) THEN
26334 X=SDE*CFE
26335 Y=SDE*SFE
26336 Z=CDE*ZO
26337 ELSE
26338 XI=SDE*CFE
26339 YI=SDE*SFE
26340 ZI=CDE
26341 A=SQRT(A)
26342 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26343 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26344 Z=A*YI+ZO*ZI
26345 ENDIF
26346
26347 RETURN
26348 END
26349
26350*$ CREATE DT_MYTRAN.FOR
26351*COPY DT_MYTRAN
26352*
26353*===mytran=============================================================*
26354*
26355 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26356
26357************************************************************************
26358* This subroutine rotates the coordinate frame *
26359* a) theta around y *
26360* b) phi around z if IMODE = 1 *
26361* *
26362* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26363* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26364* z' 0 0 1 -sin(th) 0 cos(th) z *
26365* *
26366* and vice versa if IMODE = 0. *
26367* This version dated 5.4.94 is based on the original version DTRAN *
26368* by J. Ranft and is written by S. Roesler. *
26369************************************************************************
26370
26371 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26372 SAVE
26373
26374 PARAMETER ( LINP = 10 ,
26375 & LOUT = 6 ,
26376 & LDAT = 9 )
26377
26378 IF (IMODE.EQ.1) THEN
26379 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26380 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26381 Z=-SDE *XO +CDE *ZO
26382 ELSE
26383 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26384 Y= -SFE*XO+CFE*YO
26385 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26386 ENDIF
26387 RETURN
26388 END
26389
26390*$ CREATE DT_LT2LAO.FOR
26391*COPY DT_LT2LAO
26392*
26393*===lt2lab=============================================================*
26394*
26395 SUBROUTINE DT_LT2LAO
26396
26397************************************************************************
26398* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26399* for final state particles/fragments defined in nucleon-nucleon-cms *
26400* and transforms them back to the lab. *
26401* This version dated 16.11.95 is written by S. Roesler *
26402************************************************************************
26403
26404 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26405 SAVE
26406
26407 PARAMETER ( LINP = 10 ,
26408 & LOUT = 6 ,
26409 & LDAT = 9 )
26410
26411* event history
26412
26413 PARAMETER (NMXHKK=200000)
26414
26415 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26416 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26417 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26418
26419* extended event history
26420 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26421 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26422 & IHIST(2,NMXHKK)
26423
26424 NEND = NHKK
26425 NPOINT(5) = NHKK+1
26426 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26427 DO 1 I=NPOINT(4),NEND
26428C DO 1 I=1,NEND
26429 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26430 & (ISTHKK(I).EQ.1001)) THEN
26431 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26432 NOB = NOBAM(I)
26433 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26434 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26435 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26436 ISTHKK(I) = 3*ISTHKK(I)
26437 NOBAM(NHKK) = NOB
26438 ELSE
26439 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26440 ISTHKK(I) = SIGN(3,ISTHKK(I))
26441 ENDIF
26442 JDAHKK(1,I) = NHKK
26443 ENDIF
26444 1 CONTINUE
26445
26446 RETURN
26447 END
26448
26449*$ CREATE DT_LT2LAB.FOR
26450*COPY DT_LT2LAB
26451*
26452*===lt2lab=============================================================*
26453*
26454 SUBROUTINE DT_LT2LAB
26455
26456************************************************************************
26457* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26458* for final state particles/fragments defined in nucleon-nucleon-cms *
26459* and transforms them to the lab. *
26460* This version dated 07.01.96 is written by S. Roesler *
26461************************************************************************
26462
26463 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26464 SAVE
26465
26466 PARAMETER ( LINP = 10 ,
26467 & LOUT = 6 ,
26468 & LDAT = 9 )
26469
26470* event history
26471
26472 PARAMETER (NMXHKK=200000)
26473
26474 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26475 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26476 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26477
26478* extended event history
26479 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26480 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26481 & IHIST(2,NMXHKK)
26482
26483 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26484 DO 1 I=NPOINT(4),NHKK
26485 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26486 & (ISTHKK(I).EQ.1001)) THEN
26487 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26488 PHKK(3,I) = PZ
26489 PHKK(4,I) = PE
26490 ENDIF
26491 1 CONTINUE
26492
26493 RETURN
26494 END
26495
26496************************************************************************
26497* *
26498* 5) Sampling from distributions *
26499* *
26500************************************************************************
26501*$ CREATE IDT_NPOISS.FOR
26502*COPY IDT_NPOISS
26503*
26504*===npoiss=============================================================*
26505*
26506 INTEGER FUNCTION IDT_NPOISS(AVN)
26507
26508************************************************************************
26509* Sample according to Poisson distribution with Poisson parameter AVN. *
26510* The original version written by J. Ranft. *
26511* This version dated 11.1.95 is written by S. Roesler. *
26512************************************************************************
26513
26514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26515 SAVE
26516
26517 PARAMETER ( LINP = 10 ,
26518 & LOUT = 6 ,
26519 & LDAT = 9 )
26520
26521 EXPAVN = EXP(-AVN)
26522 K = 1
26523 A = 1.0D0
26524
26525 10 CONTINUE
26526 A = DT_RNDM(A)*A
26527 IF (A.GE.EXPAVN) THEN
26528 K = K+1
26529 GOTO 10
26530 ENDIF
26531 IDT_NPOISS = K-1
26532
26533 RETURN
26534 END
26535
26536*$ CREATE DT_SAMPXB.FOR
26537*COPY DT_SAMPXB
26538*
26539*===sampxb=============================================================*
26540*
26541 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26542
26543************************************************************************
26544* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26545* Processed by S. Roesler, 6.5.95 *
26546************************************************************************
26547
26548 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26549 SAVE
26550 PARAMETER (TWO=2.0D0)
26551
26552 A1 = LOG(X1+SQRT(X1**2+B**2))
26553 A2 = LOG(X2+SQRT(X2**2+B**2))
26554 AN = A2-A1
26555 A = AN*DT_RNDM(A1)+A1
26556 BB = EXP(A)
26557 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26558
26559 RETURN
26560 END
26561
26562*$ CREATE DT_SAMPEX.FOR
26563*COPY DT_SAMPEX
26564*
26565*===sampex=============================================================*
26566*
26567 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26568
26569************************************************************************
26570* Sampling from f(x)=1./x between x1 and x2. *
26571* Processed by S. Roesler, 6.5.95 *
26572************************************************************************
26573
26574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26575 SAVE
26576 PARAMETER (ONE=1.0D0)
26577
26578 R = DT_RNDM(X1)
26579 AL1 = LOG(X1)
26580 AL2 = LOG(X2)
26581 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26582
26583 RETURN
26584 END
26585
26586*$ CREATE DT_SAMSQX.FOR
26587*COPY DT_SAMSQX
26588*
26589*===samsqx=============================================================*
26590*
26591 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26592
26593************************************************************************
26594* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26595* Processed by S. Roesler, 6.5.95 *
26596************************************************************************
26597
26598 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26599 SAVE
26600 PARAMETER (ONE=1.0D0)
26601
26602 R = DT_RNDM(X1)
26603 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26604
26605 RETURN
26606 END
26607
26608*$ CREATE DT_SAMPLW.FOR
26609*COPY DT_SAMPLW
26610*
26611*===samplw=============================================================*
26612*
26613 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26614
26615************************************************************************
26616* Sampling from f(x)=1/x^b between x_min and x_max. *
26617* S. Roesler, 18.4.98 *
26618************************************************************************
26619
26620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26621 SAVE
26622 PARAMETER (ONE=1.0D0)
26623
26624 R = DT_RNDM(B)
26625 IF (B.EQ.ONE) THEN
26626 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26627 ELSE
26628 ONEMB = ONE-B
26629 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26630 ENDIF
26631
26632 RETURN
26633 END
26634
26635*$ CREATE DT_BETREJ.FOR
26636*COPY DT_BETREJ
26637*
26638*===betrej=============================================================*
26639*
26640 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26641
26642 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26643 SAVE
26644
26645 PARAMETER ( LINP = 10 ,
26646 & LOUT = 6 ,
26647 & LDAT = 9 )
26648
26649 PARAMETER (ONE=1.0D0)
26650
26651 IF (XMIN.GE.XMAX)THEN
26652 WRITE (LOUT,500) XMIN,XMAX
26653 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26654 STOP
26655 ENDIF
26656
26657 10 CONTINUE
26658 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26659 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26660 YY = BETMAX*DT_RNDM(XX)
26661 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26662 IF (YY.GT.BETXX) GOTO 10
26663 DT_BETREJ = XX
26664
26665 RETURN
26666 END
26667
26668*$ CREATE DT_DGAMRN.FOR
26669*COPY DT_DGAMRN
26670*
26671*===dgamrn=============================================================*
26672*
26673 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26674
26675************************************************************************
26676* Sampling from Gamma-distribution. *
26677* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26678* Processed by S. Roesler, 6.5.95 *
26679************************************************************************
26680
26681 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26682 SAVE
26683 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26684
26685 NCOU = 0
26686 N = INT(ETA)
26687 F = ETA-DBLE(N)
26688 IF (F.EQ.ZERO) GOTO 20
26689 10 R = DT_RNDM(F)
26690 NCOU = NCOU+1
26691 IF (NCOU.GE.11) GOTO 20
26692 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26693 YYY = LOG(DT_RNDM(R)+TINY9)/F
26694 IF (ABS(YYY).GT.50.0D0) GOTO 20
26695 Y = EXP(YYY)
26696 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26697 GOTO 40
26698 20 Y = 0.0D0
26699 GOTO 50
26700 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26701 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26702 40 IF (N.EQ.0) GOTO 70
26703 50 Z = 1.0D0
26704 DO 60 I = 1,N
26705 60 Z = Z*DT_RNDM(Z)
26706 Y = Y-LOG(Z+TINY9)
26707 70 DT_DGAMRN = Y/ALAM
26708
26709 RETURN
26710 END
26711
26712*$ CREATE DT_DBETAR.FOR
26713*COPY DT_DBETAR
26714*
26715*===dbetar=============================================================*
26716*
26717 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26718
26719************************************************************************
26720* Sampling from Beta -distribution between 0.0 and 1.0 *
26721* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26722* Processed by S. Roesler, 6.5.95 *
26723************************************************************************
26724
26725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26726 SAVE
26727
26728 Y = DT_DGAMRN(1.0D0,GAM)
26729 Z = DT_DGAMRN(1.0D0,ETA)
26730 DT_DBETAR = Y/(Y+Z)
26731
26732 RETURN
26733 END
26734
26735*$ CREATE DT_RANNOR.FOR
26736*COPY DT_RANNOR
26737*
26738*===rannor=============================================================*
26739*
26740 SUBROUTINE DT_RANNOR(X,Y)
26741
26742************************************************************************
26743* Sampling from Gaussian distribution. *
26744* Processed by S. Roesler, 6.5.95 *
26745************************************************************************
26746
26747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26748 SAVE
26749 PARAMETER (TINY10=1.0D-10)
26750
26751 CALL DT_DSFECF(SFE,CFE)
26752 V = MAX(TINY10,DT_RNDM(X))
26753 A = SQRT(-2.D0*LOG(V))
26754 X = A*SFE
26755 Y = A*CFE
26756
26757 RETURN
26758 END
26759
26760*$ CREATE DT_DPOLI.FOR
26761*COPY DT_DPOLI
26762*
26763*===dpoli==============================================================*
26764*
26765 SUBROUTINE DT_DPOLI(CS,SI)
26766
26767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768 SAVE
26769
26770 U = DT_RNDM(CS)
26771 CS = DT_RNDM(U)
26772 IF (U.LT.0.5D0) CS=-CS
26773 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26774
26775 RETURN
26776 END
26777
26778*$ CREATE DT_DSFECF.FOR
26779*COPY DT_DSFECF
26780*
26781*===dsfecf=============================================================*
26782*
26783 SUBROUTINE DT_DSFECF(SFE,CFE)
26784
26785 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26786 SAVE
26787 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26788
26789 1 CONTINUE
26790 X = DT_RNDM(SFE)
26791 Y = DT_RNDM(X)
26792 XX = X*X
26793 YY = Y*Y
26794 XY = XX+YY
26795 IF (XY.GT.ONE) GOTO 1
26796 CFE = (XX-YY)/XY
26797 SFE = TWO*X*Y/XY
26798 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26799 RETURN
26800 END
26801
26802*$ CREATE DT_RACO.FOR
26803*COPY DT_RACO
26804*
26805*===raco===============================================================*
26806*
26807 SUBROUTINE DT_RACO(WX,WY,WZ)
26808
26809************************************************************************
26810* Direction cosines of random uniform (isotropic) direction in three *
26811* dimensional space *
26812* Processed by S. Roesler, 20.11.95 *
26813************************************************************************
26814
26815 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26816 SAVE
26817 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26818
26819 10 CONTINUE
26820 X = TWO*DT_RNDM(WX)-ONE
26821 Y = DT_RNDM(X)
26822 X2 = X*X
26823 Y2 = Y*Y
26824 IF (X2+Y2.GT.ONE) GOTO 10
26825
26826 CFE = (X2-Y2)/(X2+Y2)
26827 SFE = TWO*X*Y/(X2+Y2)
26828* z = 1/2 [ 1 + cos (theta) ]
26829 Z = DT_RNDM(X)
26830* 1/2 sin (theta)
26831 WZ = SQRT(Z*(ONE-Z))
26832 WX = TWO*WZ*CFE
26833 WY = TWO*WZ*SFE
26834 WZ = TWO*Z-ONE
26835
26836 RETURN
26837 END
26838
26839************************************************************************
26840* *
26841* 6) Special functions, algorithms and service routines *
26842* *
26843************************************************************************
26844*$ CREATE DT_YLAMB.FOR
26845*COPY DT_YLAMB
26846*
26847*===ylamb==============================================================*
26848*
26849 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26850
26851************************************************************************
26852* *
26853* auxiliary function for three particle decay mode *
26854* (standard LAMBDA**(1/2) function) *
26855* *
26856* Adopted from an original version written by R. Engel. *
26857* This version dated 12.12.94 is written by S. Roesler. *
26858************************************************************************
26859
26860 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26861 SAVE
26862
26863 YZ = Y-Z
26864 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26865 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26866 DT_YLAMB = SQRT(XLAM)
26867
26868 RETURN
26869 END
26870
26871*$ CREATE DT_SORT.FOR
26872*COPY DT_SORT
26873*
26874*===sort1==============================================================*
26875*
26876 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26877
26878************************************************************************
26879* This subroutine sorts entries in A in increasing/decreasing order *
26880* of A(3,i). *
26881* MODE = 1 increasing in A(3,i=1..N) *
26882* = 2 decreasing in A(3,i=1..N) *
26883* This version dated 21.04.95 is revised by S. Roesler *
26884************************************************************************
26885
26886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26887 SAVE
26888
26889 DIMENSION A(3,N)
26890
26891 M = I1
26892 10 CONTINUE
26893 M = I1-1
26894 IF (M.LE.0) RETURN
26895 L = 0
26896 DO 20 I=I0,M
26897 J = I+1
26898 IF (MODE.EQ.1) THEN
26899 IF (A(3,I).LE.A(3,J)) GOTO 20
26900 ELSE
26901 IF (A(3,I).GE.A(3,J)) GOTO 20
26902 ENDIF
26903 B = A(3,I)
26904 C = A(1,I)
26905 D = A(2,I)
26906 A(3,I) = A(3,J)
26907 A(2,I) = A(2,J)
26908 A(1,I) = A(1,J)
26909 A(3,J) = B
26910 A(1,J) = C
26911 A(2,J) = D
26912 L = 1
26913 20 CONTINUE
26914 IF (L.EQ.1) GOTO 10
26915
26916 RETURN
26917 END
26918
26919*$ CREATE DT_SORT1.FOR
26920*COPY DT_SORT1
26921*
26922*===sort1==============================================================*
26923*
26924 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26925
26926************************************************************************
26927* This subroutine sorts entries in A in increasing/decreasing order *
26928* of A(i). *
26929* MODE = 1 increasing in A(i=1..N) *
26930* = 2 decreasing in A(i=1..N) *
26931* This version dated 21.04.95 is revised by S. Roesler *
26932************************************************************************
26933
26934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26935 SAVE
26936
26937 DIMENSION A(N),IDX(N)
26938
26939 M = I1
26940 10 CONTINUE
26941 M = I1-1
26942 IF (M.LE.0) RETURN
26943 L = 0
26944 DO 20 I=I0,M
26945 J = I+1
26946 IF (MODE.EQ.1) THEN
26947 IF (A(I).LE.A(J)) GOTO 20
26948 ELSE
26949 IF (A(I).GE.A(J)) GOTO 20
26950 ENDIF
26951 B = A(I)
26952 A(I) = A(J)
26953 A(J) = B
26954 IX = IDX(I)
26955 IDX(I) = IDX(J)
26956 IDX(J) = IX
26957 L = 1
26958 20 CONTINUE
26959 IF (L.EQ.1) GOTO 10
26960
26961 RETURN
26962 END
26963
26964*$ CREATE DT_XTIME.FOR
26965*COPY DT_XTIME
26966*
26967*===xtime==============================================================*
26968*
26969 SUBROUTINE DT_XTIME
26970
26971 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26972 SAVE
26973
26974 PARAMETER ( LINP = 10 ,
26975 & LOUT = 6 ,
26976 & LDAT = 9 )
26977
26978 CHARACTER DAT*9,TIM*11
26979
26980 DAT = ' '
26981 TIM = ' '
26982C CALL GETDAT(IYEAR,IMONTH,IDAY)
26983C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26984
26985C CALL DATE(DAT)
26986C CALL TIME(TIM)
26987C WRITE(LOUT,1000) DAT,TIM
26988 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
26989
26990 RETURN
26991 END
26992
26993************************************************************************
26994* *
26995* 7) Random number generator package *
26996* *
26997* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
26998* SERVICE ROUTINES. *
26999* THE ALGORITHM IS FROM *
27000* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27001* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27002* IMPLEMENTATION BY K. HAHN DEC. 88, *
27003* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27004* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27005* THE PERIOD IS ABOUT 2**144, *
27006* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27007* THE PACKAGE CONTAINS *
27008* FUNCTION DT_RNDM(I) : GENERATOR *
27009* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27010* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27011* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27012* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27013*--- *
27014* FUNCTION DT_RNDM(I) *
27015* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27016* I - DUMMY VARIABLE, NOT USED *
27017* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27018* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27019* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27020* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27021* 12,34,56 ARE THE STANDARD VALUES *
27022* NB1 MUST BE IN 1..168 *
27023* 78 IS THE STANDARD VALUE *
27024* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27025* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27026* AS AFTER THE LAST DT_RNDMOU CALL ) *
27027* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27028* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27029* TAKES SEED FROM GENERATOR *
27030* U(97),C,CD,CM,I,J - SEED VALUES *
27031* SUBROUTINE DT_RNDMTE(IO) *
27032* TEST OF THE GENERATOR *
27033* IO - DEFINES OUTPUT *
27034* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27035* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27036* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27037* SAME STATUS *
27038* AS BEFORE CALL OF DT_RNDMTE *
27039************************************************************************
27040*$ CREATE DT_RNDM.FOR
27041*COPY DT_RNDM
27042*
27043*===rndm===============================================================*
27044*
27045c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27046c$$$
27047c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27048c$$$ SAVE
27049c$$$
27050c$$$* counter of calls to random number generator
27051c$$$* uncomment if needed
27052c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27053c$$$C LOGICAL LFIRST
27054c$$$C DATA LFIRST /.TRUE./
27055c$$$
27056c$$$* counter of calls to random number generator
27057c$$$* uncomment if needed
27058c$$$C IF (LFIRST) THEN
27059c$$$C IRNCT0 = 0
27060c$$$C IRNCT1 = 0
27061c$$$C LFIRST = .FALSE.
27062c$$$C ENDIF
27063c$$$
27064c$$$ DT_RNDM = FLRNDM(VDUMMY)
27065c$$$* counter of calls to random number generator
27066c$$$* uncomment if needed
27067c$$$C IRNCT1 = IRNCT1+1
27068c$$$
27069c$$$ RETURN
27070c$$$ END
27071c$$$
27072c$$$*$ CREATE DT_RNDMST.FOR
27073c$$$*COPY DT_RNDMST
27074c$$$*
27075c$$$*===rndmst=============================================================*
27076c$$$*
27077c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27078c$$$
27079c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27080c$$$ SAVE
27081c$$$
27082c$$$* random number generator
27083c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27084c$$$
27085c$$$ MA1 = NA1
27086c$$$ MA2 = NA2
27087c$$$ MA3 = NA3
27088c$$$ MB1 = NB1
27089c$$$ I = 97
27090c$$$ J = 33
27091c$$$ DO 20 II2 = 1,97
27092c$$$ S = 0
27093c$$$ T = 0.5D0
27094c$$$ DO 10 II1 = 1,24
27095c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27096c$$$ MA1 = MA2
27097c$$$ MA2 = MA3
27098c$$$ MA3 = MAT
27099c$$$ MB1 = MOD(53*MB1+1,169)
27100c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27101c$$$ 10 T = 0.5D0*T
27102c$$$ 20 U(II2) = S
27103c$$$ C = 362436.0D0/16777216.0D0
27104c$$$ CD = 7654321.0D0/16777216.0D0
27105c$$$ CM = 16777213.0D0/16777216.0D0
27106c$$$ RETURN
27107c$$$ END
27108c$$$
27109c$$$*$ CREATE DT_RNDMIN.FOR
27110c$$$*COPY DT_RNDMIN
27111c$$$*
27112c$$$*===rndmin=============================================================*
27113c$$$*
27114c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27115c$$$
27116c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27117c$$$ SAVE
27118c$$$
27119c$$$* random number generator
27120c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27121c$$$
27122c$$$ DIMENSION UIN(97)
27123c$$$
27124c$$$ DO 10 KKK = 1,97
27125c$$$ 10 U(KKK) = UIN(KKK)
27126c$$$ C = CIN
27127c$$$ CD = CDIN
27128c$$$ CM = CMIN
27129c$$$ I = IIN
27130c$$$ J = JIN
27131c$$$
27132c$$$ RETURN
27133c$$$ END
27134c$$$
27135c$$$*$ CREATE DT_RNDMOU.FOR
27136c$$$*COPY DT_RNDMOU
27137c$$$*
27138c$$$*===rndmou=============================================================*
27139c$$$*
27140c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27141c$$$
27142c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27143c$$$ SAVE
27144c$$$
27145c$$$* random number generator
27146c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27147c$$$
27148c$$$ DIMENSION UOUT(97)
27149c$$$
27150c$$$ DO 10 KKK = 1,97
27151c$$$ 10 UOUT(KKK) = U(KKK)
27152c$$$ COUT = C
27153c$$$ CDOUT = CD
27154c$$$ CMOUT = CM
27155c$$$ IOUT = I
27156c$$$ JOUT = J
27157c$$$
27158c$$$ RETURN
27159c$$$ END
27160c$$$
27161c$$$*$ CREATE DT_RNDMTE.FOR
27162c$$$*COPY DT_RNDMTE
27163c$$$*
27164c$$$*===rndmte=============================================================*
27165c$$$*
27166c$$$ SUBROUTINE DT_RNDMTE(IO)
27167c$$$
27168c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27169c$$$ SAVE
27170c$$$
27171c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27172c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27173c$$$ +8354498.D0, 10633180.D0/
27174c$$$
27175c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27176c$$$ CALL DT_RNDMST(12,34,56,78)
27177c$$$ DO 10 II1 = 1,20000
27178c$$$ 10 XX = DT_RNDM(XX)
27179c$$$ SD = 0.0D0
27180c$$$ DO 20 II2 = 1,6
27181c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27182c$$$ D(II2) = X(II2)-U(II2)
27183c$$$ 20 SD = SD+D(II2)
27184c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27185c$$$**sr 24.01.95
27186c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27187c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27188c$$$C WRITE(6,1000)
27189c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27190c$$$ & ' passed')
27191c$$$ ENDIF
27192c$$$**
27193c$$$ RETURN
27194c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27195c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27196c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27197c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27198c$$$ END
27199*
27200*$ CREATE PHO_RNDM.FOR
27201*COPY PHO_RNDM
27202*
27203*===pho_rndm===========================================================*
27204*
27205 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27206
27207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27208 SAVE
27209
27210 PHO_RNDM = DT_RNDM(DUMMY)
27211
27212 RETURN
27213 END
27214
27215*$ CREATE PYR.FOR
27216*COPY PYR
27217*
27218*===pyr================================================================*
27219*
27220 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27221
27222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27223 SAVE
27224
27225 DUMMY = DBLE(IDUMMY)
27226 PYR = DT_RNDM(DUMMY)
27227
27228 RETURN
27229 END
27230*$ CREATE DT_TITLE.FOR
27231*COPY DT_TITLE
27232*
27233*===title==============================================================*
27234*
27235 SUBROUTINE DT_TITLE
27236
27237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27238 SAVE
27239
27240 PARAMETER ( LINP = 10 ,
27241 & LOUT = 6 ,
27242 & LDAT = 9 )
27243
27244 CHARACTER*6 CVERSI
27245 CHARACTER*11 CCHANG
27246 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27247
27248 CALL DT_XTIME
27249 WRITE(LOUT,1000) CVERSI,CCHANG
27250 1000 FORMAT(1X,'+-------------------------------------------------',
27251 & '----------------------+',/,
27252 & 1X,'|',71X,'|',/,
27253 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27254 & 1X,'|',71X,'|',/,
27255 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27256 & 1X,'|',71X,'|',/,
27257 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27258 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27259 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27260C & 1X,'|',71X,'|',/,
27261C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27262C & 17X,'|',/,
27263 & 1X,'|',71X,'|',/,
27264 & 1X,'+-------------------------------------------------',
27265 & '----------------------+',/,
27266 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27267 & 'Stefan.Roesler@cern.ch |',/,
27268 & 1X,'+-------------------------------------------------',
27269 & '----------------------+',/)
27270
27271 RETURN
27272 END
27273
27274*$ CREATE DT_EVTINI.FOR
27275*COPY DT_EVTINI
27276*
27277*===evtini=============================================================*
27278*
27279 SUBROUTINE DT_EVTINI
27280
27281************************************************************************
27282* Initialization of DTEVT1. *
27283* This version dated 15.01.94 is written by S. Roesler *
27284************************************************************************
27285
27286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27287 SAVE
27288
27289 PARAMETER ( LINP = 10 ,
27290 & LOUT = 6 ,
27291 & LDAT = 9 )
27292
27293* event history
27294
27295 PARAMETER (NMXHKK=200000)
27296
27297 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27298 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27299 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27300
27301* extended event history
27302 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27303 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27304 & IHIST(2,NMXHKK)
27305
27306* event flag
27307 COMMON /DTEVNO/ NEVENT,ICASCA
27308
27309 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27310
27311* emulsion treatment
27312 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27313 & NCOMPO,IEMUL
27314
27315* initialization of DTEVT1/DTEVT2
27316 NEND = NHKK
27317 IF (NEVENT.EQ.1) NEND = NMXHKK
27318 NHKK = 0
27319 NEVHKK = NEVENT
27320 DO 1 I=1,NEND
27321 ISTHKK(I) = 0
27322 IDHKK(I) = 0
27323 JMOHKK(1,I) = 0
27324 JMOHKK(2,I) = 0
27325 JDAHKK(1,I) = 0
27326 JDAHKK(2,I) = 0
27327 IDRES(I) = 0
27328 IDXRES(I) = 0
27329 NOBAM(I) = 0
27330 IDCH(I) = 0
27331 IHIST(1,I) = 0
27332 IHIST(2,I) = 0
27333 DO 2 J=1,4
27334 PHKK(J,I) = 0.0D0
27335 VHKK(J,I) = 0.0D0
27336 WHKK(J,I) = 0.0D0
27337 2 CONTINUE
27338 PHKK(5,I) = 0.0D0
27339 1 CONTINUE
27340 DO 3 I=1,10
27341 NPOINT(I) = 0
27342 3 CONTINUE
27343 CALL DT_CHASTA(-1)
27344
27345C* initialization of DTLTRA
27346C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27347
27348 RETURN
27349 END
27350
27351*$ CREATE DT_STATIS.FOR
27352*COPY DT_STATIS
27353*
27354*===statis=============================================================*
27355*
27356 SUBROUTINE DT_STATIS(MODE)
27357
27358************************************************************************
27359* Initialization and output of run-statistics. *
27360* MODE = 1 initialization *
27361* = 2 output *
27362* This version dated 23.01.94 is written by S. Roesler *
27363************************************************************************
27364
27365 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27366 SAVE
27367
27368 PARAMETER ( LINP = 10 ,
27369 & LOUT = 6 ,
27370 & LDAT = 9 )
27371
27372 PARAMETER (TINY3=1.0D-3)
27373
27374* statistics
27375 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27376 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27377 & ICEVTG(8,0:30)
27378
27379* rejection counter
27380 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27381 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27382 & IREXCI(3),IRDIFF(2),IRINC
27383
27384* central particle production, impact parameter biasing
27385 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27386
27387* various options for treatment of partons (DTUNUC 1.x)
27388* (chain recombination, Cronin,..)
27389 LOGICAL LCO2CR,LINTPT
27390 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27391 & LCO2CR,LINTPT
27392
27393* nucleon-nucleon event-generator
27394 CHARACTER*8 CMODEL
27395 LOGICAL LPHOIN
27396 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27397
27398* flags for particle decays
27399 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27400 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27401 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27402
27403* diquark-breaking mechanism
27404 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27405
27406 DIMENSION PP(4),PT(4)
27407
27408 GOTO (1,2) MODE
27409
27410* initialization
27411 1 CONTINUE
27412
27413* initialize statistics counter
27414 ICREQU = 0
27415 ICSAMP = 0
27416 ICCPRO = 0
27417 ICDPR = 0
27418 ICDTA = 0
27419 ICRJSS = 0
27420 ICVV2S = 0
27421 DO 10 I=1,9
27422 ICRES(I) = 0
27423 ICCHAI(1,I) = 0
27424 ICCHAI(2,I) = 0
27425 10 CONTINUE
27426* initialize rejection counter
27427 IRPT = 0
27428 IRHHA = 0
27429 LOMRES = 0
27430 LOBRES = 0
27431 IRFRAG = 0
27432 IREVT = 0
27433 IRRES(1) = 0
27434 IRRES(2) = 0
27435 IRCHKI(1) = 0
27436 IRCHKI(2) = 0
27437 IRCRON(1) = 0
27438 IRCRON(2) = 0
27439 IRCRON(3) = 0
27440 IRDIFF(1) = 0
27441 IRDIFF(2) = 0
27442 IRINC = 0
27443 DO 11 I=1,5
27444 ICDIFF(I) = 0
27445 11 CONTINUE
27446 DO 12 I=1,8
27447 DO 13 J=0,30
27448 ICEVTG(I,J) = 0
27449 13 CONTINUE
27450 12 CONTINUE
27451
27452 RETURN
27453
27454* output
27455 2 CONTINUE
27456
27457* statistics counter
27458 WRITE(LOUT,1000)
27459 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27460 & 28X,'---------------------')
27461 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27462 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27463 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27464 & 'event',11X,F9.1)
27465 IF (ICDIFF(1).NE.0) THEN
27466 WRITE(LOUT,1009) ICDIFF
27467 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27468 & 'low mass high mass',/,24X,'single diffraction',
27469 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27470 ENDIF
27471 IF (ICENTR.GT.0) THEN
27472 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27473 & DBLE(ICSAMP)/DBLE(ICCPRO)
27474 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27475 & ' of sampled Glauber-events per event',9X,F9.1,/,
27476 & 2X,'fraction of production cross section',21X,F10.6)
27477 ENDIF
27478 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27479 & DBLE(ICDTA)/DBLE(ICSAMP)
27480 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27481 & ' nucleons after x-sampling',2(4X,F6.2))
27482
27483 IF (MCGENE.EQ.1) THEN
27484 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27485 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27486 & ' event',3X,F9.1)
27487 IF (ISICHA.EQ.1) THEN
27488 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27489 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27490 & 'of single chains per event',13X,F9.1)
27491 ENDIF
27492 WRITE(LOUT,1006)
27493 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27494 & 23X,'mean number of chains mean number of chains',/,
27495 & 23X,'sampled hadronized having mass of a reso.')
27496 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27497 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27498 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27499 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27500 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27501 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27502 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27503 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27504 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27505 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27506 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27507 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27508 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27509 WRITE(LOUT,1008)
27510 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27511 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27512 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27513 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27514 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27515 & DBLE(IRHHA)/DBLE(ICREQU),
27516 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27517 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27518 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27519 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27520 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27521 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27522 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27523 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27524 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27525 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27526 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27527 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27528 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27529 & F7.2,/,1X,'Total no. of rej.',
27530 & ' in chain-systems treatment (GETCSY)',/,43X,
27531 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27532 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27533 & 1X,'Total no. of rej. in DPM-treatment of one event',
27534 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27535 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27536 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27537 & 'IREXCI(3) = ',I5,/)
27538 ELSEIF (MCGENE.EQ.2) THEN
27539 WRITE(LOUT,1010) ELOJET
27540 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27541 & F4.1,' GeV')
27542 WRITE(LOUT,1011)
27543 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27544 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27545 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27546 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27547 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27548 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27549 & ((ICEVTG(I,J),I=1,8),J=3,7),
27550 & ((ICEVTG(I,J),I=1,8),J=19,21),
27551 & (ICEVTG(I,8),I=1,8),
27552 & ((ICEVTG(I,J),I=1,8),J=22,24),
27553 & (ICEVTG(I,9),I=1,8),
27554 & ((ICEVTG(I,J),I=1,8),J=25,28),
27555 & ((ICEVTG(I,J),I=1,8),J=10,18)
27556 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27557 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27558 & ' no-dif.',8I8,/,
27559 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27560 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27561 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27562 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27563 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27564 & ' hi-lo ',8I8,/,
27565 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27566 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27567 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27568 WRITE(LOUT,1013)
27569 1013 FORMAT(/,1X,'2. chain system statistics -',
27570 & ' mean numbers per evt:',/,30X,'---------------------',
27571 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27572 WRITE(LOUT,1014)
27573 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27574 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27575 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27576 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27577 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27578 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27579 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27580 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27581 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27582 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27583 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27584 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27585 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27586 WRITE(LOUT,1015)
27587 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27588 WRITE(LOUT,1016)
27589 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27590 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27591 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27592 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27593 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27594 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27595 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27596 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27597 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27598 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27599 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27600 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27601 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27602
27603 ENDIF
27604 CALL DT_CHASTA(1)
27605
27606 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27607 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27608 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27609 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27610 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27611 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27612 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27613 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27614 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27615 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27616 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27617 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27618 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27619 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27620 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27621 & DBRKA(3,1),DBRKA(3,2),
27622 & DBRKA(3,3),DBRKA(3,4)
27623 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27624 & DBRKR(3,1),DBRKR(3,2),
27625 & DBRKR(3,3),DBRKR(3,4)
27626 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27627 & DBRKA(3,5),DBRKA(3,6),
27628 & DBRKA(3,7),DBRKA(3,8)
27629 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27630 & DBRKR(3,5),DBRKR(3,6),
27631 & DBRKR(3,7),DBRKR(3,8)
27632 ENDIF
27633
27634 FAC = 1.0D0
27635 IF (MCGENE.EQ.2) THEN
27636
27637C CALL PHO_PHIST(-2,SIGMAX)
27638 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27639
27640 ENDIF
27641
27642 CALL DT_XTIME
27643
27644 RETURN
27645 END
27646
27647*$ CREATE DT_EVTOUT.FOR
27648*COPY DT_EVTOUT
27649*
27650*===evtout=============================================================*
27651*
27652 SUBROUTINE DT_EVTOUT(MODE)
27653
27654************************************************************************
27655* MODE = 1 plot content of complete DTEVT1 to out. unit *
27656* 3 plot entries of extended DTEVT1 (DTEVT2) *
27657* 4 plot entries of DTEVT1 and DTEVT2 *
27658* This version dated 11.12.94 is written by S. Roesler *
27659************************************************************************
27660
27661 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27662 SAVE
27663
27664 PARAMETER ( LINP = 10 ,
27665 & LOUT = 6 ,
27666 & LDAT = 9 )
27667
27668* event history
27669
27670 PARAMETER (NMXHKK=200000)
27671
27672 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27673 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27674 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27675
27676 DIMENSION IRANGE(NMXHKK)
27677
27678 IF (MODE.EQ.2) RETURN
27679
27680 CALL DT_EVTPLO(IRANGE,MODE)
27681
27682 RETURN
27683 END
27684
27685*$ CREATE DT_EVTPLO.FOR
27686*COPY DT_EVTPLO
27687*
27688*===evtplo=============================================================*
27689*
27690 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27691
27692************************************************************************
27693* MODE = 1 plot content of complete DTEVT1 to out. unit *
27694* 2 plot entries of DTEVT1 given by IRANGE *
27695* 3 plot entries of extended DTEVT1 (DTEVT2) *
27696* 4 plot entries of DTEVT1 and DTEVT2 *
27697* 5 plot rejection counter *
27698* This version dated 11.12.94 is written by S. Roesler *
27699************************************************************************
27700
27701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27702 SAVE
27703
27704 PARAMETER ( LINP = 10 ,
27705 & LOUT = 6 ,
27706 & LDAT = 9 )
27707
27708 CHARACTER*16 CHAU
27709
27710* event history
27711
27712 PARAMETER (NMXHKK=200000)
27713
27714 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27715 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27716 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27717
27718* extended event history
27719 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27720 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27721 & IHIST(2,NMXHKK)
27722
27723* rejection counter
27724 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27725 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27726 & IREXCI(3),IRDIFF(2),IRINC
27727
27728 DIMENSION IRANGE(NMXHKK)
27729
27730 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27731 WRITE(LOUT,1000)
27732 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27733 & 15X,' --------------------------',/,/,
27734 & ' ST ID M1 M2 D1 D2 PX PY',
27735 & ' PZ E M',/)
27736 DO 1 I=1,NHKK
27737 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27738 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27739 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27740 & PHKK(5,I)
27741C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27742C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27743C & PHKK(3,I),PHKK(4,I)
27744C WRITE(LOUT,'(4E15.4)')
27745C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27746 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27747 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27748 1 CONTINUE
27749 WRITE(LOUT,*)
27750C DO 4 I=1,NHKK
27751C WRITE(LOUT,1006) I,ISTHKK(I),
27752C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27753C & WHKK(2,I),WHKK(3,I)
27754C1006 FORMAT(1X,I4,I6,6E10.3)
27755C 4 CONTINUE
27756 ENDIF
27757
27758 IF (MODE.EQ.2) THEN
27759 WRITE(LOUT,1000)
27760 NC = 0
27761 2 CONTINUE
27762 NC = NC+1
27763 IF (IRANGE(NC).EQ.-100) GOTO 9999
27764 I = IRANGE(NC)
27765 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27766 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27767 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27768 & PHKK(5,I)
27769 GOTO 2
27770 ENDIF
27771
27772 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27773 WRITE(LOUT,1002)
27774 1002 FORMAT(/,1X,'EVTPLO:',14X,
27775 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27776 & 15X,' -----------------------------------',/,/,
27777 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27778 & ' NOBAM IDCH M',/)
27779 DO 3 I=1,NHKK
27780C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27781 KF = IDHKK(I)
27782 IDCHK = KF/10000
27783 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27784 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27785
27786 CALL PYNAME(KF,CHAU)
27787
27788 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27789 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27790 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27791 & PHKK(5,I),CHAU
27792 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27793C ENDIF
27794 3 CONTINUE
27795 ENDIF
27796
27797 IF (MODE.EQ.5) THEN
27798 WRITE(LOUT,1004)
27799 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27800 & 15X,' --------------------------',/)
27801 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27802 & IRSEA,IRCRON
27803 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27804 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27805 & 1X,'IREMC = ',10I5,/,
27806 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27807 ENDIF
27808
27809 9999 RETURN
27810 END
27811
27812*$ CREATE DT_EVTPUT.FOR
27813*COPY DT_EVTPUT
27814*
27815*===evtput=============================================================*
27816*
27817 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27818
27819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27820 SAVE
27821
27822 PARAMETER ( LINP = 10 ,
27823 & LOUT = 6 ,
27824 & LDAT = 9 )
27825
27826 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27827 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27828
27829* event history
27830
27831 PARAMETER (NMXHKK=200000)
27832
27833 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27834 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27835 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27836
27837* extended event history
27838 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27839 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27840 & IHIST(2,NMXHKK)
27841
27842* Lorentz-parameters of the current interaction
27843 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27844 & UMO,PPCM,EPROJ,PPROJ
27845
27846* particle properties (BAMJET index convention)
27847 CHARACTER*8 ANAME
27848 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27849 & IICH(210),IIBAR(210),K1(210),K2(210)
27850
27851C IF (MODE.GT.100) THEN
27852C WRITE(LOUT,'(1X,A,I5,A,I5)')
27853C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27854C NHKK = NHKK-MODE+100
27855C RETURN
27856C ENDIF
27857 MO1 = M1
27858 MO2 = M2
27859 NHKK = NHKK+1
27860
27861 IF (NHKK.GT.NMXHKK) THEN
27862 WRITE(LOUT,1000) NHKK
27863 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27864 & '! program execution stopped..')
27865 STOP
27866 ENDIF
27867 IF (M1.LT.0) MO1 = NHKK+M1
27868 IF (M2.LT.0) MO2 = NHKK+M2
27869 ISTHKK(NHKK) = IST
27870 IDHKK(NHKK) = ID
27871 JMOHKK(1,NHKK) = MO1
27872 JMOHKK(2,NHKK) = MO2
27873 JDAHKK(1,NHKK) = 0
27874 JDAHKK(2,NHKK) = 0
27875 IDRES(NHKK) = IDR
27876 IDXRES(NHKK) = IDXR
27877 IDCH(NHKK) = IDC
27878** here we need to do something..
27879 IF (ID.EQ.88888) THEN
27880 IDMO1 = ABS(IDHKK(MO1))
27881 IDMO2 = ABS(IDHKK(MO2))
27882 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27883 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27884 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27885 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27886 ELSE
27887 NOBAM(NHKK) = 0
27888 ENDIF
27889 IDBAM(NHKK) = IDT_ICIHAD(ID)
27890 IF (MO1.GT.0) THEN
27891 IF (JDAHKK(1,MO1).NE.0) THEN
27892 JDAHKK(2,MO1) = NHKK
27893 ELSE
27894 JDAHKK(1,MO1) = NHKK
27895 ENDIF
27896 ENDIF
27897 IF (MO2.GT.0) THEN
27898 IF (JDAHKK(1,MO2).NE.0) THEN
27899 JDAHKK(2,MO2) = NHKK
27900 ELSE
27901 JDAHKK(1,MO2) = NHKK
27902 ENDIF
27903 ENDIF
27904C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27905C PTOT = SQRT(PX**2+PY**2+PZ**2)
27906C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27907C AMRQ = AAM(IDBAM(NHKK))
27908C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27909C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27910C & (PTOT.GT.ZERO)) THEN
27911C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27912CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27913C E = E+DELTA
27914C PTOT1 = PTOT-DELTA
27915C PX = PX*PTOT1/PTOT
27916C PY = PY*PTOT1/PTOT
27917C PZ = PZ*PTOT1/PTOT
27918C ENDIF
27919C ENDIF
27920 PHKK(1,NHKK) = PX
27921 PHKK(2,NHKK) = PY
27922 PHKK(3,NHKK) = PZ
27923 PHKK(4,NHKK) = E
27924 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27925 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27926 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27927 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27928 ELSE
27929 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27930C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27931C & WRITE(LOUT,'(1X,A,G10.3)')
27932C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27933 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27934 ENDIF
27935 IDCHK = ID/10000
27936 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27937* special treatment for chains:
27938* z coordinate of chain in Lab = pos. of target nucleon
27939* time of chain-creation in Lab = time of passage of projectile
27940* nucleus at pos. of taget nucleus
27941C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27942C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27943 VHKK(1,NHKK) = VHKK(1,MO2)
27944 VHKK(2,NHKK) = VHKK(2,MO2)
27945 VHKK(3,NHKK) = VHKK(3,MO2)
27946 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27947C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27948C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27949 WHKK(1,NHKK) = WHKK(1,MO1)
27950 WHKK(2,NHKK) = WHKK(2,MO1)
27951 WHKK(3,NHKK) = WHKK(3,MO1)
27952 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27953 ELSE
27954 IF (MO1.GT.0) THEN
27955 DO 1 I=1,4
27956 VHKK(I,NHKK) = VHKK(I,MO1)
27957 WHKK(I,NHKK) = WHKK(I,MO1)
27958 1 CONTINUE
27959 ELSE
27960 DO 2 I=1,4
27961 VHKK(I,NHKK) = ZERO
27962 WHKK(I,NHKK) = ZERO
27963 2 CONTINUE
27964 ENDIF
27965 ENDIF
27966
27967 RETURN
27968 END
27969
27970*$ CREATE DT_CHASTA.FOR
27971*COPY DT_CHASTA
27972*
27973*===chasta=============================================================*
27974*
27975 SUBROUTINE DT_CHASTA(MODE)
27976
27977************************************************************************
27978* This subroutine performs CHAin STAtistics and checks sequence of *
27979* partons in dtevt1 and sorts them with projectile partons coming *
27980* first if necessary. *
27981* *
27982* This version dated 8.5.00 is written by S. Roesler. *
27983************************************************************************
27984
27985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27986 SAVE
27987
27988 PARAMETER ( LINP = 10 ,
27989 & LOUT = 6 ,
27990 & LDAT = 9 )
27991
27992 CHARACTER*5 CCHTYP
27993
27994* event history
27995
27996 PARAMETER (NMXHKK=200000)
27997
27998 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27999 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28000 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28001
28002* extended event history
28003 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28004 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28005 & IHIST(2,NMXHKK)
28006
28007* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28008 PARAMETER (MAXCHN=10000)
28009 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28010
28011 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28012 & CCHTYP(9),ICHSTA(10),ITOT(10)
28013 DATA ICHCFG /1800*0/
28014 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28015 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28016 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28017 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28018 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28019 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28020 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28021 & 'ad aq',' d ad','ad d ',' g g '/
28022*
28023* initialization
28024*
28025 IF (MODE.EQ.-1) THEN
28026 NCHAIN = 0
28027*
28028* loop over DTEVT1 and analyse chain configurations
28029*
28030 ELSEIF (MODE.EQ.0) THEN
28031 DO 21 IDX=NPOINT(3),NHKK
28032 IDCHK = IDHKK(IDX)/10000
28033 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28034 & (IDHKK(IDX).NE.80000).AND.
28035 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28036 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28037 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28038 & ' at entry ',IDX
28039 GOTO 21
28040 ENDIF
28041*
28042 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28043 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28044 IMO1 = IST1/10
28045 IMO1 = IST1-10*IMO1
28046 IMO2 = IST2/10
28047 IMO2 = IST2-10*IMO2
28048* swop parton entries if necessary since we need projectile partons
28049* to come first in the common
28050 IF (IMO1.GT.IMO2) THEN
28051 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28052 DO 22 K=1,NPTN/2
28053 I0 = JMOHKK(1,IDX)-1+K
28054 I1 = JMOHKK(2,IDX)+1-K
28055 ITMP = ISTHKK(I0)
28056 ISTHKK(I0) = ISTHKK(I1)
28057 ISTHKK(I1) = ITMP
28058 ITMP = IDHKK(I0)
28059 IDHKK(I0) = IDHKK(I1)
28060 IDHKK(I1) = ITMP
28061 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28062 & JDAHKK(1,JMOHKK(1,I0)) = I1
28063 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28064 & JDAHKK(2,JMOHKK(1,I0)) = I1
28065 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28066 & JDAHKK(1,JMOHKK(2,I0)) = I1
28067 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28068 & JDAHKK(2,JMOHKK(2,I0)) = I1
28069 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28070 & JDAHKK(1,JMOHKK(1,I1)) = I0
28071 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28072 & JDAHKK(2,JMOHKK(1,I1)) = I0
28073 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28074 & JDAHKK(1,JMOHKK(2,I1)) = I0
28075 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28076 & JDAHKK(2,JMOHKK(2,I1)) = I0
28077 ITMP = JMOHKK(1,I0)
28078 JMOHKK(1,I0) = JMOHKK(1,I1)
28079 JMOHKK(1,I1) = ITMP
28080 ITMP = JMOHKK(2,I0)
28081 JMOHKK(2,I0) = JMOHKK(2,I1)
28082 JMOHKK(2,I1) = ITMP
28083 ITMP = JDAHKK(1,I0)
28084 JDAHKK(1,I0) = JDAHKK(1,I1)
28085 JDAHKK(1,I1) = ITMP
28086 ITMP = JDAHKK(2,I0)
28087 JDAHKK(2,I0) = JDAHKK(2,I1)
28088 JDAHKK(2,I1) = ITMP
28089 DO 23 J=1,4
28090 RTMP1 = PHKK(J,I0)
28091 RTMP2 = VHKK(J,I0)
28092 RTMP3 = WHKK(J,I0)
28093 PHKK(J,I0) = PHKK(J,I1)
28094 VHKK(J,I0) = VHKK(J,I1)
28095 WHKK(J,I0) = WHKK(J,I1)
28096 PHKK(J,I1) = RTMP1
28097 VHKK(J,I1) = RTMP2
28098 WHKK(J,I1) = RTMP3
28099 23 CONTINUE
28100 RTMP1 = PHKK(5,I0)
28101 PHKK(5,I0) = PHKK(5,I1)
28102 PHKK(5,I1) = RTMP1
28103 ITMP = IDRES(I0)
28104 IDRES(I0) = IDRES(I1)
28105 IDRES(I1) = ITMP
28106 ITMP = IDXRES(I0)
28107 IDXRES(I0) = IDXRES(I1)
28108 IDXRES(I1) = ITMP
28109 ITMP = NOBAM(I0)
28110 NOBAM(I0) = NOBAM(I1)
28111 NOBAM(I1) = ITMP
28112 ITMP = IDBAM(I0)
28113 IDBAM(I0) = IDBAM(I1)
28114 IDBAM(I1) = ITMP
28115 ITMP = IDCH(I0)
28116 IDCH(I0) = IDCH(I1)
28117 IDCH(I1) = ITMP
28118 ITMP = IHIST(1,I0)
28119 IHIST(1,I0) = IHIST(1,I1)
28120 IHIST(1,I1) = ITMP
28121 ITMP = IHIST(2,I0)
28122 IHIST(2,I0) = IHIST(2,I1)
28123 IHIST(2,I1) = ITMP
28124 22 CONTINUE
28125 ENDIF
28126 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28127 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28128*
28129* parton 1 (projectile side)
28130 IF (IST1.EQ.21) THEN
28131 IDX1 = 1
28132 ELSEIF (IST1.EQ.22) THEN
28133 IDX1 = 2
28134 ELSEIF (IST1.EQ.31) THEN
28135 IDX1 = 3
28136 ELSEIF (IST1.EQ.32) THEN
28137 IDX1 = 4
28138 ELSEIF (IST1.EQ.41) THEN
28139 IDX1 = 5
28140 ELSEIF (IST1.EQ.42) THEN
28141 IDX1 = 6
28142 ELSEIF (IST1.EQ.51) THEN
28143 IDX1 = 7
28144 ELSEIF (IST1.EQ.52) THEN
28145 IDX1 = 8
28146 ELSEIF (IST1.EQ.61) THEN
28147 IDX1 = 9
28148 ELSEIF (IST1.EQ.62) THEN
28149 IDX1 = 10
28150 ELSE
28151c WRITE(LOUT,*)
28152c & ' CHASTA: unknown parton status flag (',
28153c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28154 GOTO 21
28155 ENDIF
28156 ID = IDHKK(JMOHKK(1,IDX))
28157 IF (ABS(ID).LE.4) THEN
28158 IF (ID.GT.0) THEN
28159 ITYP1 = 1
28160 ELSE
28161 ITYP1 = 2
28162 ENDIF
28163 ELSEIF (ABS(ID).GE.1000) THEN
28164 IF (ID.GT.0) THEN
28165 ITYP1 = 3
28166 ELSE
28167 ITYP1 = 4
28168 ENDIF
28169 ELSEIF (ID.EQ.21) THEN
28170 ITYP1 = 5
28171 ELSE
28172 WRITE(LOUT,*)
28173 & ' CHASTA: inconsistent parton identity (',
28174 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28175 GOTO 21
28176 ENDIF
28177*
28178* parton 2 (target side)
28179 IF (IST2.EQ.21) THEN
28180 IDX2 = 1
28181 ELSEIF (IST2.EQ.22) THEN
28182 IDX2 = 2
28183 ELSEIF (IST2.EQ.31) THEN
28184 IDX2 = 3
28185 ELSEIF (IST2.EQ.32) THEN
28186 IDX2 = 4
28187 ELSEIF (IST2.EQ.41) THEN
28188 IDX2 = 5
28189 ELSEIF (IST2.EQ.42) THEN
28190 IDX2 = 6
28191 ELSEIF (IST2.EQ.51) THEN
28192 IDX2 = 7
28193 ELSEIF (IST2.EQ.52) THEN
28194 IDX2 = 8
28195 ELSEIF (IST2.EQ.61) THEN
28196 IDX2 = 9
28197 ELSEIF (IST2.EQ.62) THEN
28198 IDX2 = 10
28199 ELSE
28200c WRITE(LOUT,*)
28201c & ' CHASTA: unknown parton status flag (',
28202c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28203 GOTO 21
28204 ENDIF
28205 ID = IDHKK(JMOHKK(2,IDX))
28206 IF (ABS(ID).LE.4) THEN
28207 IF (ID.GT.0) THEN
28208 ITYP2 = 1
28209 ELSE
28210 ITYP2 = 2
28211 ENDIF
28212 ELSEIF (ABS(ID).GE.1000) THEN
28213 IF (ID.GT.0) THEN
28214 ITYP2 = 3
28215 ELSE
28216 ITYP2 = 4
28217 ENDIF
28218 ELSEIF (ID.EQ.21) THEN
28219 ITYP2 = 5
28220 ELSE
28221 WRITE(LOUT,*)
28222 & ' CHASTA: inconsistent parton identity (',
28223 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28224 GOTO 21
28225 ENDIF
28226*
28227* fill counter
28228 ITYPE = ICHTYP(ITYP1,ITYP2)
28229 IF (ITYPE.NE.0) THEN
28230 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28231 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28232 ICHCFG(IDX1,IDX2,ITYPE,2) =
28233 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28234
28235 NCHAIN = NCHAIN+1
28236 IF (NCHAIN.GT.MAXCHN) THEN
28237 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28238 & NCHAIN,MAXCHN
28239 STOP
28240 ENDIF
28241 IDXCHN(1,NCHAIN) = IDX
28242 IDXCHN(2,NCHAIN) = ITYPE
28243 ELSE
28244 WRITE(LOUT,*)
28245 & ' CHASTA: inconsistent chain at entry ',IDX
28246 GOTO 21
28247 ENDIF
28248 ENDIF
28249 21 CONTINUE
28250*
28251* write statistics to output unit
28252*
28253 ELSEIF (MODE.EQ.1) THEN
28254 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28255 DO 31 I=1,10
28256 WRITE(LOUT,'(/,2A)')
28257 & ' -----------------------------------------',
28258 & '------------------------------------'
28259 WRITE(LOUT,'(2A)')
28260 & ' p\\t 21 22 31 32 41',
28261 & ' 42 51 52 61 62'
28262 WRITE(LOUT,'(2A)')
28263 & ' -----------------------------------------',
28264 & '------------------------------------'
28265 DO 32 J=1,10
28266 ITOT(J) = 0
28267 DO 33 K=1,9
28268 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28269 33 CONTINUE
28270 32 CONTINUE
28271 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28272 DO 34 K=1,9
28273 ISUM = 0
28274 DO 35 J=1,10
28275 ISUM = ISUM+ICHCFG(I,J,K,1)
28276 35 CONTINUE
28277 IF (ISUM.GT.0)
28278 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28279 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28280 34 CONTINUE
28281C WRITE(LOUT,'(2A)')
28282C & ' -----------------------------------------',
28283C & '-------------------------------'
28284 31 CONTINUE
28285*
28286 ELSE
28287 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28288 STOP
28289 ENDIF
28290
28291 RETURN
28292 END
28293*$ CREATE PHO_PHIST.FOR
28294*COPY PHO_PHIST
28295*
28296*===pohist=============================================================*
28297*
28298 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28299
28300 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28301 SAVE
28302
28303 PARAMETER ( LINP = 10 ,
28304 & LOUT = 6 ,
28305 & LDAT = 9 )
28306
28307 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28308
28309* Glauber formalism: cross sections
28310 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28311 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28312 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28313 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28314 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28315 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28316 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28317 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28318 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28319 & BSLOPE,NEBINI,NQBINI
28320
28321 ILAB = 0
28322 IF (IMODE.EQ.10) THEN
28323 IMODE = 1
28324 ILAB = 1
28325 ENDIF
28326 IF (ABS(IMODE).LT.1000) THEN
28327* PHOJET-statistics
28328C CALL POHISX(IMODE,WEIGHT)
28329 IF (IMODE.EQ.-1) THEN
28330 MODE = 1
28331 XSTOT(1,1,1) = WEIGHT
28332 ENDIF
28333 IF (IMODE.EQ. 1) MODE = 2
28334 IF (IMODE.EQ.-2) MODE = 3
28335 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28336C IF (MODE.EQ.3) WRITE(LOUT,*)
28337C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28338 CALL DT_HISTOG(MODE)
28339 CALL DT_USRHIS(MODE)
28340 ELSE
28341* DTUNUC-statistics
28342 MODE = IMODE/1000
28343C IF (MODE.EQ.3) WRITE(LOUT,*)
28344C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28345 CALL DT_HISTOG(MODE)
28346 CALL DT_USRHIS(MODE)
28347 ENDIF
28348
28349 RETURN
28350 END
28351
28352*$ CREATE DT_SWPPHO.FOR
28353*COPY DT_SWPPHO
28354*
28355*===swppho=============================================================*
28356*
28357 SUBROUTINE DT_SWPPHO(ILAB)
28358
28359 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28360 SAVE
28361
28362 PARAMETER ( LINP = 10 ,
28363 & LOUT = 6 ,
28364 & LDAT = 9 )
28365
28366 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28367
28368 LOGICAL LSTART
28369
28370* event history
28371
28372 PARAMETER (NMXHKK=200000)
28373
28374 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28375 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28376 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28377
28378* extended event history
28379 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28380 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28381 & IHIST(2,NMXHKK)
28382
28383* flags for input different options
28384 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28385 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28386 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28387
28388* properties of photon/lepton projectiles
28389 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28390
28391**PHOJET105a
28392C PARAMETER (NMXHEP=2000)
28393C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28394C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28395C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28396C COMMON /PLASAV/ PLAB
28397**PHOJET110
28398C standard particle data interface
28399 INTEGER NMXHEP
28400
28401 PARAMETER (NMXHEP=4000)
28402
28403 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28404 DOUBLE PRECISION PHEP,VHEP
28405 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28406 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28407 & VHEP(4,NMXHEP)
28408C extension to standard particle data interface (PHOJET specific)
28409 INTEGER IMPART,IPHIST,ICOLOR
28410 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28411
28412C global event kinematics and particle IDs
28413 INTEGER IFPAP,IFPAB
28414 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28415 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28416**
28417 DATA ICOUNT/0/
28418
28419 DATA LSTART /.TRUE./
28420
28421C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28422 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28423 UMO = ECM
28424 ELA = ZERO
28425 PLA = ZERO
28426 IDP = IDT_ICIHAD(IFPAP(1))
28427 IDT = IDT_ICIHAD(IFPAP(2))
28428 VIRT = PVIRT(1)
28429 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28430 PLAB = PLA
28431 LSTART = .FALSE.
28432 ENDIF
28433
28434 NHKK = 0
28435 ICOUNT = ICOUNT+1
28436C NEVHKK = NEVHEP
28437 NEVHKK = ICOUNT
28438 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28439 DO 1 I=3,NHEP
28440 IF (ISTHEP(I).EQ.1) THEN
28441 NHKK = NHKK+1
28442 ISTHKK(NHKK) = 1
28443 IDHKK(NHKK) = IDHEP(I)
28444 JMOHKK(1,NHKK) = 0
28445 JMOHKK(2,NHKK) = 0
28446 JDAHKK(1,NHKK) = 0
28447 JDAHKK(2,NHKK) = 0
28448 DO 2 K=1,4
28449 PHKK(K,NHKK) = PHEP(K,I)
28450 VHKK(K,NHKK) = ZERO
28451 WHKK(K,NHKK) = ZERO
28452 2 CONTINUE
28453 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28454 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28455 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28456 PHKK(5,NHKK) = PHEP(5,I)
28457 IDRES(NHKK) = 0
28458 IDXRES(NHKK) = 0
28459 NOBAM(NHKK) = 0
28460 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28461 IDCH(NHKK) = 0
28462 ENDIF
28463 1 CONTINUE
28464
28465 RETURN
28466 END
28467
28468*$ CREATE DT_HISTOG.FOR
28469*COPY DT_HISTOG
28470*
28471*===histog=============================================================*
28472*
28473 SUBROUTINE DT_HISTOG(MODE)
28474
28475************************************************************************
28476* This version dated 25.03.96 is written by S. Roesler *
28477************************************************************************
28478
28479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28480 SAVE
28481
28482 PARAMETER ( LINP = 10 ,
28483 & LOUT = 6 ,
28484 & LDAT = 9 )
28485
28486 LOGICAL LFSP,LRNL
28487
28488* event history
28489
28490 PARAMETER (NMXHKK=200000)
28491
28492 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28493 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28494 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28495
28496* extended event history
28497 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28498 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28499 & IHIST(2,NMXHKK)
28500
28501* event flag used for histograms
28502 COMMON /DTNORM/ ICEVT,IEVHKK
28503
28504* flags for activated histograms
28505 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28506
28507 IEVHKK = NEVHKK
28508 GOTO (1,2,3) MODE
28509
28510*------------------------------------------------------------------
28511* initialization
28512 1 CONTINUE
28513 ICEVT = 0
28514 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28515 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28516
28517 RETURN
28518*------------------------------------------------------------------
28519* filling of histogram with event-record
28520 2 CONTINUE
28521 ICEVT = ICEVT+1
28522
28523 DO 20 I=1,NHKK
28524 CALL DT_SWPFSP(I,LFSP,LRNL)
28525 IF (LFSP) THEN
28526 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28527 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28528 ENDIF
28529 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28530 20 CONTINUE
28531 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28532
28533 RETURN
28534*------------------------------------------------------------------
28535* output
28536 3 CONTINUE
28537 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28538 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28539
28540 RETURN
28541 END
28542
28543*$ CREATE DT_SWPFSP.FOR
28544*COPY DT_SWPFSP
28545*
28546*===swpfsp=============================================================*
28547*
28548 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28549
28550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28551 SAVE
28552 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28553 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28554 & PI =TWOPI/TWO,
28555 & BOG =TWOPI/360.0D0)
28556
28557* event history
28558
28559 PARAMETER (NMXHKK=200000)
28560
28561 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28562 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28563 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28564
28565* extended event history
28566 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28567 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28568 & IHIST(2,NMXHKK)
28569
28570* particle properties (BAMJET index convention)
28571 CHARACTER*8 ANAME
28572 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28573 & IICH(210),IIBAR(210),K1(210),K2(210)
28574
28575* Lorentz-parameters of the current interaction
28576 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28577 & UMO,PPCM,EPROJ,PPROJ
28578
28579* flags for input different options
28580 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28581 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28582 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28583
28584* INCLUDE '(DIMPAR)'
28585* Taken from FLUKA
28586 PARAMETER ( MXXRGN =20000 )
28587 PARAMETER ( MXXMDF = 710 )
28588 PARAMETER ( MXXMDE = 702 )
28589 PARAMETER ( MFSTCK =40000 )
28590 PARAMETER ( MESTCK = 100 )
28591 PARAMETER ( MOSTCK = 2000 )
28592 PARAMETER ( MXPRSN = 100 )
28593 PARAMETER ( MXPDPM = 800 )
28594 PARAMETER ( MXPSCS =30000 )
28595 PARAMETER ( MXGLWN = 300 )
28596 PARAMETER ( MXOUTU = 50 )
28597 PARAMETER ( NALLWP = 64 )
28598 PARAMETER ( NELEMX = 80 )
28599 PARAMETER ( MPDPDX = 18 )
28600 PARAMETER ( MXHTTR = 260 )
28601 PARAMETER ( MXSEAX = 20 )
28602 PARAMETER ( MXHTNC = MXSEAX + 1 )
28603 PARAMETER ( ICOMAX = 2400 )
28604 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28605 PARAMETER ( NSTBIS = 304 )
28606 PARAMETER ( NQSTIS = 46 )
28607 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28608 PARAMETER ( MXPABL = 120 )
28609 PARAMETER ( IDMAXP = 450 )
28610 PARAMETER ( IDMXDC = 2000 )
28611 PARAMETER ( MXMCIN = 410 )
28612 PARAMETER ( IHYPMX = 4 )
28613 PARAMETER ( MKBMX1 = 11 )
28614 PARAMETER ( MKBMX2 = 11 )
28615 PARAMETER ( MXIRRD = 2500 )
28616 PARAMETER ( MXTRDC = 1500 )
28617 PARAMETER ( NKTL = 17 )
28618 PARAMETER ( NBLNMX = 40000000 )
28619
28620* INCLUDE '(PAREVT)'
28621* Taken from FLUKA
28622 PARAMETER ( FRDIFF = 0.2D+00 )
28623 PARAMETER ( ETHSEA = 1.0D+00 )
28624*
28625 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28626 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28627 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28628 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28629 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28630 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28631 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28632 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28633 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28634 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28635
28636* temporary storage for one final state particle
28637 LOGICAL LFRAG,LGREY,LBLACK
28638 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28639 & SINTHE,COSTHE,THETA,THECMS,
28640 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28641 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28642 & LFRAG,LGREY,LBLACK
28643
28644 LOGICAL LFSP,LRNL
28645
28646 LFSP = .FALSE.
28647 LRNL = .FALSE.
28648 ISTRNL = 1000
28649 MULDEF = 1
28650 IF (LEVPRT) ISTRNL = 1001
28651
28652 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28653 IST = ISTHKK(IDX)
28654 IDPDG = IDHKK(IDX)
28655 LFRAG = .FALSE.
28656 IF (IDHKK(IDX).LT.80000) THEN
28657 IDBJT = IDBAM(IDX)
28658 IBARY = IIBAR(IDBJT)
28659 ICHAR = IICH(IDBJT)
28660 AMASS = AAM(IDBJT)
28661 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28662 IDBJT = 0
28663 IBARY = IDRES(IDX)
28664 ICHAR = IDXRES(IDX)
28665 AMASS = PHKK(5,IDX)
28666 INUT = IBARY-ICHAR
28667 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28668 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28669 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28670 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28671 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28672 ELSE
28673 GOTO 9999
28674 ENDIF
28675 PE = PHKK(4,IDX)
28676 PX = PHKK(1,IDX)
28677 PY = PHKK(2,IDX)
28678 PZ = PHKK(3,IDX)
28679 PT2 = PX**2+PY**2
28680 PT = SQRT(PT2)
28681 PTOT = SQRT(PT2+PZ**2)
28682 SINTHE = PT/MAX(PTOT,TINY14)
28683 COSTHE = PZ/MAX(PTOT,TINY14)
28684 IF (COSTHE.GT.ONE) THEN
28685 THETA = ZERO
28686 ELSEIF (COSTHE.LT.-ONE) THEN
28687 THETA = TWOPI/2.0D0
28688 ELSE
28689 THETA = ACOS(COSTHE)
28690 ENDIF
28691 EKIN = PE-AMASS
28692**sr 15.4.96 new E_t-definition
28693 IF (IBARY.GT.0) THEN
28694 ET = EKIN*SINTHE
28695 ELSEIF (IBARY.LT.0) THEN
28696 ET = (EKIN+TWO*AMASS)*SINTHE
28697 ELSE
28698 ET = PE*SINTHE
28699 ENDIF
28700**
28701 XLAB = PZ/MAX(PPROJ,TINY14)
28702C XLAB = PE/MAX(EPROJ,TINY14)
28703 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28704 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28705 PPLUS = PE+PZ
28706 PMINUS = PE-PZ
28707 IF (PMINUS.GT.TINY14) THEN
28708 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28709 ELSE
28710 YY = 100.0D0
28711 ENDIF
28712 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28713 ETA = -LOG(TAN(THETA/TWO))
28714 ELSE
28715 ETA = 100.0D0
28716 ENDIF
28717 IF (IFRAME.EQ.1) THEN
28718 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28719 PPLUS = EECMS+PZCMS
28720 PMINUS = EECMS-PZCMS
28721 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28722 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28723 ELSE
28724 YYCMS = 100.0D0
28725 ENDIF
28726 PTOTCM = SQRT(PT2+PZCMS**2)
28727 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28728 IF (COSTH.GT.ONE) THEN
28729 THECMS = ZERO
28730 ELSEIF (COSTH.LT.-ONE) THEN
28731 THECMS = TWOPI/2.0D0
28732 ELSE
28733 THECMS = ACOS(COSTH)
28734 ENDIF
28735 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28736 ETACMS = -LOG(TAN(THECMS/TWO))
28737 ELSE
28738 ETACMS = 100.0D0
28739 ENDIF
28740 XF = PZCMS/MAX(PPCM,TINY14)
28741 THECMS = THECMS/BOG
28742 ELSE
28743 PZCMS = PZ
28744 EECMS = PE
28745 YYCMS = YY
28746 ETACMS = ETA
28747 XF = XLAB
28748 THECMS = THETA/BOG
28749 ENDIF
28750 THETA = THETA/BOG
28751
28752* set flag for "grey/black"
28753 LGREY = .FALSE.
28754 LBLACK = .FALSE.
28755 EK = EKIN
28756 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28757 IF (MULDEF.EQ.1) THEN
28758* EMU01-Def.
28759 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28760 & (EK.LE.375.0D-3) ).OR.
28761 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28762 & (EK.LE. 56.0D-3) ).OR.
28763 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28764 & (EK.LE. 56.0D-3) ).OR.
28765 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28766 & (EK.LE.198.0D-3) ).OR.
28767 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28768 & (EK.LE.198.0D-3) ).OR.
28769 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28770 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28771 & (IDBJT.NE.16).AND.
28772 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28773 & LGREY = .TRUE.
28774 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28775 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28776 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28777 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28778 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28779 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28780 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28781 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28782 & LBLACK = .TRUE.
28783 ELSE
28784* common Def.
28785 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28786 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28787 ENDIF
28788 LFSP = .TRUE.
28789 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28790 IST = ISTHKK(IDX)
28791 IDPDG = IDHKK(IDX)
28792 LFRAG = .TRUE.
28793 IDBJT = 0
28794 IBARY = IDRES(IDX)
28795 ICHAR = IDXRES(IDX)
28796 AMASS = PHKK(5,IDX)
28797 PE = PHKK(4,IDX)
28798 PX = PHKK(1,IDX)
28799 PY = PHKK(2,IDX)
28800 PZ = PHKK(3,IDX)
28801 PT2 = PX**2+PY**2
28802 PT = SQRT(PT2)
28803 PTOT = SQRT(PT2+PZ**2)
28804 SINTHE = PT/MAX(PTOT,TINY14)
28805 COSTHE = PZ/MAX(PTOT,TINY14)
28806 IF (COSTHE.GT.ONE) THEN
28807 THETA = ZERO
28808 ELSEIF (COSTHE.LT.-ONE) THEN
28809 THETA = TWOPI/2.0D0
28810 ELSE
28811 THETA = ACOS(COSTHE)
28812 ENDIF
28813 EKIN = PE-AMASS
28814**sr 15.4.96 new E_t-definition
28815C ET = PE*SINTHE
28816 ET = EKIN*SINTHE
28817**
28818 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28819 ETA = -LOG(TAN(THETA/TWO))
28820 ELSE
28821 ETA = 100.0D0
28822 ENDIF
28823 THETA = THETA/BOG
28824 LRNL = .TRUE.
28825 ENDIF
28826
28827 9999 CONTINUE
28828 RETURN
28829 END
28830
28831*$ CREATE DT_HIMULT.FOR
28832*COPY DT_HIMULT
28833*
28834*===himult=============================================================*
28835*
28836 SUBROUTINE DT_HIMULT(MODE)
28837
28838************************************************************************
28839* Tables of average energies/multiplicities. *
28840* This version dated 30.08.2000 is written by S. Roesler *
28841************************************************************************
28842
28843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28844 SAVE
28845
28846 PARAMETER ( LINP = 10 ,
28847 & LOUT = 6 ,
28848 & LDAT = 9 )
28849
28850 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28851
28852 PARAMETER (SWMEXP=1.7D0)
28853
28854 CHARACTER*8 ANAMEH(4)
28855
28856* particle properties (BAMJET index convention)
28857 CHARACTER*8 ANAME
28858 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28859 & IICH(210),IIBAR(210),K1(210),K2(210)
28860
28861* temporary storage for one final state particle
28862 LOGICAL LFRAG,LGREY,LBLACK
28863 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28864 & SINTHE,COSTHE,THETA,THECMS,
28865 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28866 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28867 & LFRAG,LGREY,LBLACK
28868
28869* event flag used for histograms
28870 COMMON /DTNORM/ ICEVT,IEVHKK
28871
28872* Lorentz-parameters of the current interaction
28873 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28874 & UMO,PPCM,EPROJ,PPROJ
28875
28876 PARAMETER (NOPART=210)
28877 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28878 & AVPT(4,NOPART),IAVPT(4,NOPART)
28879 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28880
28881 GOTO (1,2,3) MODE
28882
28883*------------------------------------------------------------------
28884* initialization
28885 1 CONTINUE
28886 DO 10 I=1,NOPART
28887 DO 11 J=1,4
28888 AVMULT(J,I) = ZERO
28889 AVE(J,I) = ZERO
28890 AVSWM(J,I) = ZERO
28891 AVPT(J,I) = ZERO
28892 IAVPT(J,I) = 0
28893 11 CONTINUE
28894 10 CONTINUE
28895
28896 RETURN
28897
28898*------------------------------------------------------------------
28899* filling of histogram with event-record
28900 2 CONTINUE
28901 IF (PE.LT.0.0D0) THEN
28902 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28903 RETURN
28904 ENDIF
28905 IF (.NOT.LFRAG) THEN
28906 IVEL = 2
28907 IF (LGREY) IVEL = 3
28908 IF (LBLACK) IVEL = 4
28909 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28910 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28911 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28912 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28913 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28914 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28915 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28916 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28917 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28918 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28919 IF (IDBJT.LT.116) THEN
28920* total energy, multiplicity
28921 AVE(1,30) = AVE(1,30) +PE
28922 AVE(IVEL,30) = AVE(IVEL,30)+PE
28923 AVPT(1,30) = AVPT(1,30) +PT
28924 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28925 IAVPT(1,30) = IAVPT(1,30) +1
28926 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28927 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28928 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28929 AVMULT(1,30) = AVMULT(1,30) +ONE
28930 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28931* charged energy, multiplicity
28932 IF (ICHAR.LT.0) THEN
28933 AVE(1,26) = AVE(1,26) +PE
28934 AVE(IVEL,26) = AVE(IVEL,26)+PE
28935 AVPT(1,26) = AVPT(1,26) +PT
28936 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28937 IAVPT(1,26) = IAVPT(1,26) +1
28938 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28939 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28940 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28941 AVMULT(1,26) = AVMULT(1,26) +ONE
28942 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28943 ENDIF
28944 IF (ICHAR.NE.0) THEN
28945 AVE(1,27) = AVE(1,27) +PE
28946 AVE(IVEL,27) = AVE(IVEL,27)+PE
28947 AVPT(1,27) = AVPT(1,27) +PT
28948 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28949 IAVPT(1,27) = IAVPT(1,27) +1
28950 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28951 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28952 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28953 AVMULT(1,27) = AVMULT(1,27) +ONE
28954 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28955 ENDIF
28956 ENDIF
28957 ENDIF
28958
28959 RETURN
28960
28961*------------------------------------------------------------------
28962* output
28963 3 CONTINUE
28964 WRITE(LOUT,3000)
28965 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28966 & 29X,'---------------------',/)
28967 IF (MULDEF.EQ.1) THEN
28968 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28969 ELSE
28970 BETGRE = 0.7D0
28971 BETBLC = 0.23D0
28972 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28973 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
28974 & ,F4.2,' black: beta < ',F4.2,/)
28975 ENDIF
28976 WRITE(LOUT,3003) SWMEXP
28977 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
28978 & 13X,'| total fast',
28979C & ' grey black K f(',F3.1,')',/,1X,
28980 & ' grey black <pt> f(',F3.1,')',/,1X,
28981 & '------------+--------------',
28982 & '-------------------------------------------------')
28983 DO 30 I=1,NOPART
28984 DO 31 J=1,4
28985 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
28986 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
28987 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
28988 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
28989 31 CONTINUE
28990 IF (I.LE.115) THEN
28991 WRITE(LOUT,3004) ANAME(I),I,
28992 & AVMULT(1,I),AVMULT(2,I),
28993 & AVMULT(3,I),AVMULT(4,I),
28994C & AVE(1,I),AVSWM(1,I)
28995 & AVPT(1,I),AVSWM(1,I)
28996 ELSEIF (I.LE.119) THEN
28997 WRITE(LOUT,3004) ANAMEH(I-115),I,
28998 & AVMULT(1,I),AVMULT(2,I),
28999 & AVMULT(3,I),AVMULT(4,I),
29000C & AVE(1,I),AVSWM(1,I)
29001 & AVPT(1,I),AVSWM(1,I)
29002 ENDIF
29003 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29004 30 CONTINUE
29005**temporary
29006C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29007C & AVMULT(3,27)+AVMULT(4,27)
29008**
29009
29010 RETURN
29011 END
29012
29013*$ CREATE DT_HISTAT.FOR
29014*COPY DT_HISTAT
29015*
29016*===histat=============================================================*
29017*
29018 SUBROUTINE DT_HISTAT(IDX,MODE)
29019
29020************************************************************************
29021* This version dated 26.02.96 is written by S. Roesler *
29022* *
29023* Last change 27.12.2006 by S. Roesler. *
29024************************************************************************
29025
29026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29027 SAVE
29028
29029 PARAMETER ( LINP = 10 ,
29030 & LOUT = 6 ,
29031 & LDAT = 9 )
29032
29033 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29034 PARAMETER (NDIM=199)
29035
29036* event history
29037
29038 PARAMETER (NMXHKK=200000)
29039
29040 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29041 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29042 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29043
29044* extended event history
29045 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29046 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29047 & IHIST(2,NMXHKK)
29048
29049* particle properties (BAMJET index convention)
29050 CHARACTER*8 ANAME
29051 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29052 & IICH(210),IIBAR(210),K1(210),K2(210)
29053
29054 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29055
29056* Glauber formalism: cross sections
29057 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29058 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29059 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29060 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29061 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29062 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29063 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29064 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29065 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29066 & BSLOPE,NEBINI,NQBINI
29067
29068* emulsion treatment
29069 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29070 & NCOMPO,IEMUL
29071
29072* properties of interacting particles
29073 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29074
29075* rejection counter
29076 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29077 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29078 & IREXCI(3),IRDIFF(2),IRINC
29079
29080* statistics: residual nuclei
29081 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29082 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29083 & NINCST(2,4),NINCEV(2),
29084 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29085 & NRESPB(2),NRESCH(2),NRESEV(4),
29086 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29087 & NEVAFI(2,2)
29088
29089* parameter for intranuclear cascade
29090 LOGICAL LPAULI
29091 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29092
29093* INCLUDE '(DIMPAR)'
29094* Taken from FLUKA
29095 PARAMETER ( MXXRGN =20000 )
29096 PARAMETER ( MXXMDF = 710 )
29097 PARAMETER ( MXXMDE = 702 )
29098 PARAMETER ( MFSTCK =40000 )
29099 PARAMETER ( MESTCK = 100 )
29100 PARAMETER ( MOSTCK = 2000 )
29101 PARAMETER ( MXPRSN = 100 )
29102 PARAMETER ( MXPDPM = 800 )
29103 PARAMETER ( MXPSCS =30000 )
29104 PARAMETER ( MXGLWN = 300 )
29105 PARAMETER ( MXOUTU = 50 )
29106 PARAMETER ( NALLWP = 64 )
29107 PARAMETER ( NELEMX = 80 )
29108 PARAMETER ( MPDPDX = 18 )
29109 PARAMETER ( MXHTTR = 260 )
29110 PARAMETER ( MXSEAX = 20 )
29111 PARAMETER ( MXHTNC = MXSEAX + 1 )
29112 PARAMETER ( ICOMAX = 2400 )
29113 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29114 PARAMETER ( NSTBIS = 304 )
29115 PARAMETER ( NQSTIS = 46 )
29116 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29117 PARAMETER ( MXPABL = 120 )
29118 PARAMETER ( IDMAXP = 450 )
29119 PARAMETER ( IDMXDC = 2000 )
29120 PARAMETER ( MXMCIN = 410 )
29121 PARAMETER ( IHYPMX = 4 )
29122 PARAMETER ( MKBMX1 = 11 )
29123 PARAMETER ( MKBMX2 = 11 )
29124 PARAMETER ( MXIRRD = 2500 )
29125 PARAMETER ( MXTRDC = 1500 )
29126 PARAMETER ( NKTL = 17 )
29127 PARAMETER ( NBLNMX = 40000000 )
29128
29129* INCLUDE '(PAREVT)'
29130* Taken from FLUKA
29131 PARAMETER ( FRDIFF = 0.2D+00 )
29132 PARAMETER ( ETHSEA = 1.0D+00 )
29133*
29134 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29135 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29136 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29137 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29138 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29139 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29140 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29141 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29142 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29143 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29144
29145* INCLUDE '(FRBKCM)'
29146* Taken from FLUKA
29147* Maximum number of fragments to be emitted:
29148 PARAMETER ( MXFFBK = 6 )
29149 PARAMETER ( MXZFBK = 10 )
29150 PARAMETER ( MXNFBK = 12 )
29151 PARAMETER ( MXAFBK = 16 )
29152 PARAMETER ( MXASST = 25 )
29153 PARAMETER ( NXAFBK = MXAFBK + 1 )
29154 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29155 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29156 PARAMETER ( MXPSST = 700 )
29157* Maximum number of pre-computed break-up combinations
29158 PARAMETER ( MXPPFB = 42500 )
29159* Maximum number of break-up combinations, including special
29160* run-time ones:
29161 PARAMETER ( MXPSFB = 43000 )
29162* Base for J multiplicity encoding:
29163 PARAMETER ( IBFRBK = 73 )
29164* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29165* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29166* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29167* --> Ibfrbk^(Jpwfbx+1) < 2100000000
29168 PARAMETER ( JPWFBX = 4 )
29169 LOGICAL LFRMBK, LNCMSS
29170 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29171 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29172 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29173 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29174 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29175 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29176 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29177 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29178 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29179 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29180
29181* INCLUDE '(EVAFLG)'
29182* Taken from FLUKA
29183 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29184 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29185 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29186 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29187 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29188 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29189 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29190 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29191 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29192 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29193 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29194 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29195
29196* temporary storage for one final state particle
29197 LOGICAL LFRAG,LGREY,LBLACK
29198 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29199 & SINTHE,COSTHE,THETA,THECMS,
29200 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29201 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29202 & LFRAG,LGREY,LBLACK
29203
29204* event flag used for histograms
29205 COMMON /DTNORM/ ICEVT,IEVHKK
29206
29207* statistics: double-Pomeron exchange
29208 COMMON /DTFLG2/ INTFLG,IPOPO
29209
29210 DIMENSION EMUSAM(NCOMPX)
29211
29212 CHARACTER*13 CMSG(3)
29213 DATA CMSG /'not requested','not requested','not requested'/
29214
29215 GOTO (1,2,3,4,5) MODE
29216
29217*------------------------------------------------------------------
29218* initialization
29219 1 CONTINUE
29220* emulsion treatment
29221 IF (NCOMPO.GT.0) THEN
29222 DO 10 I=1,NCOMPX
29223 EMUSAM(I) = ZERO
29224 10 CONTINUE
29225 ENDIF
29226* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29227 NINCGE = 0
29228 DO 11 I=1,2
29229 EXCDPM(I) = ZERO
29230 EXCDPM(I+2) = ZERO
29231 EXCEVA(I) = ZERO
29232 NINCWO(I) = 0
29233 NINCEV(I) = 0
29234 NRESTO(I) = 0
29235 NRESPR(I) = 0
29236 NRESNU(I) = 0
29237 NRESBA(I) = 0
29238 NRESPB(I) = 0
29239 NRESCH(I) = 0
29240 NRESEV(I) = 0
29241 NRESEV(I+2) = 0
29242 NEVAGA(I) = 0
29243 NEVAHT(I) = 0
29244 NEVAFI(1,I) = 0
29245 NEVAFI(2,I) = 0
29246 DO 12 J=1,6
29247 IF (J.LE.2) NINCHR(I,J) = 0
29248 IF (J.LE.3) NINCCO(I,J) = 0
29249 IF (J.LE.4) NINCST(I,J) = 0
29250 NEVA(I,J) = 0
29251 12 CONTINUE
29252 DO 13 J=1,210
29253 NEVAHY(1,I,J) = 0
29254 NEVAHY(2,I,J) = 0
29255 13 CONTINUE
29256 11 CONTINUE
29257 MAXGEN = 0
29258**dble Po statistics.
29259 KPOPO = 0
29260
29261 RETURN
29262*------------------------------------------------------------------
29263* filling of histogram with event-record
29264 2 CONTINUE
29265 IF (IST.EQ.-1) THEN
29266 IF (.NOT.LFRAG) THEN
29267 IF (IDPDG.EQ.2212) THEN
29268 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29269 ELSEIF (IDPDG.EQ.2112) THEN
29270 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29271 ELSEIF (IDPDG.EQ.22) THEN
29272 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29273 ELSEIF (IDPDG.EQ.80000) THEN
29274 IF (IDBJT.EQ.116) THEN
29275 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29276 ELSEIF (IDBJT.EQ.117) THEN
29277 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29278 ELSEIF (IDBJT.EQ.118) THEN
29279 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29280 ELSEIF (IDBJT.EQ.119) THEN
29281 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29282 ENDIF
29283 ENDIF
29284 ELSE
29285* heavy fragments (here: fission products only)
29286 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29287 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29288 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29289 ENDIF
29290 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29291 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29292 ENDIF
29293
29294 RETURN
29295*------------------------------------------------------------------
29296* output
29297 3 CONTINUE
29298
29299**dble Po statistics.
29300C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29301C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29302C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29303
29304* emulsion treatment
29305 IF (NCOMPO.GT.0) THEN
29306 WRITE(LOUT,3000)
29307 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29308 & 22X,'----------------------------',/,/,19X,
29309 & 'mass charge fraction',/,39X,
29310 & 'input treated',/)
29311 DO 30 I=1,NCOMPO
29312 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29313 & EMUSAM(I)/DBLE(ICEVT)
29314 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29315 30 CONTINUE
29316 ENDIF
29317
29318* i.n.c. statistics: output
29319 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29320 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29321 & 22X,'---------------------------------',/,/,1X,
29322 & 'no. of events for normalization: (accepted final events,',
29323 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29324 & /,1X,'no. of rejected events due to intranuclear',
29325 & ' cascade',15X,I6,/)
29326 ICEV = MAX(ICEVT,1)
29327 ICEV1 = ICEV
29328 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29329 WRITE(LOUT,3002)
29330 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29331 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29332 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29333 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29334 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29335 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29336 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29337 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29338 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29339 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29340 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29341 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29342 & /,1X,'maximum no. of generations treated (maximum allowed:'
29343 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29344 & ' interactions in proj./ target (mean per evt1)',
29345 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29346 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29347 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29348 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29349 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29350 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29351 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29352 & 'evaporation',/,22X,'-----------------------------',
29353 & '------------',/,/,1X,'no. of events for normal.: ',
29354 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29355 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29356 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29357
29358 WRITE(LOUT,3004)
29359 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29360 ICEV = MAX(NRESEV(2),1)
29361 WRITE(LOUT,3005)
29362 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29363 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29364 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29365 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29366 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29367 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29368 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29369 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29370 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29371 & 'proj. / target',/,/,8X,'total number of particles',15X,
29372 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29373 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29374 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29375 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29376 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29377
29378* evaporation / fission / fragmentation statistics: output
29379 ICEV = MAX(NRESEV(2),1)
29380 ICEV1 = MAX(NRESEV(4),1)
29381 NTEVA1 =
29382 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29383 NTEVA2 =
29384 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29385 IF (LEVPRT) THEN
29386
29387 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29388
29389 IF (LFRMBK) CMSG(2) = 'requested '
29390 IF (LDEEXG) CMSG(3) = 'requested '
29391 WRITE(LOUT,3006)
29392 & CMSG,
29393 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29394 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29395 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29396 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29397 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29398 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29399 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29400 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29401 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29402 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29403 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29404 & 'deexcitation:',2X,A13,/,/,
29405 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29406 & 'proj. / target',/,/,8X,'total number of evap. particles',
29407 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29408 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29409 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29410 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29411 & 'heavy fragments',25X,2F9.3,/)
29412
29413 IF (IEVFSS.EQ.1) THEN
29414
29415 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29416 & NEVAFI(2,1),NEVAFI(2,2),
29417 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29418 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29419 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29420 & 12X,'out of which fission occured',8X,2I9,/,
29421 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29422 ENDIF
29423
29424C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29425
29426C WRITE(LOUT,3008)
29427C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29428C & ' proj. / target',/)
29429C DO 31 I=1,210
29430C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29431C WRITE(LOUT,3009) I,
29432C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29433C3009 FORMAT(38X,I3,3X,2E12.3)
29434C ENDIF
29435C 31 CONTINUE
29436C WRITE(LOUT,3010)
29437C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29438C & ' proj. / target',/)
29439C DO 32 I=1,210
29440C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29441C WRITE(LOUT,3011) I,
29442C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29443C3011 FORMAT(38X,I3,3X,2E12.3)
29444C ENDIF
29445C 32 CONTINUE
29446C WRITE(LOUT,*)
29447C ENDIF
29448 ELSE
29449 WRITE(LOUT,3012)
29450 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29451 & 'Evaporation: not requested',/)
29452 ENDIF
29453
29454 RETURN
29455*------------------------------------------------------------------
29456* filling of histogram with event-record
29457 4 CONTINUE
29458* emulsion treatment
29459 IF (NCOMPO.GT.0) THEN
29460 DO 40 I=1,NCOMPO
29461 IF (IT.EQ.IEMUMA(I)) THEN
29462 EMUSAM(I) = EMUSAM(I)+ONE
29463 ENDIF
29464 40 CONTINUE
29465 ENDIF
29466 NINCGE = NINCGE+MAXGEN
29467 MAXGEN = 0
29468**dble Po statistics.
29469 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29470
29471 RETURN
29472*------------------------------------------------------------------
29473* filling of histogram with event-record
29474 5 CONTINUE
29475 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29476 IB = IIBAR(IDBAM(IDX))
29477 IC = IICH(IDBAM(IDX))
29478 J = ISTHKK(IDX)-14
29479 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29480 NINCST(J,1) = NINCST(J,1)+1
29481 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29482 NINCST(J,2) = NINCST(J,2)+1
29483 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29484 NINCST(J,3) = NINCST(J,3)+1
29485 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29486 NINCST(J,4) = NINCST(J,4)+1
29487 ENDIF
29488 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29489 NINCWO(1) = NINCWO(1)+1
29490 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29491 NINCWO(2) = NINCWO(2)+1
29492 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29493 IB = IDRES(IDX)
29494 IC = IDXRES(IDX)
29495 IF (IC.GT.0) THEN
29496 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29497 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29498 ENDIF
29499 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29500 ENDIF
29501
29502 RETURN
29503 END
29504*$ CREATE DT_NEWHGR.FOR
29505*COPY DT_NEWHGR
29506*
29507*===newhgr=============================================================*
29508*
29509 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29510
29511************************************************************************
29512* *
29513* Histogram initialization. *
29514* *
29515* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29516* XLIM3 bin size *
29517* IBIN > 0 number of bins in equidistant lin. binning *
29518* = -1 reset histograms *
29519* < -1 |IBIN| number of bins in equidistant log. *
29520* binning or log. binning in user def. struc. *
29521* XLIMB(*) user defined bin structure *
29522* *
29523* The bin structure is sensitive to *
29524* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29525* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29526* XLIMB, IBIN if XLIM3 < 0 *
29527* *
29528* *
29529* output: IREFN histogram index *
29530* (= -1 for inconsistent histogr. request) *
29531* *
29532* This subroutine is based on a original version by R. Engel. *
29533* This version dated 22.4.95 is written by S. Roesler. *
29534************************************************************************
29535
29536 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29537 SAVE
29538
29539 PARAMETER ( LINP = 10 ,
29540 & LOUT = 6 ,
29541 & LDAT = 9 )
29542
29543 LOGICAL LSTART
29544
29545 PARAMETER (ZERO = 0.0D0,
29546 & TINY = 1.0D-10)
29547
29548 DIMENSION XLIMB(*)
29549
29550* histograms
29551
29552 PARAMETER (NHIS=150, NDIM=250)
29553
29554 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29555 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29556
29557* auxiliary common for histograms
29558 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29559
29560 DATA LSTART /.TRUE./
29561
29562* reset histogram counter
29563 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29564 IHISL = 0
29565 IF (IBIN.EQ.-1) RETURN
29566 LSTART = .FALSE.
29567 ENDIF
29568
29569 IHIS = IHISL+1
29570* check for maximum number of allowed histograms
29571 IF (IHIS.GT.NHIS) THEN
29572 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29573 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29574 & I4,') exceeds array size (',I4,')',/,21X,
29575 & 'histogram',I3,' skipped!')
29576 GOTO 9999
29577 ENDIF
29578
29579 IREFN = IHIS
29580 IBINS(IHIS) = ABS(IBIN)
29581* check requested number of bins
29582 IF (IBINS(IHIS).GE.NDIM) THEN
29583 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29584 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29585 & I3,') exceeds array size (',I3,')',/,21X,
29586 & 'and will be reset to ',I3)
29587 IBINS(IHIS) = NDIM
29588 ENDIF
29589 IF (IBINS(IHIS).EQ.0) THEN
29590 WRITE(LOUT,1001) IBIN,IHIS
29591 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29592 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29593 GOTO 9999
29594 ENDIF
29595
29596* initialize arrays
29597 DO 1 I=1,NDIM
29598 DO 2 K=1,3
29599 HIST(K,IHIS,I) = ZERO
29600 HIST(K+3,IHIS,I) = ZERO
29601 TMPHIS(K,IHIS,I) = ZERO
29602 2 CONTINUE
29603 HIST(7,IHIS,I) = ZERO
29604 1 CONTINUE
29605 DENTRY(1,IHIS)= ZERO
29606 DENTRY(2,IHIS)= ZERO
29607 OVERF(IHIS) = ZERO
29608 UNDERF(IHIS) = ZERO
29609 TMPUFL(IHIS) = ZERO
29610 TMPOFL(IHIS) = ZERO
29611
29612* bin str. sensitive to lower edge, bin size, and numb. of bins
29613 IF (XLIM3.GT.ZERO) THEN
29614 DO 3 K=1,IBINS(IHIS)+1
29615 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29616 3 CONTINUE
29617 ISWI(IHIS) = 1
29618* bin str. sensitive to lower/upper edge and numb. of bins
29619 ELSEIF (XLIM3.EQ.ZERO) THEN
29620* linear binning
29621 IF (IBIN.GT.0) THEN
29622 XLOW = XLIM1
29623 XHI = XLIM2
29624 IF (XLIM2.LE.XLIM1) THEN
29625 WRITE(LOUT,1002) XLIM1,XLIM2
29626 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29627 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29628 GOTO 9999
29629 ENDIF
29630 ISWI(IHIS) = 1
29631 ELSEIF (IBIN.LT.-1) THEN
29632* logarithmic binning
29633 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29634 WRITE(LOUT,1004) XLIM1,XLIM2
29635 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29636 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29637 GOTO 9999
29638 ENDIF
29639 IF (XLIM2.LE.XLIM1) THEN
29640 WRITE(LOUT,1005) XLIM1,XLIM2
29641 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29642 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29643 GOTO 9999
29644 ENDIF
29645 XLOW = LOG10(XLIM1)
29646 XHI = LOG10(XLIM2)
29647 ISWI(IHIS) = 3
29648 ENDIF
29649 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29650 DO 4 K=1,IBINS(IHIS)+1
29651 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29652 4 CONTINUE
29653 ELSE
29654* user defined bin structure
29655 DO 5 K=1,IBINS(IHIS)+1
29656 IF (IBIN.GT.0) THEN
29657 HIST(1,IHIS,K) = XLIMB(K)
29658 ISWI(IHIS) = 2
29659 ELSEIF (IBIN.LT.-1) THEN
29660 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29661 ISWI(IHIS) = 4
29662 ENDIF
29663 5 CONTINUE
29664 ENDIF
29665
29666* histogram accepted
29667 IHISL = IHIS
29668
29669 RETURN
29670
29671 9999 CONTINUE
29672 IREFN = -1
29673 RETURN
29674 END
29675
29676*$ CREATE DT_FILHGR.FOR
29677*COPY DT_FILHGR
29678*
29679*===filhgr=============================================================*
29680*
29681 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29682
29683************************************************************************
29684* *
29685* Scoring for histogram IHIS. *
29686* *
29687* This subroutine is based on a original version by R. Engel. *
29688* This version dated 23.4.95 is written by S. Roesler. *
29689************************************************************************
29690
29691 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29692 SAVE
29693
29694 PARAMETER ( LINP = 10 ,
29695 & LOUT = 6 ,
29696 & LDAT = 9 )
29697
29698 PARAMETER (ZERO = 0.0D0,
29699 & ONE = 1.0D0,
29700 & TINY = 1.0D-10)
29701
29702* histograms
29703
29704 PARAMETER (NHIS=150, NDIM=250)
29705
29706 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29707 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29708
29709* auxiliary common for histograms
29710 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29711
29712 DATA NCEVT /1/
29713
29714 X = XI
29715 Y = YI
29716
29717* dump content of temorary arrays into histograms
29718 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29719 CALL DT_EVTHIS(IDUM)
29720 NCEVT = NEVT
29721 ENDIF
29722
29723* check histogram index
29724 IF (IHIS.EQ.-1) RETURN
29725 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29726C WRITE(LOUT,1000) IHIS,IHISL
29727 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29728 & ' out of range (1..',I3,')')
29729 RETURN
29730 ENDIF
29731
29732 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29733* bin structure not explicitly given
29734 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29735 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29736 IF (X.LT.HIST(1,IHIS,1)) THEN
29737 I1 = 0
29738 ELSE
29739 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29740 ENDIF
29741
29742 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29743* user defined bin structure
29744 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29745 IF (X.LT.HIST(1,IHIS,1)) THEN
29746 I1 = 0
29747 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29748 I1 = IBINS(IHIS)+1
29749 ELSE
29750* binary sort algorithm
29751 KMIN = 0
29752 KMAX = IBINS(IHIS)+1
29753 1 CONTINUE
29754 IF ((KMAX-KMIN).EQ.1) GOTO 2
29755 KK = (KMAX+KMIN)/2
29756 IF (X.LE.HIST(1,IHIS,KK)) THEN
29757 KMAX=KK
29758 ELSE
29759 KMIN=KK
29760 ENDIF
29761 GOTO 1
29762 2 CONTINUE
29763 I1 = KMIN
29764 ENDIF
29765
29766 ELSE
29767 WRITE(LOUT,1001)
29768 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29769 RETURN
29770 ENDIF
29771
29772* scoring
29773 IF (I1.LE.0) THEN
29774 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29775 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29776 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29777 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29778 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29779 ELSE
29780 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29781 ENDIF
29782 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29783 ELSE
29784 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29785 ENDIF
29786
29787 RETURN
29788 END
29789
29790*$ CREATE DT_EVTHIS.FOR
29791*COPY DT_EVTHIS
29792*
29793*===evthis=============================================================*
29794*
29795 SUBROUTINE DT_EVTHIS(NEVT)
29796
29797************************************************************************
29798* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29799* is called after each event and for the last event before any call *
29800* to OUTHGR. *
29801* NEVT number of events dumped, this is only needed to *
29802* get the normalization after the last event *
29803* This version dated 23.4.95 is written by S. Roesler. *
29804************************************************************************
29805
29806 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29807 SAVE
29808
29809 PARAMETER ( LINP = 10 ,
29810 & LOUT = 6 ,
29811 & LDAT = 9 )
29812
29813 LOGICAL LNOETY
29814
29815 PARAMETER (ZERO = 0.0D0,
29816 & ONE = 1.0D0,
29817 & TINY = 1.0D-10)
29818
29819* histograms
29820
29821 PARAMETER (NHIS=150, NDIM=250)
29822
29823 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29824 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29825
29826* auxiliary common for histograms
29827 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29828
29829 DATA NCEVT /0/
29830
29831 NCEVT = NCEVT+1
29832 NEVT = NCEVT
29833
29834 DO 1 I=1,IHISL
29835 LNOETY = .TRUE.
29836 DO 2 J=1,IBINS(I)
29837 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29838 LNOETY = .FALSE.
29839 HIST(2,I,J) = HIST(2,I,J)+ONE
29840 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29841 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29842 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29843 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29844 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29845 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29846 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29847 TMPHIS(1,I,J) = ZERO
29848 TMPHIS(2,I,J) = ZERO
29849 TMPHIS(3,I,J) = ZERO
29850 ENDIF
29851 2 CONTINUE
29852 IF (LNOETY) THEN
29853 IF (TMPUFL(I).GT.ZERO) THEN
29854 UNDERF(I) = UNDERF(I)+ONE
29855 TMPUFL(I) = ZERO
29856 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29857 OVERF(I) = OVERF(I)+ONE
29858 TMPOFL(I) = ZERO
29859 ENDIF
29860 ELSE
29861 DENTRY(1,I) = DENTRY(1,I)+ONE
29862 ENDIF
29863 1 CONTINUE
29864
29865 RETURN
29866 END
29867
29868*$ CREATE DT_OUTHGR.FOR
29869*COPY DT_OUTHGR
29870*
29871*===outhgr=============================================================*
29872*
29873 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29874 & ILOGY,INORM,NMODE)
29875
29876************************************************************************
29877* *
29878* Plot histogram(s) to standard output unit *
29879* *
29880* I1..6 indices of histograms to be plotted *
29881* CHEAD,IHEAD header string,integer *
29882* NEVTS number of events *
29883* FAC scaling factor *
29884* ILOGY = 1 logarithmic y-axis *
29885* INORM normalization *
29886* = 0 no further normalization (FAC is obsolete) *
29887* = 1 per event and bin width *
29888* = 2 per entry and bin width *
29889* = 3 per bin entry *
29890* = 4 per event and "bin width" x1^2...x2^2 *
29891* = 5 per event and "log. bin width" ln x1..ln x2 *
29892* = 6 per event *
29893* MODE = 0 no output but normalization applied *
29894* = 1 all valid histograms separately (small frame) *
29895* all valid histograms separately (small frame) *
29896* = -1 and tables as histograms *
29897* = 2 all valid histograms (one plot, wide frame) *
29898* all valid histograms (one plot, wide frame) *
29899* = -2 and tables as histograms *
29900* *
29901* *
29902* Note: All histograms to be plotted with one call to this *
29903* subroutine and |MODE|=2 must have the same bin structure! *
29904* There is no test included ensuring this fact. *
29905* *
29906* This version dated 23.4.95 is written by S. Roesler. *
29907************************************************************************
29908
29909 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29910 SAVE
29911
29912 PARAMETER ( LINP = 10 ,
29913 & LOUT = 6 ,
29914 & LDAT = 9 )
29915
29916 CHARACTER*72 CHEAD
29917
29918 PARAMETER (ZERO = 0.0D0,
29919 & IZERO = 0,
29920 & ONE = 1.0D0,
29921 & TWO = 2.0D0,
29922 & OHALF = 0.5D0,
29923 & EPS = 1.0D-5,
29924 & TINY = 1.0D-8,
29925 & SMALL = -1.0D8,
29926 & RLARGE = 1.0D8 )
29927
29928* histograms
29929
29930 PARAMETER (NHIS=150, NDIM=250)
29931
29932 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29933 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29934
29935 PARAMETER (NDIM2 = 2*NDIM)
29936 DIMENSION XX(NDIM2),YY(NDIM2)
29937
29938 PARAMETER (NHISTO = 6)
29939 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29940 & IDX(NHISTO)
29941
29942 CHARACTER*43 CNORM(0:8)
29943 DATA CNORM /'no further normalization ',
29944 & 'per event and bin width ',
29945 & 'per entry1 and bin width ',
29946 & 'per bin entry ',
29947 & 'per event and "bin width" x1^2...x2^2 ',
29948 & 'per event and "log. bin width" ln x1..ln x2',
29949 & 'per event ',
29950 & 'per bin entry1 ',
29951 & 'per entry2 and bin width '/
29952
29953 IDX1(1) = I1
29954 IDX1(2) = I2
29955 IDX1(3) = I3
29956 IDX1(4) = I4
29957 IDX1(5) = I5
29958 IDX1(6) = I6
29959
29960 MODE = NMODE
29961
29962* initialization if "wide frame" is requested
29963 IF (ABS(MODE).EQ.2) THEN
29964 DO 1 I=1,NHISTO
29965 DO 2 J=1,NDIM
29966 XX1(J,I) = ZERO
29967 YY1(J,I) = ZERO
29968 2 CONTINUE
29969 1 CONTINUE
29970 ENDIF
29971
29972* plot header
29973 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29974
29975* check histogram indices
29976 NHI = 0
29977 DO 3 I=1,NHISTO
29978 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
29979 IF (ISWI(IDX1(I)).NE.0) THEN
29980 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
29981 WRITE(LOUT,1000)
29982 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
29983 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
29984 & ' histogram ',I3,/,21X,'underflows:',F10.0,
29985 & ' overflows: ',F10.0)
29986 ELSE
29987 NHI = NHI+1
29988 IDX(NHI) = IDX1(I)
29989 ENDIF
29990 ENDIF
29991 ENDIF
29992 3 CONTINUE
29993 IF (NHI.EQ.0) THEN
29994 WRITE(LOUT,1001)
29995 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
29996 RETURN
29997 ENDIF
29998
29999* check normalization request
30000 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30001 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30002 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30003 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30004 WRITE(LOUT,1002) NEVTS,INORM,FAC
30005 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30006 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30007 & 'FAC = ',E11.4)
30008 RETURN
30009 ENDIF
30010
30011 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30012
30013* apply normalization
30014 DO 4 N=1,NHI
30015
30016 I = IDX(N)
30017
30018 IF (ISWI(I).EQ.1) THEN
30019 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30020 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30021 & ' to',2X,E10.4,',',2X,I3,' bins')
30022 ELSEIF (ISWI(I).EQ.2) THEN
30023 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30024 WRITE(LOUT,1007)
30025 1007 FORMAT(1X,'user defined bin structure')
30026 ELSEIF (ISWI(I).EQ.3) THEN
30027 WRITE(LOUT,1004)
30028 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30029 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30030 & ' to',2X,E10.4,',',2X,I3,' bins')
30031 ELSEIF (ISWI(I).EQ.4) THEN
30032 WRITE(LOUT,1004)
30033 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30034 WRITE(LOUT,1007)
30035 ELSE
30036 WRITE(LOUT,1008) ISWI(I)
30037 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30038 ENDIF
30039 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30040 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30041 & ' overfl.:',F8.0)
30042 WRITE(LOUT,1009) CNORM(INORM)
30043 1009 FORMAT(1X,'normalization: ',A,/)
30044
30045 DO 5 K=1,IBINS(I)
30046 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30047 YMEAN = FAC*YMEAN
30048 YERR = FAC*YERR
30049 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30050 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30051 1006 FORMAT(1X,5E11.3)
30052* small frame
30053 II = 2*K
30054 XX(II-1) = HIST(1,I,K)
30055 XX(II) = HIST(1,I,K+1)
30056 YY(II-1) = YMEAN
30057 YY(II) = YMEAN
30058* wide frame
30059 XX1(K,N) = XMEAN
30060 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30061 & XX1(K,N) = LOG10(XMEAN)
30062 YY1(K,N) = YMEAN
30063 5 CONTINUE
30064
30065* plot small frame
30066 IF (ABS(MODE).EQ.1) THEN
30067 IBIN2 = 2*IBINS(I)
30068 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30069 IF(ILOGY.EQ.1) THEN
30070 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30071 ELSE
30072 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30073 ENDIF
30074 ENDIF
30075
30076 4 CONTINUE
30077
30078* plot wide frame
30079 IF (ABS(MODE).EQ.2) THEN
30080 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30081 NSIZE = NDIM*NHISTO
30082 DXLOW = HIST(1,IDX(1),1)
30083 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30084 YLOW = RLARGE
30085 YHI = SMALL
30086 DO 6 I=1,NHISTO
30087 DO 7 J=1,NDIM
30088 IF (YY1(J,I).LT.YLOW) THEN
30089 IF (ILOGY.EQ.1) THEN
30090 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30091 ELSE
30092 YLOW = YY1(J,I)
30093 ENDIF
30094 ENDIF
30095 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30096 7 CONTINUE
30097 6 CONTINUE
30098 DY = (YHI-YLOW)/DBLE(NDIM)
30099 IF (DY.LE.ZERO) THEN
30100 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30101 & 'OUTHGR: warning! zero bin width for histograms ',
30102 & IDX,': ',YLOW,YHI
30103 RETURN
30104 ENDIF
30105 IF (ILOGY.EQ.1) THEN
30106 YLOW = LOG10(YLOW)
30107 DY = (LOG10(YHI)-YLOW)/100.0D0
30108 DO 8 I=1,NHISTO
30109 DO 9 J=1,NDIM
30110 IF (YY1(J,I).LE.ZERO) THEN
30111 YY1(J,I) = YLOW
30112 ELSE
30113 YY1(J,I) = LOG10(YY1(J,I))
30114 ENDIF
30115 9 CONTINUE
30116 8 CONTINUE
30117 ENDIF
30118 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30119 ENDIF
30120
30121 RETURN
30122 END
30123
30124*$ CREATE DT_GETBIN.FOR
30125*COPY DT_GETBIN
30126*
30127*===getbin=============================================================*
30128*
30129 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30130 & XMEAN,YMEAN,YERR)
30131
30132************************************************************************
30133* This version dated 23.4.95 is written by S. Roesler. *
30134************************************************************************
30135
30136 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30137 SAVE
30138
30139 PARAMETER ( LINP = 10 ,
30140 & LOUT = 6 ,
30141 & LDAT = 9 )
30142
30143 PARAMETER (ZERO = 0.0D0,
30144 & ONE = 1.0D0,
30145 & TINY35 = 1.0D-35)
30146
30147* histograms
30148
30149 PARAMETER (NHIS=150, NDIM=250)
30150
30151 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30152 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30153
30154 XLOW = HIST(1,IHIS,IBIN)
30155 XHI = HIST(1,IHIS,IBIN+1)
30156 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30157 XLOW = 10**XLOW
30158 XHI = 10**XHI
30159 ENDIF
30160 IF (NORM.EQ.2) THEN
30161 DX = XHI-XLOW
30162 NEVT = INT(DENTRY(1,IHIS))
30163 ELSEIF (NORM.EQ.3) THEN
30164 DX = ONE
30165 NEVT = INT(HIST(2,IHIS,IBIN))
30166 ELSEIF (NORM.EQ.4) THEN
30167 DX = XHI**2-XLOW**2
30168 NEVT = KEVT
30169 ELSEIF (NORM.EQ.5) THEN
30170 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30171 NEVT = KEVT
30172 ELSEIF (NORM.EQ.6) THEN
30173 DX = ONE
30174 NEVT = KEVT
30175 ELSEIF (NORM.EQ.7) THEN
30176 DX = ONE
30177 NEVT = INT(HIST(7,IHIS,IBIN))
30178 ELSEIF (NORM.EQ.8) THEN
30179 DX = XHI-XLOW
30180 NEVT = INT(DENTRY(2,IHIS))
30181 ELSE
30182 DX = ABS(XHI-XLOW)
30183 NEVT = KEVT
30184 ENDIF
30185 IF (ABS(DX).LT.TINY35) DX = ONE
30186 NEVT = MAX(NEVT,1)
30187 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30188 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30189 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30190 YSUM = HIST(5,IHIS,IBIN)
30191 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30192C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30193 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30194 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30195
30196 RETURN
30197 END
30198
30199*$ CREATE DT_JOIHIS.FOR
30200*COPY DT_JOIHIS
30201*
30202*===joihis=============================================================*
30203*
30204 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30205
30206************************************************************************
30207* *
30208* Operation on histograms. *
30209* *
30210* input: IH1,IH2 histogram indices to be joined *
30211* COPER character defining the requested operation, *
30212* i.e. '+', '-', '*', '/' *
30213* FAC1,FAC2 factors for joining, i.e. *
30214* FAC1*histo1 COPER FAC2*histo2 *
30215* *
30216* This version dated 23.4.95 is written by S. Roesler. *
30217************************************************************************
30218
30219 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30220 SAVE
30221
30222 PARAMETER ( LINP = 10 ,
30223 & LOUT = 6 ,
30224 & LDAT = 9 )
30225
30226 CHARACTER COPER*1
30227
30228 PARAMETER (ZERO = 0.0D0,
30229 & ONE = 1.0D0,
30230 & OHALF = 0.5D0,
30231 & TINY8 = 1.0D-8,
30232 & SMALL = -1.0D8,
30233 & RLARGE = 1.0D8 )
30234
30235* histograms
30236
30237 PARAMETER (NHIS=150, NDIM=250)
30238
30239 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30240 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30241
30242 PARAMETER (NDIM2 = 2*NDIM)
30243 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30244
30245 CHARACTER*43 CNORM(0:6)
30246 DATA CNORM /'no further normalization ',
30247 & 'per event and bin width ',
30248 & 'per entry and bin width ',
30249 & 'per bin entry ',
30250 & 'per event and "bin width" x1^2...x2^2 ',
30251 & 'per event and "log. bin width" ln x1..ln x2',
30252 & 'per event '/
30253
30254* check histogram indices
30255 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30256 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30257 WRITE(LOUT,1000) IH1,IH2,IHISL
30258 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30259 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30260 GOTO 9999
30261 ENDIF
30262
30263* check bin structure of histograms to be joined
30264 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30265 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30266 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30267 & ' and ',I3,' failed',/,21X,
30268 & 'due to different numbers of bins (',I3,',',I3,')')
30269 GOTO 9999
30270 ENDIF
30271 DO 1 K=1,IBINS(IH1)+1
30272 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30273 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30274 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30275 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30276 & 'X1,X2 = ',2E11.4)
30277 GOTO 9999
30278 ENDIF
30279 1 CONTINUE
30280
30281 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30282 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30283 & 'operation ',A,/,11X,'and factors ',2E11.4)
30284 WRITE(LOUT,1004) CNORM(NORM)
30285 1004 FORMAT(1X,'normalization: ',A,/)
30286
30287 DO 2 K=1,IBINS(IH1)
30288 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30289 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30290 XLOW = XLOW1
30291 XHI = XHI1
30292 XMEAN = OHALF*(XMEAN1+XMEAN2)
30293 IF (COPER.EQ.'+') THEN
30294 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30295 ELSEIF (COPER.EQ.'*') THEN
30296 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30297 ELSEIF (COPER.EQ.'/') THEN
30298 IF (YMEAN2.EQ.ZERO) THEN
30299 YMEAN = ZERO
30300 ELSE
30301 IF (FAC2.EQ.ZERO) FAC2 = ONE
30302 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30303 ENDIF
30304 ELSE
30305 GOTO 9998
30306 ENDIF
30307 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30308 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30309 1006 FORMAT(1X,5E11.3)
30310* small frame
30311 II = 2*K
30312 XX(II-1) = HIST(1,IH1,K)
30313 XX(II) = HIST(1,IH1,K+1)
30314 YY(II-1) = YMEAN
30315 YY(II) = YMEAN
30316* wide frame
30317 XX1(K) = XMEAN
30318 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30319 YY1(K) = YMEAN
30320 2 CONTINUE
30321
30322* plot small frame
30323 IF (ABS(MODE).EQ.1) THEN
30324 IBIN2 = 2*IBINS(IH1)
30325 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30326 IF(ILOGY.EQ.1) THEN
30327 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30328 ELSE
30329 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30330 ENDIF
30331 ENDIF
30332
30333* plot wide frame
30334 IF (ABS(MODE).EQ.2) THEN
30335 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30336 NSIZE = NDIM
30337 DXLOW = HIST(1,IH1,1)
30338 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30339 YLOW = RLARGE
30340 YHI = SMALL
30341 DO 3 I=1,NDIM
30342 IF (YY1(I).LT.YLOW) THEN
30343 IF (ILOGY.EQ.1) THEN
30344 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30345 ELSE
30346 YLOW = YY1(I)
30347 ENDIF
30348 ENDIF
30349 IF (YY1(I).GT.YHI) YHI = YY1(I)
30350 3 CONTINUE
30351 DY = (YHI-YLOW)/DBLE(NDIM)
30352 IF (DY.LE.ZERO) THEN
30353 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30354 & 'JOIHIS: warning! zero bin width for histograms ',
30355 & IH1,IH2,': ',YLOW,YHI
30356 RETURN
30357 ENDIF
30358 IF (ILOGY.EQ.1) THEN
30359 YLOW = LOG10(YLOW)
30360 DY = (LOG10(YHI)-YLOW)/100.0D0
30361 DO 4 I=1,NDIM
30362 IF (YY1(I).LE.ZERO) THEN
30363 YY1(I) = YLOW
30364 ELSE
30365 YY1(I) = LOG10(YY1(I))
30366 ENDIF
30367 4 CONTINUE
30368 ENDIF
30369 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30370 ENDIF
30371
30372 RETURN
30373
30374 9998 CONTINUE
30375 WRITE(LOUT,1005) COPER
30376 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30377
30378 9999 CONTINUE
30379 RETURN
30380 END
30381
30382*$ CREATE DT_XGRAPH.FOR
30383*COPY DT_XGRAPH
30384*
30385*===qgraph=============================================================*
30386*
30387 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30388C***********************************************************************
30389C
30390C calculate quasi graphic picture with 25 lines and 79 columns
30391C ranges will be chosen automatically
30392C
30393C input N dimension of input fields
30394C IARG number of curves (fields) to plot
30395C X field of X
30396C Y1 field of Y1
30397C Y2 field of Y2
30398C
30399C This subroutine is written by R. Engel.
30400C***********************************************************************
30401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30402 SAVE
30403
30404 PARAMETER ( LINP = 10 ,
30405 & LOUT = 6 ,
30406 & LDAT = 9 )
30407
30408C
30409 DIMENSION X(N),Y1(N),Y2(N)
30410 PARAMETER (EPS=1.D-30)
30411 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30412 CHARACTER SYMB(5)
30413 CHARACTER COL(0:149,0:49)
30414C
30415 DATA SYMB /'0','e','z','#','x'/
30416C
30417 ISPALT=IBREIT-10
30418C
30419C*** automatic range fitting
30420C
30421 XMAX=X(1)
30422 XMIN=X(1)
30423 DO 600 I=1,N
30424 XMAX=MAX(X(I),XMAX)
30425 XMIN=MIN(X(I),XMIN)
30426 600 CONTINUE
30427 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30428C
30429 ITEST=0
30430 DO 1100 K=0,IZEIL-1
30431 ITEST=ITEST+1
30432 IF (ITEST.EQ.IYRAST) THEN
30433 DO 1010 L=1,ISPALT-1
30434 COL(L,K)='-'
304351010 CONTINUE
30436 COL(ISPALT,K)='+'
30437 ITEST=0
30438 DO 1020 L=0,ISPALT-1,IXRAST
30439 COL(L,K)='+'
304401020 CONTINUE
30441 ELSE
30442 DO 1030 L=1,ISPALT-1
30443 COL(L,K)=' '
304441030 CONTINUE
30445 DO 1040 L=0,ISPALT-1,IXRAST
30446 COL(L,K)='|'
304471040 CONTINUE
30448 COL(ISPALT,K)='|'
30449 ENDIF
304501100 CONTINUE
30451C
30452C*** plot curve Y1
30453C
30454 YMAX=Y1(1)
30455 YMIN=Y1(1)
30456 DO 500 I=1,N
30457 YMAX=MAX(Y1(I),YMAX)
30458 YMIN=MIN(Y1(I),YMIN)
30459500 CONTINUE
30460 IF(IARG.GT.1) THEN
30461 DO 550 I=1,N
30462 YMAX=MAX(Y2(I),YMAX)
30463 YMIN=MIN(Y2(I),YMIN)
30464550 CONTINUE
30465 ENDIF
30466 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30467 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30468 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30469 IF(YZOOM.LT.EPS) THEN
30470 WRITE(LOUT,'(1X,A)')
30471 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30472 RETURN
30473 ENDIF
30474C
30475C*** plot curve Y1
30476C
30477 ILAST=-1
30478 LLAST=-1
30479 DO 1200 K=1,N
30480 L=NINT((X(K)-XMIN)/XZOOM)
30481 I=NINT((YMAX-Y1(K))/YZOOM)
30482 IF(ILAST.GE.0) THEN
30483 LD = L-LLAST
30484 ID = I-ILAST
30485 DO 55 II=0,LD,SIGN(1,LD)
30486 DO 66 KK=0,ID,SIGN(1,ID)
30487 COL(II+LLAST,KK+ILAST)=SYMB(1)
30488 66 CONTINUE
30489 55 CONTINUE
30490 ELSE
30491 COL(L,I)=SYMB(1)
30492 ENDIF
30493 ILAST = I
30494 LLAST = L
304951200 CONTINUE
30496C
30497 IF(IARG.GT.1) THEN
30498C
30499C*** plot curve Y2
30500C
30501 DO 1250 K=1,N
30502 L=NINT((X(K)-XMIN)/XZOOM)
30503 I=NINT((YMAX-Y2(K))/YZOOM)
30504 COL(L,I)=SYMB(2)
305051250 CONTINUE
30506 ENDIF
30507C
30508C*** write it
30509C
30510 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30511C
30512C*** write range of X
30513C
30514 XZOOM = (XMAX-XMIN)/DBLE(7)
30515 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30516C
30517 DO 1300 K=0,IZEIL-1
30518 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30519 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30520 110 FORMAT(1X,1PE9.2,70A1)
305211300 CONTINUE
30522C
30523C*** write range of X
30524C
30525 XZOOM = (XMAX-XMIN)/DBLE(7)
30526 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30527 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30528 120 FORMAT(6X,7(1PE10.3))
30529 END
30530
30531*$ CREATE DT_XGLOGY.FOR
30532*COPY DT_XGLOGY
30533*
30534*===qglogy=============================================================*
30535*
30536 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30537C***********************************************************************
30538C
30539C calculate quasi graphic picture with 25 lines and 79 columns
30540C logarithmic y axis
30541C ranges will be chosen automatically
30542C
30543C input N dimension of input fields
30544C IARG number of curves (fields) to plot
30545C X field of X
30546C Y1 field of Y1
30547C Y2 field of Y2
30548C
30549C This subroutine is written by R. Engel.
30550C***********************************************************************
30551C
30552 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30553 SAVE
30554
30555 PARAMETER ( LINP = 10 ,
30556 & LOUT = 6 ,
30557 & LDAT = 9 )
30558
30559 DIMENSION X(N),Y1(N),Y2(N)
30560 PARAMETER (EPS=1.D-30)
30561 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30562 CHARACTER SYMB(5)
30563 CHARACTER COL(0:149,0:49)
30564 PARAMETER (DEPS = 1.D-10)
30565C
30566 DATA SYMB /'0','e','z','#','x'/
30567C
30568 ISPALT=IBREIT-10
30569C
30570C*** automatic range fitting
30571C
30572 XMAX=X(1)
30573 XMIN=X(1)
30574 DO 600 I=1,N
30575 XMAX=MAX(X(I),XMAX)
30576 XMIN=MIN(X(I),XMIN)
30577 600 CONTINUE
30578 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30579C
30580 ITEST=0
30581 DO 1100 K=0,IZEIL-1
30582 ITEST=ITEST+1
30583 IF (ITEST.EQ.IYRAST) THEN
30584 DO 1010 L=1,ISPALT-1
30585 COL(L,K)='-'
305861010 CONTINUE
30587 COL(ISPALT,K)='+'
30588 ITEST=0
30589 DO 1020 L=0,ISPALT-1,IXRAST
30590 COL(L,K)='+'
305911020 CONTINUE
30592 ELSE
30593 DO 1030 L=1,ISPALT-1
30594 COL(L,K)=' '
305951030 CONTINUE
30596 DO 1040 L=0,ISPALT-1,IXRAST
30597 COL(L,K)='|'
305981040 CONTINUE
30599 COL(ISPALT,K)='|'
30600 ENDIF
306011100 CONTINUE
30602C
30603C*** plot curve Y1
30604C
30605 YMAX=Y1(1)
30606 YMIN=MAX(Y1(1),EPS)
30607 DO 500 I=1,N
30608 YMAX =MAX(Y1(I),YMAX)
30609 IF(Y1(I).GT.EPS) THEN
30610 IF(YMIN.EQ.EPS) THEN
30611 YMIN = Y1(I)/10.D0
30612 ELSE
30613 YMIN = MIN(Y1(I),YMIN)
30614 ENDIF
30615 ENDIF
30616500 CONTINUE
30617 IF(IARG.GT.1) THEN
30618 DO 550 I=1,N
30619 YMAX=MAX(Y2(I),YMAX)
30620 IF(Y2(I).GT.EPS) THEN
30621 IF(YMIN.EQ.EPS) THEN
30622 YMIN = Y2(I)
30623 ELSE
30624 YMIN = MIN(Y2(I),YMIN)
30625 ENDIF
30626 ENDIF
30627550 CONTINUE
30628 ENDIF
30629C
30630 DO 560 I=1,N
30631 Y1(I) = MAX(Y1(I),YMIN)
30632 560 CONTINUE
30633 IF(IARG.GT.1) THEN
30634 DO 570 I=1,N
30635 Y2(I) = MAX(Y2(I),YMIN)
30636 570 CONTINUE
30637 ENDIF
30638C
30639 IF(YMAX.LE.YMIN) THEN
30640 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30641 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30642 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30643 RETURN
30644 ENDIF
30645C
30646 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30647 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30648 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30649 IF(YZOOM.LT.EPS) THEN
30650 WRITE(LOUT,'(1X,A)')
30651 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30652 RETURN
30653 ENDIF
30654C
30655C*** plot curve Y1
30656C
30657 ILAST=-1
30658 LLAST=-1
30659 DO 1200 K=1,N
30660 L=NINT((X(K)-XMIN)/XZOOM)
30661 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30662 IF(ILAST.GE.0) THEN
30663 LD = L-LLAST
30664 ID = I-ILAST
30665 DO 55 II=0,LD,SIGN(1,LD)
30666 DO 66 KK=0,ID,SIGN(1,ID)
30667 COL(II+LLAST,KK+ILAST)=SYMB(1)
30668 66 CONTINUE
30669 55 CONTINUE
30670 ELSE
30671 COL(L,I)=SYMB(1)
30672 ENDIF
30673 ILAST = I
30674 LLAST = L
306751200 CONTINUE
30676C
30677 IF(IARG.GT.1) THEN
30678C
30679C*** plot curve Y2
30680C
30681 DO 1250 K=1,N
30682 L=NINT((X(K)-XMIN)/XZOOM)
30683 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30684 COL(L,I)=SYMB(2)
306851250 CONTINUE
30686 ENDIF
30687C
30688C*** write it
30689C
30690 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30691 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30692C
30693C*** write range of X
30694C
30695 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30696 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30697C
30698 DO 1300 K=0,IZEIL-1
30699 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30700 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30701 110 FORMAT(1X,1PE9.2,70A1)
307021300 CONTINUE
30703C
30704C*** write range of X
30705C
30706 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30707 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30708 120 FORMAT(6X,7(1PE10.3))
30709C
30710 END
30711
30712*$ CREATE DT_SRPLOT.FOR
30713*COPY DT_SRPLOT
30714*
30715*===plot===============================================================*
30716*
30717 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30718
30719 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30720 SAVE
30721
30722 PARAMETER ( LINP = 10 ,
30723 & LOUT = 6 ,
30724 & LDAT = 9 )
30725
30726*
30727* initial version
30728* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30729* This is a subroutine of fluka to plot Y across the page
30730* as a function of X down the page. Up to 37 curves can be
30731* plotted in the same picture with different plotting characters.
30732* Output of first 10 overprinted characters addad by FB 88
30733* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30734*
30735* Input Variables:
30736* X = array containing the values of X
30737* Y = array containing the values of Y
30738* N = number of values in X and in Y
30739* can exceed the fixed number of lines
30740* M = number of different curves X,Y are containing
30741* MM = number of points in each curve i.e. N=M*MM
30742* XO = smallest value of X to be plotted
30743* DX = increment of X between subsequent lines
30744* YO = smallest value of Y to be plotted
30745* DY = increment of Y between subsequent character spaces
30746*
30747* other variables used inside:
30748* XX = numbers along the X-coordinate axis
30749* YY = numbers along the Y-coordinate axis
30750* LL = ten lines temporary storage for the plot
30751* L = character set used to plot different curves
30752* LOV = memorizes overprinted symbols
30753* the first 10 overprinted symbols are printed on
30754* the end of the line to avoid ambiguities
30755* (added by FB as considered quite helpful)
30756*
30757*********************************************************************
30758*
30759 DIMENSION XX(61),YY(61),LL(101,10)
30760 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30761 DATA L/
30762 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30763 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30764 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30765 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30766*
30767*
30768 MN=51
30769 DO 10 I=1,MN
30770 AI=I-1
30771 10 XX(I)=XO+AI*DX
30772 DO 20 I=1,11
30773 AI=I-1
30774 20 YY(I)=YO+10.0D0*AI*DY
30775 WRITE(LOUT, 500) (YY(I),I=1,11)
30776 MMN=MN-1
30777*
30778*
30779 DO 90 JJ=1,MMN,10
30780 JJJ=JJ-1
30781 DO 30 I=1,101
30782 DO 30 J=1,10
30783 30 LL(I,J)=L(40)
30784 DO 40 I=1,101
30785 40 LL(I,1)=L(39)
30786 DO 50 I=1,101,10
30787 DO 50 J=1,10
30788 50 LL(I,J)=L(38)
30789 DO 60 I=1,40
30790 DO 60 J=1,10
30791 60 LOV(I,J)=L(40)
30792*
30793*
30794 DO 70 I=1,M
30795 DO 70 J=1,MM
30796 II=J+(I-1)*MM
30797 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30798 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30799 AIX=AIX-DBLE(JJJ)
30800* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30801 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30802 + . AIY .LT. 102.D0) THEN
30803 IX=INT(AIX)
30804 IY=INT(AIY)
30805 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30806 + THEN
30807 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30808 + =LL(IY,IX)
30809 LL(IY,IX)=L(I)
30810 ENDIF
30811 ENDIF
30812 70 CONTINUE
30813*
30814*
30815 DO 80 I=1,10
30816 II=I+JJJ
30817 III=II+1
30818 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30819 & (LOV(J,I),J=1,10)
30820 80 CONTINUE
30821 90 CONTINUE
30822*
30823*
30824 WRITE(LOUT, 520)
30825 WRITE(LOUT, 500) (YY(I),I=1,11)
30826 RETURN
30827*
30828 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30829 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30830 520 FORMAT(20X,10('1---------'),'1')
30831 END
30832*$ CREATE DT_DEFSET.FOR
30833*COPY DT_DEFSET
30834*
30835*===defset=============================================================*
30836*
30837 BLOCK DATA DT_DEFSET
30838
30839 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30840 SAVE
30841
30842* flags for input different options
30843 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30844 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30845 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30846
30847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30848
30849* emulsion treatment
30850 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30851 & NCOMPO,IEMUL
30852
30853* / DTFLG1 /
30854 DATA IFRAG / 2, 1 /
30855 DATA IRESCO / 1 /
30856 DATA IMSHL / 1 /
30857 DATA IRESRJ / 0 /
30858 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30859 DATA LEMCCK / .FALSE. /
30860 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30861 & .TRUE.,.TRUE.,.TRUE./
30862 DATA LSEADI / .TRUE. /
30863 DATA LEVAPO / .TRUE. /
30864 DATA IFRAME / 1 /
30865 DATA ITRSPT / 0 /
30866
30867* / DTCOMP /
30868 DATA EMUFRA / NCOMPX*0.0D0 /
30869 DATA IEMUMA / NCOMPX*1 /
30870 DATA IEMUCH / NCOMPX*1 /
30871 DATA NCOMPO / 0 /
30872 DATA IEMUL / 0 /
30873
30874 END
30875
30876*$ CREATE DT_HADPRP.FOR
30877*COPY DT_HADPRP
30878*
30879*===hadprp=============================================================*
30880*
30881 BLOCK DATA DT_HADPRP
30882
30883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30884 SAVE
30885
30886* auxiliary common for reggeon exchange (DTUNUC 1.x)
30887 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30888 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30889 & IQTCHR(-6:6),MQUARK(3,39)
30890
30891* hadron index conversion (BAMJET <--> PDG)
30892 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30893 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30894 & IAMCIN(210)
30895
30896* names of hadrons used in input-cards
30897 CHARACTER*8 BTYPE
30898 COMMON /DTPAIN/ BTYPE(30)
30899
30900* / DTQUAR /
30901*----------------------------------------------------------------------*
30902* *
30903* Quark content of particles: *
30904* index quark el. charge bar. charge isospin isospin3 *
30905* 1 = u 2/3 1/3 1/2 1/2 *
30906* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30907* 2 = d -1/3 1/3 1/2 -1/2 *
30908* -2 = dbar 1/3 -1/3 1/2 1/2 *
30909* 3 = s -1/3 1/3 0 0 *
30910* -3 = sbar 1/3 -1/3 0 0 *
30911* 4 = c 2/3 1/3 0 0 *
30912* -4 = cbar -2/3 -1/3 0 0 *
30913* 5 = b -1/3 1/3 0 0 *
30914* -5 = bbar 1/3 -1/3 0 0 *
30915* 6 = t 2/3 1/3 0 0 *
30916* -6 = tbar -2/3 -1/3 0 0 *
30917* *
30918* Mquark = particle quark composition (Paprop numbering) *
30919* Iqechr = electric charge ( in 1/3 unit ) *
30920* Iqbchr = baryonic charge ( in 1/3 unit ) *
30921* Iqichr = isospin ( in 1/2 unit ), z component *
30922* Iqschr = strangeness *
30923* Iqcchr = charm *
30924* Iquchr = beauty *
30925* Iqtchr = ...... *
30926* *
30927*----------------------------------------------------------------------*
30928 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30929 DATA IQBCHR / 6*-1, 0, 6*1 /
30930 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30931 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30932 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30933 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30934 DATA IQTCHR / -1, 11*0, 1 /
30935 DATA MQUARK /
30936 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30937 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30938 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30939 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30940 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30941 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30942 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30943 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30944
30945* / DTHAIC /
30946* (renamed) (HAdron InDex COnversion)
30947* translation table version filled up by r.e. 25.01.94 *
30948 DATA IAMCIN /
30949 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30950 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30951 &3222,3212,111,311,-311, 0,0,0,0,0,
30952 &221,213,113,-213,223, 323,313,-323,-313,10323,
30953 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30954 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30955 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30956 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30957 &5*99999, 5*99999,
30958 &4*99999,331, 333,3322,3312,-3222,-3212,
30959 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30960 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30961 &-431,441,423,413,-413, -423,433,-433,20443,443,
30962 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30963 &4212,4112,3*99999, 3*99999,-4122,-4232,
30964 &-4132,-4222,-4212,-4112,99999, 5*99999,
30965 &5*99999, 5*99999,
30966 &10*99999,
30967 &5*99999 , 20211,20111,-20211,99999,20321,
30968 &-20321,20311,-20311,7*99999 ,
30969 &7*99999,12212,12112,99999/
30970
30971* / DTHAIC /
30972* (HAdron InDex COnversion)
30973 DATA (IPDG2(1,K),K=1,7)
30974 & / -11, -12, -13, -15, -16, -14, 0/
30975 DATA (IBAM2(1,K),K=1,7)
30976 & / 4, 6, 10, 131, 134, 136, 0/
30977 DATA (IPDG2(2,K),K=1,7)
30978 & / 11, 12, 22, 13, 15, 16, 14/
30979 DATA (IBAM2(2,K),K=1,7)
30980 & / 3, 5, 7, 11, 132, 133, 135/
30981 DATA (IPDG3(1,K),K=1,22)
30982 & / -211, -321, -311, -213, -323, -313, -411, -421,
30983 & -431, -413, -423, -433, 0, 0, 0, 0,
30984 & 0, 0, 0, 0, 0, 0/
30985 DATA (IBAM3(1,K),K=1,22)
30986 & / 14, 16, 25, 34, 38, 39, 118, 119,
30987 & 121, 125, 126, 128, 0, 0, 0, 0,
30988 & 0, 0, 0, 0, 0, 0/
30989 DATA (IPDG3(2,K),K=1,22)
30990 & / 130, 211, 321, 310, 111, 311, 221, 213,
30991 & 113, 223, 323, 313, 331, 333, 421, 411,
30992 & 431, 441, 423, 413, 433, 443/
30993 DATA (IBAM3(2,K),K=1,22)
30994 & / 12, 13, 15, 19, 23, 24, 31, 32,
30995 & 33, 35, 36, 37, 95, 96, 116, 117,
30996 & 120, 122, 123, 124, 127, 130/
30997 DATA (IPDG4(1,K),K=1,29)
30998 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
30999 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31000 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31001 & -4212, -4112, 0, 0, 0/
31002 DATA (IBAM4(1,K),K=1,29)
31003 & / 2, 9, 18, 67, 68, 69, 70, 75,
31004 & 76, 99, 100, 101, 102, 103, 110, 111,
31005 & 112, 113, 114, 115, 149, 150, 151, 152,
31006 & 153, 154, 0, 0, 0/
31007 DATA (IPDG4(2,K),K=1,29)
31008 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31009 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31010 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31011 & 4232, 4132, 4222, 4212, 4112/
31012 DATA (IBAM4(2,K),K=1,29)
31013 & / 1, 8, 17, 20, 21, 22, 48, 49,
31014 & 50, 51, 52, 53, 54, 55, 56, 97,
31015 & 98, 104, 105, 106, 107, 108, 109, 137,
31016 & 138, 139, 140, 141, 142/
31017 DATA (IPDG5(1,K),K=1,19)
31018 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31019 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31020 & 0, 0, 0/
31021 DATA (IBAM5(1,K),K=1,19)
31022 & / 42, 43, 46, 47, 71, 72, 73, 74,
31023 & 188, 191, 193, 0, 0, 0, 0, 0,
31024 & 0, 0, 0/
31025 DATA (IPDG5(2,K),K=1,19)
31026 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31027 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31028 & 20311, 12212, 12112/
31029 DATA (IBAM5(2,K),K=1,19)
31030 & / 40, 41, 44, 45, 57, 58, 59, 60,
31031 & 63, 64, 65, 66, 129, 186, 187, 190,
31032 & 192, 208, 209/
31033
31034* / DTPAIN /
31035* internal particle names
31036 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31037 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31038 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31039 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31040 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31041 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31042 &'BLANK ' /
31043
31044 END
31045
31046*$ CREATE DT_BLKD46.FOR
31047*COPY DT_BLKD46
31048*
31049*===blkd46=============================================================*
31050*
31051 BLOCK DATA DT_BLKD46
31052
31053 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31054 SAVE
31055
31056 PARAMETER ( AMELCT = 0.51099906 D-03 )
31057 PARAMETER ( AMMUON = 0.105658389 D+00 )
31058
31059* particle properties (BAMJET index convention)
31060 CHARACTER*8 ANAME
31061 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31062 & IICH(210),IIBAR(210),K1(210),K2(210)
31063
31064* / DTPART /
31065* Particle masses Engel version JETSET compatible
31066C DATA (AAM(K),K=1,85) /
31067C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31068C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31069C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31070C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31071C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31072C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31073C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31074C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31075C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31076C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31077C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31078C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31079C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31080C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31081C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31082C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31083C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31084C DATA (AAM(K),K=86,183) /
31085C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31086C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31087C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31088C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31089C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31090C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31091C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31092C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31093C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31094C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31095C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31096C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31097C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31098C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31099C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31100C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31101C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31102C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31103C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31104C & .1250D+01, .1250D+01, .1250D+01 /
31105C DATA (AAM ( I ), I = 184,210 ) /
31106C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31107C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31108C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31109C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31110C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31111C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31112C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31113C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31114C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31115* sr 25.1.06: particle masses adjusted to Pythia
31116 DATA (AAM(K),K=1,85) /
31117 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31118 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31119 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31120 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31121 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31122 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31123 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31124 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31125 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31126 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31127 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31128 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31129 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31130 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31131 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31132 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31133 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31134 DATA (AAM(K),K=86,183) /
31135 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31136 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31137 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31138 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31139 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31140 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31141 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31142 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31143 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31144 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31145 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31146 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31147 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31148 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31149 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31150 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31151 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31152 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31153 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31154 & .1250D+01, .1250D+01, .1250D+01 /
31155 DATA (AAM ( I ), I = 184,210 ) /
31156 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31157 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31158 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31159 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31160 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31161 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31162 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31163 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31164 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31165* Particle mean lives
31166 DATA (TAU(K),K=1,183) /
31167 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31168 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31169 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31170 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31171 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31172 & 70*.0000D+00,
31173 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31174 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31175 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31176 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31177 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31178 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31179 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31180 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31181 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31182 & 40*.0000D+00,
31183 & .0000D+00, .0000D+00, .0000D+00 /
31184 DATA ( TAU ( I ), I = 184,210 ) /
31185 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31186 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31187 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31188 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31189 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31190 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31191 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31192 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31193 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31194* Resonance width Gamma in GeV
31195 DATA (GA(K),K= 1,85) /
31196 & 30*.0000D+00,
31197 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31198 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31199 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31200 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31201 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31202 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31203 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31204 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31205 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31206 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31207 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31208 DATA (GA(K),K= 86,183) /
31209 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31210 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31211 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31213 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31214 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31215 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31216 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31217 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31218 & 50*.0000D+00,
31219 & .3000D+00, .3000D+00, .3000D+00 /
31220 DATA ( GA ( I ), I = 184,210 ) /
31221 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31222 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31223 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31224 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31225 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31226 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31227 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31228 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31229 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31230* Particle names
31231* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31232* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31233* designation N*@@ means N*@1(@2)
31234 DATA (ANAME(K),K=1,85) /
31235 & 'P ','AP ','E- ','E+ ','NUE ',
31236 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31237 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31238 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31239 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31240 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31241 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31242 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31243 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31244 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31245 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31246 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31247 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31248 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31249 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31250 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31251 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31252 DATA (ANAME(K),K=86,183) /
31253 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31254 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31255 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31256 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31257 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31258 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31259 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31260 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31261 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31262 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31263 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31264 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31265 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31266 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31267 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31268 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31269 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31270 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31271 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31272 & 'RO ','R+ ','R- ' /
31273 DATA ( ANAME ( I ), I = 184,210 ) /
31274 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31275 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31276 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31277 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31278 &'N*+14 ','N*014 ','BLANK '/
31279* Charge of particles and resonances
31280 DATA (IICH ( I ), I = 1,210 ) /
31281 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31282 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31283 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31284 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31285 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31286 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31287 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31288 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31289 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31290 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31291 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31292 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31293 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31294 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31295* Particle baryonic charges
31296 DATA (IIBAR ( I ), I = 1,210 ) /
31297 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31298 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31299 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31300 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31301 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31302 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31303 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31304 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31305 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31306 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31307 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31308 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31309 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31310 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31311* First number of decay channels used for resonances
31312* and decaying particles
31313 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31314 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31315 & 2*330, 46, 51, 52, 54, 55, 58,
31316* 50
31317 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31318 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31319 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31320* 85
31321 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31322 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31323 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31324 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31325 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31326 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31327 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31328 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31329 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31330 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31331 & 590, 596, 602 /
31332* Last number of decay channels used for resonances
31333* and decaying particles
31334 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31335 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31336 & 2* 330, 50, 51, 53, 54, 57,
31337* 50
31338 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31339 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31340 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31341* 85
31342 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31343 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31344 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31345 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31346 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31347 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31348 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31349 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31350 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31351 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31352 & 589, 595, 601, 602 /
31353
31354 END
31355
31356*$ CREATE DT_BLKD47.FOR
31357*COPY DT_BLKD47
31358*
31359*===blkd47=============================================================*
31360*
31361 BLOCK DATA DT_BLKD47
31362
31363 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31364 SAVE
31365
31366* HADRIN: decay channel information
31367 PARAMETER (IDMAX9=602)
31368 CHARACTER*8 ZKNAME
31369 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31370
31371* Name of decay channel
31372* Designation N*@ means N*@1(1236)
31373* @1=# means ++, @1 = = means --
31374* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31375 DATA (ZKNAME(K),K= 1, 85) /
31376 & 'P ','AP ','E- ','E+ ','NUE ',
31377 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31378 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31379 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31380 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31381 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31382 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31383 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31384 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31385 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31386 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31387 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31388 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31389 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31390 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31391 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31392 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31393 DATA (ZKNAME(K),K= 86,170) /
31394 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31395 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31396 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31397 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31398 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31399 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31400 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31401 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31402 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31403 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31404 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31405 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31406 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31407 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31408 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31409 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31410 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31411 DATA (ZKNAME(K),K=171,255) /
31412 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31413 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31414 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31415 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31416 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31417 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31418 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31419 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31420 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31421 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31422 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31423 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31424 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31425 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31426 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31427 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31428 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31429 DATA (ZKNAME(K),K=256,340) /
31430 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31431 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31432 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31433 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31434 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31435 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31436 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31437 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31438 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31439 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31440 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31441 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31442 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31443 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31444 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31445 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31446 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31447 DATA (ZKNAME(K),K=341,425) /
31448 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31449 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31450 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31451 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31452 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31453 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31454 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31455 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31456 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31457 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31458 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31459 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31460 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31461 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31462 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31463 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31464 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31465 DATA (ZKNAME(K),K=426,510) /
31466 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31467 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31468 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31469 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31470 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31471 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31472 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31473 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31474 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31475 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31476 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31477 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31478 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31479 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31480 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31481 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31482 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31483 DATA (ZKNAME(K),K=511,540) /
31484 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31485 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31486 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31487 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31488 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31489 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31490 DATA (ZKNAME(I),I=541,602)/
31491 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31492 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31493 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31494 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31495 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31496 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31497 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31498 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31499 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31500* Weight of decay channel
31501 DATA (WT(K),K= 1, 85) /
31502 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31503 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31504 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31505 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31506 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31507 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31508 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31509 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31510 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31511 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31512 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31513 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31514 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31515 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31516 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31517 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31518 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31519 DATA (WT(K),K= 86,170) /
31520 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31521 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31522 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31523 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31524 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31525 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31526 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31527 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31528 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31529 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31530 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31531 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31532 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31533 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31534 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31535 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31536 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31537 DATA (WT(K),K=171,255) /
31538 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31539 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31540 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31541 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31542 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31543 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31544 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31545 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31546 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31547 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31548 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31549 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31550 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31551 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31552 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31553 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31554 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31555 DATA (WT(K),K=256,340) /
31556 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31557 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31558 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31559 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31560 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31561 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31562 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31563 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31564 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31565 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31566 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31567 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31568 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31569 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31570 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31571 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31572 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31573 DATA (WT(K),K=341,425) /
31574 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31575 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31576 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31577 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31578 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31579 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31580 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31581 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31582 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31583 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31584 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31585 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31586 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31587 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31588 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31589 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31590 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31591 DATA (WT(K),K=426,510) /
31592 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31593 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31594 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31595 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31596 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31597 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31598 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31599 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31600 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31601 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31602 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31603 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31604 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31605 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31606 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31607 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31608 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31609 DATA (WT(K),K=511,540) /
31610 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31611 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31612 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31613 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31614 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31615 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31616C
31617 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31618 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31619 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31620 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31621 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31622 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31623 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31624* Particle numbers in decay channel
31625 DATA (NZK(K,1),K= 1,170) /
31626 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31627 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31628 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31629 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31630 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31631 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31632 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31633 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31634 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31635 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31636 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31637 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31638 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31639 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31640 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31641 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31642 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31643 DATA (NZK(K,1),K=171,340) /
31644 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31645 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31646 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31647 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31648 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31649 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31650 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31651 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31652 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31653 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31654 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31655 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31656 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31657 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31658 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31659 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31660 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31661 DATA (NZK(K,1),K=341,510) /
31662 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31663 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31664 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31665 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31666 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31667 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31668 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31669 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31670 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31671 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31672 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31673 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31674 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31675 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31676 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31677 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31678 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31679 DATA (NZK(K,1),K=511,540) /
31680 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31681 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31682 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31683 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31684 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31685 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31686 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31687 & 55, 8, 1, 8, 8, 54, 55, 210/
31688 DATA (NZK(K,2),K= 1,170) /
31689 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31690 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31691 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31692 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31693 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31694 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31695 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31696 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31697 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31698 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31699 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31700 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31701 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31702 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31703 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31704 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31705 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31706 DATA (NZK(K,2),K=171,340) /
31707 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31708 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31709 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31710 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31711 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31712 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31713 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31714 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31715 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31716 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31717 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31718 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31719 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31720 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31721 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31722 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31723 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31724 DATA (NZK(K,2),K=341,510) /
31725 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31726 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31727 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31728 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31729 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31730 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31731 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31732 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31733 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31734 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31735 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31736 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31737 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31738 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31739 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31740 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31741 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31742 DATA (NZK(K,2),K=511,540) /
31743 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31744 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31745 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31746 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31747 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31748 & 14, 14, 23, 14, 16, 25,
31749 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31750 & 23, 13, 14, 23, 0 /
31751 DATA (NZK(K,3),K= 1,170) /
31752 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31753 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31754 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31755 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31756 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31757 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31758 & 110*0 /
31759 DATA (NZK(K,3),K=171,340) /
31760 & 80*0,
31761 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31762 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31763 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31764 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31765 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31766 & 30*0,
31767 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31768 DATA (NZK(K,3),K=341,510) /
31769 & 30*0,
31770 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31771 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31772 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31773 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31774 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31775 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31776 & 80*0 /
31777 DATA (NZK(K,3),K=511,540) /
31778 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31779 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31780 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31781 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31782 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31783
31784 END
31785
31786*$ CREATE DT_XHOINI.FOR
31787*COPY DT_XHOINI
31788*
31789*====phoini============================================================*
31790*
31791 SUBROUTINE DT_XHOINI
31792C SUBROUTINE DT_PHOINI
31793
31794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31795 SAVE
31796
31797 PARAMETER ( LINP = 10 ,
31798 & LOUT = 6 ,
31799 & LDAT = 9 )
31800
31801 RETURN
31802 END
31803
31804*$ CREATE DT_XVENTB.FOR
31805*COPY DT_XVENTB
31806*
31807*====eventb============================================================*
31808*
31809 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31810C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31811
31812 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31813 SAVE
31814
31815 PARAMETER ( LINP = 10 ,
31816 & LOUT = 6 ,
31817 & LDAT = 9 )
31818
31819 WRITE(LOUT,1000)
31820 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31821 STOP
31822
31823 END
31824
31825*$ CREATE DT_XVENT.FOR
31826*COPY DT_XVENT
31827*
31828*===event==============================================================*
31829*
31830 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31831C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31832
31833 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31834 SAVE
31835
31836 DIMENSION PP(4),PT(4)
31837
31838 RETURN
31839 END
31840
31841*$ CREATE DT_XOHISX.FOR
31842*COPY DT_XOHISX
31843*
31844*===pohisx=============================================================*
31845*
31846 SUBROUTINE DT_XOHISX(I,X)
31847C SUBROUTINE POHISX(I,X)
31848
31849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31850 SAVE
31851
31852 RETURN
31853 END
31854
31855*$ CREATE PHO_LHIST.FOR
31856*COPY PHO_LHIST
31857*
31858*===poluhi=============================================================*
31859*
31860 SUBROUTINE PHO_LHIST(I,X)
31861
31862**
31863
31864 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31865 SAVE
31866
31867 RETURN
31868 END
31869
31870*$ CREATE PDFSET.FOR
31871*COPY PDFSET
31872*
31873C**********************************************************************
31874C
31875C dummy subroutines, remove to link PDFLIB
31876C
31877C**********************************************************************
31878 SUBROUTINE PDFSET(PARAM,VALUE)
31879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31880 DIMENSION PARAM(20),VALUE(20)
31881 CHARACTER*20 PARAM
31882 END
31883
31884*$ CREATE STRUCTM.FOR
31885*COPY STRUCTM
31886*
31887 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31889 END
31890
31891*$ CREATE STRUCTP.FOR
31892*COPY STRUCTP
31893*
31894 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31895 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31896 END
31897
31898*$ CREATE DT_DIQBRK.FOR
31899*COPY DT_DIQBRK
31900*
31901*===diqbrk=============================================================*
31902*
31903 SUBROUTINE DT_XIQBRK
31904C SUBROUTINE DT_DIQBRK
31905
31906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31907 SAVE
31908
31909 STOP 'diquark-breaking not implemeted !'
31910
31911 RETURN
31912 END
31913*$ CREATE DT_ELHAIN.FOR
31914*COPY DT_ELHAIN
31915*
31916*===elhain=============================================================*
31917*
31918 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31919
31920************************************************************************
31921* Elastic hadron-hadron scattering. *
31922* This is a revised version of the original. *
31923* This version dated 03.04.98 is written by S. Roesler *
31924************************************************************************
31925
31926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31927 SAVE
31928
31929 PARAMETER ( LINP = 10 ,
31930 & LOUT = 6 ,
31931 & LDAT = 9 )
31932
31933 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31934 & TINY10=1.0D-10)
31935
31936 PARAMETER (ENNTHR = 3.5D0)
31937 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31938 & BLOWB=0.05D0,BHIB=0.2D0,
31939 & BLOWM=0.1D0, BHIM=2.0D0)
31940
31941* particle properties (BAMJET index convention)
31942 CHARACTER*8 ANAME
31943 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31944 & IICH(210),IIBAR(210),K1(210),K2(210)
31945
31946* final state from HADRIN interaction
31947 PARAMETER (MAXFIN=10)
31948 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31949 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31950
31951C DATA TSLOPE /10.0D0/
31952
31953 IREJ = 0
31954
31955 1 CONTINUE
31956
31957 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31958 EKIN = ELAB-AAM(IP)
31959* kinematical quantities in cms of the hadrons
31960 AMP2 = AAM(IP)**2
31961 AMT2 = AAM(IT)**2
31962 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31963 ECM = SQRT(S)
31964 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31965 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31966
31967* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31968 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31969 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31970* TSAMCS treats pp and np only, therefore change pn into np and
31971* nn into pp
31972 IF (IT.EQ.1) THEN
31973 KPROJ = IP
31974 ELSE
31975 KPROJ = 8
31976 IF (IP.EQ.8) KPROJ = 1
31977 ENDIF
31978 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
31979 T = TWO*PCM**2*(CTCMS-ONE)
31980
31981* very crude treatment otherwise: sample t from exponential dist.
31982 ELSE
31983* momentum transfer t
31984 TMAX = TWO*TWO*PCM**2
31985 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
31986 IF (IIBAR(IP).NE.0) THEN
31987 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
31988 ELSE
31989 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
31990 ENDIF
31991 FMAX = EXP(-TSLOPE*TMAX)-ONE
31992 R = DT_RNDM(RR)
31993 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
31994 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
31995 ENDIF
31996
31997* target hadron in Lab after scattering
31998 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
31999 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32000 IF (PLRH(2).LE.TINY10) THEN
32001C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32002 GOTO 1
32003 ENDIF
32004* projectile hadron in Lab after scattering
32005 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32006 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32007* scattering angle of projectile in Lab
32008 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32009 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32010 CALL DT_DSFECF(SPLABP,CPLABP)
32011* direction cosines of projectile in Lab
32012 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32013 & CXRH(1),CYRH(1),CZRH(1))
32014* scattering angle of target in Lab
32015 PLLABT = PLAB-CTLABP*PLRH(1)
32016 CTLABT = PLLABT/PLRH(2)
32017 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32018* direction cosines of target in Lab
32019 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32020 & CXRH(2),CYRH(2),CZRH(2))
32021* fill /HNFSPA/
32022 IRH = 2
32023 ITRH(1) = IP
32024 ITRH(2) = IT
32025
32026 RETURN
32027 END
32028
32029*$ CREATE DT_TSAMCS.FOR
32030*COPY DT_TSAMCS
32031*
32032*===tsamcs=============================================================*
32033*
32034 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32035
32036************************************************************************
32037* Sampling of cos(theta) for nucleon-proton scattering according to *
32038* hetkfa2/bertini parametrization. *
32039* This is a revised version of the original (HJM 24/10/88) *
32040* This version dated 28.10.95 is written by S. Roesler *
32041************************************************************************
32042
32043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32044 SAVE
32045
32046 PARAMETER ( LINP = 10 ,
32047 & LOUT = 6 ,
32048 & LDAT = 9 )
32049
32050 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32051 & TINY10=1.0D-10)
32052
32053 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32054 DIMENSION PDCI(60),PDCH(55)
32055
32056 DATA (DCLIN(I),I=1,80) /
32057 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32058 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32059 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32060 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32061 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32062 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32063 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32064 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32065 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32066 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32067 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32068 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32069 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32070 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32071 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32072 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32073 DATA (DCLIN(I),I=81,160) /
32074 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32075 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32076 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32077 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32078 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32079 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32080 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32081 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32082 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32083 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32084 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32085 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32086 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32087 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32088 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32089 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32090 DATA (DCLIN(I),I=161,195) /
32091 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32092 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32093 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32094 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32095 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32096 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32097 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32098
32099 DATA PDCI /
32100 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32101 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32102 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32103 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32104 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32105 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32106 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32107 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32108 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32109 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32110 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32111 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32112
32113 DATA PDCH /
32114 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32115 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32116 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32117 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32118 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32119 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32120 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32121 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32122 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32123 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32124 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32125
32126 DATA (DCHN(I),I=1,90) /
32127 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32128 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32129 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32130 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32131 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32132 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32133 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32134 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32135 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32136 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32137 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32138 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32139 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32140 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32141 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32142 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32143 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32144 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32145 DATA (DCHN(I),I=91,143) /
32146 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32147 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32148 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32149 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32150 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32151 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32152 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32153 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32154 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32155 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32156 & 6.488D-02, 6.485D-02, 6.480D-02/
32157
32158 DATA DCHNA /
32159 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32160 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32161 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32162 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32163 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32164 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32165 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32166 & 1.000D+00/
32167
32168 DATA DCHNB /
32169 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32170 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32171 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32172 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32173 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32174 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32175 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32176 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32177 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32178 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32179 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32180 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32181
32182 CST = ONE
32183 IF (EKIN.GT.3.5D0) RETURN
32184C
32185 IF(KPROJ.EQ.8) GOTO 101
32186 IF(KPROJ.EQ.1) GOTO 102
32187C* INVALID REACTION
32188 WRITE(LOUT,'(A,I5/A)')
32189 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32190 & ' COS(THETA) = 1D0 RETURNED'
32191 RETURN
32192C-------------------------------- NP ELASTIC SCATTERING----------
32193101 CONTINUE
32194 IF (EKIN.GT.0.740D0)GOTO 1000
32195 IF (EKIN.LT.0.300D0)THEN
32196C EKIN .LT. 300 MEV
32197 IDAT=1
32198 ELSE
32199C 300 MEV < EKIN < 740 MEV
32200 IDAT=6
32201 END IF
32202C
32203 ENER=EKIN
32204 IE=INT(ABS(ENER/0.020D0))
32205 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32206C FORWARD/BACKWARD DECISION
32207 K=IDAT+5*IE
32208 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32209 IF (DT_RNDM(CST).LT.BWFW)THEN
32210 VALUE2=-1D0
32211 K=K+1
32212 ELSE
32213 VALUE2=1D0
32214 K=K+3
32215 END IF
32216C
32217 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32218 RND=DT_RNDM(COEF)
32219C
32220 IF(RND.LT.COEF)THEN
32221 CST=DT_RNDM(RND)
32222 CST=CST*VALUE2
32223 ELSE
32224 R1=DT_RNDM(CST)
32225 R2=DT_RNDM(R1)
32226 R3=DT_RNDM(R2)
32227 R4=DT_RNDM(R3)
32228C
32229 IF(VALUE2.GT.0.0)THEN
32230 CST=MAX(R1,R2,R3,R4)
32231 GOTO 1500
32232 ELSE
32233 R5=DT_RNDM(R4)
32234C
32235 IF (IDAT.EQ.1)THEN
32236 CST=-MAX(R1,R2,R3,R4,R5)
32237 ELSE
32238 R6=DT_RNDM(R5)
32239 R7=DT_RNDM(R6)
32240 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32241 END IF
32242C
32243 END IF
32244C
32245 END IF
32246C
32247 GOTO 1500
32248C
32249C******** EKIN .GT. 0.74 GEV
32250C
322511000 ENER=EKIN - 0.66D0
32252C IE=ABS(ENER/0.02)
32253 IE=INT(ENER/0.02D0)
32254 EMEV=EKIN*1D3
32255C
32256 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32257 K=IE
32258 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32259 RND=DT_RNDM(BWFW)
32260C FORWARD NEUTRON
32261 IF (RND.GE.BWFW)THEN
32262 DO 1200 K=10,36,9
32263 IF (DCHNA(K).GT.EMEV) THEN
32264 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32265 UNIV=DT_RNDM(UNIVE)
32266 DO 1100 I=1,8
32267 II=K+I
32268 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32269C
32270 IF (P.GT.UNIV)THEN
32271 UNIV=DT_RNDM(UNIVE)
32272 FLTI=DBLE(I)-UNIV
32273 GOTO(290,290,290,290,330,340,350,360) I
32274 END IF
32275 1100 CONTINUE
32276 END IF
32277 1200 CONTINUE
32278C
32279 ELSE
32280C BACKWARD NEUTRON
32281 DO 1400 K=13,60,12
32282 IF (DCHNB(K).GT.EMEV) THEN
32283 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32284 UNIV=DT_RNDM(UNIVE)
32285 DO 1300 I=1,11
32286 II=K+I
32287 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32288C
32289 IF (P.GT.UNIV)THEN
32290 UNIV=DT_RNDM(P)
32291 FLTI=DBLE(I)-UNIV
32292 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32293 END IF
32294 1300 CONTINUE
32295 END IF
32296 1400 CONTINUE
32297 END IF
32298C
32299120 CST=1.0D-2*FLTI-1.0D0
32300 GOTO 1500
32301140 CST=2.0D-2*UNIV-0.98D0
32302 GOTO 1500
32303150 CST=4.0D-2*UNIV-0.96D0
32304 GOTO 1500
32305160 CST=6.0D-2*FLTI-1.16D0
32306 GOTO 1500
32307180 CST=8.0D-2*UNIV-0.80D0
32308 GOTO 1500
32309190 CST=1.0D-1*UNIV-0.72D0
32310 GOTO 1500
32311200 CST=1.2D-1*UNIV-0.62D0
32312 GOTO 1500
32313210 CST=2.0D-1*UNIV-0.50D0
32314 GOTO 1500
32315220 CST=3.0D-1*(UNIV-1.0D0)
32316 GOTO 1500
32317C
32318290 CST=1.0D0-2.5d-2*FLTI
32319 GOTO 1500
32320330 CST=0.85D0+0.5D-1*UNIV
32321 GOTO 1500
32322340 CST=0.70D0+1.5D-1*UNIV
32323 GOTO 1500
32324350 CST=0.50D0+2.0D-1*UNIV
32325 GOTO 1500
32326360 CST=0.50D0*UNIV
32327C
323281500 RETURN
32329C
32330C----------------------------------- PP ELASTIC SCATTERING -------
32331C
32332 102 CONTINUE
32333 EMEV=EKIN*1D3
32334C
32335 IF (EKIN.LE.0.500D0) THEN
32336 RND=DT_RNDM(EMEV)
32337 CST=2.0D0*RND-1.0D0
32338 RETURN
32339C
32340 ELSEIF (EKIN.LT.1.0D0) THEN
32341 DO 2200 K=13,60,12
32342 IF (PDCI(K).GT.EMEV) THEN
32343 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32344 UNIV=DT_RNDM(UNIVE)
32345 SUM=0
32346 DO 2100 I=1,11
32347 II=K+I
32348 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32349C
32350 IF (UNIV.LT.SUM)THEN
32351 UNIV=DT_RNDM(SUM)
32352 FLTI=DBLE(I)-UNIV
32353 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32354 END IF
32355 2100 CONTINUE
32356 END IF
32357 2200 CONTINUE
32358 ELSE
32359 DO 2400 K=12,55,11
32360 IF (PDCH(K).GT.EMEV) THEN
32361 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32362 UNIV=DT_RNDM(UNIVE)
32363 SUM=0.0D0
32364 DO 2300 I=1,10
32365 II=K+I
32366 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32367C
32368 IF (UNIV.LT.SUM)THEN
32369 UNIV=DT_RNDM(SUM)
32370 FLTI=UNIV+DBLE(I)
32371 GOTO(50,55,60,60,65,65,65,65,70,70) I
32372 END IF
32373 2300 CONTINUE
32374 END IF
32375 2400 CONTINUE
32376 END IF
32377C
3237850 CST=0.4D0*UNIV
32379 GOTO 2500
3238055 CST=0.2D0*FLTI
32381 GOTO 2500
3238260 CST=0.3D0+0.1D0*FLTI
32383 GOTO 2500
3238465 CST=0.6D0+0.04D0*FLTI
32385 GOTO 2500
3238670 CST=0.78D0+0.02D0*FLTI
32387C
323882500 CONTINUE
32389 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32390C
32391 RETURN
32392 END
32393
32394*$ CREATE DT_DHADRI.FOR
32395*COPY DT_DHADRI
32396*
32397*===dhadri=============================================================*
32398*
32399 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32400
32401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32402 SAVE
32403
32404 PARAMETER ( LINP = 10 ,
32405 & LOUT = 6 ,
32406 & LDAT = 9 )
32407
32408C
32409C-----------------------------
32410C*** INPUT VARIABLES LIST:
32411C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32412C*** GEV/C LABORATORY MOMENTUM REGION
32413C*** N - PROJECTILE HADRON INDEX
32414C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32415C*** ELAB - LABORATORY ENERGY OF N (GEV)
32416C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32417C*** ITTA - TARGET NUCLEON INDEX
32418C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32419C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32420C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32421C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32422C*** RESPECT., UNITS (GEV/C AND GEV)
32423C----------------------------
32424
32425 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32426
32427 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32428
32429 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32430 & NRK(2,268),NURE(30,2)
32431
32432* particle properties (BAMJET index convention),
32433* (dublicate of DTPART for HADRIN)
32434 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32435 & K1H(110),K2H(110)
32436
32437 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32438
32439 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32440 & ITS(149),IS
32441
32442 COMMON /HNDRUN/ RUNTES,EFTES
32443
32444* particle properties (BAMJET index convention)
32445 CHARACTER*8 ANAME
32446 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32447 & IICH(210),IIBAR(210),K1(210),K2(210)
32448
32449* final state from HADRIN interaction
32450 PARAMETER (MAXFIN=10)
32451 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32452 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32453
32454 DIMENSION ITPRF(110)
32455 DATA NNN/0/
32456 DATA UMODA/0./
32457 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32458 LOWP=0
32459 IF (N.LE.0.OR.N.GE.111)N=1
32460 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32461 GOTO 280
32462* WRITE (6,1000)
32463* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32464* STOP
32465*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32466* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32467 ENDIF
32468 IATMPT=0
32469 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32470C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32471C STOP
32472 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32473 + ALLOWED REGION, PLAB=',1E15.5)
32474
32475 20 CONTINUE
32476 UMODAT=N*1.11111D0+ITTA*2.19291D0
32477 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32478 UMODA=UMODAT
32479 30 IATMPT=0
32480 LOWP=LOWP+1
32481 40 CONTINUE
32482 IMACH=0
32483 REDU=2.0D0
32484 IF (LOWP.GT.20) THEN
32485C WRITE(LOUT,*) ' jump 1'
32486 GO TO 280
32487 ENDIF
32488 NNN=N
32489 IF (NNN.EQ.N) GO TO 50
32490 RUNTES=0.0D0
32491 EFTES=0.0D0
32492 50 CONTINUE
32493 IS=1
32494 IRH=0
32495 IST=1
32496 NSTAB=23
32497 IRE=NURE(N,1)
32498 IF(ITTA.GT.1) IRE=NURE(N,2)
32499C
32500C-----------------------------
32501C*** IE,AMT,ECM,SI DETERMINATION
32502C----------------------------
32503 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32504 IANTH=-1
32505**sr
32506C IF (AMH(1).NE.0.93828D0) IANTH=1
32507 IF (AMH(1).NE.0.9383D0) IANTH=1
32508**
32509 IF (IANTH.GE.0) SI=1.0D0
32510 ECMMH=ECM
32511C
32512C-----------------------------
32513C ENERGY INDEX
32514C IRE CHARACTERIZES THE REACTION
32515C IE IS THE ENERGY INDEX
32516C----------------------------
32517 IF (SI.LT.1.D-6) THEN
32518C WRITE(LOUT,*) ' jump 2'
32519 GO TO 280
32520 ENDIF
32521 IF (N.LE.NSTAB) GO TO 60
32522 RUNTES=RUNTES+1.0D0
32523 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32524 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32525 IF(IBARH(N).EQ.1) N=8
32526 IF(IBARH(N).EQ.-1) N=9
32527 60 CONTINUE
32528 IMACH=IMACH+1
32529**sr 19.2.97: loop for direct channel suppression
32530C IF (IMACH.GT.10) THEN
32531 IF (IMACH.GT.1000) THEN
32532**
32533C WRITE(LOUT,*) ' jump 3'
32534 GO TO 280
32535 ENDIF
32536 ECM =ECMMH
32537 AMN2=AMN**2
32538 AMT2=AMT**2
32539 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32540 IF(ECMN.LE.AMN) ECMN=AMN
32541 PCMN=SQRT(ECMN**2-AMN2)
32542 GAM=(ELAB+AMT)/ECM
32543 BGAM=PLAB/ECM
32544 IF (IANTH.GE.0) ECM=2.1D0
32545C
32546C-----------------------------
32547C*** RANDOM CHOICE OF REACTION CHANNEL
32548C----------------------------
32549 IST=0
32550 VV=DT_RNDM(AMN2)
32551 VV=VV-1.D-17
32552C
32553C-----------------------------
32554C*** PLACE REDUCED VERSION
32555C----------------------------
32556 IIEI=IEII(IRE)
32557 IDWK=IEII(IRE+1)-IIEI
32558 IIWK=IRII(IRE)
32559 IIKI=IKII(IRE)
32560C
32561C-----------------------------
32562C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32563C----------------------------
32564 HECM=ECM
32565 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32566 IF (HUMO.LT.ECM) ECM=HUMO
32567C
32568C-----------------------------
32569C*** INTERPOLATION PREPARATION
32570C----------------------------
32571 ECMO=UMO(IE)
32572 ECM1=UMO(IE-1)
32573 DECM=ECMO-ECM1
32574 DEC=ECMO-ECM
32575C
32576C-----------------------------
32577C*** RANDOM LOOP
32578C----------------------------
32579 IK=0
32580 WKK=0.0D0
32581 WICOR=0.0D0
32582 70 IK=IK+1
32583 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32584 WOK=WK(IWK)
32585 WDK=WOK-WK(IWK-1)
32586C
32587C-----------------------------
32588C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32589C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32590C CONTRIBUTE
32591C----------------------------
32592 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32593 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32594 IF (WICO.EQ.WICOR) GO TO 70
32595 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32596 WICOR=WICO
32597C
32598C-----------------------------
32599C*** INTERPOLATION IN CHANNEL WEIGHTS
32600C----------------------------
32601 EKLIM=-THRESH(IIKI+IK)
32602 IELIM=IDT_IEFUND(EKLIM,IRE)
32603 DELIM=UMO(IELIM)+EKLIM
32604 *+1.D-16
32605 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32606 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32607 80 DECC=DELIM
32608 GO TO 100
32609 90 DECC=DECM
32610 100 CONTINUE
32611 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32612C
32613C-----------------------------
32614C*** RANDOM CHOICE
32615C----------------------------
32616C
32617 IF (VV.GT.WKK) GO TO 70
32618C
32619C***IK IS THE REACTION CHANNEL
32620C----------------------------
32621 INRK=IKII(IRE)+IK
32622 ECM=HECM
32623 I1001 =0
32624C
32625 110 CONTINUE
32626 IT1=NRK(1,INRK)
32627 AM1=DT_DAMG(IT1)
32628 IT2=NRK(2,INRK)
32629 AM2=DT_DAMG(IT2)
32630 AMS=AM1+AM2
32631 I1001=I1001+1
32632 IF (I1001.GT.50) GO TO 60
32633C
32634 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32635 IT11=IT1
32636 IT22=IT2
32637 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32638 AM11=AM1
32639 AM22=AM2
32640 IF (IT2.GT.0) GO TO 120
32641**sr 19.2.97: supress direct channel for pp-collisions
32642 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32643 RR = DT_RNDM(AM11)
32644 IF (RR.LE.0.75D0) GOTO 60
32645 ENDIF
32646**
32647C
32648C-----------------------------
32649C INCLUSION OF DIRECT RESONANCES
32650C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32651C------------------------
32652 KZ1=K1H(IT1)
32653 IST=IST+1
32654 IECO=0
32655 ECO=ECM
32656 GAM=(ELAB+AMT)/ECO
32657 BGAM=PLAB/ECO
32658 CXS(1)=CX
32659 CYS(1)=CY
32660 CZS(1)=CZ
32661 GO TO 170
32662 120 CONTINUE
32663 WW=DT_RNDM(ECO)
32664 IF(WW.LT. 0.5D0) GO TO 130
32665 IT1=IT22
32666 IT2=IT11
32667 AM1=AM22
32668 AM2=AM11
32669 130 CONTINUE
32670C
32671C-----------------------------
32672C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32673 IBN=IBARH(N)
32674 IB1=IBARH(IT1)
32675 IT11=IT1
32676 IT22=IT2
32677 AM11=AM1
32678 AM22=AM2
32679 IF(IB1.EQ.IBN) GO TO 140
32680 IT1=IT22
32681 IT2=IT11
32682 AM1=AM22
32683 AM2=AM11
32684 140 CONTINUE
32685C-----------------------------
32686C***IT1,IT2 ARE THE CREATED PARTICLES
32687C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32688C------------------------
32689 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32690 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32691 IST=IST+1
32692 ITS(IST)=IT1
32693 AMM(IST)=AM1
32694C
32695C-----------------------------
32696C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32697C----------------------------
32698 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32699 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32700 IST=IST+1
32701 ITS(IST)=IT2
32702 AMM(IST)=AM2
32703 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32704 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32705 150 CONTINUE
32706C
32707C-----------------------------
32708C***TEST STABLE OR UNSTABLE
32709C----------------------------
32710 IF(ITS(IST).GT.NSTAB) GO TO 160
32711 IRH=IRH+1
32712C
32713C-----------------------------
32714C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32715C----------------------------
32716C* IF (REDU.LT.0.D0) GO TO 1009
32717 ITRH(IRH)=ITS(IST)
32718 PLRH(IRH)=PLS(IST)
32719 CXRH(IRH)=CXS(IST)
32720 CYRH(IRH)=CYS(IST)
32721 CZRH(IRH)=CZS(IST)
32722 ELRH(IRH)=ELS(IST)
32723 IST=IST-1
32724 IF(IST.GE.1) GO TO 150
32725 GO TO 260
32726 160 CONTINUE
32727C
32728C RANDOM CHOICE OF DECAY CHANNELS
32729C----------------------------
32730C
32731 IT=ITS(IST)
32732 ECO=AMM(IST)
32733 GAM=ELS(IST)/ECO
32734 BGAM=PLS(IST)/ECO
32735 IECO=0
32736 KZ1=K1H(IT)
32737 170 CONTINUE
32738 IECO=IECO+1
32739 VV=DT_RNDM(GAM)
32740 VV=VV-1.D-17
32741 IIK=KZ1-1
32742 180 IIK=IIK+1
32743 IF (VV.GT.WTI(IIK)) GO TO 180
32744C
32745C IIK IS THE DECAY CHANNEL
32746C----------------------------
32747 IT1=NZKI(IIK,1)
32748 I310=0
32749 190 CONTINUE
32750 I310=I310+1
32751 AM1=DT_DAMG(IT1)
32752 IT2=NZKI(IIK,2)
32753 AM2=DT_DAMG(IT2)
32754 IF (IT2-1.LT.0) GO TO 240
32755 IT3=NZKI(IIK,3)
32756 AM3=DT_DAMG(IT3)
32757 AMS=AM1+AM2+AM3
32758C
32759C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32760C----------------------------
32761 IF (IECO.LE.10) GO TO 200
32762 IATMPT=IATMPT+1
32763 IF(IATMPT.GT.3) THEN
32764C WRITE(LOUT,*) ' jump 4'
32765 GO TO 280
32766 ENDIF
32767 GO TO 40
32768 200 CONTINUE
32769 IF (I310.GT.50) GO TO 170
32770 IF (AMS.GT.ECO) GO TO 190
32771C
32772C FOR THE DECAY CHANNEL
32773C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32774C----------------------------
32775 IF (REDU.LT.0.D0) GO TO 30
32776 ITWTHC=0
32777 REDU=2.0D0
32778 IF(IT3.EQ.0) GO TO 220
32779 210 CONTINUE
32780 ITWTH=1
32781 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32782 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32783 GO TO 230
32784 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32785 &COD2,COF2,SIF2,AM1,AM2)
32786 ITWTH=-1
32787 IT3=0
32788 230 CONTINUE
32789 ITWTHC=ITWTHC+1
32790 IF (REDU.GT.0.D0) GO TO 240
32791 REDU=2.0D0
32792 IF (ITWTHC.GT.100) GO TO 30
32793 IF (ITWTH) 220,220,210
32794 240 CONTINUE
32795 ITS(IST )=IT1
32796 IF (IT2-1.LT.0) GO TO 250
32797 ITS(IST+1) =IT2
32798 ITS(IST+2)=IT3
32799 RX=CXS(IST)
32800 RY=CYS(IST)
32801 RZ=CZS(IST)
32802 AMM(IST)=AM1
32803 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32804 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32805 IST=IST+1
32806 AMM(IST)=AM2
32807 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32808 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32809 IF (IT3.LE.0) GO TO 250
32810 IST=IST+1
32811 AMM(IST)=AM3
32812 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32813 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32814 250 CONTINUE
32815 GO TO 150
32816 260 CONTINUE
32817 270 CONTINUE
32818 RETURN
32819 280 CONTINUE
32820C
32821C----------------------------
32822C
32823C ZERO CROSS SECTION CASE
32824C----------------------------
32825C
32826 IRH=1
32827 ITRH(1)=N
32828 CXRH(1)=CX
32829 CYRH(1)=CY
32830 CZRH(1)=CZ
32831 ELRH(1)=ELAB
32832 PLRH(1)=PLAB
32833 RETURN
32834 END
32835
32836*$ CREATE DT_RUNTT.FOR
32837*COPY DT_RUNTT
32838*
32839*===runtt==============================================================*
32840*
32841 BLOCK DATA DT_RUNTT
32842
32843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32844 SAVE
32845
32846 COMMON /HNDRUN/ RUNTES,EFTES
32847
32848 DATA RUNTES,EFTES /100.D0,100.D0/
32849
32850 END
32851
32852*$ CREATE DT_NONAME.FOR
32853*COPY DT_NONAME
32854*
32855*===noname=============================================================*
32856*
32857 BLOCK DATA DT_NONAME
32858
32859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32860 SAVE
32861
32862* slope parameters for HADRIN interactions
32863 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32864
32865 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32866
32867C DATAS DATAS DATAS DATAS DATAS
32868C****** *********
32869 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32870 & 207, 224, 241, 252, 268 /
32871 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32872 & 220, 241, 262, 279, 296 /
32873 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32874 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32875
32876C
32877C MASSES FOR THE SLOPE B(M) IN GEV
32878C SLOPE B(M) FOR AN MESONIC SYSTEM
32879C SLOPE B(M) FOR A BARYONIC SYSTEM
32880
32881*
32882 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32883 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32884 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32885 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32886 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32887 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32888 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32889 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32890 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32891 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32892 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32893 & 14.2D0, 13.4D0, 12.6D0,
32894 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32895 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32896*
32897 END
32898
32899*$ CREATE DT_DAMG.FOR
32900*COPY DT_DAMG
32901*
32902*===damg===============================================================*
32903*
32904 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32905
32906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32907 SAVE
32908
32909* particle properties (BAMJET index convention),
32910* (dublicate of DTPART for HADRIN)
32911 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32912 & K1H(110),K2H(110)
32913
32914 DIMENSION GASUNI(14)
32915 DATA GASUNI/
32916 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32917 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32918 DATA GAUNO/2.352D0/
32919 DATA GAUNON/2.4D0/
32920 DATA IO/14/
32921 DATA NSTAB/23/
32922
32923 I=1
32924 IF (IT.LE.0) GO TO 30
32925 IF (IT.LE.NSTAB) GO TO 20
32926 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32927 VV=DT_RNDM(DGAUNI)
32928 VV=VV*2.0D0-1.0D0+1.D-16
32929 10 CONTINUE
32930 VO=GASUNI(I)
32931 I=I+1
32932 V1=GASUNI(I)
32933 IF (VV.GT.V1) GO TO 10
32934 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32935 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32936 DAM=GAH(IT)*UNIGA/GAUNO
32937 AAM=AMH(IT)+DAM
32938 DT_DAMG=AAM
32939 RETURN
32940 20 CONTINUE
32941 DT_DAMG=AMH(IT)
32942 RETURN
32943 30 CONTINUE
32944 DT_DAMG=0.0D0
32945 RETURN
32946 END
32947
32948*$ CREATE DT_DCALUM.FOR
32949*COPY DT_DCALUM
32950*
32951*===dcalum=============================================================*
32952*
32953 SUBROUTINE DT_DCALUM(N,ITTA)
32954
32955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32956 SAVE
32957
32958C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32959
32960* particle properties (BAMJET index convention),
32961* (dublicate of DTPART for HADRIN)
32962 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32963 & K1H(110),K2H(110)
32964
32965 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32966
32967 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32968
32969 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32970 & NRK(2,268),NURE(30,2)
32971
32972 IRE=NURE(N,ITTA/8+1)
32973 IEO=IEII(IRE)+1
32974 IEE=IEII(IRE +1)
32975 AM1=AMH(N )
32976 AM12=AM1**2
32977 AM2=AMH(ITTA)
32978 AM22=AM2**2
32979 DO 10 IE=IEO,IEE
32980 PLAB2=PLABF(IE)**2
32981 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
32982 UMO(IE)=ELAB
32983 10 CONTINUE
32984 IKO=IKII(IRE)+1
32985 IKE=IKII(IRE +1)
32986 UMOO=UMO(IEO)
32987 DO 30 IK=IKO,IKE
32988 IF(NRK(2,IK).GT.0) GO TO 30
32989 IKI=NRK(1,IK)
32990 AMSS=5.0D0
32991 K11=K1H(IKI)
32992 K22=K2H(IKI)
32993 DO 20 IK1=K11,K22
32994 IN=NZKI(IK1,1)
32995 AMS=AMH(IN)
32996 IN=NZKI(IK1,2)
32997 IF(IN.GT.0)AMS=AMS+AMH(IN)
32998 IN=NZKI(IK1,3)
32999 IF(IN.GT.0) AMS=AMS+AMH(IN)
33000 IF (AMS.LT.AMSS) AMSS=AMS
33001 20 CONTINUE
33002 IF(UMOO.LT.AMSS) UMOO=AMSS
33003 THRESH(IK)=UMOO
33004 30 CONTINUE
33005 RETURN
33006 END
33007
33008*$ CREATE DT_DCHANH.FOR
33009*COPY DT_DCHANH
33010*
33011*===dchanh=============================================================*
33012*
33013 SUBROUTINE DT_DCHANH
33014
33015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33016 SAVE
33017
33018 PARAMETER ( LINP = 10 ,
33019 & LOUT = 6 ,
33020 & LDAT = 9 )
33021
33022* particle properties (BAMJET index convention),
33023* (dublicate of DTPART for HADRIN)
33024 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33025 & K1H(110),K2H(110)
33026
33027 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33028
33029 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33030
33031 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33032 & NRK(2,268),NURE(30,2)
33033
33034 DIMENSION HWT(460),HWK(40),SI(5184)
33035 EQUIVALENCE (WK(1),SI(1))
33036C--------------------
33037C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33038C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33039C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33040C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33041C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33042C--------------------------
33043 IREG=16
33044 DO 90 IRE=1,IREG
33045 IWKO=IRII(IRE)
33046 IEE=IEII(IRE+1)-IEII(IRE)
33047 IKE=IKII(IRE+1)-IKII(IRE)
33048 IEO=IEII(IRE)+1
33049 IIKA=IKII(IRE)
33050* modifications to suppress elestic scattering 24/07/91
33051 DO 80 IE=1,IEE
33052 SIS=1.D-14
33053 SINORC=0.0D0
33054 DO 10 IK=1,IKE
33055 IWK=IWKO+IEE*(IK-1)+IE
33056 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33057 SIS=SIS+SI(IWK)*SINORC
33058 10 CONTINUE
33059 SIIN(IEO+IE-1)=SIS
33060 SIO=0.D0
33061 IF (SIS.GE.1.D-12) GO TO 20
33062 SIS=1.D0
33063 SIO=1.D0
33064 20 CONTINUE
33065 SINORC=0.0D0
33066 DO 30 IK=1,IKE
33067 IWK=IWKO+IEE*(IK-1)+IE
33068 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33069 SIO=SIO+SI(IWK)*SINORC/SIS
33070 HWK(IK)=SIO
33071 30 CONTINUE
33072 DO 40 IK=1,IKE
33073 IWK=IWKO+IEE*(IK-1)+IE
33074 40 WK(IWK)=HWK(IK)
33075 IIKI=IKII(IRE)
33076 DO 70 IK=1,IKE
33077 AM111=0.D0
33078 INRK1=NRK(1,IIKI+IK)
33079 IF (INRK1.GT.0) AM111=AMH(INRK1)
33080 AM222=0.D0
33081 INRK2=NRK(2,IIKI+IK)
33082 IF (INRK2.GT.0) AM222=AMH(INRK2)
33083 THRESH(IIKI+IK)=AM111 +AM222
33084 IF (INRK2-1.GE.0) GO TO 60
33085 INRKK=K1H(INRK1)
33086 AMSS=5.D0
33087 INRKO=K2H(INRK1)
33088 DO 50 INRK1=INRKK,INRKO
33089 INZK1=NZKI(INRK1,1)
33090 INZK2=NZKI(INRK1,2)
33091 INZK3=NZKI(INRK1,3)
33092 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33093 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33094 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33095C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33096 1000 FORMAT (4I10)
33097 AMS=AMH(INZK1)+AMH(INZK2)
33098 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33099 IF (AMSS.GT.AMS) AMSS=AMS
33100 50 CONTINUE
33101 AMS=AMSS
33102 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33103 THRESH(IIKI+IK)=AMS
33104 60 CONTINUE
33105 70 CONTINUE
33106 80 CONTINUE
33107 90 CONTINUE
33108 DO 100 J=1,460
33109 100 HWT(J)=0.D0
33110 DO 120 I=1,110
33111 IK1=K1H(I)
33112 IK2=K2H(I)
33113 HV=0.D0
33114 IF (IK2.GT.460)IK2=460
33115 IF (IK1.LE.0)IK1=1
33116 DO 110 J=IK1,IK2
33117 HV=HV+WTI(J)
33118 HWT(J)=HV
33119 JI=J
33120 110 CONTINUE
33121 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33122 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33123 120 CONTINUE
33124 DO 130 J=1,460
33125 130 WTI(J)=HWT(J)
33126 RETURN
33127 END
33128
33129*$ CREATE DT_DHADDE.FOR
33130*COPY DT_DHADDE
33131*
33132*===dhadde=============================================================*
33133*
33134 SUBROUTINE DT_DHADDE
33135
33136 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33137 SAVE
33138
33139* particle properties (BAMJET index convention)
33140 CHARACTER*8 ANAME
33141 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33142 & IICH(210),IIBAR(210),K1(210),K2(210)
33143
33144* HADRIN: decay channel information
33145 PARAMETER (IDMAX9=602)
33146 CHARACTER*8 ZKNAME
33147 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33148
33149* particle properties (BAMJET index convention),
33150* (dublicate of DTPART for HADRIN)
33151 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33152 & K1H(110),K2H(110)
33153
33154 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33155
33156* decay channel information for HADRIN
33157 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33158 & K1Z(16),K2Z(16),WTZ(153),II22,
33159 & NZK1(153),NZK2(153),NZK3(153)
33160
33161 DATA IRETUR/0/
33162
33163 IRETUR=IRETUR+1
33164 AMH(31)=0.48D0
33165 IF (IRETUR.GT.1) RETURN
33166 DO 10 I=1,94
33167 AMH(I) = AAM(I)
33168 GAH(I) = GA(I)
33169 TAUH(I) = TAU(I)
33170 ICHH(I) = IICH(I)
33171 IBARH(I) = IIBAR(I)
33172 K1H(I) = K1(I)
33173 K2H(I) = K2(I)
33174 10 CONTINUE
33175**sr
33176C AMH(1)=0.93828D0
33177 AMH(1)=0.9383D0
33178**
33179 AMH(2)=AMH(1)
33180 DO 20 I=26,30
33181 K1H(I)=452
33182 K2H(I)=452
33183 20 CONTINUE
33184 DO 30 I=1,307
33185 WTI(I) = WT(I)
33186 NZKI(I,1) = NZK(I,1)
33187 NZKI(I,2) = NZK(I,2)
33188 NZKI(I,3) = NZK(I,3)
33189 30 CONTINUE
33190 DO 40 I=1,16
33191 L=I+94
33192 AMH(L)=AMZ(I)
33193 GAH( L)=GAZ(I)
33194 TAUH( L)=TAUZ(I)
33195 ICHH( L)=ICHZ(I)
33196 IBARH( L)=IBARZ(I)
33197 K1H( L)=K1Z(I)
33198 K2H( L)=K2Z(I)
33199 40 CONTINUE
33200 DO 50 I=1,153
33201 L=I+307
33202 WTI(L) = WTZ(I)
33203 NZKI(L,3) = NZK3(I)
33204 NZKI(L,2) = NZK2(I)
33205 NZKI(L,1) = NZK1(I)
33206 50 CONTINUE
33207 RETURN
33208 END
33209
33210*$ CREATE IDT_IEFUND.FOR
33211*COPY IDT_IEFUND
33212*
33213*===iefund=============================================================*
33214*
33215 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33216
33217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33218 SAVE
33219
33220C*****IEFUN CALCULATES A MOMENTUM INDEX
33221
33222 PARAMETER ( LINP = 10 ,
33223 & LOUT = 6 ,
33224 & LDAT = 9 )
33225
33226 COMMON /HNDRUN/ RUNTES,EFTES
33227
33228 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33229
33230 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33231 & NRK(2,268),NURE(30,2)
33232
33233 IPLA=IEII(IRE)+1
33234 *+1
33235 IPLE=IEII(IRE+1)
33236 IF (PL.LT.0.) GO TO 30
33237 DO 10 I=IPLA,IPLE
33238 J=I-IPLA+1
33239 IF (PL.LE.PLABF(I)) GO TO 60
33240 10 CONTINUE
33241 I=IPLE
33242 IF ( EFTES.GT.40.D0) GO TO 20
33243 EFTES=EFTES+1.0D0
33244 WRITE(LOUT,1000)PL,J
33245 20 CONTINUE
33246 GO TO 70
33247 30 CONTINUE
33248 DO 40 I=IPLA,IPLE
33249 J=I-IPLA+1
33250 IF (-PL.LE.UMO(I)) GO TO 60
33251 40 CONTINUE
33252 I=IPLE
33253 IF ( EFTES.GT.40.D0) GO TO 50
33254 EFTES=EFTES+1.0D0
33255 WRITE(LOUT,1000)PL,I
33256 50 CONTINUE
33257 60 CONTINUE
33258 70 CONTINUE
33259 IDT_IEFUND=I
33260 RETURN
33261 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33262 +7H IEFUN=,I5)
33263 END
33264
33265*$ CREATE DT_DSIGIN.FOR
33266*COPY DT_DSIGIN
33267*
33268*===dsigin=============================================================*
33269*
33270 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33271
33272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33273 SAVE
33274
33275* particle properties (BAMJET index convention),
33276* (dublicate of DTPART for HADRIN)
33277 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33278 & K1H(110),K2H(110)
33279
33280 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33281
33282 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33283 & NRK(2,268),NURE(30,2)
33284
33285 IE=IDT_IEFUND(PLAB,IRE)
33286 IF (IE.LE.IEII(IRE)) IE=IE+1
33287 AMT=AMH(ITAR)
33288 AMN=AMH(N)
33289 AMN2=AMN*AMN
33290 AMT2=AMT*AMT
33291 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33292C*** INTERPOLATION PREPARATION
33293 ECMO=UMO(IE)
33294 ECM1=UMO(IE-1)
33295 DECM=ECMO-ECM1
33296 DEC=ECMO-ECM
33297 IIKI=IKII(IRE)+1
33298 EKLIM=-THRESH(IIKI)
33299 WOK=SIIN(IE)
33300 WDK=WOK-SIIN(IE-1)
33301 IF (ECM.GT.ECMO) WDK=0.0D0
33302C*** INTERPOLATION IN CHANNEL WEIGHTS
33303 IELIM=IDT_IEFUND(EKLIM,IRE)
33304 DELIM=UMO(IELIM)+EKLIM
33305 *+1.D-16
33306 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33307 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33308 10 DECC=DELIM
33309 GO TO 30
33310 20 DECC=DECM
33311 30 CONTINUE
33312 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33313 IF (WKK.LT.0.0D0) WKK=0.0D0
33314 SI=WKK+1.D-12
33315 IF (-EKLIM.GT.ECM) SI=1.D-14
33316 RETURN
33317 END
33318
33319*$ CREATE DT_DTCHOI.FOR
33320*COPY DT_DTCHOI
33321*
33322*===dtchoi=============================================================*
33323*
33324 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33325
33326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33327 SAVE
33328
33329C ****************************
33330C TCHOIC CALCULATES A RANDOM VALUE
33331C FOR THE FOUR-MOMENTUM-TRANSFER T
33332C ****************************
33333
33334* particle properties (BAMJET index convention),
33335* (dublicate of DTPART for HADRIN)
33336 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33337 & K1H(110),K2H(110)
33338
33339* slope parameters for HADRIN interactions
33340 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33341
33342 AMA=AM1
33343 AMB=AM2
33344 IF (I.GT.30.AND.II.GT.30) GO TO 20
33345 III=II
33346 AM3=AM2
33347 IF (I.LE.30) GO TO 10
33348 III=I
33349 AM3=AM1
33350 10 CONTINUE
33351 GO TO 30
33352 20 CONTINUE
33353 III=II
33354 AM3=AM2
33355 IF (AMA.LE.AMB) GO TO 30
33356 III=I
33357 AM3=AM1
33358 30 CONTINUE
33359 IB=IBARH(III)
33360 AMA=AM3
33361 K=INT((AMA-0.75D0)/0.05D0)
33362 IF (K-2.LT.0) K=1
33363 IF (K-26.GE.0) K=25
33364 IF (IB)50,40,50
33365 40 BM=BBM(K)
33366 GO TO 60
33367 50 BM=BBB(K)
33368 60 CONTINUE
33369C NORMALIZATION
33370 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33371 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33372 VB=DT_RNDM(TMIN)
33373**sr test
33374C IF (VB.LT.0.2D0) BM=BM*0.1
33375C **0.5
33376 BM = BM*5.05D0
33377**
33378 TMI=BM*TMIN
33379 TMA=BM*TMAX
33380 ETMA=0.D0
33381 IF (ABS(TMA).GT.120.D0) GO TO 70
33382 ETMA=EXP(TMA)
33383 70 CONTINUE
33384 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33385C*** RANDOM CHOICE OF THE T - VALUE
33386 R=DT_RNDM(TMI)
33387 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33388 RETURN
33389 END
33390
33391*$ CREATE DT_DTWOPA.FOR
33392*COPY DT_DTWOPA
33393*
33394*===dtwopa=============================================================*
33395*
33396 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33397 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33398
33399 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33400 SAVE
33401
33402C ******************************************************
33403C QUASI TWO PARTICLE PRODUCTION
33404C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33405C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33406C IN THE CM - SYSTEM
33407C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33408C SPHERICAL COORDINATES
33409C ******************************************************
33410
33411* particle properties (BAMJET index convention),
33412* (dublicate of DTPART for HADRIN)
33413 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33414 & K1H(110),K2H(110)
33415
33416 AMA=AM1
33417 AMB=AM2
33418 AMA2=AMA*AMA
33419 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33420 E2=UMOO - E1
33421 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33422 AMTE=(E1-AMA)*(E1+AMA)
33423 AMTE=AMTE+1.D-18
33424 P1=SQRT(AMTE)
33425 P2=P1
33426C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33427C DETERMINATION OF THE ANGLES
33428C COS(THETA1)=COD1 COS(THETA2)=COD2
33429C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33430C COS(PHI1)=COF1 COS(PHI2)=COF2
33431C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33432 CALL DT_DSFECF(COF1,SIF1)
33433 COF2=-COF1
33434 SIF2=-SIF1
33435C CALCULATION OF THETA1
33436 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33437 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33438 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33439 COD2=-COD1
33440 RETURN
33441 END
33442
33443*$ CREATE DT_ZK.FOR
33444*COPY DT_ZK
33445*
33446*===zk=================================================================*
33447*
33448 BLOCK DATA DT_ZK
33449
33450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33451 SAVE
33452
33453* decay channel information for HADRIN
33454 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33455 & K1Z(16),K2Z(16),WTZ(153),II22,
33456 & NZK1(153),NZK2(153),NZK3(153)
33457
33458* decay channel information for HADRIN
33459 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33460 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33461
33462* Particle masses in GeV *
33463 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33464 & 2*1.7D0, 3*0.D0/
33465* Resonance width Gamma in GeV *
33466 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33467* Mean life time in seconds *
33468 DATA TAUZ / 16*0.D0 /
33469* Charge of particles and resonances *
33470 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33471* Baryonic charge *
33472 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33473* First number of decay channels used for resonances *
33474* and decaying particles *
33475 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33476 & 3*460/
33477* Last number of decay channels used for resonances *
33478* and decaying particles *
33479 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33480 & 3*460/
33481* Weight of decay channel *
33482 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33483 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33484 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33485 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33486 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33487 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33488 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33489 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33490 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33491 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33492 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33493 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33494 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33495 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33496 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33497 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33498 & .05D0, .65D0, 9*1.D0 /
33499* Particle numbers in decay channel *
33500 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33501 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33502 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33503 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33504 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33505 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33506 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33507 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33508 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33509 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33510 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33511 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33512 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33513 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33514 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33515 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33516 & 1, 8, 1, 8, 1, 9*0 /
33517 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33518 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33519 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33520 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33521 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33522 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33523* Particle names *
33524 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33525 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33526 & 3*'BLANK' /
33527* Name of decay channel *
33528 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33529 & 'ANNPI0','APPPI0','ANPPI-'/
33530 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33531 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33532 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33533 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33534 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33535 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33536 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33537 & 'OMOMOM',
33538 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33539 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33540 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33541 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33542 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33543 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33544 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33545 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33546 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33547 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33548 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33549 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33550 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33551 & 9*'BLANK'/
33552*= end*block.zk *
33553 END
33554
33555*$ CREATE DT_BLKD43.FOR
33556*COPY DT_BLKD43
33557*
33558*===blkd43=============================================================*
33559*
33560 BLOCK DATA DT_BLKD43
33561
33562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33563 SAVE
33564
33565*
33566*=== reac =============================================================*
33567*
33568*----------------------------------------------------------------------*
33569* *
33570* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33571* Infn - Milan *
33572* *
33573* Last change on 10-dec-91 by Alfredo Ferrari *
33574* *
33575* This is the original common reac of Hadrin *
33576* *
33577*----------------------------------------------------------------------*
33578*
33579
33580 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33581 & NRK(2,268),NURE(30,2)
33582
33583 DIMENSION
33584 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33585 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33586 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33587 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33588 & SPIKP5(187), SPIKP6(289),
33589 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33590 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33591 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33592 & SANPEL(84) , SPIKPF(273),
33593 & SPKP15(187), SPKP16(272),
33594 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33595 & NURELN(60)
33596*
33597 DIMENSION NRKLIN(532)
33598 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33599 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33600 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33601 EQUIVALENCE ( UMO(263), UMOK0(1))
33602 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33603 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33604 EQUIVALENCE ( PLABF(263), PLAK0(1))
33605 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33606 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33607 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33608 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33609 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33610 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33611 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33612 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33613 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33614 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33615 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33616 EQUIVALENCE ( WK(4913), SPKP16(1))
33617 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33618 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33619 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33620 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33621 EQUIVALENCE (NURE(1,1), NURELN(1))
33622*
33623**** pi- p data *
33624**** pi+ n data *
33625 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33626 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33627 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33628 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33629 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33630 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33631 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33632 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33633 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33634 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33635 DATA PLAKC /
33636 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33637 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33638 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33639 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33640 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33641 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33642 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33643 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33644 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33645 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33646 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33647 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33648 DATA PLAK0 /
33649 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33650 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33651 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33652 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33653 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33654 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33655* pp pn np nn *
33656 DATA PLAP /
33657 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33658 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33659 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33660 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33661 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33662 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33663* app apn anp ann *
33664 DATA PLAN /
33665 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33666 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33667 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33668 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33669 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33670 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33671 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33672 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33673 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33674 DATA SIIN / 296*0.D0 /
33675 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33676 & 1.557D0,1.615D0,1.6435D0,
33677 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33678 & 2.286D0,2.366D0,2.482D0,2.56D0,
33679 & 2.735D0,2.90D0,
33680 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33681 & 1.496D0,1.527D0,1.557D0,
33682 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33683 & 2.071D0,2.159D0,2.286D0,2.366D0,
33684 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33685 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33686 & 1.496D0,1.527D0,1.557D0,
33687 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33688 & 2.071D0,2.159D0,2.286D0,2.366D0,
33689 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33690 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33691 & 1.557D0,1.615D0,1.6435D0,
33692 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33693 & 2.286D0,2.366D0,2.482D0,2.56D0,
33694 & 2.735D0, 2.90D0/
33695 DATA UMOKC/ 1.44D0,
33696 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33697 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33698 & 3.1D0,1.44D0,
33699 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33700 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33701 & 3.1D0,1.44D0,
33702 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33703 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33704 & 3.1D0,1.44D0,
33705 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33706 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33707 & 3.1D0/
33708 DATA UMOK0/ 1.44D0,
33709 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33710 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33711 & 3.1D0,1.44D0,
33712 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33713 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33714 & 3.1D0/
33715* pp pn np nn *
33716 DATA UMOP/
33717 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33718 & 3.D0,3.1D0,3.2D0,
33719 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33720 & 3.D0,3.1D0,3.2D0,
33721 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33722 & 3.D0,3.1D0,3.2D0/
33723* app apn anp ann *
33724 DATA UMON /
33725 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33726 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33727 & 3.D0,3.1D0,3.2D0,
33728 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33729 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33730 & 3.D0,3.1D0,3.2D0,
33731 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33732 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33733 & 3.D0,3.1D0,3.2D0/
33734**** reaction channel state particles *
33735 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33736 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33737 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33738 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33739 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33740 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33741 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33742 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33743 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33744 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33745 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33746 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33747 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33748 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33749 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33750 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33751 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33752 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33753* *
33754* k0 p k0 n ak0 p ak/ n *
33755* *
33756 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33757 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33758 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33759 & 53, 47, 1, 103, 0, 93, 0/
33760* pp pn np nn *
33761 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33762 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33763 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33764 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33765* app apn anp ann *
33766 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33767 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33768 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33769 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33770 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33771 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33772 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33773**** channel cross section *
33774 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33775 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33776 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33777 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33778 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33779 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33780 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33781 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33782 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33783 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33784 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33785 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33786 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33787 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33788 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33789 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33790 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33791 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33792 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33793 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33794**** pi+ n data *
33795 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33796 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33797 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33798 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33799 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33800 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33801 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33802 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33803 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33804 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33805 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33806 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33807 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33808 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33809 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33810 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33811 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33812 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33813 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33814 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33815*
33816 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33817 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33818 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33819 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33820 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33821 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33822 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33823 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33824 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33825 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33826 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33827 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33828 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33829 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33830 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33831 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33832 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33833 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33834 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33835 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33836**** pi- p data *
33837 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33838 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33839 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33840 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33841 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33842 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33843 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33844 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33845 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33846 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33847 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33848 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33849 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33850 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33851 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33852 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33853 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33854 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33855 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33856*
33857 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33858 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33859 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33860 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33861 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33862 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33863 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33864 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33865 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33866 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33867 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33868 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33869 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33870 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33871 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33872 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33873 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33874 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33875 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33876 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33877**** pi- n data *
33878 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33879 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33880 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33881 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33882 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33883 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33884 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33885 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33886 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33887 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33888 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33889 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33890 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33891 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33892 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33893 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33894 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33895 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33896 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33897 & 3.3D0, 5.4D0, 7.D0 /
33898**** k+ p data *
33899 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33900 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33901 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33902 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33903 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33904 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33905 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33906 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33907 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33908 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33909 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33910 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33911 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33912**** k+ n data *
33913 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33914 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33915 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33916 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33917 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33918 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33919 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33920 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33921 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33922 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33923 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33924 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33925 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33926 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33927 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33928 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33929 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33930 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33931 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33932**** k- p data *
33933 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33934 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33935 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33936 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33937 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33938 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33939 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33940 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33941 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33942 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33943 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33944 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33945 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33946 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33947 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33948 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33949 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33950 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33951 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33952 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33953 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33954 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33955 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33956 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33957 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33958 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33959 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33960 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33961 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33962 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33963 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33964 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33965 & 10*0.D0/
33966***** k- n data *
33967 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33968 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33969 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33970 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33971 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33972 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33973 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33974 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33975 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
33976 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33977 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
33978 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33979 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33980 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33981 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33982 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
33983 & .39D0, .22D0, .07D0, 0.D0,
33984 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33985 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
33986 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
33987 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
33988 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
33989 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
33990 & 5.10D0, 5.44D0, 5.3D0,
33991 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
33992***** p p data *
33993 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
33994 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
33995 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
33996 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
33997 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
33998 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
33999 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34000 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34001 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34002 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34003 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34004 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34005 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34006 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34007 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34008***** p n data *
34009 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34010 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34011 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34012 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34013 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34014 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34015 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34016 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34017 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34018 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34019 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34020 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34021 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34022 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34023 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34024 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34025 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34026 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34027* nn - data *
34028* *
34029 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34030 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34031 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34032 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34033 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34034 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34035 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34036 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34037 & 11.D0, 5.5D0, 3.5D0,
34038 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34039 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34040 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34041 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34042 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34043 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34044**************** ap - p - data *
34045 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34046 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34047 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34048 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34049 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34050 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34051 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34052 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34053 & 1.55D0, 1.3D0, .95D0, .75D0,
34054 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34055 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34056 & .01D0, .008D0, .006D0, .005D0/
34057 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34058 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34059 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34060 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34061 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34062 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34063 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34064 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34065 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34066 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34067 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34068 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34069 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34070 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34071 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34072 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34073 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34074 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34075 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34076 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34077**************** ap - n - data *
34078 DATA SAPNEL/
34079 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34080 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34081 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34082 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34083 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34084 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34085 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34086 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34087 & .01D0, .008D0, .006D0, .005D0 /
34088 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34089 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34090 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34091 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34092 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34093 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34094 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34095 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34096 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34097 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34098 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34099 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34100 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34101 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34102* *
34103* *
34104**************** an - p - data *
34105* *
34106 DATA SANPEL/
34107 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34108 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34109 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34110 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34111 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34112 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34113 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34114 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34115 & .01D0, .008D0, .006D0, .005D0 /
34116 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34117 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34118 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34119 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34121 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34122 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34123 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34124 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34125 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34126 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34127 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34128 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34129 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34130**** ko - n - data *
34131 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34132 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34133 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34134 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34135 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34136 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34137 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34138 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34139 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34140 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34141 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34142 & 4.85D0, 4.9D0,
34143 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34144 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34145 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34146 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34147 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34148**** ako - p - data *
34149 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34150 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34151 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34152 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34153 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34154 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34155 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34156 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34157 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34158 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34159 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34160 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34161 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34162 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34163 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34164 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34165 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34166 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34167 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34168 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34169 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34170 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34171 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34172*= end*block.blkdt3 *
34173 END
34174*$ CREATE DT_QEL_POL.FOR
34175*COPY DT_QEL_POL
34176*
34177*===qel_pol============================================================*
34178*
34179 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34180
34181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34182 SAVE
34183
34184 CALL DT_MASS_INI
34185 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34186
34187 RETURN
34188 END
34189
34190*$ CREATE DT_GEN_QEL.FOR
34191*COPY DT_GEN_QEL
34192C==================================================================
34193C Generation of a Quasi-Elastic neutrino scattering
34194C==================================================================
34195*
34196*===gen_qel============================================================*
34197*
34198 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34199
34200C...Generate a quasi-elastic neutrino/antineutrino
34201C. Interaction on a nuclear target
34202C. INPUT : LTYP = neutrino type (1,...,6)
34203C. ENU (GeV) = neutrino energy
34204C----------------------------------------------------
34205
34206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34207 SAVE
34208
34209 PARAMETER ( LINP = 10 ,
34210 & LOUT = 6 ,
34211 & LDAT = 9 )
34212 PARAMETER (MAXLND=4000)
34213 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34214
34215* nuclear potential
34216 LOGICAL LFERMI
34217 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34218 & EBINDP(2),EBINDN(2),EPOT(2,210),
34219 & ETACOU(2),ICOUL,LFERMI
34220
34221* steering flags for qel neutrino scattering modules
34222 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34223**sr - removed (not needed)
34224C COMMON /CBAD/ LBAD, NBAD
34225C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34226**
34227
34228 DIMENSION PI(3),PO(3)
34229CJR+
34230 DATA ININU/0/
34231CJR-
34232C REAL*8 DBETA(3)
34233C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34234 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34235 DATA AMN /0.93827231D0, 0.93956563D0/
34236 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34237 DATA INIPRI/0/
34238
34239C DATA PFERMI/0.22D0/
34240CGB+...Binding Energy
34241 DATA EBIND/0.008D0/
34242CGB-...
34243
34244 ININU=ININU+1
34245 IF(ININU.EQ.1)NDSIG=0
34246 LBAD = 0
34247 enu0=enu
34248c write(*,*) enu0
34249C...Lepton mass
34250 AML = AML0(LTYP) ! massa leptoni
34251 AML2 = AML**2 ! massa leptoni **2
34252C...Particle labels (LUND)
34253 N = 5
34254 K(1,1) = 21
34255 K(2,1) = 21
34256 K(3,1) = 21
34257 K(3,3) = 1
34258 K(4,1) = 1
34259 K(4,3) = 1
34260 K(5,1) = 1
34261 K(5,3) = 2
34262 K0 = (LTYP-1)/2 ! 2
34263 K1 = LTYP/2 ! 2
34264 KA = 12 + 2*K0 ! 16
34265 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34266 K(1,2) = IS*KA
34267 K(4,2) = IS*(KA-1)
34268 K(3,2) = IS*24
34269 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34270 IF (LNU .EQ. 2) THEN
34271 K(2,2) = 2212
34272 K(5,2) = 2112
34273 AMI = AMN(1)
34274 AMF = AMN(2)
34275CJR+
34276 PFERMI=PFERMN(2)
34277CJR-
34278 ELSE
34279 K(2,2) = 2112
34280 K(5,2) = 2212
34281 AMI = AMN(2)
34282 AMF = AMN(1)
34283CJR+
34284 PFERMI=PFERMP(2)
34285CJR-
34286 ENDIF
34287 AMI2 = AMI**2
34288 AMF2 = AMF**2
34289
34290 DO IGB=1,5
34291 P(3,IGB) = 0.
34292 P(4,IGB) = 0.
34293 P(5,IGB) = 0.
34294 END DO
34295
34296 NTRY = 0
34297CGB+...
34298 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34299 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34300CGB-...
34301
34302 100 CONTINUE
34303
34304C...4-momentum initial lepton
34305 P(1,5) = 0. ! massa
34306 P(1,4) = ENU0 ! energia
34307 P(1,1) = 0. ! px
34308 P(1,2) = 0. ! py
34309 P(1,3) = ENU0 ! pz
34310
34311C PF = PFERMI*PYR(0)**(1./3.)
34312c write(23,*) PYR(0)
34313c write(*,*) 'Pfermi=',PF
34314c PF = 0.
34315 NTRY=NTRY+1
34316C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34317 IF (NTRY .GT. 500) THEN
34318 LBAD = 1
34319 WRITE (LOUT,1001) NBAD, ENU
34320 RETURN
34321 ENDIF
34322C CT = -1. + 2.*PYR(0)
34323c CT = -1.
34324C ST = SQRT(1.-CT*CT)
34325C F = 2.*3.1415926*PYR(0)
34326c F = 0.
34327
34328C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34329C P(2,1) = PF*ST*COS(F) ! px
34330C P(2,2) = PF*ST*SIN(F) ! py
34331C P(2,3) = PF*CT ! pz
34332C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34333 P(2,1) = P21
34334 P(2,2) = P22
34335 P(2,3) = P23
34336 P(2,4) = P24
34337 P(2,5) = P25
34338 beta1=-p(2,1)/p(2,4)
34339 beta2=-p(2,2)/p(2,4)
34340 beta3=-p(2,3)/p(2,4)
34341 N=2
34342C WRITE(6,*)' before transforming into target rest frame'
34343
34344 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34345
34346C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34347 N=5
34348
34349 phi11=atan(p(1,2)/p(1,3))
34350 pi(1)=p(1,1)
34351 pi(2)=p(1,2)
34352 pi(3)=p(1,3)
34353
34354 CALL DT_TESTROT(PI,Po,PHI11,1)
34355 DO ll=1,3
34356 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34357 END DO
34358c WRITE(*,*) po
34359 p(1,1)=po(1)
34360 p(1,2)=po(2)
34361 p(1,3)=po(3)
34362 phi12=atan(p(1,1)/p(1,3))
34363
34364 pi(1)=p(1,1)
34365 pi(2)=p(1,2)
34366 pi(3)=p(1,3)
34367 CALL DT_TESTROT(Pi,Po,PHI12,2)
34368 DO ll=1,3
34369 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34370 END DO
34371c WRITE(*,*) po
34372 p(1,1)=po(1)
34373 p(1,2)=po(2)
34374 p(1,3)=po(3)
34375
34376 enu=p(1,4)
34377
34378C...Kinematical limits in Q**2
34379c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34380 S = P(2,5)**2 + 2.*ENU*P(2,5)
34381 SQS = SQRT(S) ! E centro massa
34382 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34383 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34384 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34385 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34386 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34387 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34388 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34389
34390C...Generate Q**2
34391 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34392 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34393 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34394 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34395 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34396 NDSIG=NDSIG+1
34397C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34398C &Q2,Q2min,Q2MAX,DSIGEV
34399
34400C...c.m. frame. Neutrino along z axis
34401 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34402 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34403 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34404 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34405c WRITE(*,*)
34406c WRITE(*,*)
34407C WRITE(*,*) 'Input values laboratory frame'
34408 N=2
34409
34410 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34411
34412 N=5
34413c STHETA = ULANGL(P(1,3),P(1,1))
34414c write(*,*) 'stheta' ,stheta
34415c stheta=0.
34416c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34417c WRITE(*,*)
34418c WRITE(*,*)
34419C WRITE(*,*) 'Output values cm frame'
34420C...Kinematic in c.m. frame
34421 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34422 STSTAR = SQRT(1.-CTSTAR**2)
34423 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34424 P(4,5) = AML ! massa leptone
34425 P(4,4) = ELF ! e leptone
34426 P(4,3) = PLF*CTSTAR ! px
34427 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34428 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34429
34430 P(5,5) = AMF ! barione
34431 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34432 P(5,3) = -P(4,3) ! px
34433 P(5,1) = -P(4,1) ! py
34434 P(5,2) = -P(4,2) ! pz
34435
34436 P(3,5) = -Q2
34437 P(3,1) = P(1,1)-P(4,1)
34438 P(3,2) = P(1,2)-P(4,2)
34439 P(3,3) = P(1,3)-P(4,3)
34440 P(3,4) = P(1,4)-P(4,4)
34441
34442C...Transform back to laboratory frame
34443C WRITE(*,*) 'before going back to nucl rest frame'
34444c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34445 N=5
34446
34447 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34448
34449C WRITE(*,*) 'Now back in nucl rest frame'
34450 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34451
34452c********************************************
34453
34454 DO kw=1,5
34455 pi(1)=p(kw,1)
34456 pi(2)=p(kw,2)
34457 pi(3)=p(kw,3)
34458 CALL DT_TESTROT(Pi,Po,PHI12,3)
34459 DO ll=1,3
34460 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34461 END DO
34462 p(kw,1)=po(1)
34463 p(kw,2)=po(2)
34464 p(kw,3)=po(3)
34465 END DO
34466c********************************************
34467
34468 DO kw=1,5
34469 pi(1)=p(kw,1)
34470 pi(2)=p(kw,2)
34471 pi(3)=p(kw,3)
34472 CALL DT_TESTROT(Pi,Po,PHI11,4)
34473 DO ll=1,3
34474 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34475 END DO
34476 p(kw,1)=po(1)
34477 p(kw,2)=po(2)
34478 p(kw,3)=po(3)
34479 END DO
34480
34481c********************************************
34482
34483C WRITE(*,*) 'Now back in lab frame'
34484
34485 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34486
34487CGB+...
34488C...test (on final momentum of nucleon) if Fermi-blocking
34489C...is operating
34490 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34491 & - P(5,5)
34492 IF (ENUCL.LT. EFMAX) THEN
34493 IF(INIPRI.LT.10)THEN
34494 INIPRI=INIPRI+1
34495C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34496C...the interaction is not possible due to Pauli-Blocking and
34497C...it must be resampled
34498 ENDIF
34499 GOTO 100
34500 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34501 IF(INIPRI.LT.10)THEN
34502 INIPRI=INIPRI+1
34503C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34504 ENDIF
34505C Reject (J:R) here all these events
34506C are otherwise rejected in dpmjet
34507 GOTO 100
34508C...the interaction is possible, but the nucleon remains inside
34509C...the nucleus. The nucleus is therefore left excited.
34510C...We treat this case as a nucleon with 0 kinetic energy.
34511C P(5,5) = AMF
34512C P(5,4) = AMF
34513C P(5,1) = 0.
34514C P(5,2) = 0.
34515C P(5,3) = 0.
34516 ELSE IF (ENUCL.GE.ENWELL) THEN
34517C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34518C...the interaction is possible, the nucleon can exit the nucleus
34519C...but the nuclear well depth must be subtracted. The nucleus could be
34520C...left in an excited state.
34521 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34522C P(5,4) = ENUCL-ENWELL + AMF
34523 Pnucl = SQRT(P(5,4)**2-AMF**2)
34524C...The 3-momentum is scaled assuming that the direction remains
34525C...unaffected
34526 P(5,1) = P(5,1) * Pnucl/Pstart
34527 P(5,2) = P(5,2) * Pnucl/Pstart
34528 P(5,3) = P(5,3) * Pnucl/Pstart
34529C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34530 ENDIF
34531CGB-...
34532 DSIGSU=DSIGSU+DSIGEV
34533
34534 GA=P(4,4)/P(4,5)
34535 BGX=P(4,1)/P(4,5)
34536 BGY=P(4,2)/P(4,5)
34537 BGZ=P(4,3)/P(4,5)
34538*
34539 DBETB(1)=BGX/GA
34540 DBETB(2)=BGY/GA
34541 DBETB(3)=BGZ/GA
34542 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34543
34544 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34545
34546 ENDIF
34547c
34548C PRINT*,' FINE EVENTO '
34549 enu=enu0
34550 RETURN
34551
34552 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34553 END
34554
34555*$ CREATE DT_MASS_INI.FOR
34556*COPY DT_MASS_INI
34557C====================================================================
34558C. Masses
34559C====================================================================
34560*
34561*===mass_ini===========================================================*
34562*
34563 SUBROUTINE DT_MASS_INI
34564C...Initialize the kinematics for the quasi-elastic cross section
34565
34566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34567 SAVE
34568
34569* particle masses used in qel neutrino scattering modules
34570 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34571 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34572 & EMPROTSQ,EMNEUTSQ,EMNSQ
34573
34574 EML(1) = 0.51100D-03 ! e-
34575 EML(2) = EML(1) ! e+
34576 EML(3) = 0.105659D0 ! mu-
34577 EML(4) = EML(3) ! mu+
34578 EML(5) = 1.7777D0 ! tau-
34579 EML(6) = EML(5) ! tau+
34580 EMPROT = 0.93827231D0 ! p
34581 EMNEUT = 0.93956563D0 ! n
34582 EMPROTSQ = EMPROT**2
34583 EMNEUTSQ = EMNEUT**2
34584 EMN = (EMPROT + EMNEUT)/2.
34585 EMNSQ = EMN**2
34586 DO J=1,3
34587 J0 = 2*(J-1)
34588 EMN1(J0+1) = EMNEUT
34589 EMN1(J0+2) = EMPROT
34590 EMN2(J0+1) = EMPROT
34591 EMN2(J0+2) = EMNEUT
34592 ENDDO
34593 DO J=1,6
34594 EMLSQ(J) = EML(J)**2
34595 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34596 ENDDO
34597 RETURN
34598 END
34599
34600*$ CREATE DT_DSQEL_Q2.FOR
34601*COPY DT_DSQEL_Q2
34602*
34603*===dsqel_q2===========================================================*
34604*
34605 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34606
34607C...differential cross section for Quasi-Elastic scattering
34608C. nu + N -> l + N'
34609C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34610C.
34611C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34612C. ENU (GeV) = Neutrino energy
34613C. Q2 (GeV**2) = (Transfer momentum)**2
34614C.
34615C. OUTPUT : DSQEL_Q2 = differential cross section :
34616C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34617C------------------------------------------------------------------
34618
34619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34620 SAVE
34621
34622* particle masses used in qel neutrino scattering modules
34623 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34624 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34625 & EMPROTSQ,EMNEUTSQ,EMNSQ
34626**sr - removed (not needed)
34627C COMMON /CAXIAL/ FA0, AXIAL2
34628**
34629
34630 DIMENSION SS(6)
34631 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34632 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34633 DATA AXIAL2 /1.03D0/ ! to be checked
34634
34635 FA0=-1.253D0
34636 CSI = 3.71D0 ! ???
34637 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34638 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34639 X = Q2/(EMN*EMN) ! emn=massa barione
34640 XA = X/4.D0
34641 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34642 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34643 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34644 FFA = FA*FA
34645 FFV1 = FV1*FV1
34646 FFV2 = FV2*FV2
34647 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34648 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34649 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34650 AA = (XA+0.25D0*RM)*(A1 + A2)
34651 BB = -X*FA*(FV1 + FV2)
34652 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34653 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34654 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34655 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34656
34657 RETURN
34658 END
34659
34660*$ CREATE DT_PREPOLA.FOR
34661*COPY DT_PREPOLA
34662*
34663*===prepola============================================================*
34664*
34665 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34666
34667 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34668 SAVE
34669c
34670c By G. Battistoni and E. Scapparone (sept. 1997)
34671c According to:
34672c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34673c
34674c
34675 PARAMETER (MAXLND=4000)
34676 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34677
34678 COMMON /QNPOL/ POLARX(4),PMODUL
34679
34680* particle masses used in qel neutrino scattering modules
34681 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34682 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34683 & EMPROTSQ,EMNEUTSQ,EMNSQ
34684
34685* steering flags for qel neutrino scattering modules
34686 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34687**sr - removed (not needed)
34688C COMMON /CAXIAL/ FA0, AXIAL2
34689C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34690C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34691**
34692 REAL*8 POL(4,4),BB2(3)
34693 DIMENSION SS(6)
34694C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34695 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34696**sr uncommented since common block CAXIAL is now commented
34697 DATA AXIAL2 /1.03D0/ ! to be checked
34698**
34699
34700 RML=P(4,5)
34701 RMM=0.93960D+00
34702 FM2 = RMM**2
34703 MPI = 0.135D+00
34704 OLDQ2=Q2
34705 FA0=-1.253D+00
34706 CSI = 3.71D+00 !
34707 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34708 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34709 X = Q2/(EMN*EMN) ! emn=massa barione
34710 XA = X/4.D0
34711 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34712 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34713 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34714 FFA = FA*FA
34715 FFV1 = FV1*FV1
34716 FFV2 = FV2*FV2
34717 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34718 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34719 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34720 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34721 AA = (XA+0.25D+00*RM)*(A1 + A2)
34722 BB = -X*FA*(FV1 + FV2)
34723 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34724 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34725
34726 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34727 OMEGA2=4.D+00*CC
34728 OMEGA3=2.D+00*FA*(FV1+FV2)
34729 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34730 1 (Q2/FM2))*FP**2)
34731 OMEGA5=OMEGA2
34732 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34733 WW1=2.D+00*OMEGA1*EMN**2
34734 WW2=2.D+00*OMEGA2*EMN**2
34735 WW3=2.D+00*OMEGA3*EMN**2
34736 WW4=2.D+00*OMEGA4*EMN**2
34737 WW5=2.D+00*OMEGA5*EMN**2
34738
34739 DO I=1,3
34740 BB2(I)=-P(4,I)/P(4,4)
34741 END DO
34742c WRITE(*,*)
34743c WRITE(*,*)
34744c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34745 N=5
34746
34747 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34748
34749* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34750c WRITE(*,*)
34751c WRITE(*,*)
34752c WRITE(*,*) 'Prepola: now in lepton rest frame'
34753 EE=ENU
34754 QM2=Q2+RML**2
34755 U=Q2/(2.*RMM)
34756 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34757 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34758 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34759
34760 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34761 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34762
34763 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34764
34765 DO I=1,3
34766 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34767 POLARX(I)=POL(4,I)
34768 END DO
34769
34770 PMODUL=0.D0
34771 DO I=1,3
34772 PMODUL=PMODUL+POL(4,I)**2
34773 END DO
34774
34775 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34776 IF(NEUDEC.EQ.1) THEN
34777 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34778 + ETL,PXL,PYL,PZL,
34779 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34780c
34781c Tau has decayed in muon
34782c
34783 ENDIF
34784 IF(NEUDEC.EQ.2) THEN
34785 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34786 + ETL,PXL,PYL,PZL,
34787 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34788c
34789c Tau has decayed in electron
34790c
34791 ENDIF
34792 K(4,1)=15
34793 K(4,4) = 6
34794 K(4,5) = 8
34795 N=N+3
34796c
34797c fill common for muon(electron)
34798c
34799 P(6,1)=PXL
34800 P(6,2)=PYL
34801 P(6,3)=PZL
34802 P(6,4)=ETL
34803 K(6,1)=1
34804 IF(JTYP.EQ.5) THEN
34805 IF(NEUDEC.EQ.1) THEN
34806 P(6,5)=EML(JTYP-2)
34807 K(6,2)=13
34808 ELSEIF(NEUDEC.EQ.2) THEN
34809 P(6,5)=EML(JTYP-4)
34810 K(6,2)=11
34811 ENDIF
34812 ELSEIF(JTYP.EQ.6) THEN
34813 IF(NEUDEC.EQ.1) THEN
34814 K(6,2)=-13
34815 ELSEIF(NEUDEC.EQ.2) THEN
34816 K(6,2)=-11
34817 ENDIF
34818 END IF
34819 K(6,3)=4
34820 K(6,4)=0
34821 K(6,5)=0
34822c
34823c fill common for tau_(anti)neutrino
34824c
34825 P(7,1)=PXB
34826 P(7,2)=PYB
34827 P(7,3)=PZB
34828 P(7,4)=ETB
34829 P(7,5)=0.
34830 K(7,1)=1
34831 IF(JTYP.EQ.5) THEN
34832 K(7,2)=16
34833 ELSEIF(JTYP.EQ.6) THEN
34834 K(7,2)=-16
34835 END IF
34836 K(7,3)=4
34837 K(7,4)=0
34838 K(7,5)=0
34839c
34840c Fill common for muon(electron)_(anti)neutrino
34841c
34842 P(8,1)=PXN
34843 P(8,2)=PYN
34844 P(8,3)=PZN
34845 P(8,4)=ETN
34846 P(8,5)=0.
34847 K(8,1)=1
34848 IF(JTYP.EQ.5) THEN
34849 IF(NEUDEC.EQ.1) THEN
34850 K(8,2)=-14
34851 ELSEIF(NEUDEC.EQ.2) THEN
34852 K(8,2)=-12
34853 ENDIF
34854 ELSEIF(JTYP.EQ.6) THEN
34855 IF(NEUDEC.EQ.1) THEN
34856 K(8,2)=14
34857 ELSEIF(NEUDEC.EQ.2) THEN
34858 K(8,2)=12
34859 ENDIF
34860 END IF
34861 K(8,3)=4
34862 K(8,4)=0
34863 K(8,5)=0
34864 ENDIF
34865c WRITE(*,*)
34866c WRITE(*,*)
34867
34868c IF(PMODUL.GE.1.D+00) THEN
34869c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34870c write(*,*) pmodul
34871c DO I=1,3
34872c POL(4,I)=POL(4,I)/PMODUL
34873c POLARX(I)=POL(4,I)
34874c END DO
34875c PMODUL=0.
34876c DO I=1,3
34877c PMODUL=PMODUL+POL(4,I)**2
34878c END DO
34879c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34880c
34881c ENDIF
34882
34883c WRITE(*,*) 'PMODUL = ',PMODUL
34884
34885c WRITE(*,*)
34886c WRITE(*,*)
34887c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34888
34889 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34890
34891 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34892 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34893 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34894 DO NDC =6,8
34895 V(NDC,1) = XDC
34896 V(NDC,2) = YDC
34897 V(NDC,3) = ZDC
34898 END DO
34899
34900 RETURN
34901 END
34902
34903*$ CREATE DT_TESTROT.FOR
34904*COPY DT_TESTROT
34905*
34906*===testrot============================================================*
34907*
34908 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34909
34910 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34911 SAVE
34912
34913 DIMENSION ROT(3,3),PI(3),PO(3)
34914
34915 IF (MODE.EQ.1) THEN
34916 ROT(1,1) = 1.D0
34917 ROT(1,2) = 0.D0
34918 ROT(1,3) = 0.D0
34919 ROT(2,1) = 0.D0
34920 ROT(2,2) = COS(PHI)
34921 ROT(2,3) = -SIN(PHI)
34922 ROT(3,1) = 0.D0
34923 ROT(3,2) = SIN(PHI)
34924 ROT(3,3) = COS(PHI)
34925 ELSEIF (MODE.EQ.2) THEN
34926 ROT(1,1) = 0.D0
34927 ROT(1,2) = 1.D0
34928 ROT(1,3) = 0.D0
34929 ROT(2,1) = COS(PHI)
34930 ROT(2,2) = 0.D0
34931 ROT(2,3) = -SIN(PHI)
34932 ROT(3,1) = SIN(PHI)
34933 ROT(3,2) = 0.D0
34934 ROT(3,3) = COS(PHI)
34935 ELSEIF (MODE.EQ.3) THEN
34936 ROT(1,1) = 0.D0
34937 ROT(2,1) = 1.D0
34938 ROT(3,1) = 0.D0
34939 ROT(1,2) = COS(PHI)
34940 ROT(2,2) = 0.D0
34941 ROT(3,2) = -SIN(PHI)
34942 ROT(1,3) = SIN(PHI)
34943 ROT(2,3) = 0.D0
34944 ROT(3,3) = COS(PHI)
34945 ELSEIF (MODE.EQ.4) THEN
34946 ROT(1,1) = 1.D0
34947 ROT(2,1) = 0.D0
34948 ROT(3,1) = 0.D0
34949 ROT(1,2) = 0.D0
34950 ROT(2,2) = COS(PHI)
34951 ROT(3,2) = -SIN(PHI)
34952 ROT(1,3) = 0.D0
34953 ROT(2,3) = SIN(PHI)
34954 ROT(3,3) = COS(PHI)
34955 ELSE
34956 STOP ' TESTROT: mode not supported!'
34957 ENDIF
34958 DO 1 J=1,3
34959 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34960 1 CONTINUE
34961
34962 RETURN
34963 END
34964
34965*$ CREATE DT_LEPDCYP.FOR
34966*COPY DT_LEPDCYP
34967*
34968*===lepdcyp============================================================*
34969*
34970 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34971 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34972C
34973C-----------------------------------------------------------------
34974C
34975C Author :- G. Battistoni 10-NOV-1995
34976C
34977C=================================================================
34978C
34979C Purpose : performs decay of polarized lepton in
34980C its rest frame: a => b + l + anti-nu
34981C (Example: mu- => nu-mu + e- + anti-nu-e)
34982C Polarization is assumed along Z-axis
34983C WARNING:
34984C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
34985C OF NEGLIGIBLE MASS
34986C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
34987C IN THIS VERSION
34988C
34989C Method : modifies phase space distribution obtained
34990C by routine EXPLOD using a rejection against the
34991C matrix element for unpolarized lepton decay
34992C
34993C Inputs : Mass of a : AMA
34994C Mass of l : AML
34995C Polar. of a: POL
34996C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
34997C POL = -1)
34998C
34999C Outputs : kinematic variables in the rest frame of decaying lepton
35000C ETL,PXL,PYL,PZL 4-moment of l
35001C ETB,PXB,PYB,PZB 4-moment of b
35002C ETN,PXN,PYN,PZN 4-moment of anti-nu
35003C
35004C============================================================
35005C +
35006C Declarations.
35007C -
35008 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35009 SAVE
35010
35011 PARAMETER ( LINP = 10 ,
35012 & LOUT = 6 ,
35013 & LDAT = 9 )
35014
35015 PARAMETER ( KALGNM = 2 )
35016 PARAMETER ( ANGLGB = 5.0D-16 )
35017 PARAMETER ( ANGLSQ = 2.5D-31 )
35018 PARAMETER ( AXCSSV = 0.2D+16 )
35019 PARAMETER ( ANDRFL = 1.0D-38 )
35020 PARAMETER ( AVRFLW = 1.0D+38 )
35021 PARAMETER ( AINFNT = 1.0D+30 )
35022 PARAMETER ( AZRZRZ = 1.0D-30 )
35023 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35024 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35025 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35026 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35027 PARAMETER ( CSNNRM = 2.0D-15 )
35028 PARAMETER ( DMXTRN = 1.0D+08 )
35029 PARAMETER ( ZERZER = 0.D+00 )
35030 PARAMETER ( ONEONE = 1.D+00 )
35031 PARAMETER ( TWOTWO = 2.D+00 )
35032 PARAMETER ( THRTHR = 3.D+00 )
35033 PARAMETER ( FOUFOU = 4.D+00 )
35034 PARAMETER ( FIVFIV = 5.D+00 )
35035 PARAMETER ( SIXSIX = 6.D+00 )
35036 PARAMETER ( SEVSEV = 7.D+00 )
35037 PARAMETER ( EIGEIG = 8.D+00 )
35038 PARAMETER ( ANINEN = 9.D+00 )
35039 PARAMETER ( TENTEN = 10.D+00 )
35040 PARAMETER ( HLFHLF = 0.5D+00 )
35041 PARAMETER ( ONETHI = ONEONE / THRTHR )
35042 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35043 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35044 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35045 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35046 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35047 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35048 PARAMETER ( AMELGR = 9.1093897 D-28 )
35049 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35050 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35051 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35052 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35053 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35054 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35055 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35056 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35057 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35058 PARAMETER ( PLABRC = 0.197327053 D+00 )
35059 PARAMETER ( AMELCT = 0.51099906 D-03 )
35060 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35061 PARAMETER ( AMMUON = 0.105658389 D+00 )
35062 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35063 PARAMETER ( GEVMEV = 1.0 D+03 )
35064 PARAMETER ( EMVGEV = 1.0 D-03 )
35065 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35066 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35067 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35068C +
35069C variables for EXPLOD
35070C -
35071 PARAMETER ( KPMX = 10 )
35072 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35073 & PZEXPL (KPMX), ETEXPL (KPMX)
35074C +
35075C test variables
35076C -
35077**sr - removed (not needed)
35078C COMMON /GBATNU/ ELERAT,NTRY
35079**
35080C +
35081C Initializes test variables
35082C -
35083 NTRY = 0
35084 ELERAT = 0.D+00
35085C +
35086C Maximum value for matrix element
35087C -
35088 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35089 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35090C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35091C Inputs for EXPLOD
35092C part. no. 1 is l (e- in mu- decay)
35093C part. no. 2 is b (nu-mu in mu- decay)
35094C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35095C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35096 NPEXPL = 3
35097 ETOTEX = AMA
35098 AMEXPL(1) = AML
35099 AMEXPL(2) = 0.D+00
35100 AMEXPL(3) = 0.D+00
35101C +
35102C phase space distribution
35103C -
35104 100 CONTINUE
35105 NTRY = NTRY + 1
35106
35107 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35108 & PYEXPL, PZEXPL )
35109
35110C +
35111C Calculates matrix element:
35112C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35113C Here CTH is the cosine of the angle between anti-nu and Z axis
35114C -
35115 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35116 & PZEXPL(3)**2 )
35117 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35118 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35119 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35120 ELEMAT = 16.D+00 * PROD1 * PROD2
35121 IF(ELEMAT.GT.ELEMAX) THEN
35122 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35123 STOP
35124 ENDIF
35125C +
35126C Here performs the rejection
35127C -
35128 TEST = DT_RNDM(ETOTEX) * ELEMAX
35129 IF ( TEST .GT. ELEMAT ) GO TO 100
35130C +
35131C final assignment of variables
35132C -
35133 ELERAT = ELEMAT/ELEMAX
35134 ETL = ETEXPL(1)
35135 PXL = PXEXPL(1)
35136 PYL = PYEXPL(1)
35137 PZL = PZEXPL(1)
35138 ETB = ETEXPL(2)
35139 PXB = PXEXPL(2)
35140 PYB = PYEXPL(2)
35141 PZB = PZEXPL(2)
35142 ETN = ETEXPL(3)
35143 PXN = PXEXPL(3)
35144 PYN = PYEXPL(3)
35145 PZN = PZEXPL(3)
35146 999 RETURN
35147 END
35148
35149*$ CREATE DT_GEN_DELTA.FOR
35150*COPY DT_GEN_DELTA
35151C==================================================================
35152C. Generation of Delta resonance events
35153C==================================================================
35154*
35155*===gen_delta==========================================================*
35156*
35157 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35158
35159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35160 SAVE
35161
35162 PARAMETER ( LINP = 10 ,
35163 & LOUT = 6 ,
35164 & LDAT = 9 )
35165
35166C...Generate a Delta-production neutrino/antineutrino
35167C. CC-interaction on a nucleon
35168C
35169C. INPUT ENU (GeV) = Neutrino Energy
35170C. LLEP = neutrino type
35171C. LTARG = nucleon target type 1=p, 2=n.
35172C. JINT = 1:CC, 2::NC
35173C.
35174C. OUTPUT PPL(4) 4-monentum of final lepton
35175C----------------------------------------------------
35176 PARAMETER (MAXLND=4000)
35177 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35178
35179**sr - removed (not needed)
35180C COMMON /CBAD/ LBAD, NBAD
35181**
35182
35183 DIMENSION PI(3),PO(3)
35184C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35185 DIMENSION AML0(6),AMN(2)
35186 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35187 DATA AMN /0.93827231, 0.93956563/
35188 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35189
35190c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35191 LBAD = 0
35192C...Final lepton mass
35193 IF (JINT.EQ.1) THEN
35194 AML = AML0(LLEP)
35195 ELSE
35196 AML = 0.
35197 ENDIF
35198 AML2 = AML**2
35199
35200C...Particle labels (LUND)
35201 N = 5
35202 K(1,1) = 21
35203 K(2,1) = 21
35204 K(3,1) = 21
35205 K(4,1) = 1
35206 K(3,3) = 1
35207 K(4,3) = 1
35208 IF (LTARG .EQ. 1) THEN
35209 K(2,2) = 2212
35210 ELSE
35211 K(2,2) = 2112
35212 ENDIF
35213 K0 = (LLEP-1)/2
35214 K1 = LLEP/2
35215 KA = 12 + 2*K0
35216 IS = -1 + 2*LLEP - 4*K1
35217 LNU = 2 - LLEP + 2*K1
35218 K(1,2) = IS*KA
35219 K(5,1) = 1
35220 K(5,3) = 2
35221 IF (JINT .EQ. 1) THEN ! CC interactions
35222 K(3,2) = IS*24
35223 K(4,2) = IS*(KA-1)
35224 IF(LNU.EQ.1) THEN
35225 IF (LTARG .EQ. 1) THEN
35226 K(5,2) = 2224
35227 ELSE
35228 K(5,2) = 2214
35229 ENDIF
35230 ELSE
35231 IF (LTARG .EQ. 1) THEN
35232 K(5,2) = 2114
35233 ELSE
35234 K(5,2) = 1114
35235 ENDIF
35236 ENDIF
35237 ELSE
35238 K(3,2) = 23 ! NC (Z0) interactions
35239 K(4,2) = K(1,2)
35240**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35241* Delta0 for neutron (LTARG=2)
35242C IF (LTARG .EQ. 1) THEN
35243C K(5,2) = 2114
35244C ELSE
35245C K(5,2) = 2214
35246C ENDIF
35247 IF (LTARG .EQ. 1) THEN
35248 K(5,2) = 2214
35249 ELSE
35250 K(5,2) = 2114
35251 ENDIF
35252**
35253 ENDIF
35254
35255C...4-momentum initial lepton
35256 P(1,5) = 0.
35257 P(1,4) = ENU
35258 P(1,1) = 0.
35259 P(1,2) = 0.
35260 P(1,3) = ENU
35261C...4-momentum initial nucleon
35262 P(2,5) = AMN(LTARG)
35263C P(2,4) = P(2,5)
35264C P(2,1) = 0.
35265C P(2,2) = 0.
35266C P(2,3) = 0.
35267 P(2,1) = P21
35268 P(2,2) = P22
35269 P(2,3) = P23
35270 P(2,4) = P24
35271 P(2,5) = P25
35272 N=2
35273 beta1=-p(2,1)/p(2,4)
35274 beta2=-p(2,2)/p(2,4)
35275 beta3=-p(2,3)/p(2,4)
35276 N=2
35277
35278 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35279
35280C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35281
35282 phi11=atan(p(1,2)/p(1,3))
35283 pi(1)=p(1,1)
35284 pi(2)=p(1,2)
35285 pi(3)=p(1,3)
35286
35287 CALL DT_TESTROT(PI,Po,PHI11,1)
35288 DO ll=1,3
35289 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35290 END DO
35291 p(1,1)=po(1)
35292 p(1,2)=po(2)
35293 p(1,3)=po(3)
35294 phi12=atan(p(1,1)/p(1,3))
35295
35296 pi(1)=p(1,1)
35297 pi(2)=p(1,2)
35298 pi(3)=p(1,3)
35299 CALL DT_TESTROT(Pi,Po,PHI12,2)
35300 DO ll=1,3
35301 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35302 END DO
35303 p(1,1)=po(1)
35304 p(1,2)=po(2)
35305 p(1,3)=po(3)
35306
35307 ENUU=P(1,4)
35308
35309C...Generate the Mass of the Delta
35310 NTRY = 0
35311100 R = PYR(0)
35312 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35313 NTRY = NTRY + 1
35314 IF (NTRY .GT. 1000) THEN
35315 LBAD = 1
35316 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35317 RETURN
35318 ENDIF
35319 IF (AMD .LT. AMDMIN) GOTO 100
35320 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35321 IF (ENUU .LT. ET) GOTO 100
35322
35323C...Kinematical limits in Q**2
35324 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35325 SQS = SQRT(S)
35326 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35327 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35328 PLF = SQRT(ELF**2 - AML2)
35329 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35330 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35331 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35332
35333 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35334200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35335 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35336 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35337
35338C...Generate the kinematics of the final particles
35339 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35340 GAM = EISTAR/AMN(LTARG)
35341 BET = PSTAR/EISTAR
35342 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35343 EL = GAM*(ELF + BET*PLF*CTSTAR)
35344 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35345 PL = SQRT(EL**2 - AML2)
35346 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35347 PHI = 6.28319*PYR(0)
35348 P(4,1) = PLT*COS(PHI)
35349 P(4,2) = PLT*SIN(PHI)
35350 P(4,3) = PLZ
35351 P(4,4) = EL
35352 P(4,5) = AML
35353
35354C...4-momentum of Delta
35355 P(5,1) = -P(4,1)
35356 P(5,2) = -P(4,2)
35357 P(5,3) = ENUU-P(4,3)
35358 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35359 P(5,5) = AMD
35360
35361C...4-momentum of intermediate boson
35362 P(3,5) = -Q2
35363 P(3,4) = P(1,4)-P(4,4)
35364 P(3,1) = P(1,1)-P(4,1)
35365 P(3,2) = P(1,2)-P(4,2)
35366 P(3,3) = P(1,3)-P(4,3)
35367 N=5
35368
35369 DO kw=1,5
35370 pi(1)=p(kw,1)
35371 pi(2)=p(kw,2)
35372 pi(3)=p(kw,3)
35373 CALL DT_TESTROT(Pi,Po,PHI12,3)
35374 DO ll=1,3
35375 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35376 END DO
35377 p(kw,1)=po(1)
35378 p(kw,2)=po(2)
35379 p(kw,3)=po(3)
35380 END DO
35381
35382c********************************************
35383
35384 DO kw=1,5
35385 pi(1)=p(kw,1)
35386 pi(2)=p(kw,2)
35387 pi(3)=p(kw,3)
35388 CALL DT_TESTROT(Pi,Po,PHI11,4)
35389 DO ll=1,3
35390 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35391 END DO
35392 p(kw,1)=po(1)
35393 p(kw,2)=po(2)
35394 p(kw,3)=po(3)
35395 END DO
35396c********************************************
35397C transform back into Lab.
35398
35399 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35400
35401C WRITE(6,*)' Lab fram ( fermi incl.) '
35402 N=5
35403 CALL PYEXEC
35404
35405 RETURN
354061001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35407 END
35408
35409*$ CREATE DT_DSIGMA_DELTA.FOR
35410*COPY DT_DSIGMA_DELTA
35411*
35412*===dsigma_delta=======================================================*
35413*
35414 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35415
35416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35417 SAVE
35418
35419C...Reaction nu + N -> lepton + Delta
35420C. returns the cross section
35421C. dsigma/dt
35422C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35423C. QQ = t (always negative) GeV**2
35424C. S = (c.m energy)**2 GeV**2
35425C. OUTPUT = 10**-38 cm+2/GeV**2
35426C-----------------------------------------------------
35427 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35428 DATA MN /0.938/
35429 DATA PI /3.1415926/
35430
35431 GF = (1.1664 * 1.97)
35432 GF2 = GF*GF
35433 MN2 = MN*MN
35434 MN4 = MN2*MN2
35435 MD2 = MD*MD
35436 MD4 = MD2*MD2
35437 AML2 = AML*AML
35438 AML4 = AML2*AML2
35439 VQ = (MN2 - MD2 - QQ)/2.
35440 VPI = (MN2 + MD2 - QQ)/2.
35441 VK = (S + QQ - MN2 - AML2)/2.
35442 PIK = (S - MN2)/2.
35443 QK = (AML2 - QQ)/2.
35444 PIQ = (QQ + MN2 - MD2)/2.
35445 Q = SQRT(-QQ)
35446 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35447 C3 = SQRT(3.)*C3V/MN
35448 C4 = -C3/MD ! attenzione al segno
35449 C5A = 1.18/(1.-QQ/0.4225)**2
35450 C32 = C3**2
35451 C42 = C4**2
35452 C5A2 = C5A**2
35453
35454 IF (LNU .EQ. 1) THEN
35455 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35456 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35457 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35458 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35459 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35460 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35461 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35462 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35463 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35464 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35465 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35466 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35467 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35468 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35469 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35470 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35471 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35472 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35473 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35474 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35475 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35476 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35477 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35478 ELSE
35479 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35480 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35481 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35482 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35483 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35484 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35485 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35486 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35487 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35488 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35489 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35490 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35491 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35492 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35493 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35494 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35495 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35496 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35497 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35498 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35499 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35500 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35501 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35502 ENDIF
35503 ANS1=32.*ANS2
35504 ANS=ANS1/(3.*MD2)
35505 P1CM = (S-MN2)/(2.*SQRT(S))
35506 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35507
35508 RETURN
35509 END
35510
35511*$ CREATE DT_QGAUS.FOR
35512*COPY DT_QGAUS
35513*
35514*===qgaus==============================================================*
35515*
35516 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35517
35518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35519 SAVE
35520
35521 DIMENSION X(5),W(5)
35522 DATA X/.1488743389D0,.4333953941D0,
35523 & .6794095682D0,.8650633666D0,.9739065285D0
35524 */
35525 DATA W/.2955242247D0,.2692667193D0,
35526 & .2190863625D0,.1494513491D0,.0666713443D0
35527 */
35528 XM=0.5D0*(B+A)
35529 XR=0.5D0*(B-A)
35530 SS=0
35531 DO 11 J=1,5
35532 DX=XR*X(J)
35533 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35534 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3553511 CONTINUE
35536 SS=XR*SS
35537
35538 RETURN
35539 END
35540*$ CREATE DT_DIQBRK.FOR
35541*COPY DT_DIQBRK
35542*
35543*===diqbrk=============================================================*
35544*
35545 SUBROUTINE DT_DIQBRK
35546
35547 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35548 SAVE
35549
35550* event history
35551
35552 PARAMETER (NMXHKK=200000)
35553
35554 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35555 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35556 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35557
35558* extended event history
35559 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35560 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35561 & IHIST(2,NMXHKK)
35562
35563* event flag
35564 COMMON /DTEVNO/ NEVENT,ICASCA
35565
35566C IF(DT_RNDM(VV).LE.0.5D0)THEN
35567C CALL GSQBS1(NHKK)
35568C CALL GSQBS2(NHKK)
35569C CALL USQBS1(NHKK)
35570C CALL USQBS2(NHKK)
35571C CALL GSABS1(NHKK)
35572C CALL GSABS2(NHKK)
35573C CALL USABS1(NHKK)
35574C CALL USABS2(NHKK)
35575C ELSE
35576C CALL GSQBS2(NHKK)
35577C CALL GSQBS1(NHKK)
35578C CALL USQBS2(NHKK)
35579C CALL USQBS1(NHKK)
35580C CALL GSABS2(NHKK)
35581C CALL GSABS1(NHKK)
35582C CALL USABS2(NHKK)
35583C CALL USABS1(NHKK)
35584C ENDIF
35585
35586 IF(DT_RNDM(VV).LE.0.5D0) THEN
35587 CALL DT_DBREAK(1)
35588 CALL DT_DBREAK(2)
35589 CALL DT_DBREAK(3)
35590 CALL DT_DBREAK(4)
35591 CALL DT_DBREAK(5)
35592 CALL DT_DBREAK(6)
35593 CALL DT_DBREAK(7)
35594 CALL DT_DBREAK(8)
35595 ELSE
35596 CALL DT_DBREAK(2)
35597 CALL DT_DBREAK(1)
35598 CALL DT_DBREAK(4)
35599 CALL DT_DBREAK(3)
35600 CALL DT_DBREAK(6)
35601 CALL DT_DBREAK(5)
35602 CALL DT_DBREAK(8)
35603 CALL DT_DBREAK(7)
35604 ENDIF
35605
35606 RETURN
35607 END
35608
35609*$ CREATE MUSQBS2.FOR
35610*COPY MUSQBS2
35611C
35612C
35613C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35614 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35615 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35616C
35617C USQBS-2 diagram (split target diquark)
35618C
35619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35620 SAVE
35621
35622 PARAMETER ( LINP = 10 ,
35623 & LOUT = 6 ,
35624 & LDAT = 9 )
35625
35626* event history
35627
35628 PARAMETER (NMXHKK=200000)
35629
35630 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35631 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35632 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35633
35634* extended event history
35635 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35636 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35637 & IHIST(2,NMXHKK)
35638
35639* Lorentz-parameters of the current interaction
35640 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35641 & UMO,PPCM,EPROJ,PPROJ
35642
35643* diquark-breaking mechanism
35644 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35645
35646C
35647 PARAMETER (NTMHKK= 300)
35648 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35649 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35650 +(4,NTMHKK)
35651*KEEP,XSEADI.
35652 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35653 +SSMIMQ,VVMTHR
35654*KEEP,DPRIN.
35655 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35656 COMMON /EVFLAG/ NUMEV
35657C
35658C USQBS-2 diagram (split target diquark)
35659C
35660C
35661C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35662C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35663C
35664C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35665C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35666C
35667C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35668C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35669C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35670C
35671C
35672C Put new chains into COMMON /HKKTMP/
35673C
35674 IIGLU1=NC1T-NC1P-1
35675 IIGLU2=NC2T-NC2P-1
35676 IGCOUN=0
35677C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35678 CVQ=1.D0
35679 IREJ=0
35680 IF(IPIP.EQ.2)THEN
35681C IF(NUMEV.EQ.-324)THEN
35682C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35683C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35684C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35685C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35686 ENDIF
35687C
35688C
35689C
35690C determine x-values of NC1T diquark
35691 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35692 XVQP=PHKK(4,NC1P)*2.D0/UMO
35693C
35694C determine x-values of sea quark pair
35695C
35696 IPCO=1
35697 ICOU=0
35698 2234 CONTINUE
35699 ICOU=ICOU+1
35700 IF(ICOU.GE.500)THEN
35701 IREJ=1
35702 IF(ISQ.EQ.3)IREJ=3
35703 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35704 IPCO=0
35705 RETURN
35706 ENDIF
35707 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35708 * UMO, XDIQT,XVQP
35709 XSQ=0.D0
35710 XSAQ=0.D0
35711**NEW
35712C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35713 IF (IPIP.EQ.1) THEN
35714 XQMAX = XDIQT/2.0D0
35715 XAQMAX = 2.D0*XVQP/3.0D0
35716 ELSE
35717 XQMAX = 2.D0*XVQP/3.0D0
35718 XAQMAX = XDIQT/2.0D0
35719 ENDIF
35720 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35721 ISAQ = 6+ISQ
35722C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35723**
35724 IF(IPCO.GE.3)
35725 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35726 IF(IREJ.GE.1)THEN
35727 IF(IPCO.GE.3)
35728 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35729 IPCO=0
35730 RETURN
35731 ENDIF
35732 IF(IPIP.EQ.1)THEN
35733 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35734 ELSEIF(IPIP.EQ.2)THEN
35735 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35736 ENDIF
35737 IF(IPCO.GE.3)THEN
35738 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35739 & XDIQT,XVQP,XSQ,XSAQ
35740 ENDIF
35741C
35742C subtract xsq,xsaq from NC1T diquark and NC1P quark
35743C
35744C XSQ=0.D0
35745 IF(IPIP.EQ.1)THEN
35746 XDIQT=XDIQT-XSQ
35747 XVQP =XVQP -XSAQ
35748 ELSEIF(IPIP.EQ.2)THEN
35749 XDIQT=XDIQT-XSAQ
35750 XVQP =XVQP -XSQ
35751 ENDIF
35752 IF(IPCO.GE.3)
35753 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35754C
35755C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35756C
35757 XVTHRO=CVQ/UMO
35758 IVTHR=0
35759 3466 CONTINUE
35760 IF(IVTHR.EQ.10)THEN
35761 IREJ=1
35762 IF(ISQ.EQ.3)IREJ=3
35763 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35764 IPCO=0
35765 RETURN
35766 ENDIF
35767 IVTHR=IVTHR+1
35768 XVTHR=XVTHRO/(201-IVTHR)
35769 UNOPRV=UNON
35770 380 CONTINUE
35771 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35772 IREJ=1
35773 IF(ISQ.EQ.3)IREJ=3
35774 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35775 * XVTHR
35776 IPCO=0
35777 RETURN
35778 ENDIF
35779 IF(DT_RNDM(V).LT.0.5D0)THEN
35780 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35781 XVTQII=XDIQT-XVTQI
35782 ELSE
35783 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35784 XVTQI=XDIQT-XVTQII
35785 ENDIF
35786 IF(IPCO.GE.3)THEN
35787 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35788 ENDIF
35789C
35790C Prepare 4 momenta of new chains and chain ends
35791C
35792C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35793C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35794C +(4,NTMHKK)
35795C
35796C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35797C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35798C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35799C
35800C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35801C * IP1,IP21,IP22,IPP1,IPP2)
35802C
35803 IF(IPIP.EQ.1)THEN
35804 XSQ1=XSQ
35805 XSAQ1=XSAQ
35806 ISQ1=ISQ
35807 ISAQ1=ISAQ
35808 ELSEIF(IPIP.EQ.2)THEN
35809 XSQ1=XSAQ
35810 XSAQ1=XSQ
35811 ISQ1=ISAQ
35812 ISAQ1=ISQ
35813 ENDIF
35814 IDHKT(1) =IPP1
35815 ISTHKT(1) =951
35816 JMOHKT(1,1)=NC2P
35817 JMOHKT(2,1)=0
35818 JDAHKT(1,1)=3+IIGLU1
35819 JDAHKT(2,1)=0
35820C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35821 PHKT(1,1) =PHKK(1,NC2P)
35822 PHKT(2,1) =PHKK(2,NC2P)
35823 PHKT(3,1) =PHKK(3,NC2P)
35824 PHKT(4,1) =PHKK(4,NC2P)
35825C PHKT(5,1) =PHKK(5,NC2P)
35826 XMIST =(PHKT(4,1)**2-
35827 * PHKT(3,1)**2-PHKT(2,1)**2-
35828 *PHKT(1,1)**2)
35829 IF(XMIST.GT.0.D0)THEN
35830 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35831 *PHKT(1,1)**2)
35832 ELSE
35833C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35834 PHKT(5,1)=0.D0
35835 ENDIF
35836 VHKT(1,1) =VHKK(1,NC2P)
35837 VHKT(2,1) =VHKK(2,NC2P)
35838 VHKT(3,1) =VHKK(3,NC2P)
35839 VHKT(4,1) =VHKK(4,NC2P)
35840 WHKT(1,1) =WHKK(1,NC2P)
35841 WHKT(2,1) =WHKK(2,NC2P)
35842 WHKT(3,1) =WHKK(3,NC2P)
35843 WHKT(4,1) =WHKK(4,NC2P)
35844C Add here IIGLU1 gluons to this chaina
35845 PG1=0.D0
35846 PG2=0.D0
35847 PG3=0.D0
35848 PG4=0.D0
35849 IF(IIGLU1.GE.1)THEN
35850 JJG=NC1P
35851 DO 61 IIG=2,2+IIGLU1-1
35852 KKG=JJG+IIG-1
35853 IDHKT(IIG) =IDHKK(KKG)
35854 ISTHKT(IIG) =921
35855 JMOHKT(1,IIG)=KKG
35856 JMOHKT(2,IIG)=0
35857 JDAHKT(1,IIG)=3+IIGLU1
35858 JDAHKT(2,IIG)=0
35859 PHKT(1,IIG)=PHKK(1,KKG)
35860 PG1=PG1+ PHKT(1,IIG)
35861 PHKT(2,IIG)=PHKK(2,KKG)
35862 PG2=PG2+ PHKT(2,IIG)
35863 PHKT(3,IIG)=PHKK(3,KKG)
35864 PG3=PG3+ PHKT(3,IIG)
35865 PHKT(4,IIG)=PHKK(4,KKG)
35866 PG4=PG4+ PHKT(4,IIG)
35867 PHKT(5,IIG)=PHKK(5,KKG)
35868 VHKT(1,IIG) =VHKK(1,KKG)
35869 VHKT(2,IIG) =VHKK(2,KKG)
35870 VHKT(3,IIG) =VHKK(3,KKG)
35871 VHKT(4,IIG) =VHKK(4,KKG)
35872 WHKT(1,IIG) =WHKK(1,KKG)
35873 WHKT(2,IIG) =WHKK(2,KKG)
35874 WHKT(3,IIG) =WHKK(3,KKG)
35875 WHKT(4,IIG) =WHKK(4,KKG)
35876 61 CONTINUE
35877 ENDIF
35878 IDHKT(2+IIGLU1) =IP21
35879 ISTHKT(2+IIGLU1) =952
35880 JMOHKT(1,2+IIGLU1)=NC1T
35881 JMOHKT(2,2+IIGLU1)=0
35882 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35883 JDAHKT(2,2+IIGLU1)=0
35884 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35885 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35886 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35887 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35888C PHKT(5,2) =PHKK(5,NC1T)
35889 XMIST =(PHKT(4,2+IIGLU1)**2-
35890 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35891 *PHKT(1,2+IIGLU1)**2)
35892 IF(XMIST.GT.0.D0)THEN
35893 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35894 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35895 *PHKT(1,2+IIGLU1)**2)
35896 ELSE
35897C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35898 PHKT(5,5+IIGLU1)=0.D0
35899 ENDIF
35900 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35901 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35902 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35903 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35904 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35905 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35906 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35907 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35908 IDHKT(3+IIGLU1) =88888
35909 ISTHKT(3+IIGLU1) =95
35910 JMOHKT(1,3+IIGLU1)=1
35911 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35912 JDAHKT(1,3+IIGLU1)=0
35913 JDAHKT(2,3+IIGLU1)=0
35914 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35915 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35916 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35917 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35918 XMIST
35919 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35920 * -PHKT(3,3+IIGLU1)**2)
35921 IF(XMIST.GT.0.D0)THEN
35922 PHKT(5,3+IIGLU1)
35923 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35924 * -PHKT(3,3+IIGLU1)**2)
35925 ELSE
35926C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35927 PHKT(5,5+IIGLU1)=0.D0
35928 ENDIF
35929 IF(IPIP.GE.2)THEN
35930C IF(NUMEV.EQ.-324)THEN
35931C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35932C * JDAHKT(1,1),
35933C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35934 DO 71 IIG=2,2+IIGLU1-1
35935C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35936C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35937C * JDAHKT(1,IIG),
35938C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35939 71 CONTINUE
35940C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35941C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35942C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35943C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35944C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35945C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35946 ENDIF
35947 CHAMAL=CHAM1
35948 IF(IPIP.EQ.1)THEN
35949 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35950 ELSEIF(IPIP.EQ.2)THEN
35951 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35952 ENDIF
35953 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35954C IREJ=1
35955 IPCO=0
35956C RETURN
35957C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35958 GO TO 3466
35959 ENDIF
35960 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35961 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35962 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35963 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35964 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35965 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35966 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35967 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35968 IF(IPIP.EQ.1)THEN
35969 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35970 ELSEIF(IPIP.EQ.2)THEN
35971 IDHKT(4+IIGLU1) =ISAQ1
35972 ENDIF
35973 ISTHKT(4+IIGLU1) =951
35974 JMOHKT(1,4+IIGLU1)=NC1P
35975 JMOHKT(2,4+IIGLU1)=0
35976 JDAHKT(1,4+IIGLU1)=6+IIGLU1
35977 JDAHKT(2,4+IIGLU1)=0
35978C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35979 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
35980 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
35981 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
35982 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
35983C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
35984 XMIST =(PHKT(4,4+IIGLU1)**2-
35985 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35986 *PHKT(1,4+IIGLU1)**2)
35987 IF(XMIST.GT.0.D0)THEN
35988 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
35989 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35990 *PHKT(1,4+IIGLU1)**2)
35991 ELSE
35992C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
35993 PHKT(5,4+IIGLU1)=0.D0
35994 ENDIF
35995 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
35996 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
35997 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
35998 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
35999 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36000 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36001 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36002 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36003 IDHKT(5+IIGLU1) =IP22
36004 ISTHKT(5+IIGLU1) =952
36005 JMOHKT(1,5+IIGLU1)=NC1T
36006 JMOHKT(2,5+IIGLU1)=0
36007 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36008 JDAHKT(2,5+IIGLU1)=0
36009 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36010 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36011 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36012 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36013C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36014 XMIST =(PHKT(4,5+IIGLU1)**2-
36015 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36016 *PHKT(1,5+IIGLU1)**2)
36017 IF(XMIST.GT.0.D0)THEN
36018 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36019 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36020 *PHKT(1,5+IIGLU1)**2)
36021 ELSE
36022C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36023 PHKT(5,5+IIGLU1)=0.D0
36024 ENDIF
36025 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36026 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36027 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36028 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36029 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36030 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36031 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36032 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36033 IDHKT(6+IIGLU1) =88888
36034 ISTHKT(6+IIGLU1) =95
36035 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36036 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36037 JDAHKT(1,6+IIGLU1)=0
36038 JDAHKT(2,6+IIGLU1)=0
36039 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36040 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36041 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36042 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36043 XMIST
36044 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36045 * -PHKT(3,6+IIGLU1)**2)
36046 IF(XMIST.GT.0.D0)THEN
36047 PHKT(5,6+IIGLU1)
36048 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36049 * -PHKT(3,6+IIGLU1)**2)
36050 ELSE
36051C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36052 PHKT(5,5+IIGLU1)=0.D0
36053 ENDIF
36054C IF(IPIP.GE.2)THEN
36055C IF(NUMEV.EQ.-324)THEN
36056C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36057C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36058C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36059C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36060C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36061C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36062C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36063C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36064C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36065C ENDIF
36066 CHAMAL=CHAM1
36067 IF(IPIP.EQ.1)THEN
36068 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36069 ELSEIF(IPIP.EQ.2)THEN
36070 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36071 ENDIF
36072 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36073C IREJ=1
36074 IPCO=0
36075C RETURN
36076C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36077C * CHAMAL,PHKT(5,6+IIGLU1)
36078 GO TO 3466
36079 ENDIF
36080 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36081 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36082 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36083 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36084 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36085 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36086 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36087 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36088C IDHKT(7) =1000*IPP1+100*ISQ+1
36089 IDHKT(7+IIGLU1) =IP1
36090 ISTHKT(7+IIGLU1) =951
36091 JMOHKT(1,7+IIGLU1)=NC1P
36092 JMOHKT(2,7+IIGLU1)=0
36093**NEW
36094C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36095 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36096**
36097 JDAHKT(2,7+IIGLU1)=0
36098 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36099 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36100 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36101 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36102C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36103 XMIST =(PHKT(4,7+IIGLU1)**2-
36104 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36105 *PHKT(1,7+IIGLU1)**2)
36106 IF(XMIST.GT.0.D0)THEN
36107 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36108 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36109 *PHKT(1,7+IIGLU1)**2)
36110 ELSE
36111C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36112 PHKT(5,7+IIGLU1)=0.D0
36113 ENDIF
36114 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36115 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36116 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36117 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36118 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36119 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36120 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36121 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36122C Insert here the IIGLU2 gluons
36123 PG1=0.D0
36124 PG2=0.D0
36125 PG3=0.D0
36126 PG4=0.D0
36127 IF(IIGLU2.GE.1)THEN
36128 JJG=NC2P
36129 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36130 KKG=JJG+IIG-7-IIGLU1
36131 IDHKT(IIG) =IDHKK(KKG)
36132 ISTHKT(IIG) =921
36133 JMOHKT(1,IIG)=KKG
36134 JMOHKT(2,IIG)=0
36135 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36136 JDAHKT(2,IIG)=0
36137 PHKT(1,IIG)=PHKK(1,KKG)
36138 PG1=PG1+ PHKT(1,IIG)
36139 PHKT(2,IIG)=PHKK(2,KKG)
36140 PG2=PG2+ PHKT(2,IIG)
36141 PHKT(3,IIG)=PHKK(3,KKG)
36142 PG3=PG3+ PHKT(3,IIG)
36143 PHKT(4,IIG)=PHKK(4,KKG)
36144 PG4=PG4+ PHKT(4,IIG)
36145 PHKT(5,IIG)=PHKK(5,KKG)
36146 VHKT(1,IIG) =VHKK(1,KKG)
36147 VHKT(2,IIG) =VHKK(2,KKG)
36148 VHKT(3,IIG) =VHKK(3,KKG)
36149 VHKT(4,IIG) =VHKK(4,KKG)
36150 WHKT(1,IIG) =WHKK(1,KKG)
36151 WHKT(2,IIG) =WHKK(2,KKG)
36152 WHKT(3,IIG) =WHKK(3,KKG)
36153 WHKT(4,IIG) =WHKK(4,KKG)
36154 81 CONTINUE
36155 ENDIF
36156 IF(IPIP.EQ.1)THEN
36157 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36158 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36159 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36160 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36161 ELSEIF(IPIP.EQ.2)THEN
36162 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36163 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36164 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36165 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36166 ENDIF
36167 ISTHKT(8+IIGLU1+IIGLU2) =952
36168 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36169 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36170 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36171 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36172 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36173 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36174 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36175 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36176 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36177 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36178 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36179 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36180C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36181C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36182 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36183C IREJ=1
36184C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36185C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36186 IPCO=0
36187C RETURN
36188 GO TO 3466
36189 ENDIF
36190C PHKT(5,8) =PHKK(5,NC2T)
36191 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36192 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36193 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36194 IF(XMIST.GT.0.D0)THEN
36195 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36196 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36197 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36198 ELSE
36199C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36200 PHKT(5,5+IIGLU1)=0.D0
36201 ENDIF
36202 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36203 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36204 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36205 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36206 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36207 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36208 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36209 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36210 IDHKT(9+IIGLU1+IIGLU2) =88888
36211 ISTHKT(9+IIGLU1+IIGLU2) =95
36212 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36213 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36214 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36215 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36216**NEW
36217C PHKT(1,9+IIGLU1+IIGLU2)
36218C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36219C PHKT(2,9+IIGLU1+IIGLU2)
36220C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36221C PHKT(3,9+IIGLU1+IIGLU2)
36222C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36223C PHKT(4,9+IIGLU1+IIGLU2)
36224C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36225 PHKT(1,9+IIGLU1+IIGLU2)
36226 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36227 PHKT(2,9+IIGLU1+IIGLU2)
36228 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36229 PHKT(3,9+IIGLU1+IIGLU2)
36230 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36231 PHKT(4,9+IIGLU1+IIGLU2)
36232 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36233**
36234 XMIST
36235 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36236 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36237 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36238 IF(XMIST.GT.0.D0)THEN
36239 PHKT(5,9+IIGLU1+IIGLU2)
36240 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36241 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36242 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36243 ELSE
36244C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36245 PHKT(5,5+IIGLU1)=0.D0
36246 ENDIF
36247 IF(IPIP.GE.2)THEN
36248C IF(NUMEV.EQ.-324)THEN
36249C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36250C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36251C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36252C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36253C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36254C * JDAHKT(1,IIG),
36255C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36256C 91 CONTINUE
36257C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36258C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36259C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36260C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36261C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36262C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36263C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36264C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36265 ENDIF
36266 CHAMAL=CHAB1
36267 IF(IPIP.EQ.1)THEN
36268 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36269 ELSEIF(IPIP.EQ.2)THEN
36270 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36271 ENDIF
36272 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36273C IREJ=1
36274 IPCO=0
36275C RETURN
36276C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36277C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36278 GO TO 3466
36279 ENDIF
36280 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36281 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36282 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36283 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36284 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36285 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36286 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36287 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36288C
36289 IPCO=0
36290 IGCOUN=9+IIGLU1+IIGLU2
36291 RETURN
36292 END
36293
36294*$ CREATE MGSQBS2.FOR
36295*COPY MGSQBS2
36296C
36297C
36298C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36299 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36300 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36301C
36302C GSQBS-2 diagram (split target diquark)
36303C
36304 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36305 SAVE
36306
36307 PARAMETER ( LINP = 10 ,
36308 & LOUT = 6 ,
36309 & LDAT = 9 )
36310
36311* event history
36312
36313 PARAMETER (NMXHKK=200000)
36314
36315 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36316 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36317 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36318
36319* extended event history
36320 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36321 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36322 & IHIST(2,NMXHKK)
36323
36324* Lorentz-parameters of the current interaction
36325 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36326 & UMO,PPCM,EPROJ,PPROJ
36327
36328* diquark-breaking mechanism
36329 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36330
36331C
36332 PARAMETER (NTMHKK= 300)
36333 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36334 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36335 +(4,NTMHKK)
36336
36337*KEEP,XSEADI.
36338 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36339 +SSMIMQ,VVMTHR
36340*KEEP,DPRIN.
36341 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36342C
36343C GSQBS-2 diagram (split target diquark)
36344C
36345C
36346C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36347C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36348C
36349C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36350C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36351C
36352C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36353C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36354C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36355C
36356C
36357C
36358C Put new chains into COMMON /HKKTMP/
36359C
36360 IIGLU1=NC1T-NC1P-1
36361 IIGLU2=NC2T-NC2P-1
36362 IGCOUN=0
36363C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36364 CVQ=1.D0
36365 IREJ=0
36366C IF(IPIP.EQ.2)THEN
36367C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36368C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36369C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36370C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36371C ENDIF
36372C
36373C
36374C
36375C determine x-values of NC1T diquark
36376 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36377 XVQP=PHKK(4,NC1P)*2.D0/UMO
36378C
36379C determine x-values of sea quark pair
36380C
36381 IPCO=1
36382 ICOU=0
36383 2234 CONTINUE
36384 ICOU=ICOU+1
36385 IF(ICOU.GE.500)THEN
36386 IREJ=1
36387 IF(ISQ.EQ.3)IREJ=3
36388 IF(IPCO.GE.3)
36389 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36390 IPCO=0
36391 RETURN
36392 ENDIF
36393 IF(IPCO.GE.3)
36394 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36395 * UMO, XDIQT,XVQP
36396 XSQ=0.D0
36397 XSAQ=0.D0
36398**NEW
36399C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36400 IF (IPIP.EQ.1) THEN
36401 XQMAX = XDIQT/2.0D0
36402 XAQMAX = 2.D0*XVQP/3.0D0
36403 ELSE
36404 XQMAX = 2.D0*XVQP/3.0D0
36405 XAQMAX = XDIQT/2.0D0
36406 ENDIF
36407 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36408 ISAQ = 6+ISQ
36409C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36410**
36411 IF(IPCO.GE.3)
36412 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36413 IF(IREJ.GE.1)THEN
36414 IF(IPCO.GE.3)
36415 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36416 IPCO=0
36417 RETURN
36418 ENDIF
36419 IF(IPIP.EQ.1)THEN
36420 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36421 ELSEIF(IPIP.EQ.2)THEN
36422 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36423 ENDIF
36424 IF(IPCO.GE.3)THEN
36425 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36426 & XDIQT,XVQP,XSQ,XSAQ
36427 ENDIF
36428C
36429C subtract xsq,xsaq from NC1T diquark and NC1P quark
36430C
36431C XSQ=0.D0
36432 IF(IPIP.EQ.1)THEN
36433 XDIQT=XDIQT-XSQ
36434 XVQP =XVQP -XSAQ
36435 ELSEIF(IPIP.EQ.2)THEN
36436 XDIQT=XDIQT-XSAQ
36437 XVQP =XVQP -XSQ
36438 ENDIF
36439 IF(IPCO.GE.3)
36440 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36441C
36442C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36443C
36444 XVTHRO=CVQ/UMO
36445 IVTHR=0
36446 3466 CONTINUE
36447 IF(IVTHR.EQ.10)THEN
36448 IREJ=1
36449 IF(ISQ.EQ.3)IREJ=3
36450 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36451 IPCO=0
36452 RETURN
36453 ENDIF
36454 IVTHR=IVTHR+1
36455 XVTHR=XVTHRO/(201-IVTHR)
36456 UNOPRV=UNON
36457 380 CONTINUE
36458 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36459 IREJ=1
36460 IF(ISQ.EQ.3)IREJ=3
36461 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36462 * XVTHR
36463 IPCO=0
36464 RETURN
36465 ENDIF
36466 IF(DT_RNDM(V).LT.0.5D0)THEN
36467 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36468 XVTQII=XDIQT-XVTQI
36469 ELSE
36470 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36471 XVTQI=XDIQT-XVTQII
36472 ENDIF
36473 IF(IPCO.GE.3)THEN
36474 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36475 ENDIF
36476C
36477C Prepare 4 momenta of new chains and chain ends
36478C
36479C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36480C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36481C +(4,NTMHKK)
36482C
36483C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36484C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36485C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36486C
36487C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36488C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36489C
36490 IF(IPIP.EQ.1)THEN
36491 XSQ1=XSQ
36492 XSAQ1=XSAQ
36493 ISQ1=ISQ
36494 ISAQ1=ISAQ
36495 ELSEIF(IPIP.EQ.2)THEN
36496 XSQ1=XSAQ
36497 XSAQ1=XSQ
36498 ISQ1=ISAQ
36499 ISAQ1=ISQ
36500 ENDIF
36501 KK11=IP21
36502C IDHKT(1) =1000*IPP11+100*IPP12+1
36503 KK21=IPP11
36504 KK22=IPP12
36505 XGIVE=0.D0
36506 IF(IPIP.EQ.1)THEN
36507 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36508 ELSEIF(IPIP.EQ.2)THEN
36509 IDHKT(4+IIGLU1) =ISAQ1
36510 ENDIF
36511 ISTHKT(4+IIGLU1) =961
36512 JMOHKT(1,4+IIGLU1)=NC1P
36513 JMOHKT(2,4+IIGLU1)=0
36514 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36515 JDAHKT(2,4+IIGLU1)=0
36516C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36517 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36518 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36519 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36520 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36521C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36522 XXMIST=(PHKT(4,4+IIGLU1)**2-
36523 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36524 *PHKT(1,4+IIGLU1)**2)
36525 IF(XXMIST.GT.0.D0)THEN
36526 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36527 ELSE
36528 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36529 XXMIST=ABS(XXMIST)
36530 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36531 ENDIF
36532 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36533 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36534 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36535 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36536 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36537 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36538 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36539 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36540 IDHKT(5+IIGLU1) =IP22
36541 ISTHKT(5+IIGLU1) =962
36542 JMOHKT(1,5+IIGLU1)=NC1T
36543 JMOHKT(2,5+IIGLU1)=0
36544 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36545 JDAHKT(2,5+IIGLU1)=0
36546 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36547 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36548 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36549 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36550C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36551 XXMIST=(PHKT(4,5+IIGLU1)**2-
36552 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36553 *PHKT(1,5+IIGLU1)**2)
36554 IF(XXMIST.GT.0.D0)THEN
36555 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36556 ELSE
36557 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36558 XXMIST=ABS(XXMIST)
36559 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36560 ENDIF
36561 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36562 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36563 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36564 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36565 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36566 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36567 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36568 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36569 IDHKT(6+IIGLU1) =88888
36570 ISTHKT(6+IIGLU1) =96
36571 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36572 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36573 JDAHKT(1,6+IIGLU1)=0
36574 JDAHKT(2,6+IIGLU1)=0
36575 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36576 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36577 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36578 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36579 PHKT(5,6+IIGLU1)
36580 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36581 * -PHKT(3,6+IIGLU1)**2)
36582 CHAMAL=CHAM1
36583 IF(IPIP.EQ.1)THEN
36584 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36585 ELSEIF(IPIP.EQ.2)THEN
36586 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36587 ENDIF
36588C---------------------------------------------------
36589 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36590 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36591C we drop chain 6 and give the energy to chain 3
36592 IDHKT(6+IIGLU1)=22888
36593 XGIVE=1.D0
36594C WRITE(6,*)' drop chain 6 xgive=1'
36595 GO TO 7788
36596 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36597C we drop chain 6 and give the energy to chain 3
36598C and change KK11 to IDHKT(5)
36599 IDHKT(6+IIGLU1)=22888
36600 XGIVE=1.D0
36601C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36602 KK11=IDHKT(5+IIGLU1)
36603 GO TO 7788
36604 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36605C we drop chain 6 and give the energy to chain 3
36606C and change KK21 to IDHKT(5+IIGLU1)
36607C IDHKT(1) =1000*IPP11+100*IPP12+1
36608 IDHKT(6+IIGLU1)=22888
36609 XGIVE=1.D0
36610C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36611 KK21=IDHKT(5+IIGLU1)
36612 GO TO 7788
36613 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36614C we drop chain 6 and give the energy to chain 3
36615C and change KK22 to IDHKT(5)
36616C IDHKT(1) =1000*IPP11+100*IPP12+1
36617 IDHKT(6+IIGLU1)=22888
36618 XGIVE=1.D0
36619C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36620 KK22=IDHKT(5+IIGLU1)
36621 GO TO 7788
36622 ENDIF
36623C IREJ=1
36624 IPCO=0
36625C RETURN
36626 GO TO 3466
36627 ENDIF
36628 7788 CONTINUE
36629C---------------------------------------------------
36630 IF(IPIP.GE.3)THEN
36631 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36632 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36633 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36634 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36635 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36636 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36637 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36638 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36639 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36640 ENDIF
36641 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36642 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36643 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36644 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36645 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36646 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36647 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36648 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36649C IDHKT(1) =1000*IPP11+100*IPP12+1
36650 IF(IPIP.EQ.1)THEN
36651 IDHKT(1) =1000*KK21+100*KK22+3
36652 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36653 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36654 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36655 ELSEIF(IPIP.EQ.2)THEN
36656 IDHKT(1) =1000*KK21+100*KK22-3
36657 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36658 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36659 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36660 ENDIF
36661 ISTHKT(1) =961
36662 JMOHKT(1,1)=NC2P
36663 JMOHKT(2,1)=0
36664 JDAHKT(1,1)=3+IIGLU1
36665 JDAHKT(2,1)=0
36666C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36667 PHKT(1,1) =PHKK(1,NC2P)
36668 *+XGIVE*PHKT(1,4+IIGLU1)
36669 PHKT(2,1) =PHKK(2,NC2P)
36670 *+XGIVE*PHKT(2,4+IIGLU1)
36671 PHKT(3,1) =PHKK(3,NC2P)
36672 *+XGIVE*PHKT(3,4+IIGLU1)
36673 PHKT(4,1) =PHKK(4,NC2P)
36674 *+XGIVE*PHKT(4,4+IIGLU1)
36675C PHKT(5,1) =PHKK(5,NC2P)
36676 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36677 *PHKT(1,1)**2
36678 IF(XXMIST.GT.0.D0)THEN
36679 PHKT(5,1) =SQRT(XXMIST)
36680 ELSE
36681 WRITE(LOUT,*)'MGSQBS2',XXMIST
36682 XXMIST=ABS(XXMIST)
36683 PHKT(5,1) =SQRT(XXMIST)
36684 ENDIF
36685 VHKT(1,1) =VHKK(1,NC2P)
36686 VHKT(2,1) =VHKK(2,NC2P)
36687 VHKT(3,1) =VHKK(3,NC2P)
36688 VHKT(4,1) =VHKK(4,NC2P)
36689 WHKT(1,1) =WHKK(1,NC2P)
36690 WHKT(2,1) =WHKK(2,NC2P)
36691 WHKT(3,1) =WHKK(3,NC2P)
36692 WHKT(4,1) =WHKK(4,NC2P)
36693C Add here IIGLU1 gluons to this chaina
36694 PG1=0.D0
36695 PG2=0.D0
36696 PG3=0.D0
36697 PG4=0.D0
36698 IF(IIGLU1.GE.1)THEN
36699 JJG=NC1P
36700 DO 61 IIG=2,2+IIGLU1-1
36701 KKG=JJG+IIG-1
36702 IDHKT(IIG) =IDHKK(KKG)
36703 ISTHKT(IIG) =921
36704 JMOHKT(1,IIG)=KKG
36705 JMOHKT(2,IIG)=0
36706 JDAHKT(1,IIG)=3+IIGLU1
36707 JDAHKT(2,IIG)=0
36708 PHKT(1,IIG)=PHKK(1,KKG)
36709 PG1=PG1+ PHKT(1,IIG)
36710 PHKT(2,IIG)=PHKK(2,KKG)
36711 PG2=PG2+ PHKT(2,IIG)
36712 PHKT(3,IIG)=PHKK(3,KKG)
36713 PG3=PG3+ PHKT(3,IIG)
36714 PHKT(4,IIG)=PHKK(4,KKG)
36715 PG4=PG4+ PHKT(4,IIG)
36716 PHKT(5,IIG)=PHKK(5,KKG)
36717 VHKT(1,IIG) =VHKK(1,KKG)
36718 VHKT(2,IIG) =VHKK(2,KKG)
36719 VHKT(3,IIG) =VHKK(3,KKG)
36720 VHKT(4,IIG) =VHKK(4,KKG)
36721 WHKT(1,IIG) =WHKK(1,KKG)
36722 WHKT(2,IIG) =WHKK(2,KKG)
36723 WHKT(3,IIG) =WHKK(3,KKG)
36724 WHKT(4,IIG) =WHKK(4,KKG)
36725 61 CONTINUE
36726 ENDIF
36727C IDHKT(2) =IP21
36728 IDHKT(2+IIGLU1) =KK11
36729 ISTHKT(2+IIGLU1) =962
36730 JMOHKT(1,2+IIGLU1)=NC1T
36731 JMOHKT(2,2+IIGLU1)=0
36732 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36733 JDAHKT(2,2+IIGLU1)=0
36734 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36735C * +0.5D0*PHKK(1,NC2T)
36736 *+XGIVE*PHKT(1,5+IIGLU1)
36737 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36738C *+0.5D0*PHKK(2,NC2T)
36739 *+XGIVE*PHKT(2,5+IIGLU1)
36740 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36741C *+0.5D0*PHKK(3,NC2T)
36742 *+XGIVE*PHKT(3,5+IIGLU1)
36743 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36744C *+0.5D0*PHKK(4,NC2T)
36745 *+XGIVE*PHKT(4,5+IIGLU1)
36746C PHKT(5,2) =PHKK(5,NC1T)
36747 XXMIST=(PHKT(4,2+IIGLU1)**2-
36748 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36749 *PHKT(1,2+IIGLU1)**2)
36750 IF(XXMIST.GT.0.D0)THEN
36751 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36752 ELSE
36753 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36754 XXMIST=ABS(XXMIST)
36755 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36756 ENDIF
36757 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36758 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36759 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36760 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36761 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36762 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36763 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36764 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36765 IDHKT(3+IIGLU1) =88888
36766 ISTHKT(3+IIGLU1) =96
36767 JMOHKT(1,3+IIGLU1)=1
36768 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36769 JDAHKT(1,3+IIGLU1)=0
36770 JDAHKT(2,3+IIGLU1)=0
36771 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36772 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36773 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36774 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36775 PHKT(5,3+IIGLU1)
36776 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36777 * -PHKT(3,3+IIGLU1)**2)
36778 IF(IPIP.EQ.3)THEN
36779 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36780 * JDAHKT(1,1),
36781 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36782 DO 71 IIG=2,2+IIGLU1-1
36783 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36784 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36785 * JDAHKT(1,IIG),
36786 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36787 71 CONTINUE
36788 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36789 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36790 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36791 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36792 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36793 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36794 ENDIF
36795 CHAMAL=CHAB1
36796 IF(IPIP.EQ.1)THEN
36797 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36798 ELSEIF(IPIP.EQ.2)THEN
36799 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36800 ENDIF
36801 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36802C IREJ=1
36803 IPCO=0
36804C RETURN
36805 GO TO 3466
36806 ENDIF
36807 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36808 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36809 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36810 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36811 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36812 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36813 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36814 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36815C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36816 IDHKT(7+IIGLU1) =IP1
36817 ISTHKT(7+IIGLU1) =961
36818 JMOHKT(1,7+IIGLU1)=NC1P
36819 JMOHKT(2,7+IIGLU1)=0
36820 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36821 JDAHKT(2,7+IIGLU1)=0
36822 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36823 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36824 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36825 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36826C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36827 XXMIST=(PHKT(4,7+IIGLU1)**2-
36828 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36829 *PHKT(1,7+IIGLU1)**2)
36830 IF(XXMIST.GT.0.D0)THEN
36831 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36832 ELSE
36833 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36834 XXMIST=ABS(XXMIST)
36835 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36836 ENDIF
36837 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36838 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36839 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36840 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36841 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36842 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36843 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36844 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36845C IDHKT(7) =1000*IPP1+100*ISQ+1
36846C Insert here the IIGLU2 gluons
36847 PG1=0.D0
36848 PG2=0.D0
36849 PG3=0.D0
36850 PG4=0.D0
36851 IF(IIGLU2.GE.1)THEN
36852 JJG=NC2P
36853 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36854 KKG=JJG+IIG-7-IIGLU1
36855 IDHKT(IIG) =IDHKK(KKG)
36856 ISTHKT(IIG) =921
36857 JMOHKT(1,IIG)=KKG
36858 JMOHKT(2,IIG)=0
36859 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36860 JDAHKT(2,IIG)=0
36861 PHKT(1,IIG)=PHKK(1,KKG)
36862 PG1=PG1+ PHKT(1,IIG)
36863 PHKT(2,IIG)=PHKK(2,KKG)
36864 PG2=PG2+ PHKT(2,IIG)
36865 PHKT(3,IIG)=PHKK(3,KKG)
36866 PG3=PG3+ PHKT(3,IIG)
36867 PHKT(4,IIG)=PHKK(4,KKG)
36868 PG4=PG4+ PHKT(4,IIG)
36869 PHKT(5,IIG)=PHKK(5,KKG)
36870 VHKT(1,IIG) =VHKK(1,KKG)
36871 VHKT(2,IIG) =VHKK(2,KKG)
36872 VHKT(3,IIG) =VHKK(3,KKG)
36873 VHKT(4,IIG) =VHKK(4,KKG)
36874 WHKT(1,IIG) =WHKK(1,KKG)
36875 WHKT(2,IIG) =WHKK(2,KKG)
36876 WHKT(3,IIG) =WHKK(3,KKG)
36877 WHKT(4,IIG) =WHKK(4,KKG)
36878 81 CONTINUE
36879 ENDIF
36880 IF(IPIP.EQ.1)THEN
36881 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36882 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36883 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36884 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36885 ELSEIF(IPIP.EQ.2)THEN
36886**NEW
36887C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36888 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36889**
36890 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36891 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36892 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36893 ENDIF
36894 ISTHKT(8+IIGLU1+IIGLU2) =962
36895 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36896 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36897 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36898 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36899C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36900C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36901C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36902C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36903 PHKT(1,8+IIGLU1+IIGLU2) =
36904 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36905 PHKT(2,8+IIGLU1+IIGLU2) =
36906 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36907 PHKT(3,8+IIGLU1+IIGLU2) =
36908 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36909 PHKT(4,8+IIGLU1+IIGLU2) =
36910 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36911C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36912C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36913 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36914C IREJ=1
36915C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36916 IPCO=0
36917C RETURN
36918 GO TO 3466
36919 ENDIF
36920C PHKT(5,8) =PHKK(5,NC2T)
36921 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36922 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36923 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36924 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36925 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36926 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36927 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36928 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36929 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36930 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36931 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36932 IDHKT(9+IIGLU1+IIGLU2) =88888
36933 ISTHKT(9+IIGLU1+IIGLU2) =96
36934 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36935 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36936 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36937 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36938 PHKT(1,9+IIGLU1+IIGLU2)
36939 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36940 PHKT(2,9+IIGLU1+IIGLU2)
36941 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36942 PHKT(3,9+IIGLU1+IIGLU2)
36943 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36944 PHKT(4,9+IIGLU1+IIGLU2)
36945 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36946 PHKT(5,9+IIGLU1+IIGLU2)
36947 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36948 * PHKT(2,9+IIGLU1+IIGLU2)**2
36949 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36950 IF(IPIP.GE.3)THEN
36951 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36952 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36953 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36954 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36955 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36956 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36957 * JDAHKT(1,IIG),
36958 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36959 91 CONTINUE
36960 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36961 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36962 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36963 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36964 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36965 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36966 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36967 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36968 ENDIF
36969 CHAMAL=CHAB1
36970 IF(IPIP.EQ.1)THEN
36971 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36972 ELSEIF(IPIP.EQ.2)THEN
36973 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36974 ENDIF
36975 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36976C IREJ=1
36977 IPCO=0
36978C RETURN
36979 GO TO 3466
36980 ENDIF
36981 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36982 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36983 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36984 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36985 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36986 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36987 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36988 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36989C
36990 IPCO=0
36991 IGCOUN=9+IIGLU1+IIGLU2
36992 RETURN
36993 END
36994
36995*$ CREATE MUSQBS1.FOR
36996*COPY MUSQBS1
36997C
36998C
36999C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37000 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37001 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37002C
37003C USQBS-1 diagram (split projectile diquark)
37004C
37005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37006 SAVE
37007
37008 PARAMETER ( LINP = 10 ,
37009 & LOUT = 6 ,
37010 & LDAT = 9 )
37011
37012* event history
37013
37014 PARAMETER (NMXHKK=200000)
37015
37016 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37017 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37018 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37019
37020* extended event history
37021 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37022 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37023 & IHIST(2,NMXHKK)
37024
37025* Lorentz-parameters of the current interaction
37026 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37027 & UMO,PPCM,EPROJ,PPROJ
37028
37029* diquark-breaking mechanism
37030 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37031
37032C
37033 PARAMETER (NTMHKK= 300)
37034 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37035 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37036 +(4,NTMHKK)
37037*KEEP,XSEADI.
37038 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37039 +SSMIMQ,VVMTHR
37040*KEEP,DPRIN.
37041 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37042 COMMON /EVFLAG/ NUMEV
37043C
37044C USQBS-1 diagram (split projectile diquark)
37045C
37046C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37047C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37048C
37049C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37050C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37051C
37052C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37053C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37054C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37055C
37056C Put new chains into COMMON /HKKTMP/
37057C
37058 IIGLU1=NC1T-NC1P-1
37059 IIGLU2=NC2T-NC2P-1
37060 IGCOUN=0
37061C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37062 CVQ=1.D0
37063 IREJ=0
37064 IF(IPIP.EQ.3)THEN
37065C IF(NUMEV.EQ.-324)THEN
37066 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37067 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37068 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37069 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37070 ENDIF
37071C
37072C
37073C
37074C determine x-values of NC1P diquark
37075 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37076 XVQT=PHKK(4,NC1T)*2.D0/UMO
37077C
37078C determine x-values of sea quark pair
37079C
37080 IPCO=1
37081 ICOU=0
37082 2234 CONTINUE
37083 ICOU=ICOU+1
37084 IF(ICOU.GE.500)THEN
37085 IREJ=1
37086 IF(ISQ.EQ.3)IREJ=3
37087 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37088 IPCO=0
37089 RETURN
37090 ENDIF
37091 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37092 * UMO, XDIQP,XVQT
37093 XSQ=0.D0
37094 XSAQ=0.D0
37095**NEW
37096C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37097 IF (IPIP.EQ.1) THEN
37098 XQMAX = XDIQP/2.0D0
37099 XAQMAX = 2.D0*XVQT/3.0D0
37100 ELSE
37101 XQMAX = 2.D0*XVQT/3.0D0
37102 XAQMAX = XDIQP/2.0D0
37103 ENDIF
37104 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37105 ISAQ = 6+ISQ
37106C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37107**
37108 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37109 IF(IREJ.GE.1)THEN
37110 IF(IPCO.GE.3)
37111 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37112 IPCO=0
37113 RETURN
37114 ENDIF
37115 IF(IPIP.EQ.1)THEN
37116 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37117 ELSEIF(IPIP.EQ.2)THEN
37118 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37119 ENDIF
37120 IF(IPCO.GE.3)THEN
37121 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37122 & XDIQP,XVQT,XSQ,XSAQ
37123 ENDIF
37124C
37125C subtract xsq,xsaq from NC1P diquark and NC1T quark
37126C
37127C XSQ=0.D0
37128 IF(IPIP.EQ.1)THEN
37129 XDIQP=XDIQP-XSQ
37130 XVQT =XVQT -XSAQ
37131 ELSEIF(IPIP.EQ.2)THEN
37132 XDIQP=XDIQP-XSAQ
37133 XVQT =XVQT -XSQ
37134 ENDIF
37135 IF(IPCO.GE.3)
37136 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37137C
37138C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37139C
37140 XVTHRO=CVQ/UMO
37141 IVTHR=0
37142 3466 CONTINUE
37143 IF(IVTHR.EQ.10)THEN
37144 IREJ=1
37145 IF(ISQ.EQ.3)IREJ=3
37146 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37147 IPCO=0
37148 RETURN
37149 ENDIF
37150 IVTHR=IVTHR+1
37151 XVTHR=XVTHRO/(201-IVTHR)
37152 UNOPRV=UNON
37153 380 CONTINUE
37154 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37155 IREJ=1
37156 IF(ISQ.EQ.3)IREJ=3
37157 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37158 * XVTHR
37159 IPCO=0
37160 RETURN
37161 ENDIF
37162 IF(DT_RNDM(V).LT.0.5D0)THEN
37163 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37164 XVPQII=XDIQP-XVPQI
37165 ELSE
37166 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37167 XVPQI=XDIQP-XVPQII
37168 ENDIF
37169 IF(IPCO.GE.3)THEN
37170 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37171 ENDIF
37172C
37173C Prepare 4 momenta of new chains and chain ends
37174C
37175C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37176C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37177C +(4,NTMHKK)
37178C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37179C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37180C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37181 IF(IPIP.EQ.1)THEN
37182 XSQ1=XSQ
37183 XSAQ1=XSAQ
37184 ISQ1=ISQ
37185 ISAQ1=ISAQ
37186 ELSEIF(IPIP.EQ.2)THEN
37187 XSQ1=XSAQ
37188 XSAQ1=XSQ
37189 ISQ1=ISAQ
37190 ISAQ1=ISQ
37191 ENDIF
37192 IDHKT(1) =IP11
37193 ISTHKT(1) =931
37194 JMOHKT(1,1)=NC1P
37195 JMOHKT(2,1)=0
37196 JDAHKT(1,1)=3+IIGLU1
37197 JDAHKT(2,1)=0
37198C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37199 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37200 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37201 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37202 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37203C PHKT(5,1) =PHKK(5,NC1P)
37204 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37205 *PHKT(1,1)**2)
37206 IF(XMIST.GE.0.D0)THEN
37207 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37208 *PHKT(1,1)**2)
37209 ELSE
37210C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37211 PHKT(5,1)=0.D0
37212 ENDIF
37213 VHKT(1,1) =VHKK(1,NC1P)
37214 VHKT(2,1) =VHKK(2,NC1P)
37215 VHKT(3,1) =VHKK(3,NC1P)
37216 VHKT(4,1) =VHKK(4,NC1P)
37217 WHKT(1,1) =WHKK(1,NC1P)
37218 WHKT(2,1) =WHKK(2,NC1P)
37219 WHKT(3,1) =WHKK(3,NC1P)
37220 WHKT(4,1) =WHKK(4,NC1P)
37221C Add here IIGLU1 gluons to this chaina
37222 PG1=0.D0
37223 PG2=0.D0
37224 PG3=0.D0
37225 PG4=0.D0
37226 IF(IIGLU1.GE.1)THEN
37227 JJG=NC1P
37228 DO 61 IIG=2,2+IIGLU1-1
37229 KKG=JJG+IIG-1
37230 IDHKT(IIG) =IDHKK(KKG)
37231 ISTHKT(IIG) =921
37232 JMOHKT(1,IIG)=KKG
37233 JMOHKT(2,IIG)=0
37234 JDAHKT(1,IIG)=3+IIGLU1
37235 JDAHKT(2,IIG)=0
37236 PHKT(1,IIG)=PHKK(1,KKG)
37237 PG1=PG1+ PHKT(1,IIG)
37238 PHKT(2,IIG)=PHKK(2,KKG)
37239 PG2=PG2+ PHKT(2,IIG)
37240 PHKT(3,IIG)=PHKK(3,KKG)
37241 PG3=PG3+ PHKT(3,IIG)
37242 PHKT(4,IIG)=PHKK(4,KKG)
37243 PG4=PG4+ PHKT(4,IIG)
37244 PHKT(5,IIG)=PHKK(5,KKG)
37245 VHKT(1,IIG) =VHKK(1,KKG)
37246 VHKT(2,IIG) =VHKK(2,KKG)
37247 VHKT(3,IIG) =VHKK(3,KKG)
37248 VHKT(4,IIG) =VHKK(4,KKG)
37249 WHKT(1,IIG) =WHKK(1,KKG)
37250 WHKT(2,IIG) =WHKK(2,KKG)
37251 WHKT(3,IIG) =WHKK(3,KKG)
37252 WHKT(4,IIG) =WHKK(4,KKG)
37253 61 CONTINUE
37254 ENDIF
37255 IDHKT(2+IIGLU1) =IPP2
37256 ISTHKT(2+IIGLU1) =932
37257 JMOHKT(1,2+IIGLU1)=NC2T
37258 JMOHKT(2,2+IIGLU1)=0
37259 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37260 JDAHKT(2,2+IIGLU1)=0
37261 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37262 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37263 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37264 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37265C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37266 XMIST=(PHKT(4,2+IIGLU1)**2-
37267 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37268 *PHKT(1,2+IIGLU1)**2)
37269 IF(XMIST.GT.0.D0)THEN
37270 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37271 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37272 *PHKT(1,2+IIGLU1)**2)
37273 ELSE
37274C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37275 PHKT(5,2+IIGLU1)=0.D0
37276 ENDIF
37277 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37278 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37279 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37280 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37281 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37282 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37283 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37284 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37285 IDHKT(3+IIGLU1) =88888
37286 ISTHKT(3+IIGLU1) =94
37287 JMOHKT(1,3+IIGLU1)=1
37288 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37289 JDAHKT(1,3+IIGLU1)=0
37290 JDAHKT(2,3+IIGLU1)=0
37291 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37292 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37293 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37294 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37295 XMIST
37296 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37297 * -PHKT(3,3+IIGLU1)**2)
37298 IF(XMIST.GE.0.D0)THEN
37299 PHKT(5,3+IIGLU1)
37300 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37301 * -PHKT(3,3+IIGLU1)**2)
37302 ELSE
37303C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37304 PHKT(5,1)=0.D0
37305 ENDIF
37306 IF(IPIP.GE.3)THEN
37307C IF(NUMEV.EQ.-324)THEN
37308 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37309 * JMOHKT(2,1),JDAHKT(1,1),
37310 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37311 DO 71 IIG=2,2+IIGLU1-1
37312 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37313 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37314 * JDAHKT(1,IIG),
37315 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37316 71 CONTINUE
37317 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37318 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37319 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37320 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37321 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37322 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37323 ENDIF
37324 CHAMAL=CHAM1
37325 IF(IPIP.EQ.1)THEN
37326 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37327 ELSEIF(IPIP.EQ.2)THEN
37328 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37329 ENDIF
37330 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37331C IREJ=1
37332 IPCO=0
37333C RETURN
37334C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37335 GO TO 3466
37336 ENDIF
37337 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37338 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37339 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37340 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37341 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37342 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37343 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37344 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37345 IDHKT(4+IIGLU1) =IP12
37346 ISTHKT(4+IIGLU1) =931
37347 JMOHKT(1,4+IIGLU1)=NC1P
37348 JMOHKT(2,4+IIGLU1)=0
37349 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37350 JDAHKT(2,4+IIGLU1)=0
37351C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37352 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37353 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37354 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37355 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37356C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37357 XMIST =(PHKT(4,4+IIGLU1)**2-
37358 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37359 *PHKT(1,4+IIGLU1)**2)
37360 IF(XMIST.GT.0.D0)THEN
37361 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37362 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37363 *PHKT(1,4+IIGLU1)**2)
37364 ELSE
37365C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37366 PHKT(5,4+IIGLU1)=0.D0
37367 ENDIF
37368 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37369 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37370 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37371 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37372 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37373 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37374 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37375 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37376 IF(IPIP.EQ.1)THEN
37377 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37378 ELSEIF(IPIP.EQ.2)THEN
37379 IDHKT(5+IIGLU1) =ISAQ1
37380 ENDIF
37381 ISTHKT(5+IIGLU1) =932
37382 JMOHKT(1,5+IIGLU1)=NC1T
37383 JMOHKT(2,5+IIGLU1)=0
37384 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37385 JDAHKT(2,5+IIGLU1)=0
37386 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37387 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37388 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37389 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37390C IF( PHKT(4,5).EQ.0.D0)THEN
37391C IREJ=1
37392CIPCO=0
37393CRETURN
37394C ENDIF
37395C PHKT(5,5) =PHKK(5,NC1T)
37396 XMIST=(PHKT(4,5+IIGLU1)**2-
37397 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37398 *PHKT(1,5+IIGLU1)**2)
37399 IF(XMIST.GT.0.D0)THEN
37400 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37401 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37402 *PHKT(1,5+IIGLU1)**2)
37403 ELSE
37404C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37405 PHKT(5,5+IIGLU1)=0.D0
37406 ENDIF
37407 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37408 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37409 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37410 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37411 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37412 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37413 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37414 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37415 IDHKT(6+IIGLU1) =88888
37416 ISTHKT(6+IIGLU1) =94
37417 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37418 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37419 JDAHKT(1,6+IIGLU1)=0
37420 JDAHKT(2,6+IIGLU1)=0
37421 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37422 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37423 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37424 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37425 XMIST
37426 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37427 * -PHKT(3,6+IIGLU1)**2)
37428 IF(XMIST.GE.0.D0)THEN
37429 PHKT(5,6+IIGLU1)
37430 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37431 * -PHKT(3,6+IIGLU1)**2)
37432 ELSE
37433C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37434 PHKT(5,1)=0.D0
37435 ENDIF
37436C IF(IPIP.EQ.3)THEN
37437 CHAMAL=CHAM1
37438 IF(IPIP.EQ.1)THEN
37439 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37440 ELSEIF(IPIP.EQ.2)THEN
37441 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37442 ENDIF
37443 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37444C IREJ=1
37445 IPCO=0
37446C RETURN
37447C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37448C & CHAMAL,PHKT(5,6+IIGLU1)
37449 GO TO 3466
37450 ENDIF
37451 IF(IPIP.GE.3)THEN
37452C IF(NUMEV.EQ.-324)THEN
37453 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37454 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37455 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37456 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37457 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37458 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37459 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37460 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37461 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37462 ENDIF
37463 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37464 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37465 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37466 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37467 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37468 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37469 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37470 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37471 IF(IPIP.EQ.1)THEN
37472 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37473 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37474 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37475 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37476 ELSEIF(IPIP.EQ.2)THEN
37477 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37478 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37479 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37480 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37481C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37482 ENDIF
37483 ISTHKT(7+IIGLU1) =931
37484 JMOHKT(1,7+IIGLU1)=NC2P
37485 JMOHKT(2,7+IIGLU1)=0
37486 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37487 JDAHKT(2,7+IIGLU1)=0
37488C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37489 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37490 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37491 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37492 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37493C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37494C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37495 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37496C IREJ=1
37497C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37498 IPCO=0
37499C RETURN
37500 GO TO 3466
37501 ENDIF
37502C PHKT(5,7) =PHKK(5,NC2P)
37503 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37504 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37505 *PHKT(1,7+IIGLU1)**2)
37506 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37507 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37508 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37509 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37510 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37511 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37512 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37513 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37514C Insert here the IIGLU2 gluons
37515 PG1=0.D0
37516 PG2=0.D0
37517 PG3=0.D0
37518 PG4=0.D0
37519 IF(IIGLU2.GE.1)THEN
37520 JJG=NC2P
37521 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37522 KKG=JJG+IIG-7-IIGLU1
37523 IDHKT(IIG) =IDHKK(KKG)
37524 ISTHKT(IIG) =921
37525 JMOHKT(1,IIG)=KKG
37526 JMOHKT(2,IIG)=0
37527 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37528 JDAHKT(2,IIG)=0
37529 PHKT(1,IIG)=PHKK(1,KKG)
37530 PG1=PG1+ PHKT(1,IIG)
37531 PHKT(2,IIG)=PHKK(2,KKG)
37532 PG2=PG2+ PHKT(2,IIG)
37533 PHKT(3,IIG)=PHKK(3,KKG)
37534 PG3=PG3+ PHKT(3,IIG)
37535 PHKT(4,IIG)=PHKK(4,KKG)
37536 PG4=PG4+ PHKT(4,IIG)
37537 PHKT(5,IIG)=PHKK(5,KKG)
37538 VHKT(1,IIG) =VHKK(1,KKG)
37539 VHKT(2,IIG) =VHKK(2,KKG)
37540 VHKT(3,IIG) =VHKK(3,KKG)
37541 VHKT(4,IIG) =VHKK(4,KKG)
37542 WHKT(1,IIG) =WHKK(1,KKG)
37543 WHKT(2,IIG) =WHKK(2,KKG)
37544 WHKT(3,IIG) =WHKK(3,KKG)
37545 WHKT(4,IIG) =WHKK(4,KKG)
37546 81 CONTINUE
37547 ENDIF
37548 IDHKT(8+IIGLU1+IIGLU2) =IP2
37549 ISTHKT(8+IIGLU1+IIGLU2) =932
37550 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37551 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37552 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37553 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37554 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37555 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37556 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37557 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37558C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37559 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37560 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37561 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37562 IF(XMIST.GT.0.D0)THEN
37563 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37564 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37565 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37566 ELSE
37567C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37568 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37569 ENDIF
37570 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37571 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37572 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37573 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37574 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37575 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37576 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37577 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37578 IDHKT(9+IIGLU1+IIGLU2) =88888
37579 ISTHKT(9+IIGLU1+IIGLU2) =94
37580 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37581 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37582 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37583 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37584 PHKT(1,9+IIGLU1+IIGLU2)
37585 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37586 PHKT(2,9+IIGLU1+IIGLU2)
37587 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37588 PHKT(3,9+IIGLU1+IIGLU2)
37589 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37590 PHKT(4,9+IIGLU1+IIGLU2)
37591 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37592 XMIST
37593 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37594 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37595 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37596 IF(XMIST.GE.0.D0)THEN
37597 PHKT(5,9+IIGLU1+IIGLU2)
37598 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37599 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37600 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37601 ELSE
37602C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37603 PHKT(5,1)=0.D0
37604 ENDIF
37605 IF(IPIP.GE.3)THEN
37606C IF(NUMEV.EQ.-324)THEN
37607 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37608 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37609 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37610 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37611 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37612 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37613 * JDAHKT(1,IIG),
37614 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37615 91 CONTINUE
37616 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37617 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37618 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37619 *JDAHKT(1,8+IIGLU1+IIGLU2),
37620 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37621 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37622 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37623 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37624 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37625 ENDIF
37626 CHAMAL=CHAB1
37627 IF(IPIP.EQ.1)THEN
37628 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37629 ELSEIF(IPIP.EQ.2)THEN
37630 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37631 ENDIF
37632 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37633C IREJ=1
37634 IPCO=0
37635C RETURN
37636C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37637C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37638 GO TO 3466
37639 ENDIF
37640 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37641 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37642 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37643 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37644 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37645 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37646 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37647 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37648C
37649 IPCO=0
37650 IGCOUN=9+IIGLU1+IIGLU2
37651 RETURN
37652 END
37653
37654*$ CREATE MGSQBS1.FOR
37655*COPY MGSQBS1
37656C
37657C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37658 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37659 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37660C
37661C GSQBS-1 diagram (split projectile diquark)
37662C
37663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37664 SAVE
37665
37666 PARAMETER ( LINP = 10 ,
37667 & LOUT = 6 ,
37668 & LDAT = 9 )
37669
37670* event history
37671
37672 PARAMETER (NMXHKK=200000)
37673
37674 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37675 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37676 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37677
37678* extended event history
37679 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37680 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37681 & IHIST(2,NMXHKK)
37682
37683* Lorentz-parameters of the current interaction
37684 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37685 & UMO,PPCM,EPROJ,PPROJ
37686
37687* diquark-breaking mechanism
37688 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37689
37690C
37691 PARAMETER (NTMHKK= 300)
37692 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37693 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37694 +(4,NTMHKK)
37695*KEEP,XSEADI.
37696 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37697 +SSMIMQ,VVMTHR
37698*KEEP,DPRIN.
37699 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37700C
37701C GSQBS-1 diagram (split projectile diquark)
37702C
37703C
37704C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37705C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37706C
37707C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37708C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37709C
37710C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37711C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37712C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37713C
37714C Put new chains into COMMON /HKKTMP/
37715C
37716 IIGLU1=NC1T-NC1P-1
37717 IIGLU2=NC2T-NC2P-1
37718 IGCOUN=0
37719C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37720 CVQ=1.D0
37721 NNNC1=IDHKK(NC1)/1000
37722 MMMC1=IDHKK(NC1)-NNNC1*1000
37723 KKKC1=ISTHKK(NC1)
37724 NNNC2=IDHKK(NC2)/1000
37725 MMMC2=IDHKK(NC2)-NNNC2*1000
37726 KKKC2=ISTHKK(NC2)
37727 IREJ=0
37728 IF(IPIP.EQ.3)THEN
37729 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37730 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37731 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37732 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37733 ENDIF
37734C
37735C
37736C
37737C determine x-values of NC1P diquark
37738 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37739 XVQT=PHKK(4,NC1T)*2.D0/UMO
37740C
37741C determine x-values of sea quark pair
37742C
37743 IPCO=1
37744 ICOU=0
37745 2234 CONTINUE
37746 ICOU=ICOU+1
37747 IF(ICOU.GE.500)THEN
37748 IREJ=1
37749 IF(ISQ.EQ.3)IREJ=3
37750 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37751 IPCO=0
37752 RETURN
37753 ENDIF
37754 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37755 * UMO, XDIQP,XVQT
37756 XSQ=0.D0
37757 XSAQ=0.D0
37758**NEW
37759C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37760 IF (IPIP.EQ.1) THEN
37761 XQMAX = XDIQP/2.0D0
37762 XAQMAX = 2.D0*XVQT/3.0D0
37763 ELSE
37764 XQMAX = 2.D0*XVQT/3.0D0
37765 XAQMAX = XDIQP/2.0D0
37766 ENDIF
37767 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37768 ISAQ = 6+ISQ
37769C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37770**
37771 IF(IPCO.GE.3)
37772 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37773 IF(IREJ.GE.1)THEN
37774 IF(IPCO.GE.3)
37775 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37776 IPCO=0
37777 RETURN
37778 ENDIF
37779 IF(IPIP.EQ.1)THEN
37780 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37781 ELSEIF(IPIP.EQ.2)THEN
37782 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37783 ENDIF
37784 IF(IPCO.GE.3)THEN
37785 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37786 & XDIQP,XVQT,XSQ,XSAQ
37787 ENDIF
37788C
37789C subtract xsq,xsaq from NC1P diquark and NC1T quark
37790C
37791C XSQ=0.D0
37792 IF(IPIP.EQ.1)THEN
37793 XDIQP=XDIQP-XSQ
37794**NEW
37795C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37796**
37797 XVQT =XVQT -XSAQ
37798 ELSEIF(IPIP.EQ.2)THEN
37799 XDIQP=XDIQP-XSAQ
37800 XVQT =XVQT -XSQ
37801 ENDIF
37802 IF(IPCO.GE.3)
37803 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37804C
37805C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37806C
37807 XVTHRO=CVQ/UMO
37808 IVTHR=0
37809 3466 CONTINUE
37810 IF(IVTHR.EQ.10)THEN
37811 IREJ=1
37812 IF(ISQ.EQ.3)IREJ=3
37813 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37814 IPCO=0
37815 RETURN
37816 ENDIF
37817 IVTHR=IVTHR+1
37818 XVTHR=XVTHRO/(201-IVTHR)
37819 UNOPRV=UNON
37820 380 CONTINUE
37821 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37822 IREJ=1
37823 IF(ISQ.EQ.3)IREJ=3
37824 IF(IPCO.GE.3)
37825 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37826 * XVTHR
37827 IPCO=0
37828 RETURN
37829 ENDIF
37830 IF(DT_RNDM(V).LT.0.5D0)THEN
37831 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37832 XVPQII=XDIQP-XVPQI
37833 ELSE
37834 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37835 XVPQI=XDIQP-XVPQII
37836 ENDIF
37837 IF(IPCO.GE.3)THEN
37838 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37839 & XVTHR,XDIQP,XVPQI,XVPQII
37840 ENDIF
37841C
37842C Prepare 4 momenta of new chains and chain ends
37843C
37844C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37845C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37846C +(4,NTMHKK)
37847C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37848C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37849C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37850 IF(IPIP.EQ.1)THEN
37851 XSQ1=XSQ
37852 XSAQ1=XSAQ
37853 ISQ1=ISQ
37854 ISAQ1=ISAQ
37855 ELSEIF(IPIP.EQ.2)THEN
37856 XSQ1=XSAQ
37857 XSAQ1=XSQ
37858 ISQ1=ISAQ
37859 ISAQ1=ISQ
37860 ENDIF
37861 KK11=IP11
37862C IDHKT(2) =1000*IPP21+100*IPP22+1
37863 KK21= IPP21
37864 KK22= IPP22
37865 XGIVE=0.D0
37866 IDHKT(4+IIGLU1) =IP12
37867 ISTHKT(4+IIGLU1) =921
37868 JMOHKT(1,4+IIGLU1)=NC1P
37869 JMOHKT(2,4+IIGLU1)=0
37870 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37871 JDAHKT(2,4+IIGLU1)=0
37872**NEW
37873 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37874 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37875**
37876 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37877 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37878 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37879 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37880C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37881 XXMIST=(PHKT(4,4+IIGLU1)**2-
37882 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37883 * PHKT(1,4+IIGLU1)**2)
37884 IF(XXMIST.GT.0.D0)THEN
37885 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37886 ELSE
37887 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37888 XXMIST=ABS(XXMIST)
37889 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37890 ENDIF
37891 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37892 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37893 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37894 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37895 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37896 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37897 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37898 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37899 IF(IPIP.EQ.1)THEN
37900 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37901 ELSEIF(IPIP.EQ.2)THEN
37902 IDHKT(5+IIGLU1) =ISAQ1
37903 ENDIF
37904 ISTHKT(5+IIGLU1) =922
37905 JMOHKT(1,5+IIGLU1)=NC1T
37906 JMOHKT(2,5+IIGLU1)=0
37907 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37908 JDAHKT(2,5+IIGLU1)=0
37909**NEW
37910 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37911 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37912**
37913 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37914 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37915 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37916 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37917C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37918 XMIST=(PHKT(4,5+IIGLU1)**2-
37919 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37920 *PHKT(1,5+IIGLU1)**2)
37921 IF(XMIST.GT.0.D0)THEN
37922 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37923 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37924 *PHKT(1,5+IIGLU1)**2)
37925 ELSE
37926C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37927 PHKT(5,5+IIGLU1)=0.D0
37928 ENDIF
37929 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37930 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37931 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37932 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37933 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37934 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37935 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37936 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37937 IDHKT(6+IIGLU1) =88888
37938C IDHKT(6) =1000*NNNC1+MMMC1
37939 ISTHKT(6+IIGLU1) =93
37940C ISTHKT(6) =KKKC1
37941 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37942 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37943 JDAHKT(1,6+IIGLU1)=0
37944 JDAHKT(2,6+IIGLU1)=0
37945 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37946 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37947 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37948 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37949 PHKT(5,6+IIGLU1)
37950 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37951 * -PHKT(3,6+IIGLU1)**2)
37952 CHAMAL=CHAM1
37953 IF(IPIP.EQ.1)THEN
37954 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37955 ELSEIF(IPIP.EQ.2)THEN
37956 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37957 ENDIF
37958 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37959 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37960C we drop chain 6 and give the energy to chain 3
37961 IDHKT(6+IIGLU1)=33888
37962 XGIVE=1.D0
37963C WRITE(6,*)' drop chain 6 xgive=1'
37964 GO TO 7788
37965 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37966C we drop chain 6 and give the energy to chain 3
37967C and change KK11 to IDHKT(4)
37968 IDHKT(6+IIGLU1)=33888
37969 XGIVE=1.D0
37970C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37971 KK11=IDHKT(4+IIGLU1)
37972 GO TO 7788
37973 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37974C we drop chain 6 and give the energy to chain 3
37975C and change KK21 to IDHKT(4)
37976C IDHKT(2) =1000*IPP21+100*IPP22+1
37977 IDHKT(6+IIGLU1)=33888
37978 XGIVE=1.D0
37979C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
37980 KK21=IDHKT(4+IIGLU1)
37981 GO TO 7788
37982 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
37983C we drop chain 6 and give the energy to chain 3
37984C and change KK22 to IDHKT(4)
37985C IDHKT(2) =1000*IPP21+100*IPP22+1
37986 IDHKT(6+IIGLU1)=33888
37987 XGIVE=1.D0
37988C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
37989 KK22=IDHKT(4+IIGLU1)
37990 GO TO 7788
37991 ENDIF
37992C IREJ=1
37993 IPCO=0
37994C RETURN
37995C WRITE(6,*)' MGSQBS1 jump back from chain 6'
37996 GO TO 3466
37997 ENDIF
37998 7788 CONTINUE
37999 IF(IPIP.GE.3)THEN
38000 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38001 * JMOHKT(1,4+IIGLU1),
38002 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38003 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38004 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38005 * JMOHKT(1,5+IIGLU1),
38006 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38007 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38008 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38009 * JMOHKT(1,6+IIGLU1),
38010 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38011 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38012 ENDIF
38013 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38014 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38015 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38016 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38017 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38018 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38019 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38020 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38021C IDHKT(1) =IP11
38022 IDHKT(1) =KK11
38023 ISTHKT(1) =921
38024 JMOHKT(1,1)=NC1P
38025 JMOHKT(2,1)=0
38026 JDAHKT(1,1)=3+IIGLU1
38027 JDAHKT(2,1)=0
38028 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38029C * +0.5D0*PHKK(1,NC2P)
38030 *+XGIVE*PHKT(1,4+IIGLU1)
38031 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38032C * +0.5D0*PHKK(2,NC2P)
38033 *+XGIVE*PHKT(2,4+IIGLU1)
38034 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38035C * +0.5D0*PHKK(3,NC2P)
38036 *+XGIVE*PHKT(3,4+IIGLU1)
38037 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38038C * +0.5D0*PHKK(4,NC2P)
38039 *+XGIVE*PHKT(4,4+IIGLU1)
38040C PHKT(5,1) =PHKK(5,NC1P)
38041 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38042 *PHKT(1,1)**2)
38043 IF(XMIST.GE.0.D0)THEN
38044 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38045 *PHKT(1,1)**2)
38046 ELSE
38047C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38048 PHKT(5,1)=0.D0
38049 ENDIF
38050 VHKT(1,1) =VHKK(1,NC1P)
38051 VHKT(2,1) =VHKK(2,NC1P)
38052 VHKT(3,1) =VHKK(3,NC1P)
38053 VHKT(4,1) =VHKK(4,NC1P)
38054 WHKT(1,1) =WHKK(1,NC1P)
38055 WHKT(2,1) =WHKK(2,NC1P)
38056 WHKT(3,1) =WHKK(3,NC1P)
38057 WHKT(4,1) =WHKK(4,NC1P)
38058C Add here IIGLU1 gluons to this chaina
38059 PG1=0.D0
38060 PG2=0.D0
38061 PG3=0.D0
38062 PG4=0.D0
38063 IF(IIGLU1.GE.1)THEN
38064 JJG=NC1P
38065 DO 61 IIG=2,2+IIGLU1-1
38066 KKG=JJG+IIG-1
38067 IDHKT(IIG) =IDHKK(KKG)
38068 ISTHKT(IIG) =921
38069 JMOHKT(1,IIG)=KKG
38070 JMOHKT(2,IIG)=0
38071 JDAHKT(1,IIG)=3+IIGLU1
38072 JDAHKT(2,IIG)=0
38073 PHKT(1,IIG)=PHKK(1,KKG)
38074 PG1=PG1+ PHKT(1,IIG)
38075 PHKT(2,IIG)=PHKK(2,KKG)
38076 PG2=PG2+ PHKT(2,IIG)
38077 PHKT(3,IIG)=PHKK(3,KKG)
38078 PG3=PG3+ PHKT(3,IIG)
38079 PHKT(4,IIG)=PHKK(4,KKG)
38080 PG4=PG4+ PHKT(4,IIG)
38081 PHKT(5,IIG)=PHKK(5,KKG)
38082 VHKT(1,IIG) =VHKK(1,KKG)
38083 VHKT(2,IIG) =VHKK(2,KKG)
38084 VHKT(3,IIG) =VHKK(3,KKG)
38085 VHKT(4,IIG) =VHKK(4,KKG)
38086 WHKT(1,IIG) =WHKK(1,KKG)
38087 WHKT(2,IIG) =WHKK(2,KKG)
38088 WHKT(3,IIG) =WHKK(3,KKG)
38089 WHKT(4,IIG) =WHKK(4,KKG)
38090 61 CONTINUE
38091 ENDIF
38092C IDHKT(2) =1000*IPP21+100*IPP22+1
38093 IF(IPIP.EQ.1)THEN
38094 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38095 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38096 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38097 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38098 ELSEIF(IPIP.EQ.2)THEN
38099 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38100 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38101 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38102 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38103 ENDIF
38104 ISTHKT(2+IIGLU1) =922
38105 JMOHKT(1,2+IIGLU1)=NC2T
38106 JMOHKT(2,2+IIGLU1)=0
38107 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38108 JDAHKT(2,2+IIGLU1)=0
38109 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38110 *+XGIVE*PHKT(1,5+IIGLU1)
38111 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38112 *+XGIVE*PHKT(2,5+IIGLU1)
38113 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38114 *+XGIVE*PHKT(3,5+IIGLU1)
38115 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38116 *+XGIVE*PHKT(4,5+IIGLU1)
38117C PHKT(5,2) =PHKK(5,NC2T)
38118 XMIST=(PHKT(4,2+IIGLU1)**2-
38119 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38120 *PHKT(1,2+IIGLU1)**2)
38121 IF(XMIST.GT.0.D0)THEN
38122 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38123 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38124 *PHKT(1,2+IIGLU1)**2)
38125 ELSE
38126C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38127 PHKT(5,2+IIGLU1)=0.D0
38128 ENDIF
38129 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38130 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38131 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38132 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38133 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38134 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38135 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38136 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38137 IDHKT(3+IIGLU1) =88888
38138C IDHKT(3) =1000*NNNC1+MMMC1+10
38139 ISTHKT(3+IIGLU1) =93
38140C ISTHKT(3) =KKKC1
38141 JMOHKT(1,3+IIGLU1)=1
38142 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38143 JDAHKT(1,3+IIGLU1)=0
38144 JDAHKT(2,3+IIGLU1)=0
38145 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38146 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38147 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38148 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38149 PHKT(5,3+IIGLU1)
38150 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38151 * -PHKT(3,3+IIGLU1)**2)
38152 IF(IPIP.GE.3)THEN
38153 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38154 * JDAHKT(1,1),
38155 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38156 DO 71 IIG=2,2+IIGLU1-1
38157 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38158 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38159 * JDAHKT(1,IIG),
38160 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38161 71 CONTINUE
38162 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38163 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38164 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38165 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38166 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38167 * JMOHKT(1,3+IIGLU1),
38168 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38169 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38170 ENDIF
38171 CHAMAL=CHAB1
38172**NEW
38173C IF(IPIP.EQ.1)THEN
38174C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38175C ELSEIF(IPIP.EQ.2)THEN
38176C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38177C ENDIF
38178 IF(IPIP.EQ.1)THEN
38179 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38180 ELSEIF(IPIP.EQ.2)THEN
38181 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38182 ENDIF
38183**
38184 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38185C IREJ=1
38186 IPCO=0
38187C RETURN
38188C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38189 GO TO 3466
38190 ENDIF
38191 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38192 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38193 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38194 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38195 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38196 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38197 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38198 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38199 IF(IPIP.EQ.1)THEN
38200 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38201 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38202 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38203 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38204 ELSEIF(IPIP.EQ.2)THEN
38205 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38206 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38207 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38208 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38209C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38210 ENDIF
38211 ISTHKT(7+IIGLU1) =921
38212 JMOHKT(1,7+IIGLU1)=NC2P
38213 JMOHKT(2,7+IIGLU1)=0
38214 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38215 JDAHKT(2,7+IIGLU1)=0
38216C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38217C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38218C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38219C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38220**NEW
38221 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38222 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38223**
38224 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38225 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38226 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38227 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38228C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38229C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38230 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38231C IREJ=1
38232C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38233 IPCO=0
38234C RETURN
38235 GO TO 3466
38236 ENDIF
38237C PHKT(5,7) =PHKK(5,NC2P)
38238 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38239 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38240 *PHKT(1,7+IIGLU1)**2)
38241 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38242 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38243 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38244 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38245 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38246 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38247 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38248 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38249C Insert here the IIGLU2 gluons
38250 PG1=0.D0
38251 PG2=0.D0
38252 PG3=0.D0
38253 PG4=0.D0
38254 IF(IIGLU2.GE.1)THEN
38255 JJG=NC2P
38256 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38257 KKG=JJG+IIG-7-IIGLU1
38258 IDHKT(IIG) =IDHKK(KKG)
38259 ISTHKT(IIG) =921
38260 JMOHKT(1,IIG)=KKG
38261 JMOHKT(2,IIG)=0
38262 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38263 JDAHKT(2,IIG)=0
38264 PHKT(1,IIG)=PHKK(1,KKG)
38265 PG1=PG1+ PHKT(1,IIG)
38266 PHKT(2,IIG)=PHKK(2,KKG)
38267 PG2=PG2+ PHKT(2,IIG)
38268 PHKT(3,IIG)=PHKK(3,KKG)
38269 PG3=PG3+ PHKT(3,IIG)
38270 PHKT(4,IIG)=PHKK(4,KKG)
38271 PG4=PG4+ PHKT(4,IIG)
38272 PHKT(5,IIG)=PHKK(5,KKG)
38273 VHKT(1,IIG) =VHKK(1,KKG)
38274 VHKT(2,IIG) =VHKK(2,KKG)
38275 VHKT(3,IIG) =VHKK(3,KKG)
38276 VHKT(4,IIG) =VHKK(4,KKG)
38277 WHKT(1,IIG) =WHKK(1,KKG)
38278 WHKT(2,IIG) =WHKK(2,KKG)
38279 WHKT(3,IIG) =WHKK(3,KKG)
38280 WHKT(4,IIG) =WHKK(4,KKG)
38281 81 CONTINUE
38282 ENDIF
38283 IDHKT(8+IIGLU1+IIGLU2) =IP2
38284 ISTHKT(8+IIGLU1+IIGLU2) =922
38285 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38286 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38287 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38288 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38289**NEW
38290 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38291 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38292**
38293 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38294 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38295 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38296 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38297C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38298 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38299 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38300 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38301 IF(XMIST.GT.0.D0)THEN
38302 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38303 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38304 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38305 ELSE
38306C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38307 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38308 ENDIF
38309 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38310 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38311 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38312 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38313 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38314 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38315 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38316 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38317 IDHKT(9+IIGLU1+IIGLU2) =88888
38318C IDHKT(9) =1000*NNNC2+MMMC2+10
38319 ISTHKT(9+IIGLU1+IIGLU2) =93
38320C ISTHKT(9) =KKKC2
38321 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38322 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38323 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38324 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38325 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38326 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38327 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38328 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38329 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38330 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38331 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38332 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38333 PHKT(5,9+IIGLU1+IIGLU2)
38334 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38335 * PHKT(2,9+IIGLU1+IIGLU2)**2
38336 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38337 IF(IPIP.GE.3)THEN
38338 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38339 * JMOHKT(1,7+IIGLU1),
38340 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38341 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38342 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38343 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38344 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38345 * JDAHKT(1,IIG),
38346 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38347 91 CONTINUE
38348 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38349 * IDHKT(8+IIGLU1+IIGLU2),
38350 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38351 * JDAHKT(1,8+IIGLU1+IIGLU2),
38352 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38353 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38354 * IDHKT(9+IIGLU1+IIGLU2),
38355 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38356 * JDAHKT(1,9+IIGLU1+IIGLU2),
38357 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38358 ENDIF
38359 CHAMAL=CHAB1
38360 IF(IPIP.EQ.1)THEN
38361 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38362 ELSEIF(IPIP.EQ.2)THEN
38363 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38364 ENDIF
38365 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38366C IREJ=1
38367 IPCO=0
38368C RETURN
38369C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38370C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38371 GO TO 3466
38372 ENDIF
38373 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38374 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38375 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38376 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38377 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38378 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38379 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38380 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38381C
38382 IGCOUN=9+IIGLU1+IIGLU2
38383 IPCO=0
38384 RETURN
38385 END
38386
38387*$ CREATE HKKHKT.FOR
38388*COPY HKKHKT
38389C
38390C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38391C
38392 SUBROUTINE HKKHKT(I,J)
38393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38394 SAVE
38395
38396* event history
38397
38398 PARAMETER (NMXHKK=200000)
38399
38400 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38401 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38402 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38403
38404* extended event history
38405 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38406 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38407 & IHIST(2,NMXHKK)
38408
38409 PARAMETER (NTMHKK= 300)
38410 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38411 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38412 +(4,NTMHKK)
38413C
38414 ISTHKK(I) =ISTHKT(J)
38415 IDHKK(I) =IDHKT(J)
38416C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38417 IF(IDHKK(I).EQ.88888)THEN
38418C JMOHKK(1,I)=I-2
38419C JMOHKK(2,I)=I-1
38420 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38421 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38422 ELSE
38423 JMOHKK(1,I)=JMOHKT(1,J)
38424 JMOHKK(2,I)=JMOHKT(2,J)
38425 ENDIF
38426 JDAHKK(1,I)=JDAHKT(1,J)
38427 JDAHKK(2,I)=JDAHKT(2,J)
38428C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38429C JDAHKK(1,I)=I+2
38430C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38431C JDAHKK(1,I)=I+1
38432C ENDIF
38433 IF(JDAHKT(1,J).GT.0)THEN
38434 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38435 ENDIF
38436 PHKK(1,I) =PHKT(1,J)
38437 PHKK(2,I) =PHKT(2,J)
38438 PHKK(3,I) =PHKT(3,J)
38439 PHKK(4,I) =PHKT(4,J)
38440 PHKK(5,I) =PHKT(5,J)
38441 VHKK(1,I) =VHKT(1,J)
38442 VHKK(2,I) =VHKT(2,J)
38443 VHKK(3,I) =VHKT(3,J)
38444 VHKK(4,I) =VHKT(4,J)
38445 WHKK(1,I) =WHKT(1,J)
38446 WHKK(2,I) =WHKT(2,J)
38447 WHKK(3,I) =WHKT(3,J)
38448 WHKK(4,I) =WHKT(4,J)
38449 RETURN
38450 END
38451
38452*$ CREATE DT_DBREAK.FOR
38453*COPY DT_DBREAK
38454*
38455*===dbreak=============================================================*
38456*
38457 SUBROUTINE DT_DBREAK(MODE)
38458
38459************************************************************************
38460* This is the steering subroutine for the different diquark breaking *
38461* mechanisms. *
38462* *
38463* MODE = 1 breaking of projectile diquark in qq-q chain using *
38464* a sea quark (q-qq chain) of the same projectile *
38465* = 2 breaking of target diquark in q-qq chain using *
38466* a sea quark (qq-q chain) of the same target *
38467* = 3 breaking of projectile diquark in qq-q chain using *
38468* a sea quark (q-aq chain) of the same projectile *
38469* = 4 breaking of target diquark in q-qq chain using *
38470* a sea quark (aq-q chain) of the same target *
38471* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38472* a sea anti-quark (aq-aqaq chain) of the same projectile *
38473* = 6 breaking of target anti-diquark in aq-aqaq chain using *
38474* a sea anti-quark (aqaq-aq chain) of the same target *
38475* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38476* a sea anti-quark (aq-q chain) of the same projectile *
38477* = 8 breaking of target anti-diquark in aq-aqaq chain using *
38478* a sea anti-quark (q-aq chain) of the same target *
38479* *
38480* Original version by J. Ranft. *
38481* This version dated 17.5.00 is written by S. Roesler. *
38482************************************************************************
38483
38484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38485 SAVE
38486
38487 PARAMETER ( LINP = 10 ,
38488 & LOUT = 6 ,
38489 & LDAT = 9 )
38490
38491* event history
38492
38493 PARAMETER (NMXHKK=200000)
38494
38495 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38496 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38497 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38498
38499* extended event history
38500 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38501 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38502 & IHIST(2,NMXHKK)
38503
38504* flags for input different options
38505 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38506 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38507 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38508
38509* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38510 PARAMETER (MAXCHN=10000)
38511 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38512
38513* diquark-breaking mechanism
38514 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38515
38516* flags for particle decays
38517 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38518 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38519 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38520
38521*
38522* chain identifiers
38523* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38524* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38525 DIMENSION IDCHN1(8),IDCHN2(8)
38526 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38527 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38528*
38529* parton identifiers
38530* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38531* +-51/52 = unitarity-sea, +-61/62 = gluons )
38532 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38533 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38534 & 31, 31, 31, 31, 31, 31, 31, 31,
38535 & 41, 41, 41, 41, 51, 51, 51, 51/
38536 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38537 & 32, 32, 32, 32, 32, 32, 32, 32,
38538 & 42, 42, 42, 42, 52, 52, 52, 52/
38539 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38540 & 51, 31, 41, 41, 31, 31, 31, 31,
38541 & 0, 41, 51, 51, 51, 51, 51, 51/
38542 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38543 & 32, 52, 42, 42, 32, 32, 32, 32,
38544 & 42, 0, 52, 52, 52, 52, 52, 52/
38545
38546 IF (NCHAIN.LE.0) RETURN
38547 DO 1 I=1,NCHAIN
38548 IDX1 = IDXCHN(1,I)
38549 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38550 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38551 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38552 & .AND.
38553 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38554 & (IS1P.EQ.ISP1P(MODE,3)))
38555 & .AND.
38556 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38557 & (IS1T.EQ.ISP1T(MODE,3)))
38558 & ) THEN
38559 DO 2 J=1,NCHAIN
38560 IDX2 = IDXCHN(1,J)
38561 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38562 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38563 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38564 & .AND.
38565 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38566 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38567 & .AND.
38568 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38569 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38570 & ) THEN
38571* find mother nucleons of the diquark to be splitted and of the
38572* sea-quark and reject this combination if it is not the same
38573 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38574 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38575 IANCES = 1
38576 ELSE
38577 IANCES = 2
38578 ENDIF
38579 IDXMO1 = JMOHKK(IANCES,IDX1)
38580 4 CONTINUE
38581 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38582 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38583 IANC = IANCES
38584 ELSE
38585 IANC = 1
38586 ENDIF
38587 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38588 IDXMO1 = JMOHKK(IANC,IDXMO1)
38589 GOTO 4
38590 ENDIF
38591 IDXMO2 = JMOHKK(IANCES,IDX2)
38592 5 CONTINUE
38593 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38594 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38595 IANC = IANCES
38596 ELSE
38597 IANC = 1
38598 ENDIF
38599 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38600 IDXMO2 = JMOHKK(IANC,IDXMO2)
38601 GOTO 5
38602 ENDIF
38603 IF (IDXMO1.NE.IDXMO2) GOTO 2
38604* quark content of projectile parton
38605 IP1 = IDHKK(JMOHKK(1,IDX1))
38606 IP11 = IP1/1000
38607 IP12 = (IP1-1000*IP11)/100
38608 IP2 = IDHKK(JMOHKK(2,IDX1))
38609 IP21 = IP2/1000
38610 IP22 = (IP2-1000*IP21)/100
38611* quark content of target parton
38612 IT1 = IDHKK(JMOHKK(1,IDX2))
38613 IT11 = IT1/1000
38614 IT12 = (IT1-1000*IT11)/100
38615 IT2 = IDHKK(JMOHKK(2,IDX2))
38616 IT21 = IT2/1000
38617 IT22 = (IT2-1000*IT21)/100
38618* split diquark and form new chains
38619 IF (MODE.EQ.1) THEN
38620 IF (IT1.EQ.4) GOTO 2
38621 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38622 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38623 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38624 ELSEIF (MODE.EQ.2) THEN
38625 IF (IT2.EQ.4) GOTO 2
38626 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38627 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38628 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38629 ELSEIF (MODE.EQ.3) THEN
38630 IF (IT1.EQ.4) GOTO 2
38631 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38632 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38633 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38634 ELSEIF (MODE.EQ.4) THEN
38635 IF (IT2.EQ.4) GOTO 2
38636 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38637 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38638 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38639 ELSEIF (MODE.EQ.5) THEN
38640 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38641 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38642 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38643 ELSEIF (MODE.EQ.6) THEN
38644 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38645 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38646 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38647 ELSEIF (MODE.EQ.7) THEN
38648 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38649 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38650 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38651 ELSEIF (MODE.EQ.8) THEN
38652 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38653 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38654 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38655 ENDIF
38656 IF (IREJ.GE.1) THEN
38657 if ((ipq.lt.0).or.(ipq.ge.4))
38658 & write(LOUT,*) 'ipq !!!',ipq,mode
38659 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38660* accept or reject new chains corresponding to PDBSEA
38661 ELSE
38662 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38663 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38664 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38665 ELSEIF (IPQ.EQ.3) THEN
38666 ACC = DBRKA(3,MODE)
38667 REJ = DBRKR(3,MODE)
38668 ELSE
38669 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38670 STOP
38671 ENDIF
38672 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38673 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38674 IACC = 1
38675 ELSE
38676 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38677 IACC = 0
38678 ENDIF
38679* new chains have been accepted and are now copied into HKKEVT
38680 IF (IACC.EQ.1) THEN
38681 IF (LEMCCK) THEN
38682 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38683 & PHKK(3,IDX1),PHKK(4,IDX1),
38684 & 1,IDUM1,IDUM2)
38685 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38686 & PHKK(3,IDX2),PHKK(4,IDX2),
38687 & 2,IDUM1,IDUM2)
38688 ENDIF
38689 IDHKK(IDX1) = 99888
38690 IDHKK(IDX2) = 99888
38691 IDXCHN(2,I) = -1
38692 IDXCHN(2,J) = -1
38693 DO 3 K=1,IGCOUN
38694 NHKK = NHKK+1
38695 CALL HKKHKT(NHKK,K)
38696 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38697 PX = -PHKK(1,NHKK)
38698 PY = -PHKK(2,NHKK)
38699 PZ = -PHKK(3,NHKK)
38700 PE = -PHKK(4,NHKK)
38701 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38702 ENDIF
38703 3 CONTINUE
38704 IF (LEMCCK) THEN
38705 CHKLEV = 0.1D0
38706 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38707 & IREJ)
38708 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38709 ENDIF
38710 GOTO 1
38711 ENDIF
38712 ENDIF
38713 ENDIF
38714 2 CONTINUE
38715 ENDIF
38716 1 CONTINUE
38717 RETURN
38718 END
38719
38720*$ CREATE DT_CQPAIR.FOR
38721*COPY DT_CQPAIR
38722*
38723*===cqpair=============================================================*
38724*
38725 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38726
38727************************************************************************
38728* This subroutine Creates a Quark-antiquark PAIR from the sea. *
38729* *
38730* XQMAX maxium energy fraction of quark (input) *
38731* XAQMAX maxium energy fraction of antiquark (input) *
38732* XQ energy fraction of quark (output) *
38733* XAQ energy fraction of antiquark (output) *
38734* IFLV quark flavour (- antiquark flavor) (output) *
38735* *
38736* This version dated 14.5.00 is written by S. Roesler. *
38737************************************************************************
38738
38739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38740 SAVE
38741
38742 PARAMETER ( LINP = 10 ,
38743 & LOUT = 6 ,
38744 & LDAT = 9 )
38745
38746* Lorentz-parameters of the current interaction
38747 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38748 & UMO,PPCM,EPROJ,PPROJ
38749
38750*
38751 IREJ = 0
38752 XQ = 0.0D0
38753 XAQ = 0.0D0
38754*
38755* sample quark flavour
38756*
38757* set seasq here (the one from DTCHAI should be used in the future)
38758 SEASQ = 0.5D0
38759 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38760*
38761* sample energy fractions of sea pair
38762* we first sample the energy fraction of a gluon and then split the gluon
38763*
38764* maximum energy fraction of the gluon forced via input
38765 XGMAXI = XQMAX+XAQMAX
38766* minimum energy fraction of the gluon
38767 XTHR1 = 4.0D0 /UMO**2
38768 XTHR2 = 0.54D0/UMO**1.5D0
38769 XGMIN = MAX(XTHR1,XTHR2)
38770* maximum energy fraction of the gluon
38771 XGMAX = 0.3D0
38772 XGMAX = MIN(XGMAXI,XGMAX)
38773 IF (XGMIN.GE.XGMAX) THEN
38774 IREJ = 1
38775 RETURN
38776 ENDIF
38777*
38778* sample energy fraction of the gluon
38779 NLOOP = 0
38780 1 CONTINUE
38781 NLOOP = NLOOP+1
38782 IF (NLOOP.GE.50) THEN
38783 IREJ = 1
38784 RETURN
38785 ENDIF
38786 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38787 EGLUON = XGLUON*UMO/2.0D0
38788*
38789* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38790 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38791 ZMAX = 1.0D0-ZMIN
38792 RZ = DT_RNDM(ZMAX)
38793 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38794 RQ = DT_RNDM(ZMAX)
38795 IF (RQ.LT.0.5D0) THEN
38796 XQ = XGLUON*XHLP
38797 XAQ = XGLUON-XQ
38798 ELSE
38799 XAQ = XGLUON*XHLP
38800 XQ = XGLUON-XAQ
38801 ENDIF
38802 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38803
38804 RETURN
38805 END