]> 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
//
[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)
004932dd 272 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 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
6cf1df4c 2261 IF ((IP.GT.1) .AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
7b076c76 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
430525dd 3595
3596 IF ((ABS(ISTHKK(I)).EQ.1) .OR.
3597 & (ABS(ISTHKK(I)).EQ.2) .OR.
3598 & (ISTHKK(I).EQ.1000) .OR.
3599 & (ISTHKK(I).EQ.1001)) THEN
3600
7b076c76 3601 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3602 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3603 PECMS = PHKK(4,I)
3604 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3605 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3606 ENDIF
3607 20 CONTINUE
3608 ELSE
3609 MODE = -1
3610 ENDIF
3611
3612 RETURN
3613 END
3614
3615*$ CREATE DT_REJUCO.FOR
3616*COPY DT_REJUCO
3617*
3618*===rejuco=============================================================*
3619*
3620 SUBROUTINE DT_REJUCO(MODE,IREJ)
3621
3622************************************************************************
3623* REJection of Unphysical COnfigurations *
3624* MODE = 1 rejection of particles with unphysically large energy *
3625* *
3626* This version dated 27.12.2006 is written by S. Roesler. *
3627************************************************************************
3628
3629 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3630 SAVE
3631
3632 PARAMETER ( LINP = 10 ,
3633 & LOUT = 6 ,
3634 & LDAT = 9 )
3635
3636 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3637 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3638
3639* maximum x_cms of final state particle
3640 PARAMETER (XCMSMX = 1.4D0)
3641
3642* event history
3643
3644 PARAMETER (NMXHKK=200000)
3645
3646 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3647 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3648 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3649
3650* extended event history
3651 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3652 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3653 & IHIST(2,NMXHKK)
3654
3655* Lorentz-parameters of the current interaction
3656 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3657 & UMO,PPCM,EPROJ,PPROJ
3658
3659 IREJ = 0
3660
3661 IF (MODE.EQ.1) THEN
3662 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3663 ECMHLF = UMO/2.0D0
3664 DO 10 I=NPOINT(4),NHKK
3665 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3666 XCMS = ABS(PHKK(4,I))/ECMHLF
3667 IF (XCMS.GT.XCMSMX) GOTO 9999
3668 ENDIF
3669 10 CONTINUE
3670 ENDIF
3671
3672 RETURN
3673 9999 CONTINUE
3674 IREJ = 1
3675 RETURN
3676 END
3677*$ CREATE DT_EVENTB.FOR
3678*COPY DT_EVENTB
3679*
3680*===eventb=============================================================*
3681*
3682 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3683
3684************************************************************************
3685* Treatment of nucleon-nucleon interactions with full two-component *
3686* Dual Parton Model. *
3687* NCSY number of nucleon-nucleon interactions *
3688* IREJ rejection flag *
3689* This version dated 14.01.2000 is written by S. Roesler *
3690************************************************************************
3691
3692 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3693 SAVE
3694
3695 PARAMETER ( LINP = 10 ,
3696 & LOUT = 6 ,
3697 & LDAT = 9 )
3698
3699 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3700
3701* event history
3702
3703 PARAMETER (NMXHKK=200000)
3704
3705 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3706 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3707 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3708
3709* extended event history
3710 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3711 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3712 & IHIST(2,NMXHKK)
3713*! uncomment this line for internal phojet-fragmentation
3714C #include "dtu_dtevtp.inc"
3715
3716* particle properties (BAMJET index convention)
3717 CHARACTER*8 ANAME
3718 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3719 & IICH(210),IIBAR(210),K1(210),K2(210)
3720
3721* flags for input different options
3722 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3723 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3724 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3725
3726* rejection counter
3727 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3728 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3729 & IREXCI(3),IRDIFF(2),IRINC
3730
3731* properties of interacting particles
3732 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3733
3734* properties of photon/lepton projectiles
3735 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3736
3737* various options for treatment of partons (DTUNUC 1.x)
3738* (chain recombination, Cronin,..)
3739 LOGICAL LCO2CR,LINTPT
3740 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3741 & LCO2CR,LINTPT
3742
3743* statistics
3744 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3745 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3746 & ICEVTG(8,0:30)
3747
3748* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3749 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3750
3751* Glauber formalism: collision properties
3752 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3753 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3754
3755* flags for diffractive interactions (DTUNUC 1.x)
3756 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3757
3758* statistics: double-Pomeron exchange
3759 COMMON /DTFLG2/ INTFLG,IPOPO
3760
3761* flags for particle decays
3762 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3763 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3764 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3765
3766* nucleon-nucleon event-generator
3767 CHARACTER*8 CMODEL
3768 LOGICAL LPHOIN
3769 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3770
3771C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3772 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3773 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3774 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3775 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3776
3777C model switches and parameters
3778 CHARACTER*8 MDLNA
3779 INTEGER ISWMDL,IPAMDL
3780 DOUBLE PRECISION PARMDL
3781 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3782
3783C initial state parton radiation (internal part)
3784 INTEGER MXISR3,MXISR4
3785 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3786 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3787 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3788 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3789 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3790 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3791 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3792
3793C event debugging information
3794 INTEGER NMAXD
3795 PARAMETER (NMAXD=100)
3796 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3797 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3798 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3799 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3800
3801C general process information
3802 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3803 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3804
3805 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3806 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3807 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3808 & KPRON(15),ISINGL(2000)
3809
3810* initial values for max. number of phojet scatterings and dtunuc chains
3811* to be fragmented with one pyexec call
3812 DATA MXPHFR,MXDTFR /10,100/
3813
3814 IREJ = 0
3815* pointer to first parton of the first chain in dtevt common
3816 NPOINT(3) = NHKK+1
3817* special flag for double-Pomeron statistics
3818 IPOPO = 1
3819* counter for low-mass (DTUNUC) interactions
3820 NDTUSC = 0
3821* counter for interactions treated by PHOJET
3822 NPHOSC = 0
3823
3824* scan interactions for single nucleon-nucleon interactions
3825* (this has to be checked here because Cronin modifies parton momenta)
3826 NC = NPOINT(2)
3827 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3828 DO 8 I=1,NCSY
3829 ISINGL(I) = 0
3830 MOP = JMOHKK(1,NC)
3831 MOT = JMOHKK(1,NC+1)
3832 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3833 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3834 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3835 NC = NC+4
3836 8 CONTINUE
3837
3838* multiple scattering of chain ends
3839 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3840 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3841
3842* switch to PHOJET-settings for JETSET parameter
3843 CALL DT_INITJS(1)
3844
3845* loop over nucleon-nucleon interaction
3846 NC = NPOINT(2)
3847 DO 2 I=1,NCSY
3848*
3849* pick up one nucleon-nucleon interaction from DTEVT1
3850* ppnn / ptnn - momenta of the interacting nucleons (cms)
3851* ptotnn - total momentum of the interacting nucleons (cms)
3852* pp1,2 / pt1,2 - momenta of the four partons
3853* pp / pt - total momenta of the proj / targ partons
3854* ptot - total momentum of the four partons
3855 MOP = JMOHKK(1,NC)
3856 MOT = JMOHKK(1,NC+1)
3857 DO 3 K=1,4
3858 PPNN(K) = PHKK(K,MOP)
3859 PTNN(K) = PHKK(K,MOT)
3860 PTOTNN(K) = PPNN(K)+PTNN(K)
3861 PP1(K) = PHKK(K,NC)
3862 PT1(K) = PHKK(K,NC+1)
3863 PP2(K) = PHKK(K,NC+2)
3864 PT2(K) = PHKK(K,NC+3)
3865 PP(K) = PP1(K)+PP2(K)
3866 PT(K) = PT1(K)+PT2(K)
3867 PTOT(K) = PP(K)+PT(K)
3868 3 CONTINUE
3869*
3870*-----------------------------------------------------------------------
3871* this is a complete nucleon-nucleon interaction
3872*
3873 IF (ISINGL(I).EQ.1) THEN
3874*
3875* initialize PHOJET-variables for remnant/valence-partons
3876 IHFLD(1,1) = 0
3877 IHFLD(1,2) = 0
3878 IHFLD(2,1) = 0
3879 IHFLD(2,2) = 0
3880 IHFLS(1) = 1
3881 IHFLS(2) = 1
3882* save current settings of PHOJET process and min. bias flags
3883 DO 9 K=1,11
3884 KPRON(K) = IPRON(K,1)
3885 9 CONTINUE
3886 ISWSAV = ISWMDL(2)
3887*
3888* check if forced sampling of diffractive interaction requested
3889 IF (ISINGD.LT.-1) THEN
3890 DO 90 K=1,11
3891 IPRON(K,1) = 0
3892 90 CONTINUE
3893 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3894 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3895 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3896 ENDIF
3897*
3898* for photons: a direct/anomalous interaction is not sampled
3899* in PHOJET but already in Glauber-formalism. Here we check if such
3900* an interaction is requested
3901 IF (IJPROJ.EQ.7) THEN
3902* first switch off direct interactions
3903 IPRON(8,1) = 0
3904* this is a direct interactions
3905 IF (IDIREC.EQ.1) THEN
3906 DO 12 K=1,11
3907 IPRON(K,1) = 0
3908 12 CONTINUE
3909 IPRON(8,1) = 1
3910* this is an anomalous interactions
3911* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3912 ELSEIF (IDIREC.EQ.2) THEN
3913 ISWMDL(2) = 0
3914 ENDIF
3915 ELSE
3916 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3917 ENDIF
3918*
3919* make sure that total momenta of partons, pp and pt, are on mass
3920* shell (Cronin may have srewed this up..)
3921 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3922 IF (IR1.NE.0) THEN
3923 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3924 & 'EVENTB: mass shell correction rejected'
3925 GOTO 9999
3926 ENDIF
3927*
3928* initialize the incoming particles in PHOJET
3929 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3930
3931 CALL PHO_SETPAR(1,22,0,VIRT)
3932
3933 ELSE
3934
3935 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3936
3937 ENDIF
3938
3939 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3940
3941*
3942* initialize rejection loop counter for anomalous processes
3943 IRJANO = 0
3944 800 CONTINUE
3945 IRJANO = IRJANO+1
3946*
3947* temporary fix for ifano problem
3948 IFANO(1) = 0
3949 IFANO(2) = 0
3950*
3951* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3952
3953 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3954
3955*
3956* for photons: special consistency check for anomalous interactions
3957 IF (IJPROJ.EQ.7) THEN
3958 IF (IRJANO.LT.30) THEN
3959 IF (IFANO(1).NE.0) THEN
3960* here, an anomalous interaction was generated. Check if it
3961* was also requested. Otherwise reject this event.
3962 IF (IDIREC.EQ.0) GOTO 800
3963 ELSE
3964* here, an anomalous interaction was not generated. Check if it
3965* was requested in which case we need to reject this event.
3966 IF (IDIREC.EQ.2) GOTO 800
3967 ENDIF
3968 ELSE
3969 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3970 & IRJANO,IDIREC,NEVHKK
3971 ENDIF
3972 ENDIF
3973*
3974* copy back original settings of PHOJET process and min. bias flags
3975 DO 10 K=1,11
3976 IPRON(K,1) = KPRON(K)
3977 10 CONTINUE
3978 ISWMDL(2) = ISWSAV
3979*
3980* check if PHOJET has rejected this event
3981 IF (IREJ1.NE.0) THEN
3982C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3983 WRITE(LOUT,'(1X,A,I4)')
3984 & 'EVENTB: chain system rejected',IDIREC
3985
3986 CALL PHO_PREVNT(0)
3987
3988 GOTO 9999
3989 ENDIF
3990*
3991* copy partons and strings from PHOJET common back into DTEVT for
3992* external fragmentation
3993 MO1 = NC
3994 MO2 = NC+3
3995*! uncomment this line for internal phojet-fragmentation
3996C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3997 NPHOSC = NPHOSC+1
3998 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3999 IF (IREJ1.NE.0) THEN
4000 IF (IOULEV(1).GT.0)
4001 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
4002 GOTO 9999
4003 ENDIF
4004*
4005* update statistics counter
4006 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4007*
4008*-----------------------------------------------------------------------
4009* this interaction involves "remnants"
4010*
4011 ELSE
4012*
4013* total mass of this system
4014 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4015 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4016 IF (AMTOT2.LT.ZERO) THEN
4017 AMTOT = ZERO
4018 ELSE
4019 AMTOT = SQRT(AMTOT2)
4020 ENDIF
4021*
4022* systems with masses larger than elojet are treated with PHOJET
4023 IF (AMTOT.GT.ELOJET) THEN
4024*
4025* initialize PHOJET-variables for remnant/valence-partons
4026* projectile parton flavors and valence flag
4027 IHFLD(1,1) = IDHKK(NC)
4028 IHFLD(1,2) = IDHKK(NC+2)
4029 IHFLS(1) = 0
4030 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4031 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4032* target parton flavors and valence flag
4033 IHFLD(2,1) = IDHKK(NC+1)
4034 IHFLD(2,2) = IDHKK(NC+3)
4035 IHFLS(2) = 0
4036 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4037 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4038* flag signalizing PHOJET how to treat the remnant:
4039* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4040* iremn > -1 valence remnant: PHOJET assumes flavors according
4041* to mother particle
4042 IREMN1 = IHFLS(1)-1
4043 IREMN2 = IHFLS(2)-1
4044*
4045* initialize the incoming particles in PHOJET
4046 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4047
4048 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4049
4050 ELSE
4051
4052 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4053
4054 ENDIF
4055
4056 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4057
4058*
4059* calculate Lorentz parameter of the nucleon-nucleon cm-system
4060 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4061 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4062 BGX = PTOTNN(1)/AMNN
4063 BGY = PTOTNN(2)/AMNN
4064 BGZ = PTOTNN(3)/AMNN
4065 GAM = PTOTNN(4)/AMNN
4066* transform interacting nucleons into nucleon-nucleon cm-system
4067 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4068 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4069 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4070 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4071 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4072 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4073* transform (total) momenta of the proj and targ partons into
4074* nucleon-nucleon cm-system
4075 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4076 & PP(1),PP(2),PP(3),PP(4),
4077 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4078 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4079 & PT(1),PT(2),PT(3),PT(4),
4080 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4081* energy fractions of the proj and targ partons
4082 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4083 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4084***
4085* testprint
4086c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4087c & (PPTCMS(2)+PTTCMS(2))**2 +
4088c & (PPTCMS(3)+PTTCMS(3))**2 )
4089c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4090c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4091c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4092c & (PPSUB(2)+PTSUB(2))**2 +
4093c & (PPSUB(3)+PTSUB(3))**2 )
4094c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4095c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4096***
4097*
4098* save current settings of PHOJET process and min. bias flags
4099 DO 7 K=1,11
4100 KPRON(K) = IPRON(K,1)
4101 7 CONTINUE
4102* disallow direct photon int. (does not make sense here anyway)
4103 IPRON(8,1) = 0
4104* disallow double pomeron processes (due to technical problems
4105* in PHOJET, needs to be solved sometime)
4106 IPRON(4,1) = 0
4107* disallow diffraction for sea-diquarks
4108 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4109 & (IABS(IHFLD(1,2)).GT.1100)) THEN
4110 IPRON(3,1) = 0
4111 IPRON(6,1) = 0
4112 ENDIF
4113 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4114 & (IABS(IHFLD(2,2)).GT.1100)) THEN
4115 IPRON(3,1) = 0
4116 IPRON(5,1) = 0
4117 ENDIF
4118*
4119* we need massless partons: transform them on mass shell
4120 XMP = ZERO
4121 XMT = ZERO
4122 DO 6 K=1,4
4123 PPTMP(K) = PPSUB(K)
4124 PTTMP(K) = PTSUB(K)
4125 6 CONTINUE
4126 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4127 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4128 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4129 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4130 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4131* total energy of the subsysten after mass transformation
4132* (should be the same as before..)
4133 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4134 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
4135*
4136* after mass shell transformation the x_sub - relation has to be
4137* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4138*
4139* The old version was to scale based on the original x_sub and the
4140* 4-momenta of the subsystem. At very high energy this could lead to
4141* "pseudo-cm energies" of the parent system considerably exceeding
4142* the true cm energy. Now we keep the true cm energy and calculate
4143* new x_sub instead.
4144C old version PPTCMS(4) = PPSUB(4)/XPSUB
4145 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4146 XPSUB = PPSUB(4)/PPTCMS(4)
4147 IF (IJPROJ.EQ.7) THEN
4148 AMP2 = PHKK(5,MOT)**2
4149 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4150 ELSE
4151*???????
4152 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4153 & *(PPTCMS(4)+PHKK(5,MOP)))
4154C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4155C & *(PPTCMS(4)+PHKK(5,MOT)))
4156 ENDIF
4157C old version PTTCMS(4) = PTSUB(4)/XTSUB
4158 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4159 XTSUB = PTSUB(4)/PTTCMS(4)
4160 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4161 & *(PTTCMS(4)+PHKK(5,MOT)))
4162 DO 4 K=1,3
4163 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4164 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4165 4 CONTINUE
4166***
4167* testprint
4168*
4169* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
4170* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
4171* pptcms/ pttcms - momenta of the interacting nucleons (cms)
4172* pp1,2 / pt1,2 - momenta of the four partons
4173*
4174* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
4175* ptot - total momentum of the four partons (cms, negl. Fermi)
4176* ppsub / ptsub - total momenta of the proj / targ partons (cms)
4177*
4178c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4179c & (PPTCMS(2)+PTTCMS(2))**2 +
4180c & (PPTCMS(3)+PTTCMS(3))**2 )
4181c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4182c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4183c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4184c & (PPSUB(2)+PTSUB(2))**2 +
4185c & (PPSUB(3)+PTSUB(3))**2 )
4186c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4187c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4188c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4189c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4190c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4191c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
4192c ENDIF
4193c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4194c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4195c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4196c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4197* transform interacting nucleons into nucleon-nucleon cm-system
4198c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4199c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4200c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4201c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4202c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4203c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4204c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4205c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4206c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4207c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4208c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4209c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4210c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4211c & (PPNEW2+PTNEW2)**2 +
4212c & (PPNEW3+PTNEW3)**2 )
4213c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4214c & (PPNEW4+PTNEW4+PTSTCM) )
4215c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4216c & (PPSUB2+PTSUB2)**2 +
4217c & (PPSUB3+PTSUB3)**2 )
4218c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4219c & (PPSUB4+PTSUB4+PTSTSU) )
4220C WRITE(*,*) ' mother cmE :'
4221C WRITE(*,*) ETSTCM,ENEWCM
4222C WRITE(*,*) ' subsystem cmE :'
4223C WRITE(*,*) ETSTSU,ENEWSU
4224C WRITE(*,*) ' projectile mother :'
4225C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4226C WRITE(*,*) ' target mother :'
4227C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4228C WRITE(*,*) ' projectile subsystem:'
4229C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4230C WRITE(*,*) ' target subsystem:'
4231C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4232C WRITE(*,*) ' projectile subsystem should be:'
4233C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4234C & XPSUB*ETSTCM/2.0D0
4235C WRITE(*,*) ' target subsystem should be:'
4236C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4237C & XTSUB*ETSTCM/2.0D0
4238C WRITE(*,*) ' subsystem cmE should be: '
4239C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4240***
4241*
4242* generate complete remnant - nucleon/remnant event with PHOJET
4243
4244 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4245
4246*
4247* copy back original settings of PHOJET process flags
4248 DO 11 K=1,11
4249 IPRON(K,1) = KPRON(K)
4250 11 CONTINUE
4251*
4252* check if PHOJET has rejected this event
4253 IF (IREJ1.NE.0) THEN
4254 IF (IOULEV(1).GT.0)
4255 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
4256 WRITE(LOUT,*)
4257 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4258
4259 CALL PHO_PREVNT(0)
4260
4261 GOTO 9999
4262 ENDIF
4263*
4264* copy partons and strings from PHOJET common back into DTEVT for
4265* external fragmentation
4266 MO1 = NC
4267 MO2 = NC+3
4268*! uncomment this line for internal phojet-fragmentation
4269C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4270 NPHOSC = NPHOSC+1
4271 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4272 IF (IREJ1.NE.0) THEN
4273 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4274 & 'EVENTB: chain system rejected 2'
4275 GOTO 9999
4276 ENDIF
4277*
4278* update statistics counter
4279 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4280*
4281*-----------------------------------------------------------------------
4282* two-chain approx. for smaller systems
4283*
4284 ELSE
4285*
4286 NDTUSC = NDTUSC+1
4287* special flag for double-Pomeron statistics
4288 IPOPO = 0
4289*
4290* pick up flavors at the ends of the two chains
4291 IFP1 = IDHKK(NC)
4292 IFT1 = IDHKK(NC+1)
4293 IFP2 = IDHKK(NC+2)
4294 IFT2 = IDHKK(NC+3)
4295* ..and the indices of the mothers
4296 MOP1 = NC
4297 MOT1 = NC+1
4298 MOP2 = NC+2
4299 MOT2 = NC+3
4300 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4301 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4302*
4303* check if this chain system was rejected
4304 IF (IREJ1.GT.0) THEN
4305 IF (IOULEV(1).GT.0) THEN
4306 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4307 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4308 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4309 ENDIF
4310 IRHHA = IRHHA+1
4311 GOTO 9999
4312 ENDIF
4313* the following lines are for sea-sea chains rejected in GETCSY
4314 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4315 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4316 ENDIF
4317*
4318 ENDIF
4319*
4320* update statistics counter
4321 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4322*
4323 NC = NC+4
4324*
4325 2 CONTINUE
4326*
4327*-----------------------------------------------------------------------
4328* treatment of low-mass chains (if there are any)
4329*
4330 IF (NDTUSC.GT.0) THEN
4331*
4332* correct chains of very low masses for possible resonances
4333 IF (IRESCO.EQ.1) THEN
4334 CALL DT_EVTRES(IREJ1)
4335 IF (IREJ1.GT.0) THEN
4336 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4337 IRRES(1) = IRRES(1)+1
4338 GOTO 9999
4339 ENDIF
4340 ENDIF
4341* fragmentation of low-mass chains
4342*! uncomment this line for internal phojet-fragmentation
4343* (of course it will still be fragmented by DPMJET-routines but it
4344* has to be done here instead of further below)
4345C CALL DT_EVTFRA(IREJ1)
4346C IF (IREJ1.GT.0) THEN
4347C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4348C IRFRAG = IRFRAG+1
4349C GOTO 9999
4350C ENDIF
4351 ELSE
4352*! uncomment this line for internal phojet-fragmentation
4353C NPOINT(4) = NHKK+1
4354 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4355 ENDIF
4356*
4357*-----------------------------------------------------------------------
4358* new di-quark breaking mechanisms
4359*
4360 MXLEFT = 2
4361 CALL DT_CHASTA(0)
4362 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4363 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4364 CALL DT_DIQBRK
4365 MXLEFT = 4
4366 ENDIF
4367*
4368*-----------------------------------------------------------------------
4369* hadronize this event
4370*
4371* hadronize PHOJET chain systems
4372 NPYMAX = 0
4373 NPJE = NPHOSC/MXPHFR
4374 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4375 IF (NPJE.GT.1) THEN
4376 NLEFT = NPHOSC-NPJE*MXPHFR
4377 DO 20 JFRG=1,NPJE
4378 NFRG = JFRG*MXPHFR
4379 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4380 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4381 IF (IREJ1.GT.0) GOTO 22
4382 NLEFT = 0
4383 ELSE
4384 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4385 IF (IREJ1.GT.0) GOTO 22
4386 ENDIF
4387 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4388 20 CONTINUE
4389 IF (NLEFT.GT.0) THEN
4390 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4391 IF (IREJ1.GT.0) GOTO 22
4392 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4393 ENDIF
4394 ELSE
4395 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4396 IF (IREJ1.GT.0) GOTO 22
4397 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4398 ENDIF
4399*
4400* check max. filling level of jetset common and
4401* reduce mxphfr if necessary
4402 IF (NPYMAX.GT.3000) THEN
4403 IF (NPYMAX.GT.3500) THEN
4404 MXPHFR = MAX(1,MXPHFR-2)
4405 ELSE
4406 MXPHFR = MAX(1,MXPHFR-1)
4407 ENDIF
4408C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4409 ENDIF
4410*
4411* hadronize DTUNUC chain systems
4412 23 CONTINUE
4413 IBACK = MXDTFR
4414 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4415 IF (IREJ2.GT.0) GOTO 22
4416*
4417* check max. filling level of jetset common and
4418* reduce mxdtfr if necessary
4419 IF (NPYMEM.GT.3000) THEN
4420 IF (NPYMEM.GT.3500) THEN
4421 MXDTFR = MAX(1,MXDTFR-20)
4422 ELSE
4423 MXDTFR = MAX(1,MXDTFR-10)
4424 ENDIF
4425C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4426 ENDIF
4427*
4428 IF (IBACK.EQ.-1) GOTO 23
4429*
4430 22 CONTINUE
4431C CALL DT_EVTFRG(1,IREJ1)
4432C CALL DT_EVTFRG(2,IREJ2)
4433 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4434 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4435 IRFRAG = IRFRAG+1
4436 GOTO 9999
4437 ENDIF
4438*
4439* get final state particles from /DTEVTP/
4440*! uncomment this line for internal phojet-fragmentation
4441C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4442
4443 IF (IJPROJ.NE.7)
4444 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4445C IF (IREJ3.NE.0) GOTO 9999
4446
4447 RETURN
4448
4449 9999 CONTINUE
4450 IREVT = IREVT+1
4451 IREJ = 1
4452 RETURN
4453 END
4454
4455*$ CREATE DT_GETPJE.FOR
4456*COPY DT_GETPJE
4457*
4458*===getpje=============================================================*
4459*
4460 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4461
4462************************************************************************
4463* This subroutine copies PHOJET partons and strings from POEVT1 into *
4464* DTEVT1. *
4465* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4466* PP,PT 4-momenta of projectile/target being handled by *
4467* PHOJET *
4468* This version dated 11.12.99 is written by S. Roesler *
4469************************************************************************
4470
4471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4472 SAVE
4473
4474 PARAMETER ( LINP = 10 ,
4475 & LOUT = 6 ,
4476 & LDAT = 9 )
4477
4478 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4479 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4480
4481 LOGICAL LFLIP
4482
4483* event history
4484
4485 PARAMETER (NMXHKK=200000)
4486
4487 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4488 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4489 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4490
4491* extended event history
4492 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4493 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4494 & IHIST(2,NMXHKK)
4495
4496* Lorentz-parameters of the current interaction
4497 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4498 & UMO,PPCM,EPROJ,PPROJ
4499
4500* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4501 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4502
4503* flags for input different options
4504 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4505 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4506 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4507
4508* statistics: double-Pomeron exchange
4509 COMMON /DTFLG2/ INTFLG,IPOPO
4510
4511* statistics
4512 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4513 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4514 & ICEVTG(8,0:30)
4515
4516* rejection counter
4517 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4518 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4519 & IREXCI(3),IRDIFF(2),IRINC
4520C standard particle data interface
4521 INTEGER NMXHEP
4522
4523 PARAMETER (NMXHEP=4000)
4524
4525 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4526 DOUBLE PRECISION PHEP,VHEP
4527 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4528 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4529 & VHEP(4,NMXHEP)
4530C extension to standard particle data interface (PHOJET specific)
4531 INTEGER IMPART,IPHIST,ICOLOR
4532 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4533
4534C color string configurations including collapsed strings and hadrons
4535 INTEGER MSTR
4536 PARAMETER (MSTR=500)
4537 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4538 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4539 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4540 & NNCH(MSTR),IBHAD(MSTR),ISTR
4541
4542C general process information
4543 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4544 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4545
4546C model switches and parameters
4547 CHARACTER*8 MDLNA
4548 INTEGER ISWMDL,IPAMDL
4549 DOUBLE PRECISION PARMDL
4550 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4551
4552C event debugging information
4553 INTEGER NMAXD
4554 PARAMETER (NMAXD=100)
4555 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4556 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4557 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4558 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4559
4560 DIMENSION PP(4),PT(4)
4561 DATA MAXLOP /10000/
4562
4563 INHKK = NHKK
4564 LFLIP = .TRUE.
4565 1 CONTINUE
4566 NPVAL = 0
4567 NTVAL = 0
4568 IREJ = 0
4569
4570* store initial momenta for energy-momentum conservation check
4571 IF (LEMCCK) THEN
4572 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4573 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4574 ENDIF
4575* copy partons and strings from POEVT1 into DTEVT1
4576 DO 11 I=1,ISTR
4577C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4578 IF (NCODE(I).EQ.-99) THEN
4579 IDXSTG = NPOS(1,I)
4580 IDSTG = IDHEP(IDXSTG)
4581 PX = PHEP(1,IDXSTG)
4582 PY = PHEP(2,IDXSTG)
4583 PZ = PHEP(3,IDXSTG)
4584 PE = PHEP(4,IDXSTG)
4585 IF (MODE.LT.0) THEN
4586 ISTAT = 70000+IPJE
4587 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4588 & 11,IDSTG,0)
4589 IF (LEMCCK) THEN
4590 PX = -PX
4591 PY = -PY
4592 PZ = -PZ
4593 PE = -PE
4594 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4595 ENDIF
4596 ELSE
4597 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4598 & PPX,PPY,PPZ,PPE)
4599 ISTAT = 70000+IPJE
4600 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4601 & 11,IDSTG,0)
4602 IF (LEMCCK) THEN
4603 PX = -PPX
4604 PY = -PPY
4605 PZ = -PPZ
4606 PE = -PPE
4607 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4608 ENDIF
4609 ENDIF
4610 NOBAM(NHKK) = 0
4611 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4612 IHIST(2,NHKK) = 0
4613 ELSEIF (NCODE(I).GE.0) THEN
4614* indices of partons and string in POEVT1
4615 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4616 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4617 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4618 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4619 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4620 STOP ' GETPJE 1'
4621 ENDIF
4622 IDXSTG = NPOS(1,I)
4623* find "mother" string of the string
4624 IDXMS1 = ABS(JMOHEP(1,IDX1))
4625 IDXMS2 = ABS(JMOHEP(1,IDX2))
4626 IF (IDXMS1.NE.IDXMS2) THEN
4627 IDXMS1 = IDXSTG
4628 IDXMS2 = IDXSTG
4629C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4630 ENDIF
4631* search POEVT1 for the original hadron of the parton
4632 ILOOP = 0
4633 IPOM1 = 0
4634 14 CONTINUE
4635 ILOOP = ILOOP+1
4636
4637 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4638
4639 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4640 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4641 & (ILOOP.LT.MAXLOP)) GOTO 14
4642 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4643 IPOM2 = 0
4644 ILOOP = 0
4645 15 CONTINUE
4646 ILOOP = ILOOP+1
4647
4648 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4649
4650 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4651 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4652 ELSE
4653 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4654 ENDIF
4655 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4656 & (ILOOP.LT.MAXLOP)) GOTO 15
4657 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4658* parton 1
4659 IF (IDXMS1.EQ.1) THEN
4660 ISPTN1 = ISTHKK(MO1)
4661 M1PTN1 = MO1
4662 M2PTN1 = MO1+2
4663 ELSE
4664 ISPTN1 = ISTHKK(MO2)
4665 M1PTN1 = MO2-2
4666 M2PTN1 = MO2
4667 ENDIF
4668* parton 2
4669 IF (IDXMS2.EQ.1) THEN
4670 ISPTN2 = ISTHKK(MO1)
4671 M1PTN2 = MO1
4672 M2PTN2 = MO1+2
4673 ELSE
4674 ISPTN2 = ISTHKK(MO2)
4675 M1PTN2 = MO2-2
4676 M2PTN2 = MO2
4677 ENDIF
4678* check for mis-identified mothers and switch mother indices if necessary
4679 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4680 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4681 & (LFLIP)) THEN
4682 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4683 ISPTN1 = ISTHKK(MO1)
4684 M1PTN1 = MO1
4685 M2PTN1 = MO1+2
4686 ISPTN2 = ISTHKK(MO2)
4687 M1PTN2 = MO2-2
4688 M2PTN2 = MO2
4689 ELSE
4690 ISPTN1 = ISTHKK(MO2)
4691 M1PTN1 = MO2-2
4692 M2PTN1 = MO2
4693 ISPTN2 = ISTHKK(MO1)
4694 M1PTN2 = MO1
4695 M2PTN2 = MO1+2
4696 ENDIF
4697 ENDIF
4698* register partons in temporary common
4699* parton at chain end
4700 PX = PHEP(1,IDX1)
4701 PY = PHEP(2,IDX1)
4702 PZ = PHEP(3,IDX1)
4703 PE = PHEP(4,IDX1)
4704* flag only partons coming from Pomeron with 41/42
4705C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4706 IF (IPOM1.NE.0) THEN
4707 ISTX = ABS(ISPTN1)/10
4708 IMO = ABS(ISPTN1)-10*ISTX
4709 ISPTN1 = -(40+IMO)
4710 ELSE
4711 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4712 ISTX = ABS(ISPTN1)/10
4713 IMO = ABS(ISPTN1)-10*ISTX
4714 IF ((IDHEP(IDX1).EQ.21).OR.
4715 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4716 ISPTN1 = -(60+IMO)
4717 ELSE
4718 ISPTN1 = -(50+IMO)
4719 ENDIF
4720 ENDIF
4721 ENDIF
4722 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4723 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4724 IF (MODE.LT.0) THEN
4725 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4726 & PZ,PE,0,0,0)
4727 ELSE
4728 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4729 & PPX,PPY,PPZ,PPE)
4730 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4731 & PPZ,PPE,0,0,0)
4732 ENDIF
4733 IHIST(1,NHKK) = IPHIST(1,IDX1)
4734 IHIST(2,NHKK) = 0
4735 DO 19 KK=1,4
4736 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4737 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4738 19 CONTINUE
4739 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4740 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4741 M1STRG = NHKK
4742* gluon kinks
4743 NGLUON = IDX2-IDX1-1
4744 IF (NGLUON.GT.0) THEN
4745 DO 17 IGLUON=1,NGLUON
4746 IDX = IDX1+IGLUON
4747 IDXMS = ABS(JMOHEP(1,IDX))
4748 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4749 ILOOP = 0
4750 16 CONTINUE
4751 ILOOP = ILOOP+1
4752 IDXMS = ABS(JMOHEP(1,IDXMS))
4753 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4754 & (ILOOP.LT.MAXLOP)) GOTO 16
4755 IF (ILOOP.EQ.MAXLOP)
4756 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4757 ENDIF
4758 IF (IDXMS.EQ.1) THEN
4759 ISPTN = ISTHKK(MO1)
4760 M1PTN = MO1
4761 M2PTN = MO1+2
4762 ELSE
4763 ISPTN = ISTHKK(MO2)
4764 M1PTN = MO2-2
4765 M2PTN = MO2
4766 ENDIF
4767 PX = PHEP(1,IDX)
4768 PY = PHEP(2,IDX)
4769 PZ = PHEP(3,IDX)
4770 PE = PHEP(4,IDX)
4771 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4772 ISTX = ABS(ISPTN)/10
4773 IMO = ABS(ISPTN)-10*ISTX
4774 IF ((IDHEP(IDX).EQ.21).OR.
4775 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4776 ISPTN = -(60+IMO)
4777 ELSE
4778 ISPTN = -(50+IMO)
4779 ENDIF
4780 ENDIF
4781 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4782 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4783 IF (MODE.LT.0) THEN
4784 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4785 & PX,PY,PZ,PE,0,0,0)
4786 ELSE
4787 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4788 & PPX,PPY,PPZ,PPE)
4789 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4790 & PPX,PPY,PPZ,PPE,0,0,0)
4791 ENDIF
4792 IHIST(1,NHKK) = IPHIST(1,IDX)
4793 IHIST(2,NHKK) = 0
4794 DO 20 KK=1,4
4795 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4796 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4797 20 CONTINUE
4798 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4799 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4800 17 CONTINUE
4801 ENDIF
4802* parton at chain end
4803 PX = PHEP(1,IDX2)
4804 PY = PHEP(2,IDX2)
4805 PZ = PHEP(3,IDX2)
4806 PE = PHEP(4,IDX2)
4807* flag only partons coming from Pomeron with 41/42
4808C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4809 IF (IPOM2.NE.0) THEN
4810 ISTX = ABS(ISPTN2)/10
4811 IMO = ABS(ISPTN2)-10*ISTX
4812 ISPTN2 = -(40+IMO)
4813 ELSE
4814 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4815 ISTX = ABS(ISPTN2)/10
4816 IMO = ABS(ISPTN2)-10*ISTX
4817 IF ((IDHEP(IDX2).EQ.21).OR.
4818 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4819 ISPTN2 = -(60+IMO)
4820 ELSE
4821 ISPTN2 = -(50+IMO)
4822 ENDIF
4823 ENDIF
4824 ENDIF
4825 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4826 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4827 IF (MODE.LT.0) THEN
4828 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4829 & PX,PY,PZ,PE,0,0,0)
4830 ELSE
4831 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4832 & PPX,PPY,PPZ,PPE)
4833 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4834 & PPX,PPY,PPZ,PPE,0,0,0)
4835 ENDIF
4836 IHIST(1,NHKK) = IPHIST(1,IDX2)
4837 IHIST(2,NHKK) = 0
4838 DO 21 KK=1,4
4839 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4840 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4841 21 CONTINUE
4842 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4843 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4844 M2STRG = NHKK
4845* register string
4846 JSTRG = 100*IPROCE+NCODE(I)
4847 PX = PHEP(1,IDXSTG)
4848 PY = PHEP(2,IDXSTG)
4849 PZ = PHEP(3,IDXSTG)
4850 PE = PHEP(4,IDXSTG)
4851 IF (MODE.LT.0) THEN
4852 ISTAT = 70000+IPJE
4853 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4854 & PX,PY,PZ,PE,0,0,0)
4855 IF (LEMCCK) THEN
4856 PX = -PX
4857 PY = -PY
4858 PZ = -PZ
4859 PE = -PE
4860 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4861 ENDIF
4862 ELSE
4863 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4864 & PPX,PPY,PPZ,PPE)
4865 ISTAT = 70000+IPJE
4866 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4867 & PPX,PPY,PPZ,PPE,0,0,0)
4868 IF (LEMCCK) THEN
4869 PX = -PPX
4870 PY = -PPY
4871 PZ = -PPZ
4872 PE = -PPE
4873 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4874 ENDIF
4875 ENDIF
4876 NOBAM(NHKK) = 0
4877 IHIST(1,NHKK) = 0
4878 IHIST(2,NHKK) = 0
4879 DO 18 KK=1,4
4880 VHKK(KK,NHKK) = VHKK(KK,MO2)
4881 WHKK(KK,NHKK) = WHKK(KK,MO1)
4882 18 CONTINUE
4883 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4884 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4885 ENDIF
4886 11 CONTINUE
4887
4888 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4889 NHKK = INHKK
4890 LFLIP = .FALSE.
4891 GOTO 1
4892 ENDIF
4893
4894 IF (LEMCCK) THEN
4895 IF (UMO.GT.1.0D5) THEN
4896 CHKLEV = 1.0D0
4897 ELSE
4898 CHKLEV = TINY1
4899 ENDIF
4900 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4901
4902 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4903
4904 ENDIF
4905
4906* internal statistics
4907* dble-Po statistics.
4908 IF (IPROCE.NE.4) IPOPO = 0
4909
4910 INTFLG = IPROCE
4911 IDCHSY = IDCH(MO1)
4912 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4913 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4914 ELSE
4915 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4916 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4917 & ') at evt(chain) ',I6,'(',I2,')')
4918 ENDIF
4919 IF (IPROCE.EQ.5) THEN
4920 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4921 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4922 ELSE
4923C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4924 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4925 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4926 ENDIF
4927 ELSEIF (IPROCE.EQ.6) THEN
4928 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4929 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4930 ELSE
4931C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4932 ENDIF
4933 ELSEIF (IPROCE.EQ.7) THEN
4934 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4935 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4936 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4937 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4938 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4939 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4940 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4941 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4942 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4943 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4944 ELSE
4945 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4946 ENDIF
4947 ENDIF
4948 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4949 & THEN
4950 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4951 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4952 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4953 ENDIF
4954 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4955 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4956 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4957 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4958 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4959
4960 RETURN
4961
4962 9999 CONTINUE
4963 IREJ = 1
4964 RETURN
4965 END
4966
4967*$ CREATE DT_PHOINI.FOR
4968*COPY DT_PHOINI
4969*
4970*===phoini=============================================================*
4971*
4972 SUBROUTINE DT_PHOINI
4973
4974************************************************************************
4975* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4976* This version dated 16.11.95 is written by S. Roesler *
4977* *
4978* Last change 27.12.2006 by S. Roesler. *
4979************************************************************************
4980
4981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982 SAVE
4983
4984 PARAMETER ( LINP = 10 ,
4985 & LOUT = 6 ,
4986 & LDAT = 9 )
4987
4988 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4989
4990* nucleon-nucleon event-generator
4991 CHARACTER*8 CMODEL
4992 LOGICAL LPHOIN
4993 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4994
4995* particle properties (BAMJET index convention)
4996 CHARACTER*8 ANAME
4997 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4998 & IICH(210),IIBAR(210),K1(210),K2(210)
4999
5000* Lorentz-parameters of the current interaction
5001 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5002 & UMO,PPCM,EPROJ,PPROJ
5003
5004* properties of interacting particles
5005 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5006
5007* properties of photon/lepton projectiles
5008 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5009
5010 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5011
5012* emulsion treatment
5013 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5014 & NCOMPO,IEMUL
5015
5016* VDM parameter for photon-nucleus interactions
5017 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5018
5019* nuclear potential
5020 LOGICAL LFERMI
5021 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5022 & EBINDP(2),EBINDN(2),EPOT(2,210),
5023 & ETACOU(2),ICOUL,LFERMI
5024
5025* Glauber formalism: flags and parameters for statistics
5026 LOGICAL LPROD
5027 CHARACTER*8 CGLB
5028 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5029*
5030* parameters for cascade calculations:
5031* maximum mumber of PDF's which can be defined in phojet (limited
5032* by the dimension of ipdfs in pho_setpdf)
5033 PARAMETER (MAXPDF = 20)
5034* PDF parametrization and number of set for the first 30 hadrons in
5035* the bamjet-code list
5036* negative numbers mean that the PDF is set in phojet,
5037* zero stands for "not a hadron"
5038 DIMENSION IPARPD(30),ISETPD(30)
5039* PDF parametrization
5040 DATA IPARPD /
5041 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5042 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5043* number of set
5044 DATA ISETPD /
5045 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5046 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5047
5048**PHOJET105a
5049C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5050C PARAMETER ( MAXPRO = 16 )
5051C PARAMETER ( MAXTAB = 20 )
5052C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5053C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5054C CHARACTER*8 MDLNA
5055C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5056C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5057**PHOJET110
5058
5059C global event kinematics and particle IDs
5060 INTEGER IFPAP,IFPAB
5061 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5062 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5063
5064C hard cross sections and MC selection weights
5065 INTEGER Max_pro_2
5066 PARAMETER ( Max_pro_2 = 16 )
5067 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5068 & MH_acc_1,MH_acc_2
5069 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5070 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5071 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5072 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5073 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5074 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5075
5076C model switches and parameters
5077 CHARACTER*8 MDLNA
5078 INTEGER ISWMDL,IPAMDL
5079 DOUBLE PRECISION PARMDL
5080 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5081
5082C general process information
5083 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5084 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5085**
5086 DIMENSION PP(4),PT(4)
5087
5088 LOGICAL LSTART
5089 DATA LSTART /.TRUE./
5090
5091 IJP = IJPROJ
5092 IJT = IJTARG
5093 Q2 = VIRT
5094* lepton-projectiles: initialize real photon instead
5095 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5096 IJP = 7
5097 Q2 = ZERO
5098 ENDIF
5099
5100 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5101
5102* switch Reggeon off
5103C IPAMDL(3)= 0
5104 IF (IP.EQ.1) THEN
5105 IFPAP(1) = IDT_IPDGHA(IJP)
5106 IFPAB(1) = IJP
5107 ELSE
5108 IFPAP(1) = 2212
5109 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5110 ENDIF
5111 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5112 PVIRT(1) = PMASS(1)**2
5113 IF (IT.EQ.1) THEN
5114 IFPAP(2) = IDT_IPDGHA(IJT)
5115 IFPAB(2) = IJT
5116 ELSE
5117 IFPAP(2) = 2212
5118 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5119 ENDIF
5120 PMASS(2) = AAM(IFPAB(2))
5121 PVIRT(2) = ZERO
5122 DO 1 K=1,4
5123 PP(K) = ZERO
5124 PT(K) = ZERO
5125 1 CONTINUE
5126* get max. possible momenta of incoming particles to be used for PHOJET ini.
5127 PPF = ZERO
5128 PTF = ZERO
5129 SCPF= 1.5D0
5130 IF (UMO.GE.1.E5) THEN
5131 SCPF= 5.0D0
5132 ENDIF
5133 IF (NCOMPO.GT.0) THEN
5134 DO 2 I=1,NCOMPO
5135 IF (IT.GT.1) THEN
5136 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5137 ELSE
5138 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5139 ENDIF
5140 PPFTMP = MAX(PFERMP(1),PFERMN(1))
5141 PTFTMP = MAX(PFERMP(2),PFERMN(2))
5142 IF (PPFTMP.GT.PPF) PPF = PPFTMP
5143 IF (PTFTMP.GT.PTF) PTF = PTFTMP
5144 2 CONTINUE
5145 ELSE
5146 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5147 PPF = MAX(PFERMP(1),PFERMN(1))
5148 PTF = MAX(PFERMP(2),PFERMN(2))
5149 ENDIF
5150 PTF = -PTF
5151 PPF = SCPF*PPF
5152 PTF = SCPF*PTF
5153 IF (IJP.EQ.7) THEN
5154 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5155 PP(3) = PPCM
5156 PP(4) = SQRT(AMP2+PP(3)**2)
5157 ELSE
5158 EPF = SQRT(PPF**2+PMASS(1)**2)
5159 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5160 ENDIF
5161 ETF = SQRT(PTF**2+PMASS(2)**2)
5162 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5163 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5164 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5165 IF (LSTART) THEN
5166 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5167 1001 FORMAT(
5168 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
5169 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5170 IF (NCOMPO.GT.0) THEN
5171 WRITE(LOUT,1002) SCPF,PTF,PT
5172 ELSE
5173 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5174 ENDIF
5175 1002 FORMAT(
5176 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
5177 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5178 1003 FORMAT(
5179 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
5180 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5181 WRITE(LOUT,1004) ECMINI
5182 1004 FORMAT(' E_cm = ',E10.3)
5183 IF (IJP.EQ.8) WRITE(LOUT,1005)
5184 1005 FORMAT(
5185 & ' DT_PHOINI: warning! proton parameters used for neutron',
5186 & ' projectile')
5187 LSTART = .FALSE.
5188 ENDIF
5189* switch off new diffractive cross sections at low energies for nuclei
5190* (temporary solution)
5191 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5192 WRITE(LOUT,'(1X,A)')
5193 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5194 CALL PHO_SETMDL(30,0,1)
5195 ENDIF
5196*
5197C IF (IJP.EQ.7) THEN
5198C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5199C PP(3) = PPCM
5200C PP(4) = SQRT(AMP2+PP(3)**2)
5201C ELSE
5202C PFERMX = ZERO
5203C IF (IP.GT.1) PFERMX = 0.5D0
5204C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5205C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5206C ENDIF
5207C PFERMX = ZERO
5208C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5209C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5210C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5211**sr 26.10.96
5212 ISAV = IPAMDL(13)
5213 IF ((ISHAD(2).EQ.1).AND.
5214 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5215 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5216**
5217
5218 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5219
5220**sr 26.10.96
5221 IPAMDL(13) = ISAV
5222**
5223*
5224* patch for cascade calculations:
5225* define parton distribution functions for other hadrons, i.e. other
5226* then defined already in phojet
5227 IF (IOGLB.EQ.100) THEN
5228 WRITE(LOUT,1006)
5229 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5230 & ' assiged (ID,IPAR,ISET)',/)
5231 NPDF = 0
5232 DO 3 I=1,30
5233 IF (IPARPD(I).NE.0) THEN
5234 NPDF = NPDF+1
5235 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5236 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5237 IDPDG = IDT_IPDGHA(I)
5238 IPAR = IPARPD(I)
5239 ISET = ISETPD(I)
5240 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5241 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5242 ENDIF
5243 ENDIF
5244 3 CONTINUE
5245 ENDIF
5246
5247C CALL PHO_PHIST(-1,SIGMAX)
5248
5249 IF (IREJ1.NE.0) THEN
5250 WRITE(LOUT,1000)
5251 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
5252 STOP
5253 ENDIF
5254
5255 RETURN
5256 END
5257
5258*$ CREATE DT_EVENTD.FOR
5259*COPY DT_EVENTD
5260*
5261*===eventd=============================================================*
5262*
5263 SUBROUTINE DT_EVENTD(IREJ)
5264
5265************************************************************************
5266* Quasi-elastic neutrino nucleus scattering. *
5267* This version dated 29.04.00 is written by S. Roesler. *
5268************************************************************************
5269
5270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5271 SAVE
5272
5273 PARAMETER ( LINP = 10 ,
5274 & LOUT = 6 ,
5275 & LDAT = 9 )
5276
5277 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5278 PARAMETER (SQTINF=1.0D+15)
5279
5280 LOGICAL LFIRST
5281
5282* event history
5283
5284 PARAMETER (NMXHKK=200000)
5285
5286 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5287 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5288 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5289
5290* extended event history
5291 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5292 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5293 & IHIST(2,NMXHKK)
5294
5295* flags for input different options
5296 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5297 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5298 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5299 PARAMETER (MAXLND=4000)
5300 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5301
5302* properties of interacting particles
5303 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5304
5305* Lorentz-parameters of the current interaction
5306 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5307 & UMO,PPCM,EPROJ,PPROJ
5308
5309* nuclear potential
5310 LOGICAL LFERMI
5311 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5312 & EBINDP(2),EBINDN(2),EPOT(2,210),
5313 & ETACOU(2),ICOUL,LFERMI
5314
5315* steering flags for qel neutrino scattering modules
5316 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5317
5318 COMMON /QNPOL/ POLARX(4),PMODUL
5319
5320 INTEGER PYK
5321
5322 DATA LFIRST /.TRUE./
5323
5324 IREJ = 0
5325
5326 IF (LFIRST) THEN
5327 LFIRST = .FALSE.
5328 CALL DT_MASS_INI
5329 ENDIF
5330
5331* JETSET parameter
5332 CALL DT_INITJS(0)
5333
5334* interacting target nucleon
5335 LTYP = NEUTYP
5336 IF (NEUDEC.LE.9) THEN
5337 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5338 NUCTYP = 2112
5339 NUCTOP = 2
5340 ELSE
5341 NUCTYP = 2212
5342 NUCTOP = 1
5343 ENDIF
5344 ELSE
5345 RTYP = DT_RNDM(RTYP)
5346 ZFRAC = DBLE(ITZ)/DBLE(IT)
5347 IF (RTYP.LE.ZFRAC) THEN
5348 NUCTYP = 2212
5349 NUCTOP = 1
5350 ELSE
5351 NUCTYP = 2112
5352 NUCTOP = 2
5353 ENDIF
5354 ENDIF
5355
5356* select first nucleon in list with matching id and reset all other
5357* nucleons which have been marked as "wounded" by ININUC
5358 IFOUND = 0
5359 DO 1 I=1,NHKK
5360 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5361 ISTHKK(I) = 12
5362 IFOUND = 1
5363 IDX = I
5364 ELSE
5365 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5366 ENDIF
5367 1 CONTINUE
5368 IF (IFOUND.EQ.0)
5369 & STOP ' EVENTD: interacting target nucleon not found! '
5370
5371* correct position of proj. lepton: assume position of target nucleon
5372 DO 3 I=1,4
5373 VHKK(I,1) = VHKK(I,IDX)
5374 WHKK(I,1) = WHKK(I,IDX)
5375 3 CONTINUE
5376
5377* load initial momenta for conservation check
5378 IF (LEMCCK) THEN
5379 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5380 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5381 & 2,IDUM,IDUM)
5382 ENDIF
5383
5384* quasi-elastic scattering
5385 IF (NEUDEC.LT.9) THEN
5386 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5387 & PHKK(4,IDX),PHKK(5,IDX))
5388* CC event on p or n
5389 ELSEIF (NEUDEC.EQ.10) THEN
5390 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5391 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392* NC event on p or n
5393 ELSEIF (NEUDEC.EQ.11) THEN
5394 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5395 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5396 ENDIF
5397
5398* get final state particles from Lund-common and write them into HKKEVT
5399 NPOINT(1) = NHKK+1
5400 NPOINT(4) = NHKK+1
5401
5402 NLINES = PYK(0,1)
5403
5404 NHKK0 = NHKK+1
5405 DO 4 I=4,NLINES
5406 IF (K(I,1).EQ.1) THEN
5407 ID = K(I,2)
5408 PX = P(I,1)
5409 PY = P(I,2)
5410 PZ = P(I,3)
5411 PE = P(I,4)
5412 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5413 IDBJ = IDT_ICIHAD(ID)
5414 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5415 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5416 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5417 ENDIF
5418 VHKK(1,NHKK) = VHKK(1,IDX)
5419 VHKK(2,NHKK) = VHKK(2,IDX)
5420 VHKK(3,NHKK) = VHKK(3,IDX)
5421 VHKK(4,NHKK) = VHKK(4,IDX)
5422C IF (I.EQ.4) THEN
5423C WHKK(1,NHKK) = POLARX(1)
5424C WHKK(2,NHKK) = POLARX(2)
5425C WHKK(3,NHKK) = POLARX(3)
5426C WHKK(4,NHKK) = POLARX(4)
5427C ELSE
5428 WHKK(1,NHKK) = WHKK(1,IDX)
5429 WHKK(2,NHKK) = WHKK(2,IDX)
5430 WHKK(3,NHKK) = WHKK(3,IDX)
5431 WHKK(4,NHKK) = WHKK(4,IDX)
5432C ENDIF
5433 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5434 ENDIF
5435 4 CONTINUE
5436
5437 IF (LEMCCK) THEN
5438 CHKLEV = TINY5
5439 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5440 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5441 ENDIF
5442
5443* transform momenta into cms (as required for inc etc.)
5444 DO 5 I=NHKK0,NHKK
5445 IF (ISTHKK(I).EQ.1) THEN
5446 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5447 PHKK(3,I) = PZ
5448 PHKK(4,I) = PE
5449 ENDIF
5450 5 CONTINUE
5451
5452 RETURN
5453 END
5454*$ CREATE DT_KKEVNT.FOR
5455*COPY DT_KKEVNT
5456*
5457*===kkevnt=============================================================*
5458*
5459 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5460
5461************************************************************************
5462* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5463* without nuclear effects (one event). *
5464* This subroutine is an update of the previous version (KKEVT) written *
5465* by J. Ranft/ H.-J. Moehring. *
5466* This version dated 20.04.95 is written by S. Roesler *
5467************************************************************************
5468
5469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5470 SAVE
5471
5472 PARAMETER ( LINP = 10 ,
5473 & LOUT = 6 ,
5474 & LDAT = 9 )
5475
5476 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5477
5478 PARAMETER ( MAXNCL = 260,
5479
5480 & MAXVQU = MAXNCL,
5481 & MAXSQU = 20*MAXVQU,
5482 & MAXINT = MAXVQU+MAXSQU)
5483
5484* event history
5485
5486 PARAMETER (NMXHKK=200000)
5487
5488 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5489 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5490 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5491
5492* extended event history
5493 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5494 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5495 & IHIST(2,NMXHKK)
5496
5497* flags for input different options
5498 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5499 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5500 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5501
5502* rejection counter
5503 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5504 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5505 & IREXCI(3),IRDIFF(2),IRINC
5506
5507* statistics
5508 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5509 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5510 & ICEVTG(8,0:30)
5511
5512* properties of interacting particles
5513 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5514
5515* Lorentz-parameters of the current interaction
5516 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5517 & UMO,PPCM,EPROJ,PPROJ
5518
5519* flags for diffractive interactions (DTUNUC 1.x)
5520 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5521
5522* interface HADRIN-DPM
5523 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5524
5525* nucleon-nucleon event-generator
5526 CHARACTER*8 CMODEL
5527 LOGICAL LPHOIN
5528 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5529
5530* coordinates of nucleons
5531 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5532
5533* interface between Glauber formalism and DPM
5534 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5535 & INTER1(MAXINT),INTER2(MAXINT)
5536
5537* Glauber formalism: collision properties
5538 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
ebb0c0e0 5539 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5540 & NCP,NCT
7b076c76 5541
5542* central particle production, impact parameter biasing
5543 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5544**temporary
5545
5546* statistics: Glauber-formalism
5547 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5548**
5549
5550 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5551
5552 IREJ = 0
5553 ICREQU = ICREQU+1
5554 NC = 0
ebb0c0e0 5555 NCP = 0
5556 NCT = 0
7b076c76 5557
5558 1 CONTINUE
5559 ICSAMP = ICSAMP+1
5560 NC = NC+1
5561 IF (MOD(NC,10).EQ.0) THEN
5562 WRITE(LOUT,1000) NEVHKK
5563 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5564 GOTO 9999
5565 ENDIF
5566
5567* initialize DTEVT1/DTEVT2
5568 CALL DT_EVTINI
5569
5570* We need the following only in order to sample nucleon coordinates.
5571* However we don't have parameters (cross sections, slope etc.)
5572* for neutrinos available. Therefore switch projectile to proton
5573* in this case.
5574 IF (MCGENE.EQ.4) THEN
5575 JJPROJ = 1
5576 ELSE
5577 JJPROJ = IJPROJ
5578 ENDIF
5579
5580 10 CONTINUE
5581 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5582* make sure that Glauber-formalism is called each time the interaction
5583* configuration changed
5584 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5585 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5586* sample number of nucleon-nucleon coll. according to Glauber-form.
5587 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5588 NWTSAM = NN
5589 NWASAM = NP
5590 NWBSAM = NT
5591 NEVOLD = NEVHKK
5592 IPOLD = IP
5593 ITOLD = IT
5594 JJPOLD = JJPROJ
5595 EPROLD = EPROJ
7d5a4d62 5596 DO 8 I=1, IP
ebb0c0e0 5597 NCP = NCP+JSSH(I)
5598* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5599 8 CONTINUE
7d5a4d62 5600 DO 9 I=1, IT
ebb0c0e0 5601 NCT = NCT+JTSH(I)
5602* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5603 9 CONTINUE
7b076c76 5604 ENDIF
5605
5606* force diffractive particle production in h-K interactions
5607 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5608 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5609 NEVOLD = 0
5610 GOTO 10
5611 ENDIF
5612
5613* check number of involved proj. nucl. (NP) if central prod.is requested
5614 IF (ICENTR.GT.0) THEN
5615 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5616 IF (IBACK.GT.0) GOTO 10
5617 ENDIF
5618
5619* get initial nucleon-configuration in projectile and target
5620* rest-system (including Fermi-momenta if requested)
5621 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5622 MODE = 2
5623 IF (EPROJ.LE.EHADTH) MODE = 3
5624 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5625
5626 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5627
5628* activate HADRIN at low energies (implemented for h-N scattering only)
5629 IF (EPROJ.LE.EHADHI) THEN
5630 IF (EHADTH.LT.ZERO) THEN
5631* smooth transition btwn. DPM and HADRIN
5632 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5633 RR = DT_RNDM(FRAC)
5634 IF (RR.GT.FRAC) THEN
5635 IF (IP.EQ.1) THEN
5636 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5637 IF (IREJ1.GT.0) GOTO 1
5638 RETURN
5639 ELSE
5640 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5641 ENDIF
5642 ENDIF
5643 ELSE
5644* fixed threshold for onset of production via HADRIN
5645 IF (EPROJ.LE.EHADTH) THEN
5646 IF (IP.EQ.1) THEN
5647 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5648 IF (IREJ1.GT.0) GOTO 1
5649 RETURN
5650 ELSE
5651 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5652 ENDIF
5653 ENDIF
5654 ENDIF
5655 ENDIF
5656 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5657 & I3,') with target (m=',I3,')',/,11X,
5658 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5659 & 'GeV) cannot be handled')
5660
5661* sampling of momentum-x fractions & flavors of chain ends
5662 CALL DT_SPLPTN(NN)
5663
5664* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5665 CALL DT_NUC2CM
5666
5667* collect momenta of chain ends and put them into DTEVT1
5668 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5669 IF (IREJ1.NE.0) GOTO 1
5670
5671 ENDIF
5672
5673* handle chains including fragmentation (two-chain approximation)
5674 IF (MCGENE.EQ.1) THEN
5675* two-chain approximation
5676 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5677 IF (IREJ1.NE.0) THEN
5678 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5679 GOTO 1
5680 ENDIF
5681 ELSEIF (MCGENE.EQ.2) THEN
5682* multiple-Po exchange including minijets
5683 CALL DT_EVENTB(NCSY,IREJ1)
5684 IF (IREJ1.NE.0) THEN
5685 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5686 GOTO 1
5687 ENDIF
5688 ELSEIF (MCGENE.EQ.3) THEN
5689 STOP ' This version does not contain LEPTO !'
5690
5691 ELSEIF (MCGENE.EQ.4) THEN
5692* quasi-elastic neutrino scattering
5693 CALL DT_EVENTD(IREJ1)
5694 IF (IREJ1.NE.0) THEN
5695 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5696 GOTO 1
5697 ENDIF
5698 ELSE
5699 WRITE(LOUT,1002) MCGENE
5700 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5701 & ' not available - program stopped')
5702 STOP
5703 ENDIF
5704
5705 RETURN
5706
5707 9999 CONTINUE
5708 IREJ = 1
5709 RETURN
5710 END
5711
5712*$ CREATE DT_CHKCEN.FOR
5713*COPY DT_CHKCEN
5714*
5715*===chkcen=============================================================*
5716*
5717 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5718
5719************************************************************************
5720* Check of number of involved projectile nucleons if central production*
5721* is requested. *
5722* Adopted from a part of the old KKEVT routine which was written by *
5723* J. Ranft/H.-J.Moehring. *
5724* This version dated 13.01.95 is written by S. Roesler *
5725************************************************************************
5726
5727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5728 SAVE
5729
5730 PARAMETER ( LINP = 10 ,
5731 & LOUT = 6 ,
5732 & LDAT = 9 )
5733
5734* statistics
5735 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5736 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5737 & ICEVTG(8,0:30)
5738
5739* central particle production, impact parameter biasing
5740 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5741
5742 IBACK = 0
5743
5744* old version
5745 IF (ICENTR.EQ.2) THEN
5746 IF (IP.LT.IT) THEN
5747 IF (IP.LE.8) THEN
5748 IF (NP.LT.IP-1) IBACK = 1
5749 ELSEIF (IP.LE.16) THEN
5750 IF (NP.LT.IP-2) IBACK = 1
5751 ELSEIF (IP.LE.32) THEN
5752 IF (NP.LT.IP-3) IBACK = 1
5753 ELSEIF (IP.GE.33) THEN
5754 IF (NP.LT.IP-5) IBACK = 1
5755 ENDIF
5756 ELSEIF (IP.EQ.IT) THEN
5757 IF (IP.EQ.32) THEN
5758 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5759 ELSE
5760 IF (NP.LT.IP-IP/8) IBACK = 1
5761 ENDIF
5762 ELSEIF (ABS(IP-IT).LT.3) THEN
5763 IF (NP.LT.IP-IP/8) IBACK = 1
5764 ENDIF
5765 ELSE
5766* new version (DPMJET, 5.6.99)
5767 IF (IP.LT.IT) THEN
5768 IF (IP.LE.8) THEN
5769 IF (NP.LT.IP-1) IBACK = 1
5770 ELSEIF (IP.LE.16) THEN
5771 IF (NP.LT.IP-2) IBACK = 1
5772 ELSEIF (IP.LT.32) THEN
5773 IF (NP.LT.IP-3) IBACK = 1
5774 ELSEIF (IP.GE.32) THEN
5775 IF (IT.LE.150) THEN
5776* Example: S-Ag
5777 IF (NP.LT.IP-1) IBACK = 1
5778 ELSE
5779* Example: S-Au
5780 IF (NP.LT.IP) IBACK = 1
5781 ENDIF
5782 ENDIF
5783 ELSEIF (IP.EQ.IT) THEN
5784* Example: S-S
5785 IF (IP.EQ.32) THEN
5786 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5787* Example: Pb-Pb
5788 ELSE
5789 IF (NP.LT.IP-IP/4) IBACK = 1
5790 ENDIF
5791 ELSEIF (ABS(IP-IT).LT.3) THEN
5792 IF (NP.LT.IP-IP/8) IBACK = 1
5793 ENDIF
5794 ENDIF
5795
5796 ICCPRO = ICCPRO+1
5797
5798 RETURN
5799 END
5800
5801*$ CREATE DT_ININUC.FOR
5802*COPY DT_ININUC
5803*
5804*===ininuc=============================================================*
5805*
5806 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5807
5808************************************************************************
5809* Samples initial configuration of nucleons in nucleus with mass NMASS *
5810* including Fermi-momenta (if reqested). *
5811* ID BAMJET-code for hadrons (instead of nuclei) *
5812* NMASS mass number of nucleus (number of nucleons) *
5813* NCH charge of nucleus *
5814* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5815* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5816* IMODE = 1 projectile nucleus *
5817* = 2 target nucleus *
5818* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5819* Adopted from a part of the old KKEVT routine which was written by *
5820* J. Ranft/H.-J.Moehring. *
5821* This version dated 13.01.95 is written by S. Roesler *
5822************************************************************************
5823
5824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5825 SAVE
5826
5827 PARAMETER ( LINP = 10 ,
5828 & LOUT = 6 ,
5829 & LDAT = 9 )
5830
5831 PARAMETER (FM2MM=1.0D-12)
5832
5833 PARAMETER ( MAXNCL = 260,
5834
5835 & MAXVQU = MAXNCL,
5836 & MAXSQU = 20*MAXVQU,
5837 & MAXINT = MAXVQU+MAXSQU)
5838
5839* event history
5840
5841 PARAMETER (NMXHKK=200000)
5842
5843 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5844 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5845 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5846
5847* extended event history
5848 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5849 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5850 & IHIST(2,NMXHKK)
5851
5852* flags for input different options
5853 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5854 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5855 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5856
5857* auxiliary common for chain system storage (DTUNUC 1.x)
5858 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5859
5860* nuclear potential
5861 LOGICAL LFERMI
5862 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5863 & EBINDP(2),EBINDN(2),EPOT(2,210),
5864 & ETACOU(2),ICOUL,LFERMI
5865
5866* properties of photon/lepton projectiles
5867 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5868
5869* particle properties (BAMJET index convention)
5870 CHARACTER*8 ANAME
5871 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5872 & IICH(210),IIBAR(210),K1(210),K2(210)
5873
5874* Glauber formalism: collision properties
5875 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5876 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5877
5878* flavors of partons (DTUNUC 1.x)
5879 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5880 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5881 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5882 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5883 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5884 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5885 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5886
5887* interface HADRIN-DPM
5888 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5889
5890 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5891
5892* number of neutrons
5893 NNEU = NMASS-NCH
5894* initializations
5895 NP = 0
5896 NN = 0
5897 DO 1 K=1,4
5898 PFTOT(K) = 0.0D0
5899 1 CONTINUE
5900 MODE = IMODE
5901 IF (IMODE.GT.2) MODE = 2
5902**sr 29.5. new NPOINT(1)-definition
5903C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5904**
5905 NHADRI = 0
5906 NC = NHKK
5907
5908* get initial configuration
5909 DO 2 I=1,NMASS
5910 NHKK = NHKK+1
5911 IF (JS(I).GT.0) THEN
5912 ISTHKK(NHKK) = 10+MODE
5913 IF (IMODE.EQ.3) THEN
5914* additional treatment if HADRIN-generator is requested
5915 NHADRI = NHADRI+1
5916 IF (NHADRI.EQ.1) IDXTA = NHKK
5917 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5918 ENDIF
5919 ELSE
5920 ISTHKK(NHKK) = 12+MODE
5921 ENDIF
5922 IF (NMASS.GE.2) THEN
5923* treatment for nuclei
5924 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5925 RR = DT_RNDM(FRAC)
5926 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5927 IDX = 8
5928 NN = NN+1
5929 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5930 IDX = 1
5931 NP = NP+1
5932 ELSEIF (NN.LT.NNEU) THEN
5933 IDX = 8
5934 NN = NN+1
5935 ELSEIF (NP.LT.NCH) THEN
5936 IDX = 1
5937 NP = NP+1
5938 ENDIF
5939 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5940 IDBAM(NHKK) = IDX
5941 IF (MODE.EQ.1) THEN
5942 IPOSP(I) = NHKK
5943 KKPROJ(I) = IDX
5944 ELSE
5945 IPOST(I) = NHKK
5946 KKTARG(I) = IDX
5947 ENDIF
5948 IF (IDX.EQ.1) THEN
5949 PFER = PFERMP(MODE)
5950 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5951 ELSE
5952 PFER = PFERMN(MODE)
5953 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5954 ENDIF
5955 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5956 DO 3 K=1,4
5957 PFTOT(K) = PFTOT(K)+PF(K)
5958 PHKK(K,NHKK) = PF(K)
5959 3 CONTINUE
5960 PHKK(5,NHKK) = AAM(IDX)
5961 ELSE
5962* treatment for hadrons
5963 IDHKK(NHKK) = IDT_IPDGHA(ID)
5964 IDBAM(NHKK) = ID
5965 PHKK(4,NHKK) = AAM(ID)
5966 PHKK(5,NHKK) = AAM(ID)
5967C* VDM assumption
5968C IF (IDHKK(NHKK).EQ.22) THEN
5969C PHKK(4,NHKK) = AAM(33)
5970C PHKK(5,NHKK) = AAM(33)
5971C ENDIF
5972 IF (MODE.EQ.1) THEN
5973 IPOSP(I) = NHKK
5974 KKPROJ(I) = ID
5975 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5976 ELSE
5977 IPOST(I) = NHKK
5978 KKTARG(I) = ID
5979 ENDIF
5980 ENDIF
5981 DO 4 K=1,3
5982 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5983 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5984 4 CONTINUE
5985 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5986 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5987 VHKK(4,NHKK) = 0.0D0
5988 WHKK(4,NHKK) = 0.0D0
5989 2 CONTINUE
5990
5991* balance Fermi-momenta
5992 IF (NMASS.GE.2) THEN
5993 DO 5 I=1,NMASS
5994 NC = NC+1
5995 DO 6 K=1,3
5996 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5997 6 CONTINUE
5998 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5999 & PHKK(2,NC)**2+PHKK(3,NC)**2)
6000 5 CONTINUE
6001 ENDIF
6002
6003 RETURN
6004 END
6005
6006*$ CREATE DT_FER4M.FOR
6007*COPY DT_FER4M
6008*
6009*===fer4m==============================================================*
6010*
6011 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6012
6013************************************************************************
6014* Sampling of nucleon Fermi-momenta from distributions at T=0. *
6015* processed by S. Roesler, 17.10.95 *
6016************************************************************************
6017
6018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6019 SAVE
6020
6021 PARAMETER ( LINP = 10 ,
6022 & LOUT = 6 ,
6023 & LDAT = 9 )
6024
6025 LOGICAL LSTART
6026
6027* particle properties (BAMJET index convention)
6028 CHARACTER*8 ANAME
6029 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6030 & IICH(210),IIBAR(210),K1(210),K2(210)
6031
6032* nuclear potential
6033 LOGICAL LFERMI
6034 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6035 & EBINDP(2),EBINDN(2),EPOT(2,210),
6036 & ETACOU(2),ICOUL,LFERMI
6037
6038 DATA LSTART /.TRUE./
6039
6040 ILOOP = 0
6041 IF (LFERMI) THEN
6042 IF (LSTART) THEN
6043 WRITE(LOUT,1000)
6044 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6045 LSTART = .FALSE.
6046 ENDIF
6047 1 CONTINUE
6048 CALL DT_DFERMI(PABS)
6049 PABS = PFERM*PABS
6050C IF (PABS.GE.PBIND) THEN
6051C ILOOP = ILOOP+1
6052C IF (MOD(ILOOP,500).EQ.0) THEN
6053C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6054C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6055C & ' energy ',2E12.3,I6)
6056C ENDIF
6057C GOTO 1
6058C ENDIF
6059 CALL DT_DPOLI(POLC,POLS)
6060 CALL DT_DSFECF(SFE,CFE)
6061 CXTA = POLS*CFE
6062 CYTA = POLS*SFE
6063 CZTA = POLC
6064 ET = SQRT(PABS*PABS+AAM(KT)**2)
6065 PXT = CXTA*PABS
6066 PYT = CYTA*PABS
6067 PZT = CZTA*PABS
6068 ELSE
6069 ET = AAM(KT)
6070 PXT = 0.0D0
6071 PYT = 0.0D0
6072 PZT = 0.0D0
6073 ENDIF
6074
6075 RETURN
6076 END
6077
6078*$ CREATE DT_NUC2CM.FOR
6079*COPY DT_NUC2CM
6080*
6081*===nuc2cm=============================================================*
6082*
6083 SUBROUTINE DT_NUC2CM
6084
6085************************************************************************
6086* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6087* nucl. cms. (This subroutine replaces NUCMOM.) *
6088* This version dated 15.01.95 is written by S. Roesler *
6089************************************************************************
6090
6091 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6092 SAVE
6093
6094 PARAMETER ( LINP = 10 ,
6095 & LOUT = 6 ,
6096 & LDAT = 9 )
6097
6098 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6099
6100* event history
6101
6102 PARAMETER (NMXHKK=200000)
6103
6104 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6105 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6106 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6107
6108* extended event history
6109 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6110 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6111 & IHIST(2,NMXHKK)
6112
6113* statistics
6114 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6115 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6116 & ICEVTG(8,0:30)
6117
6118* properties of photon/lepton projectiles
6119 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6120
6121* particle properties (BAMJET index convention)
6122 CHARACTER*8 ANAME
6123 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6124 & IICH(210),IIBAR(210),K1(210),K2(210)
6125
6126* Glauber formalism: collision properties
6127 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6128 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6129**temporary
6130
6131* statistics: Glauber-formalism
6132 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6133**
6134
6135 ICWP = 0
6136 ICWT = 0
6137 NWTACC = 0
6138 NWAACC = 0
6139 NWBACC = 0
6140
6141 NPOINT(1) = NHKK+1
6142 NEND = NHKK
6143 DO 1 I=1,NEND
6144 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6145 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6146 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6147 MODE = ISTHKK(I)-9
6148C IF (IDHKK(I).EQ.22) THEN
6149C* VDM assumption
6150C PEIN = AAM(33)
6151C IDB = 33
6152C ELSE
6153C PEIN = PHKK(4,I)
6154C IDB = IDBAM(I)
6155C ENDIF
6156C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6157C & PX,PY,PZ,PE,IDB,MODE)
6158 IF (PHKK(5,I).GT.ZERO) THEN
6159 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6160 & PX,PY,PZ,PE,IDBAM(I),MODE)
6161 ELSE
6162 PX = PGAMM(1)
6163 PY = PGAMM(2)
6164 PZ = PGAMM(3)
6165 PE = PGAMM(4)
6166 ENDIF
6167 IST = ISTHKK(I)-2
6168 ID = IDHKK(I)
6169C* VDM assumption
6170C IF (ID.EQ.22) ID = 113
6171 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6172 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6173 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6174 ENDIF
6175 1 CONTINUE
6176
6177 NWTACC = MAX(NWAACC,NWBACC)
6178 ICDPR = ICDPR+ICWP
6179 ICDTA = ICDTA+ICWT
6180**temporary
6181 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6182 CALL DT_EVTOUT(4)
6183 STOP
6184 ENDIF
6185
6186 RETURN
6187 END
6188
6189*$ CREATE DT_SPLPTN.FOR
6190*COPY DT_SPLPTN
6191*
6192*===splptn=============================================================*
6193*
6194 SUBROUTINE DT_SPLPTN(NN)
6195
6196************************************************************************
6197* SamPLing of ParToN momenta and flavors. *
6198* This version dated 15.01.95 is written by S. Roesler *
6199************************************************************************
6200
6201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6202 SAVE
6203
6204 PARAMETER ( LINP = 10 ,
6205 & LOUT = 6 ,
6206 & LDAT = 9 )
6207
6208* Lorentz-parameters of the current interaction
6209 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6210 & UMO,PPCM,EPROJ,PPROJ
6211
6212* sample flavors of sea-quarks
6213 CALL DT_SPLFLA(NN,1)
6214
6215* sample x-values of partons at chain ends
6216 ECM = UMO
6217 CALL DT_XKSAMP(NN,ECM)
6218
6219* samle flavors
6220 CALL DT_SPLFLA(NN,2)
6221
6222 RETURN
6223 END
6224
6225*$ CREATE DT_SPLFLA.FOR
6226*COPY DT_SPLFLA
6227*
6228*===splfla=============================================================*
6229*
6230 SUBROUTINE DT_SPLFLA(NN,MODE)
6231
6232************************************************************************
6233* SamPLing of FLAvors of partons at chain ends. *
6234* This subroutine replaces FLKSAA/FLKSAM. *
6235* NN number of nucleon-nucleon interactions *
6236* MODE = 1 sea-flavors *
6237* = 2 valence-flavors *
6238* Based on the original version written by J. Ranft/H.-J. Moehring. *
6239* This version dated 16.01.95 is written by S. Roesler *
6240************************************************************************
6241
6242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6243 SAVE
6244
6245 PARAMETER ( LINP = 10 ,
6246 & LOUT = 6 ,
6247 & LDAT = 9 )
6248
6249 PARAMETER ( MAXNCL = 260,
6250
6251 & MAXVQU = MAXNCL,
6252 & MAXSQU = 20*MAXVQU,
6253 & MAXINT = MAXVQU+MAXSQU)
6254
6255* flavors of partons (DTUNUC 1.x)
6256 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6257 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6258 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6259 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6260 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6261 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6262 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6263
6264* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6265 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6266 & IXPV,IXPS,IXTV,IXTS,
6267 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6268 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6269 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6270 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6271 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6272 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6273 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6274 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6275
6276* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6277 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6278 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6279
6280* particle properties (BAMJET index convention)
6281 CHARACTER*8 ANAME
6282 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6283 & IICH(210),IIBAR(210),K1(210),K2(210)
6284
6285* various options for treatment of partons (DTUNUC 1.x)
6286* (chain recombination, Cronin,..)
6287 LOGICAL LCO2CR,LINTPT
6288 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6289 & LCO2CR,LINTPT
6290
6291 IF (MODE.EQ.1) THEN
6292* sea-flavors
6293 DO 1 I=1,NN
6294 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6295 IPSAQ(I) = -IPSQ(I)
6296 1 CONTINUE
6297 DO 2 I=1,NN
6298 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6299 ITSAQ(I)= -ITSQ(I)
6300 2 CONTINUE
6301 ELSEIF (MODE.EQ.2) THEN
6302* valence flavors
6303 DO 3 I=1,IXPV
6304 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6305 3 CONTINUE
6306 DO 4 I=1,IXTV
6307 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6308 4 CONTINUE
6309 ENDIF
6310
6311 RETURN
6312 END
6313
6314*$ CREATE DT_GETPTN.FOR
6315*COPY DT_GETPTN
6316*
6317*===getptn=============================================================*
6318*
6319 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6320
6321************************************************************************
6322* This subroutine collects partons at chain ends from temporary *
6323* commons and puts them into DTEVT1. *
6324* This version dated 15.01.95 is written by S. Roesler *
6325************************************************************************
6326
6327 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6328 SAVE
6329
6330 PARAMETER ( LINP = 10 ,
6331 & LOUT = 6 ,
6332 & LDAT = 9 )
6333
6334 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6335
6336 LOGICAL LCHK
6337
6338 PARAMETER ( MAXNCL = 260,
6339
6340 & MAXVQU = MAXNCL,
6341 & MAXSQU = 20*MAXVQU,
6342 & MAXINT = MAXVQU+MAXSQU)
6343
6344* event history
6345
6346 PARAMETER (NMXHKK=200000)
6347
6348 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6349 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6350 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6351
6352* extended event history
6353 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6354 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6355 & IHIST(2,NMXHKK)
6356
6357* flags for input different options
6358 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6359 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6360 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6361
6362* auxiliary common for chain system storage (DTUNUC 1.x)
6363 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6364
6365* statistics
6366 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6367 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6368 & ICEVTG(8,0:30)
6369
6370* flags for diffractive interactions (DTUNUC 1.x)
6371 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6372
6373* x-values of partons (DTUNUC 1.x)
6374 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6375 & XTVQ(MAXVQU),XTVD(MAXVQU),
6376 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6377 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6378
6379* flavors of partons (DTUNUC 1.x)
6380 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6381 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6382 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6383 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6384 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6385 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6386 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6387
6388* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6389 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6390 & IXPV,IXPS,IXTV,IXTS,
6391 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6392 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6393 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6394 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6395 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6396 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6397 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6398 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6399
6400* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6401 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6402 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6403
6404 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6405
6406 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6407
6408 IREJ = 0
6409 NCSY = 0
6410 NPOINT(2) = NHKK+1
6411
6412* sea-sea chains
6413 DO 10 I=1,NSS
6414 IF (ISKPCH(1,I).EQ.99) GOTO 10
6415 ICCHAI(1,1) = ICCHAI(1,1)+2
6416 IDXP = INTSS1(I)
6417 IDXT = INTSS2(I)
6418 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6419 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6420 DO 11 K=1,4
6421 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6422 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6423 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6424 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6425 11 CONTINUE
6426 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6427 & +(PP1(3)+PT1(3))**2)
6428 ECH = PP1(4)+PT1(4)
6429 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6430 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6431 & +(PP2(3)+PT2(3))**2)
6432 ECH = PP2(4)+PT2(4)
6433 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6434 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6435 AM1 = SQRT(AM1)
6436 AM2 = SQRT(AM2)
6437 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6438C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6439 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6440 ENDIF
6441 ELSE
6442 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6443 ENDIF
6444 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6445 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6446 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6447 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6448 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6449 & 0,0,1)
6450 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6451 & 0,0,1)
6452 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6453 & 0,0,1)
6454 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6455 & 0,0,1)
6456 NCSY = NCSY+1
6457 10 CONTINUE
6458
6459* disea-sea chains
6460 DO 20 I=1,NDS
6461 IF (ISKPCH(2,I).EQ.99) GOTO 20
6462 ICCHAI(1,2) = ICCHAI(1,2)+2
6463 IDXP = INTDS1(I)
6464 IDXT = INTDS2(I)
6465 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6466 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6467 DO 21 K=1,4
6468 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6469 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6470 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6471 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6472 21 CONTINUE
6473 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6474 & +(PP1(3)+PT1(3))**2)
6475 ECH = PP1(4)+PT1(4)
6476 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6477 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6478 & +(PP2(3)+PT2(3))**2)
6479 ECH = PP2(4)+PT2(4)
6480 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6481 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6482 AM1 = SQRT(AM1)
6483 AM2 = SQRT(AM2)
6484 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6485C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6486 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6487 ENDIF
6488 ELSE
6489 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6490 ENDIF
6491 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6492 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6493 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6494 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6495 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6496 & 0,0,2)
6497 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6498 & 0,0,2)
6499 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6500 & 0,0,2)
6501 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6502 & 0,0,2)
6503 NCSY = NCSY+1
6504 20 CONTINUE
6505
6506* sea-disea chains
6507 DO 30 I=1,NSD
6508 IF (ISKPCH(3,I).EQ.99) GOTO 30
6509 ICCHAI(1,3) = ICCHAI(1,3)+2
6510 IDXP = INTSD1(I)
6511 IDXT = INTSD2(I)
6512 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6513 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6514 DO 31 K=1,4
6515 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6516 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6517 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6518 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6519 31 CONTINUE
6520 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6521 & +(PP1(3)+PT1(3))**2)
6522 ECH = PP1(4)+PT1(4)
6523 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6524 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6525 & +(PP2(3)+PT2(3))**2)
6526 ECH = PP2(4)+PT2(4)
6527 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6528 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6529 AM1 = SQRT(AM1)
6530 AM2 = SQRT(AM2)
6531 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6532C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6533 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6534 ENDIF
6535 ELSE
6536 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6537 ENDIF
6538 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6539 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6540 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6541 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6542 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6543 & 0,0,3)
6544 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6545 & 0,0,3)
6546 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6547 & 0,0,3)
6548 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6549 & 0,0,3)
6550 NCSY = NCSY+1
6551 30 CONTINUE
6552
6553* disea-valence chains
6554 DO 50 I=1,NDV
6555 IF (ISKPCH(5,I).EQ.99) GOTO 50
6556 ICCHAI(1,5) = ICCHAI(1,5)+2
6557 IDXP = INTDV1(I)
6558 IDXT = INTDV2(I)
6559 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6560 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6561 DO 51 K=1,4
6562 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6563 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6564 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6565 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6566 51 CONTINUE
6567 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6568 & +(PP1(3)+PT1(3))**2)
6569 ECH = PP1(4)+PT1(4)
6570 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6571 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6572 & +(PP2(3)+PT2(3))**2)
6573 ECH = PP2(4)+PT2(4)
6574 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6575 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6576 AM1 = SQRT(AM1)
6577 AM2 = SQRT(AM2)
6578 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6579C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6580 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6581 ENDIF
6582 ELSE
6583 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6584 ENDIF
6585 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6586 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6587 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6588 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6589 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6590 & 0,0,5)
6591 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6592 & 0,0,5)
6593 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6594 & 0,0,5)
6595 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6596 & 0,0,5)
6597 NCSY = NCSY+1
6598 50 CONTINUE
6599
6600* valence-sea chains
6601 DO 60 I=1,NVS
6602 IF (ISKPCH(6,I).EQ.99) GOTO 60
6603 ICCHAI(1,6) = ICCHAI(1,6)+2
6604 IDXP = INTVS1(I)
6605 IDXT = INTVS2(I)
6606 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6607 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6608 DO 61 K=1,4
6609 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6610 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6611 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6612 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6613 61 CONTINUE
6614 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6615 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6616 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6617 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6618 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6619 IF (LCHK) THEN
6620 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6621 & 0,0,6)
6622 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6623 & 0,0,6)
6624 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6625 & 0,0,6)
6626 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6627 & 0,0,6)
6628 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6629 & +(PP1(3)+PT1(3))**2)
6630 ECH = PP1(4)+PT1(4)
6631 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6632 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6633 & +(PP2(3)+PT2(3))**2)
6634 ECH = PP2(4)+PT2(4)
6635 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6636 ELSE
6637 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6638 & 0,0,6)
6639 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6640 & 0,0,6)
6641 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6642 & 0,0,6)
6643 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6644 & 0,0,6)
6645 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6646 & +(PP1(3)+PT2(3))**2)
6647 ECH = PP1(4)+PT2(4)
6648 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6649 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6650 & +(PP2(3)+PT1(3))**2)
6651 ECH = PP2(4)+PT1(4)
6652 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6653 ENDIF
6654 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6655 AM1 = SQRT(AM1)
6656 AM2 = SQRT(AM2)
6657 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6658C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6659 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6660 ENDIF
6661 ELSE
6662 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6663 ENDIF
6664 NCSY = NCSY+1
6665 60 CONTINUE
6666
6667* sea-valence chains
6668 DO 40 I=1,NSV
6669 IF (ISKPCH(4,I).EQ.99) GOTO 40
6670 ICCHAI(1,4) = ICCHAI(1,4)+2
6671 IDXP = INTSV1(I)
6672 IDXT = INTSV2(I)
6673 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6674 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6675 DO 41 K=1,4
6676 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6677 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6678 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6679 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6680 41 CONTINUE
6681 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6682 & +(PP1(3)+PT1(3))**2)
6683 ECH = PP1(4)+PT1(4)
6684 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6685 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6686 & +(PP2(3)+PT2(3))**2)
6687 ECH = PP2(4)+PT2(4)
6688 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6689 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6690 AM1 = SQRT(AM1)
6691 AM2 = SQRT(AM2)
6692 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6693C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6694 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6695 ENDIF
6696 ELSE
6697 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6698 ENDIF
6699 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6700 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6701 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6702 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6703 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6704 & 0,0,4)
6705 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6706 & 0,0,4)
6707 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6708 & 0,0,4)
6709 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6710 & 0,0,4)
6711 NCSY = NCSY+1
6712 40 CONTINUE
6713
6714* valence-disea chains
6715 DO 70 I=1,NVD
6716 IF (ISKPCH(7,I).EQ.99) GOTO 70
6717 ICCHAI(1,7) = ICCHAI(1,7)+2
6718 IDXP = INTVD1(I)
6719 IDXT = INTVD2(I)
6720 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6721 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6722 DO 71 K=1,4
6723 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6724 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6725 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6726 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6727 71 CONTINUE
6728 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6729 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6730 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6731 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6732 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6733 IF (LCHK) THEN
6734 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6735 & 0,0,7)
6736 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6737 & 0,0,7)
6738 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6739 & 0,0,7)
6740 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6741 & 0,0,7)
6742 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6743 & +(PP1(3)+PT1(3))**2)
6744 ECH = PP1(4)+PT1(4)
6745 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6746 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6747 & +(PP2(3)+PT2(3))**2)
6748 ECH = PP2(4)+PT2(4)
6749 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6750 ELSE
6751 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6752 & 0,0,7)
6753 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6754 & 0,0,7)
6755 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6756 & 0,0,7)
6757 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6758 & 0,0,7)
6759 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6760 & +(PP1(3)+PT2(3))**2)
6761 ECH = PP1(4)+PT2(4)
6762 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6763 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6764 & +(PP2(3)+PT1(3))**2)
6765 ECH = PP2(4)+PT1(4)
6766 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6767 ENDIF
6768 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6769 AM1 = SQRT(AM1)
6770 AM2 = SQRT(AM2)
6771 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6772C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6773 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6774 ENDIF
6775 ELSE
6776 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6777 ENDIF
6778 NCSY = NCSY+1
6779 70 CONTINUE
6780
6781* valence-valence chains
6782 DO 80 I=1,NVV
6783 IF (ISKPCH(8,I).EQ.99) GOTO 80
6784 ICCHAI(1,8) = ICCHAI(1,8)+2
6785 IDXP = INTVV1(I)
6786 IDXT = INTVV2(I)
6787 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6788 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6789 DO 81 K=1,4
6790 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6791 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6792 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6793 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6794 81 CONTINUE
6795 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6796 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6797 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6798 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6799
6800* check for diffractive event
6801 IDIFF = 0
6802 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6803 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6804 DO 800 K=1,4
6805 PP(K) = PP1(K)+PP2(K)
6806 PT(K) = PT1(K)+PT2(K)
6807 800 CONTINUE
6808 ISTCK = NHKK
6809 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6810 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6811C IF (IREJ1.NE.0) GOTO 9999
6812 IF (IREJ1.NE.0) THEN
6813 IDIFF = 0
6814 NHKK = ISTCK
6815 ENDIF
6816 ELSE
6817 IDIFF = 0
6818 ENDIF
6819
6820 IF (IDIFF.EQ.0) THEN
6821* valence-valence chain system
6822 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6823 IF (LCHK) THEN
6824* baryon-baryon
6825 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6826 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6827 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6828 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6829 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6830 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6831 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6832 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6833 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6834 & +(PP1(3)+PT1(3))**2)
6835 ECH = PP1(4)+PT1(4)
6836 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6837 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6838 & +(PP2(3)+PT2(3))**2)
6839 ECH = PP2(4)+PT2(4)
6840 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6841 ELSE
6842* antibaryon-baryon
6843 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6844 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6845 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6846 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6847 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6848 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6849 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6850 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6851 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6852 & +(PP1(3)+PT2(3))**2)
6853 ECH = PP1(4)+PT2(4)
6854 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6855 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6856 & +(PP2(3)+PT1(3))**2)
6857 ECH = PP2(4)+PT1(4)
6858 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6859 ENDIF
6860 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6861 AM1 = SQRT(AM1)
6862 AM2 = SQRT(AM2)
6863 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6864C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6865 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6866 ENDIF
6867 ELSE
6868 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6869 ENDIF
6870 NCSY = NCSY+1
6871 ENDIF
6872 80 CONTINUE
6873 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6874
6875* energy-momentum & flavor conservation check
6876 IF (ABS(IDIFF).NE.1) THEN
6877 IF (IDIFF.NE.0) THEN
6878 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6879 & 1,3,10,IREJ)
6880 ELSE
6881 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6882 & 1,3,10,IREJ)
6883 ENDIF
6884 IF (IREJ.NE.0) THEN
6885 CALL DT_EVTOUT(4)
6886 STOP
6887 ENDIF
6888 ENDIF
6889
6890 RETURN
6891
6892 9999 CONTINUE
6893 IREJ = 1
6894 RETURN
6895 END
6896
6897*$ CREATE DT_CHKCSY.FOR
6898*COPY DT_CHKCSY
6899*
6900*===chkcsy=============================================================*
6901*
6902 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6903
6904************************************************************************
6905* CHeCk Chain SYstem for consistency of partons at chain ends. *
6906* ID1,ID2 PDG-numbers of partons at chain ends *
6907* LCHK = .true. consistent chain *
6908* = .false. inconsistent chain *
6909* This version dated 18.01.95 is written by S. Roesler *
6910************************************************************************
6911
6912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6913 SAVE
6914
6915 PARAMETER ( LINP = 10 ,
6916 & LOUT = 6 ,
6917 & LDAT = 9 )
6918
6919 LOGICAL LCHK
6920
6921 LCHK = .TRUE.
6922
6923* q-aq chain
6924 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6925 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6926* q-qq, aq-aqaq chain
6927 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6928 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6929 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6930* qq-aqaq chain
6931 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6932 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6933 ENDIF
6934
6935 RETURN
6936 END
6937
6938*$ CREATE DT_EVENTA.FOR
6939*COPY DT_EVENTA
6940*
6941*===eventa=============================================================*
6942*
6943 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6944
6945************************************************************************
6946* Treatment of nucleon-nucleon interactions in a two-chain *
6947* approximation. *
6948* (input) ID BAMJET-index of projectile hadron (in case of *
6949* h-K scattering) *
6950* IP/IT mass number of projectile/target nucleus *
6951* NCSY number of two chain systems *
6952* IREJ rejection flag *
6953* This version dated 15.01.95 is written by S. Roesler *
6954************************************************************************
6955
6956 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6957 SAVE
6958
6959 PARAMETER ( LINP = 10 ,
6960 & LOUT = 6 ,
6961 & LDAT = 9 )
6962
6963 PARAMETER (TINY10=1.0D-10)
6964
6965* event history
6966
6967 PARAMETER (NMXHKK=200000)
6968
6969 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6970 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6971 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6972
6973* extended event history
6974 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6975 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6976 & IHIST(2,NMXHKK)
6977
6978* rejection counter
6979 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6980 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6981 & IREXCI(3),IRDIFF(2),IRINC
6982
6983* flags for diffractive interactions (DTUNUC 1.x)
6984 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6985
6986* particle properties (BAMJET index convention)
6987 CHARACTER*8 ANAME
6988 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6989 & IICH(210),IIBAR(210),K1(210),K2(210)
6990
6991* flags for input different options
6992 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6993 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6994 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6995
6996* various options for treatment of partons (DTUNUC 1.x)
6997* (chain recombination, Cronin,..)
6998 LOGICAL LCO2CR,LINTPT
6999 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7000 & LCO2CR,LINTPT
7001
7002 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7003
7004 IREJ = 0
7005 NPOINT(3) = NHKK+1
7006
7007* skip following treatment for low-mass diffraction
7008 IF (ABS(IFLAGD).EQ.1) THEN
7009 NPOINT(3) = NPOINT(2)
7010 GOTO 5
7011 ENDIF
7012
7013* multiple scattering of chain ends
7014 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7015 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7016
7017 NC = NPOINT(2)
7018* get a two-chain system from DTEVT1
7019 DO 3 I=1,NCSY
7020 IFP1 = IDHKK(NC)
7021 IFT1 = IDHKK(NC+1)
7022 IFP2 = IDHKK(NC+2)
7023 IFT2 = IDHKK(NC+3)
7024 DO 4 K=1,4
7025 PP1(K) = PHKK(K,NC)
7026 PT1(K) = PHKK(K,NC+1)
7027 PP2(K) = PHKK(K,NC+2)
7028 PT2(K) = PHKK(K,NC+3)
7029 4 CONTINUE
7030 MOP1 = NC
7031 MOT1 = NC+1
7032 MOP2 = NC+2
7033 MOT2 = NC+3
7034 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7035 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7036 IF (IREJ1.GT.0) THEN
7037 IRHHA = IRHHA+1
7038 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7039 GOTO 9999
7040 ENDIF
7041 NC = NC+4
7042 3 CONTINUE
7043
7044* meson/antibaryon projectile:
7045* sample single-chain valence-valence systems (Reggeon contrib.)
7046 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7047 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7048 ENDIF
7049
7050 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7051* check DTEVT1 for remaining resonance mass corrections
7052 CALL DT_EVTRES(IREJ1)
7053 IF (IREJ1.GT.0) THEN
7054 IRRES(1) = IRRES(1)+1
7055 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7056 GOTO 9999
7057 ENDIF
7058 ENDIF
7059
7060* assign p_t to two-"chain" systems consisting of two resonances only
7061* since only entries for chains will be affected, this is obsolete
7062* in case of JETSET-fragmetation
7063 CALL DT_RESPT
7064
7065* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7066 IF (LCO2CR) CALL DT_COM2CR
7067
7068 5 CONTINUE
7069
7070* fragmentation of the complete event
7071**uncomment for internal phojet-fragmentation
7072C CALL DT_EVTFRA(IREJ1)
7073 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7074 IF (IREJ1.GT.0) THEN
7075 IRFRAG = IRFRAG+1
7076 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7077 GOTO 9999
7078 ENDIF
7079
7080* decay of possible resonances (should be obsolete)
7081 CALL DT_DECAY1
7082
7083 RETURN
7084
7085 9999 CONTINUE
7086 IREVT = IREVT+1
7087 IREJ = 1
7088 RETURN
7089 END
7090
7091*$ CREATE DT_GETCSY.FOR
7092*COPY DT_GETCSY
7093*
7094*===getcsy=============================================================*
7095*
7096 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7097 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7098
7099************************************************************************
7100* This version dated 15.01.95 is written by S. Roesler *
7101************************************************************************
7102
7103 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7104 SAVE
7105
7106 PARAMETER ( LINP = 10 ,
7107 & LOUT = 6 ,
7108 & LDAT = 9 )
7109
7110 PARAMETER (TINY10=1.0D-10)
7111
7112* event history
7113
7114 PARAMETER (NMXHKK=200000)
7115
7116 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7117 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7118 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7119
7120* extended event history
7121 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7122 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7123 & IHIST(2,NMXHKK)
7124
7125* rejection counter
7126 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7127 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7128 & IREXCI(3),IRDIFF(2),IRINC
7129
7130* flags for input different options
7131 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7132 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7133 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7134
7135* flags for diffractive interactions (DTUNUC 1.x)
7136 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7137
7138 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7139 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7140
7141 IREJ = 0
7142
7143* get quark content of partons
7144 DO 1 I=1,2
7145 IFP1(I) = 0
7146 IFP2(I) = 0
7147 IFT1(I) = 0
7148 IFT2(I) = 0
7149 1 CONTINUE
7150 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7151 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7152 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7153 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7154 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7155 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7156 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7157 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7158
7159* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7160 IDCH1 = 2
7161 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7162 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7163 IDCH2 = 2
7164 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7165 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7166
7167* store initial configuration for energy-momentum cons. check
7168 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7169
7170* sample intrinsic p_t at chain-ends
7171 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7172 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7173 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7174 IF (IREJ1.NE.0) THEN
7175 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7176 IRPT = IRPT+1
7177 GOTO 9999
7178 ENDIF
7179
7180C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7181C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7182C* check second chain for resonance
7183C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7184C & AMCH2,AMCH2N,IDCH2,IREJ1)
7185C IF (IREJ1.NE.0) GOTO 9999
7186C IF (IDR2.NE.0) THEN
7187C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7188C & AMCH2,AMCH2N,AMCH1,IREJ1)
7189C IF (IREJ1.NE.0) GOTO 9999
7190C ENDIF
7191C* check first chain for resonance
7192C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7193C & AMCH1,AMCH1N,IDCH1,IREJ1)
7194C IF (IREJ1.NE.0) GOTO 9999
7195C IF (IDR1.NE.0) IDR1 = 100*IDR1
7196C ELSE
7197C* check first chain for resonance
7198C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7199C & AMCH1,AMCH1N,IDCH1,IREJ1)
7200C IF (IREJ1.NE.0) GOTO 9999
7201C IF (IDR1.NE.0) THEN
7202C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7203C & AMCH1,AMCH1N,AMCH2,IREJ1)
7204C IF (IREJ1.NE.0) GOTO 9999
7205C ENDIF
7206C* check second chain for resonance
7207C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7208C & AMCH2,AMCH2N,IDCH2,IREJ1)
7209C IF (IREJ1.NE.0) GOTO 9999
7210C IF (IDR2.NE.0) IDR2 = 100*IDR2
7211C ENDIF
7212C ENDIF
7213
7214 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7215* check chains for resonances
7216 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7217 & AMCH1,AMCH1N,IDCH1,IREJ1)
7218 IF (IREJ1.NE.0) GOTO 9999
7219 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7220 & AMCH2,AMCH2N,IDCH2,IREJ1)
7221 IF (IREJ1.NE.0) GOTO 9999
7222* change kinematics corresponding to resonance-masses
7223 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7224 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7225 & AMCH1,AMCH1N,AMCH2,IREJ1)
7226 IF (IREJ1.GT.0) GOTO 9999
7227 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7228 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7229 & AMCH2,AMCH2N,IDCH2,IREJ1)
7230 IF (IREJ1.NE.0) GOTO 9999
7231 IF (IDR2.NE.0) IDR2 = 100*IDR2
7232 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7233 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7234 & AMCH2,AMCH2N,AMCH1,IREJ1)
7235 IF (IREJ1.GT.0) GOTO 9999
7236 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7237 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7238 & AMCH1,AMCH1N,IDCH1,IREJ1)
7239 IF (IREJ1.NE.0) GOTO 9999
7240 IF (IDR1.NE.0) IDR1 = 100*IDR1
7241 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7242 AMDIF1 = ABS(AMCH1-AMCH1N)
7243 AMDIF2 = ABS(AMCH2-AMCH2N)
7244 IF (AMDIF2.LT.AMDIF1) THEN
7245 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7246 & AMCH2,AMCH2N,AMCH1,IREJ1)
7247 IF (IREJ1.GT.0) GOTO 9999
7248 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7249 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7250 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7251 IF (IREJ1.NE.0) GOTO 9999
7252 IF (IDR1.NE.0) IDR1 = 100*IDR1
7253 ELSE
7254 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7255 & AMCH1,AMCH1N,AMCH2,IREJ1)
7256 IF (IREJ1.GT.0) GOTO 9999
7257 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7258 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7259 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7260 IF (IREJ1.NE.0) GOTO 9999
7261 IF (IDR2.NE.0) IDR2 = 100*IDR2
7262 ENDIF
7263 ENDIF
7264 ENDIF
7265
7266* store final configuration for energy-momentum cons. check
7267 IF (LEMCCK) THEN
7268 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7269 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7270 IF (IREJ1.NE.0) GOTO 9999
7271 ENDIF
7272
7273* put partons and chains into DTEVT1
7274 DO 10 I=1,4
7275 PCH1(I) = PP1(I)+PT1(I)
7276 PCH2(I) = PP2(I)+PT2(I)
7277 10 CONTINUE
7278 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7279 & PP1(3),PP1(4),0,0,0)
7280 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7281 & PT1(3),PT1(4),0,0,0)
7282 KCH = 100+IDCH(MOP1)*10+1
7283 CALL DT_EVTPUT(KCH,88888,-2,-1,
7284 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7285 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7286 & PP2(3),PP2(4),0,0,0)
7287 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7288 & PT2(3),PT2(4),0,0,0)
7289 KCH = KCH+1
7290 CALL DT_EVTPUT(KCH,88888,-2,-1,
7291 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7292
7293 RETURN
7294
7295 9999 CONTINUE
7296 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7297* "cancel" sea-sea chains
7298 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7299 IF (IREJ1.NE.0) GOTO 9998
7300**sr 16.5. flag for EVENTB
7301 IREJ = -1
7302 RETURN
7303 ENDIF
7304 9998 CONTINUE
7305 IREJ = 1
7306 RETURN
7307 END
7308
7309*$ CREATE DT_CHKINE.FOR
7310*COPY DT_CHKINE
7311*
7312*===chkine=============================================================*
7313*
7314 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7315 & AMCH1,AMCH1N,AMCH2,IREJ)
7316
7317************************************************************************
7318* This subroutine replaces CORMOM. *
7319* This version dated 05.01.95 is written by S. Roesler *
7320************************************************************************
7321
7322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7323 SAVE
7324
7325 PARAMETER ( LINP = 10 ,
7326 & LOUT = 6 ,
7327 & LDAT = 9 )
7328
7329 PARAMETER (TINY10=1.0D-10)
7330
7331* flags for input different options
7332 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7333 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7334 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7335
7336* rejection counter
7337 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7338 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7339 & IREXCI(3),IRDIFF(2),IRINC
7340
7341 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7342 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7343
7344 IREJ = 0
7345 JMSHL = IMSHL
7346
7347 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7348 DO 10 I=1,4
7349 PP1(I) = PP1I(I)
7350 PP2(I) = PP2I(I)
7351 PT1(I) = PT1I(I)
7352 PT2(I) = PT2I(I)
7353 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7354 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7355 PP1(I) = SCALE*PP1(I)
7356 PT1(I) = SCALE*PT1(I)
7357 10 CONTINUE
7358 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7359 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7360
7361 ECH = PP2(4)+PT2(4)
7362 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7363 & (PP2(3)+PT2(3))**2 )
7364 AMCH22 = (ECH-PCH)*(ECH+PCH)
7365 IF (AMCH22.LT.0.0D0) THEN
7366 IF (IOULEV(1).GT.0)
7367 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7368 GOTO 9997
7369 ENDIF
7370
7371 AMCH1 = AMCH1N
7372 AMCH2 = SQRT(AMCH22)
7373
7374* put partons again on mass shell
7375 13 CONTINUE
7376 XM1 = 0.0D0
7377 XM2 = 0.0D0
7378 IF (JMSHL.EQ.1) THEN
7379
7380 XM1 = PYMASS(IFP1)
7381 XM2 = PYMASS(IFT1)
7382
7383 ENDIF
7384 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7385 IF (IREJ1.NE.0) THEN
7386 IF (JMSHL.EQ.0) GOTO 9998
7387 JMSHL = 0
7388 GOTO 13
7389 ENDIF
7390 JMSHL = IMSHL
7391 DO 11 I=1,4
7392 PP1(I) = P1(I)
7393 PT1(I) = P2(I)
7394 11 CONTINUE
7395 14 CONTINUE
7396 XM1 = 0.0D0
7397 XM2 = 0.0D0
7398 IF (JMSHL.EQ.1) THEN
7399
7400 XM1 = PYMASS(IFP2)
7401 XM2 = PYMASS(IFT2)
7402
7403 ENDIF
7404 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7405 IF (IREJ1.NE.0) THEN
7406 IF (JMSHL.EQ.0) GOTO 9998
7407 JMSHL = 0
7408 GOTO 14
7409 ENDIF
7410 DO 12 I=1,4
7411 PP2(I) = P1(I)
7412 PT2(I) = P2(I)
7413 12 CONTINUE
7414 DO 15 I=1,4
7415 PP1I(I) = PP1(I)
7416 PP2I(I) = PP2(I)
7417 PT1I(I) = PT1(I)
7418 PT2I(I) = PT2(I)
7419 15 CONTINUE
7420 RETURN
7421
7422 9997 IRCHKI(1) = IRCHKI(1)+1
7423**sr
7424C GOTO 9999
7425 IREJ = -1
7426 RETURN
7427**
7428 9998 IRCHKI(2) = IRCHKI(2)+1
7429
7430 9999 CONTINUE
7431 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7432 IREJ = 1
7433 RETURN
7434 END
7435
7436*$ CREATE DT_CH2RES.FOR
7437*COPY DT_CH2RES
7438*
7439*===ch2res=============================================================*
7440*
7441 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7442 & AM,AMN,IMODE,IREJ)
7443
7444************************************************************************
7445* Check chains for resonance production. *
7446* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7447* input: *
7448* IF1,2,3,4 input flavors (q,aq in any order) *
7449* AM chain mass *
7450* MODE = 1 check q-aq chain for meson-resonance *
7451* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7452* = 3 check qq-aqaq chain for lower mass cut *
7453* output: *
7454* IDR = 0 no resonances found *
7455* = -1 pseudoscalar meson/octet baryon *
7456* = 1 vector-meson/decuplet baryon *
7457* IDXR BAMJET-index of corresponding resonance *
7458* AMN mass of corresponding resonance *
7459* *
7460* IREJ rejection flag *
7461* This version dated 06.01.95 is written by S. Roesler *
7462************************************************************************
7463
7464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7465 SAVE
7466
7467 PARAMETER ( LINP = 10 ,
7468 & LOUT = 6 ,
7469 & LDAT = 9 )
7470
7471* particle properties (BAMJET index convention)
7472 CHARACTER*8 ANAME
7473 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7474 & IICH(210),IIBAR(210),K1(210),K2(210)
7475
7476* quark-content to particle index conversion (DTUNUC 1.x)
7477 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7478 & IA08(6,21),IA10(6,21)
7479
7480* rejection counter
7481 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7482 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7483 & IREXCI(3),IRDIFF(2),IRINC
7484
7485* flags for input different options
7486 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7487 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7488 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7489
7490 DIMENSION IF(4),JF(4)
7491
7492**sr 4.7. test
7493C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7494 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7495**
7496C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7497
7498 MODE = ABS(IMODE)
7499
7500 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7501 WRITE(LOUT,1000) MODE
7502 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7503 & 1X,' program stopped')
7504 STOP
7505 ENDIF
7506
7507 AMX = AM
7508 IREJ = 0
7509 IDR = 0
7510 IDXR = 0
7511 AMN = AMX
7512 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7513 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7514
7515 IF(1) = IF1
7516 IF(2) = IF2
7517 IF(3) = IF3
7518 IF(4) = IF4
7519 NF = 0
7520 DO 100 I=1,4
7521 IF (IF(I).NE.0) THEN
7522 NF = NF+1
7523 JF(NF) = IF(I)
7524 ENDIF
7525 100 CONTINUE
7526 IF (NF.LE.MODE) THEN
7527 WRITE(LOUT,1001) MODE,IF
7528 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7529 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7530 GOTO 9999
7531 ENDIF
7532
7533 GOTO (1,2,3) MODE
7534
7535* check for meson resonance
7536 1 CONTINUE
7537 IFQ = JF(1)
7538 IFAQ = ABS(JF(2))
7539 IF (JF(2).GT.0) THEN
7540 IFQ = JF(2)
7541 IFAQ = ABS(JF(1))
7542 ENDIF
7543 IFPS = IMPS(IFAQ,IFQ)
7544 IFV = IMVE(IFAQ,IFQ)
7545 AMPS = AAM(IFPS)
7546 AMV = AAM(IFV)
7547 AMHI = AMV+0.3D0
7548 IF (AMX.LT.AMV) THEN
7549 IF (AMX.LT.AMPS) THEN
7550 IF (IMODE.GT.0) THEN
7551 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7552 ELSE
7553 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7554 ENDIF
7555 LOMRES = LOMRES+1
7556 ENDIF
7557* replace chain by pseudoscalar meson
7558 IDR = -1
7559 IDXR = IFPS
7560 AMN = AMPS
7561 ELSEIF (AMX.LT.AMHI) THEN
7562* replace chain by vector-meson
7563 IDR = 1
7564 IDXR = IFV
7565 AMN = AMV
7566 ENDIF
7567 RETURN
7568
7569* check for baryon resonance
7570 2 CONTINUE
7571 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7572 AM8 = AAM(JB8)
7573 AM10 = AAM(JB10)
7574 AMHI = AM10+0.3D0
7575 IF (AMX.LT.AM10) THEN
7576 IF (AMX.LT.AM8) THEN
7577 IF (IMODE.GT.0) THEN
7578 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7579 ELSE
7580 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7581 ENDIF
7582 LOBRES = LOBRES+1
7583 ENDIF
7584* replace chain by oktet baryon
7585 IDR = -1
7586 IDXR = JB8
7587 AMN = AM8
7588 ELSEIF (AMX.LT.AMHI) THEN
7589 IDR = 1
7590 IDXR = JB10
7591 AMN = AM10
7592 ENDIF
7593 RETURN
7594
7595* check qq-aqaq for lower mass cut
7596 3 CONTINUE
7597* empirical definition of AMHI to allow for (b-antib)-pair prod.
7598 AMHI = 2.5D0
7599 IF (AMX.LT.AMHI) GOTO 9999
7600 RETURN
7601
7602 9999 CONTINUE
7603 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7604 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7605 IREJ = 1
7606 IRRES(2) = IRRES(2)+1
7607 RETURN
7608 END
7609
7610*$ CREATE DT_RJSEAC.FOR
7611*COPY DT_RJSEAC
7612*
7613*===rjseac=============================================================*
7614*
7615 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7616
7617************************************************************************
7618* ReJection of SEA-sea Chains. *
7619* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7620* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7621* This version dated 16.01.95 is written by S. Roesler *
7622************************************************************************
7623
7624 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7625 SAVE
7626
7627 PARAMETER ( LINP = 10 ,
7628 & LOUT = 6 ,
7629 & LDAT = 9 )
7630
7631 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7632
7633* event history
7634
7635 PARAMETER (NMXHKK=200000)
7636
7637 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7638 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7639 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7640
7641* extended event history
7642 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7643 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7644 & IHIST(2,NMXHKK)
7645
7646* statistics
7647 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7648 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7649 & ICEVTG(8,0:30)
7650
7651 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7652
7653 IREJ = 0
7654
7655* projectile sea q-aq-pair
7656* indices of sea-pair
7657 IDXSEA(1,1) = MOP1
7658 IDXSEA(1,2) = MOP2
7659* index of mother-nucleon
7660 IDXNUC(1) = JMOHKK(1,MOP1)
7661* status of valence quarks to be corrected
7662 ISTVAL(1) = -21
7663
7664* target sea q-aq-pair
7665* indices of sea-pair
7666 IDXSEA(2,1) = MOT1
7667 IDXSEA(2,2) = MOT2
7668* index of mother-nucleon
7669 IDXNUC(2) = JMOHKK(1,MOT1)
7670* status of valence quarks to be corrected
7671 ISTVAL(2) = -22
7672
7673 DO 1 N=1,2
7674 IDONE = 0
7675 DO 2 I=NPOINT(2),NHKK
7676 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7677 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7678* valence parton found
7679* inrease 4-momentum by sea 4-momentum
7680 DO 3 K=1,4
7681 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7682 & PHKK(K,IDXSEA(N,2))
7683 3 CONTINUE
7684 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7685 & PHKK(2,I)**2-PHKK(3,I)**2))
7686* "cancel" sea-pair
7687 DO 4 J=1,2
7688 ISTHKK(IDXSEA(N,J)) = 100
7689 IDHKK(IDXSEA(N,J)) = 0
7690 JMOHKK(1,IDXSEA(N,J)) = 0
7691 JMOHKK(2,IDXSEA(N,J)) = 0
7692 JDAHKK(1,IDXSEA(N,J)) = 0
7693 JDAHKK(2,IDXSEA(N,J)) = 0
7694 DO 5 K=1,4
7695 PHKK(K,IDXSEA(N,J)) = ZERO
7696 VHKK(K,IDXSEA(N,J)) = ZERO
7697 WHKK(K,IDXSEA(N,J)) = ZERO
7698 5 CONTINUE
7699 PHKK(5,IDXSEA(N,J)) = ZERO
7700 4 CONTINUE
7701 IDONE = 1
7702 ENDIF
7703 2 CONTINUE
7704 IF (IDONE.NE.1) THEN
7705 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7706 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7707 & '-record!',/,1X,' sea-quark pairs ',
7708 & 2I5,4X,2I5,' could not be canceled!')
7709 GOTO 9999
7710 ENDIF
7711 1 CONTINUE
7712 ICRJSS = ICRJSS+1
7713 RETURN
7714
7715 9999 CONTINUE
7716 IREJ = 1
7717 RETURN
7718 END
7719
7720*$ CREATE DT_VV2SCH.FOR
7721*COPY DT_VV2SCH
7722*
7723*===vv2sch=============================================================*
7724*
7725 SUBROUTINE DT_VV2SCH
7726
7727************************************************************************
7728* Change Valence-Valence chain systems to Single CHain systems for *
7729* hadron-nucleus collisions with meson or antibaryon projectile. *
7730* (Reggeon contribution) *
7731* The single chain system is approximately treated as one chain and a *
7732* meson at rest. *
7733* This version dated 18.01.95 is written by S. Roesler *
7734************************************************************************
7735
7736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7737 SAVE
7738
7739 PARAMETER ( LINP = 10 ,
7740 & LOUT = 6 ,
7741 & LDAT = 9 )
7742
7743 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7744
7745 LOGICAL LSTART
7746
7747* event history
7748
7749 PARAMETER (NMXHKK=200000)
7750
7751 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7752 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7753 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7754
7755* extended event history
7756 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7757 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7758 & IHIST(2,NMXHKK)
7759
7760* flags for input different options
7761 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7762 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7763 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7764
7765* statistics
7766 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7767 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7768 & ICEVTG(8,0:30)
7769
7770 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7771 & PCH2(4)
7772
7773 DATA LSTART /.TRUE./
7774
7775 IFSC = 0
7776 IF (LSTART) THEN
7777 WRITE(LOUT,1000)
7778 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7779 & 'valence chains treated')
7780 LSTART = .FALSE.
7781 ENDIF
7782
7783 NSTOP = NHKK
7784
7785* get index of first chain
7786 DO 1 I=NPOINT(3),NHKK
7787 IF (IDHKK(I).EQ.88888) THEN
7788 NC = I
7789 GOTO 2
7790 ENDIF
7791 1 CONTINUE
7792
7793 2 CONTINUE
7794 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7795 & .AND.(NC.LT.NSTOP)) THEN
7796* get valence-valence chains
7797 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7798* get "mother"-hadron indices
7799 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7800 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7801 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7802 KTARG = IDT_ICIHAD(IDHKK(MO2))
7803* Lab momentum of projectile hadron
7804 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7805 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7806 & PHKK(3,MO1)**2)
7807
7808 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7809 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7810 ICVV2S = ICVV2S+1
7811* single chain requested
7812* get flavors of chain-end partons
7813 MO(1) = JMOHKK(1,NC)
7814 MO(2) = JMOHKK(2,NC)
7815 MO(3) = JMOHKK(1,NC+3)
7816 MO(4) = JMOHKK(2,NC+3)
7817 DO 3 I=1,4
7818 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7819 IF(I,2) = 0
7820 IF (ABS(IDHKK(MO(I))).GE.1000)
7821 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7822 3 CONTINUE
7823* which one is the q-aq chain?
7824* N1,N1+1 - DTEVT1-entries for q-aq system
7825* N2,N2+1 - DTEVT1-entries for the other chain
7826 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7827 K1 = 1
7828 K2 = 3
7829 N1 = NC-2
7830 N2 = NC+1
7831 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7832 K1 = 3
7833 K2 = 1
7834 N1 = NC+1
7835 N2 = NC-2
7836 ELSE
7837 GOTO 10
7838 ENDIF
7839 DO 4 K=1,4
7840 PP1(K) = PHKK(K,N1)
7841 PT1(K) = PHKK(K,N1+1)
7842 PP2(K) = PHKK(K,N2)
7843 PT2(K) = PHKK(K,N2+1)
7844 4 CONTINUE
7845 AMCH1 = PHKK(5,N1+2)
7846 AMCH2 = PHKK(5,N2+2)
7847* get meson-identity corresponding to flavors of q-aq chain
7848 ITMP = IRESRJ
7849 IRESRJ = 0
7850 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7851 & ZERO,AMCH1N,1,IDUM)
7852 IRESRJ = ITMP
7853* change kinematics of chains
7854 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7855 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7856 & AMCH1,AMCH1N,AMCH2,IREJ1)
7857 IF (IREJ1.NE.0) GOTO 10
7858* check second chain for resonance
7859 IDCHAI = 2
7860 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7861 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7862 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7863 IF (IREJ1.NE.0) GOTO 10
7864 IF (IDR2.NE.0) IDR2 = 100*IDR2
7865* add partons and chains to DTEVT1
7866 DO 5 K=1,4
7867 PCH1(K) = PP1(K)+PT1(K)
7868 PCH2(K) = PP2(K)+PT2(K)
7869 5 CONTINUE
7870 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7871 & PP1(3),PP1(4),0,0,0)
7872 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7873 & PT1(2),PT1(3),PT1(4),0,0,0)
7874 KCH = ISTHKK(N1+2)+100
7875 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7876 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7877 IDHKK(N1+2) = 22222
7878 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7879 & PP2(3),PP2(4),0,0,0)
7880 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7881 & PT2(2),PT2(3),PT2(4),0,0,0)
7882 KCH = ISTHKK(N2+2)+100
7883 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7884 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7885 IDHKK(N2+2) = 22222
7886 ENDIF
7887 ENDIF
7888 ELSE
7889 GOTO 11
7890 ENDIF
7891 10 CONTINUE
7892 NC = NC+6
7893 GOTO 2
7894
7895 11 CONTINUE
7896
7897 RETURN
7898 END
7899
7900*$ CREATE DT_PHNSCH.FOR
7901*COPY DT_PHNSCH
7902*
7903*=== phnsch ===========================================================*
7904*
7905 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7906
7907*----------------------------------------------------------------------*
7908* *
7909* Probability for Hadron Nucleon Single CHain interactions: *
7910* *
7911* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7912* Infn - Milan *
7913* *
7914* Last change on 04-jan-94 by Alfredo Ferrari *
7915* *
7916* modified by J.R.for use in DTUNUC 6.1.94 *
7917* *
7918* Input variables: *
7919* Kp = hadron projectile index (Part numbering *
7920* scheme) *
7921* Ktarg = target nucleon index (1=proton, 8=neutron) *
7922* Plab = projectile laboratory momentum (GeV/c) *
7923* Output variable: *
7924* Phnsch = probability per single chain (particle *
7925* exchange) interactions *
7926* *
7927*----------------------------------------------------------------------*
7928
7929 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7930 SAVE
7931
7932 PARAMETER ( LUNOUT = 6 )
7933 PARAMETER ( LUNERR = 6 )
7934 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7935 PARAMETER ( ZERZER = 0.D+00 )
7936 PARAMETER ( ONEONE = 1.D+00 )
7937 PARAMETER ( TWOTWO = 2.D+00 )
7938 PARAMETER ( FIVFIV = 5.D+00 )
7939 PARAMETER ( HLFHLF = 0.5D+00 )
7940
7941 PARAMETER ( NALLWP = 39 )
7942 PARAMETER ( IDMAXP = 210 )
7943
7944 DIMENSION ICHRGE(39),AM(39)
7945
7946* particle properties (BAMJET index convention)
7947 CHARACTER*8 ANAME
7948 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7949 & IICH(210),IIBAR(210),K1(210),K2(210)
7950
7951 DIMENSION KPTOIP(210)
7952
7953* auxiliary common for reggeon exchange (DTUNUC 1.x)
7954 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7955 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7956 & IQTCHR(-6:6),MQUARK(3,39)
7957
7958 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7959 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7960 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7961 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7962 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7963
7964* Conversion from part to paprop numbering
7965 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7966 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7967 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7968
7969* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7970 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7971 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7972C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7973 DATA SGTCO1 /
7974* 1st reaction: gamma p total
7975 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7976* 2nd reaction: gamma d total
7977 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7978* 3rd reaction: pi+ p total
7979 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7980* 4th reaction: pi- p total
7981 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7982* 5th reaction: pi+/- d total
7983 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7984* 6th reaction: K+ p total
7985 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7986* 7th reaction: K+ n total
7987 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7988* 8th reaction: K+ d total
7989 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7990* 9th reaction: K- p total
7991 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7992* 10th reaction: K- n total
7993 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7994C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7995 DATA SGTCO2 /
7996* 11th reaction: K- d total
7997 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7998* 12th reaction: p p total
7999 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
8000* 13th reaction: p n total
8001 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
8002* 14th reaction: p d total
8003 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
8004* 15th reaction: pbar p total
8005 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
8006* 16th reaction: pbar n total
8007 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
8008* 17th reaction: pbar d total
8009 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
8010* 18th reaction: Lamda p total
8011 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
8012C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8013 DATA SGTCO3 /
8014* 19th reaction: pi+ p elastic
8015 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8016* 20th reaction: pi- p elastic
8017 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8018* 21st reaction: K+ p elastic
8019 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8020* 22nd reaction: K- p elastic
8021 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8022* 23rd reaction: p p elastic
8023 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8024* 24th reaction: p d elastic
8025 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8026* 25th reaction: pbar p elastic
8027 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8028* 26th reaction: pbar p elastic bis
8029 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8030* 27th reaction: pbar n elastic
8031 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8032* 28th reaction: Lamda p elastic
8033 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8034* 29th reaction: K- p ela bis
8035 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8036* 30th reaction: pi- p cx
8037 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8038* 31st reaction: K- p cx
8039 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8040* 32nd reaction: K+ n cx
8041 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8042* 33rd reaction: pbar p cx
8043 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8044*
8045* +-------------------------------------------------------------------*
8046 ICHRGE(KTARG)=IICH(KTARG)
8047 AM (KTARG)=AAM (KTARG)
8048* | Check for pi0 (d-dbar)
8049 IF ( KP .NE. 26 ) THEN
8050 IP = KPTOIP (KP)
8051 IF(IP.EQ.0)IP=1
8052 ICHRGE(IP)=IICH(KP)
8053 AM (IP)=AAM (KP)
8054* |
8055* +-------------------------------------------------------------------*
8056* |
8057 ELSE
8058 IP = 23
8059 ICHRGE(IP)=0
8060 END IF
8061* |
8062* +-------------------------------------------------------------------*
8063* +-------------------------------------------------------------------*
8064* | No such interactions for baryon-baryon
8065 IF ( IIBAR (KP) .GT. 0 ) THEN
8066 DT_PHNSCH = ZERZER
8067 RETURN
8068* |
8069* +-------------------------------------------------------------------*
8070* | No "annihilation" diagram possible for K+ p/n
8071 ELSE IF ( IP .EQ. 15 ) THEN
8072 DT_PHNSCH = ZERZER
8073 RETURN
8074* |
8075* +-------------------------------------------------------------------*
8076* | No "annihilation" diagram possible for K0 p/n
8077 ELSE IF ( IP .EQ. 24 ) THEN
8078 DT_PHNSCH = ZERZER
8079 RETURN
8080* |
8081* +-------------------------------------------------------------------*
8082* | No "annihilation" diagram possible for Omebar p/n
8083 ELSE IF ( IP .GE. 38 ) THEN
8084 DT_PHNSCH = ZERZER
8085 RETURN
8086 END IF
8087* |
8088* +-------------------------------------------------------------------*
8089* +-------------------------------------------------------------------*
8090* | If the momentum is larger than 50 GeV/c, compute the single
8091* | chain probability at 50 GeV/c and extrapolate to the present
8092* | momentum according to 1/sqrt(s)
8093* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8094* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8095* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8096* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8097* | x sqrt(s/s(50))
8098* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8099 IF ( PLAB .GT. 50.D+00 ) THEN
8100 PLA = 50.D+00
8101 AMPSQ = AM (IP)**2
8102 AMTSQ = AM (KTARG)**2
8103 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8104 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8105 EPROJ = SQRT ( PLA**2 + AMPSQ )
8106 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8107 UMORAT = SQRT ( UMOSQ / UMO50 )
8108* |
8109* +-------------------------------------------------------------------*
8110* | P < 3 GeV/c
8111 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8112 PLA = 3.D+00
8113 AMPSQ = AM (IP)**2
8114 AMTSQ = AM (KTARG)**2
8115 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8116 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8117 EPROJ = SQRT ( PLA**2 + AMPSQ )
8118 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8119 UMORAT = SQRT ( UMOSQ / UMO50 )
8120* |
8121* +-------------------------------------------------------------------*
8122* | P < 50 GeV/c
8123 ELSE
8124 PLA = PLAB
8125 UMORAT = ONEONE
8126 END IF
8127* |
8128* +-------------------------------------------------------------------*
8129 ALGPLA = LOG (PLA)
8130* +-------------------------------------------------------------------*
8131* | Pions:
8132 IF ( IHLP (IP) .EQ. 2 ) THEN
8133 ACOF = SGTCOE (1,3)
8134 BCOF = SGTCOE (2,3)
8135 ENNE = SGTCOE (3,3)
8136 CCOF = SGTCOE (4,3)
8137 DCOF = SGTCOE (5,3)
8138* | Compute the pi+ p total cross section:
8139 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8140 & + DCOF * ALGPLA
8141 ACOF = SGTCOE (1,19)
8142 BCOF = SGTCOE (2,19)
8143 ENNE = SGTCOE (3,19)
8144 CCOF = SGTCOE (4,19)
8145 DCOF = SGTCOE (5,19)
8146* | Compute the pi+ p elastic cross section:
8147 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8148 & + DCOF * ALGPLA
8149* | Compute the pi+ p inelastic cross section:
8150 SPPPIN = SPPPTT - SPPPEL
8151 ACOF = SGTCOE (1,4)
8152 BCOF = SGTCOE (2,4)
8153 ENNE = SGTCOE (3,4)
8154 CCOF = SGTCOE (4,4)
8155 DCOF = SGTCOE (5,4)
8156* | Compute the pi- p total cross section:
8157 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8158 & + DCOF * ALGPLA
8159 ACOF = SGTCOE (1,20)
8160 BCOF = SGTCOE (2,20)
8161 ENNE = SGTCOE (3,20)
8162 CCOF = SGTCOE (4,20)
8163 DCOF = SGTCOE (5,20)
8164* | Compute the pi- p elastic cross section:
8165 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8166 & + DCOF * ALGPLA
8167* | Compute the pi- p inelastic cross section:
8168 SPMPIN = SPMPTT - SPMPEL
8169 SIGDIA = SPMPIN - SPPPIN
8170* | +----------------------------------------------------------------*
8171* | | Charged pions: besides isospin consideration it is supposed
8172* | | that (pi+ n)el is almost equal to (pi- p)el
8173* | | and (pi+ p)el " " " " (pi- n)el
8174* | | and all are almost equal among each others
8175* | | (reasonable above 5 GeV/c)
8176 IF ( ICHRGE (IP) .NE. 0 ) THEN
8177 KHELP = KTARG / 8
8178 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8179 ACOF = SGTCOE (1,JREAC)
8180 BCOF = SGTCOE (2,JREAC)
8181 ENNE = SGTCOE (3,JREAC)
8182 CCOF = SGTCOE (4,JREAC)
8183 DCOF = SGTCOE (5,JREAC)
8184* | | Compute the total cross section:
8185 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8186 & + DCOF * ALGPLA
8187 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8188 ACOF = SGTCOE (1,JREAC)
8189 BCOF = SGTCOE (2,JREAC)
8190 ENNE = SGTCOE (3,JREAC)
8191 CCOF = SGTCOE (4,JREAC)
8192 DCOF = SGTCOE (5,JREAC)
8193* | | Compute the elastic cross section:
8194 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8195 & + DCOF * ALGPLA
8196* | | Compute the inelastic cross section:
8197 SHNCIN = SHNCTT - SHNCEL
8198* | | Number of diagrams:
8199 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8200* | | Now compute the chain end (anti)quark-(anti)diquark
8201 IQFSC1 = 1 + IP - 13
8202 IQFSC2 = 0
8203 IQBSC1 = 1 + KHELP
8204 IQBSC2 = 1 + IP - 13
8205* | |
8206* | +----------------------------------------------------------------*
8207* | | pi0: besides isospin consideration it is supposed that the
8208* | | elastic cross section is not very different from
8209* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8210 ELSE
8211 KHELP = KTARG / 8
8212 K2HLP = ( KP - 23 ) / 3
8213* | | Number of diagrams:
8214* | | For u ubar (k2hlp=0):
8215* NDIAGR = 2 - KHELP
8216* | | For d dbar (k2hlp=1):
8217* NDIAGR = 2 + KHELP - K2HLP
8218 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8219 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8220* | | Now compute the chain end (anti)quark-(anti)diquark
8221 IQFSC1 = 1 + K2HLP
8222 IQFSC2 = 0
8223 IQBSC1 = 1 + KHELP
8224 IQBSC2 = 2 - K2HLP
8225 END IF
8226* | |
8227* | +----------------------------------------------------------------*
8228* | end pi's
8229* +-------------------------------------------------------------------*
8230* | Kaons:
8231 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8232 ACOF = SGTCOE (1,6)
8233 BCOF = SGTCOE (2,6)
8234 ENNE = SGTCOE (3,6)
8235 CCOF = SGTCOE (4,6)
8236 DCOF = SGTCOE (5,6)
8237* | Compute the K+ p total cross section:
8238 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8239 & + DCOF * ALGPLA
8240 ACOF = SGTCOE (1,21)
8241 BCOF = SGTCOE (2,21)
8242 ENNE = SGTCOE (3,21)
8243 CCOF = SGTCOE (4,21)
8244 DCOF = SGTCOE (5,21)
8245* | Compute the K+ p elastic cross section:
8246 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8247 & + DCOF * ALGPLA
8248* | Compute the K+ p inelastic cross section:
8249 SKPPIN = SKPPTT - SKPPEL
8250 ACOF = SGTCOE (1,9)
8251 BCOF = SGTCOE (2,9)
8252 ENNE = SGTCOE (3,9)
8253 CCOF = SGTCOE (4,9)
8254 DCOF = SGTCOE (5,9)
8255* | Compute the K- p total cross section:
8256 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8257 & + DCOF * ALGPLA
8258 ACOF = SGTCOE (1,22)
8259 BCOF = SGTCOE (2,22)
8260 ENNE = SGTCOE (3,22)
8261 CCOF = SGTCOE (4,22)
8262 DCOF = SGTCOE (5,22)
8263* | Compute the K- p elastic cross section:
8264 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8265 & + DCOF * ALGPLA
8266* | Compute the K- p inelastic cross section:
8267 SKMPIN = SKMPTT - SKMPEL
8268 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8269* | +----------------------------------------------------------------*
8270* | | Charged Kaons: actually only K-
8271 IF ( ICHRGE (IP) .NE. 0 ) THEN
8272 KHELP = KTARG / 8
8273* | | +-------------------------------------------------------------*
8274* | | | Proton target:
8275 IF ( KHELP .EQ. 0 ) THEN
8276 SHNCIN = SKMPIN
8277* | | | Number of diagrams:
8278 NDIAGR = 2
8279* | | |
8280* | | +-------------------------------------------------------------*
8281* | | | Neutron target: besides isospin consideration it is supposed
8282* | | | that (K- n)el is almost equal to (K- p)el
8283* | | | (reasonable above 5 GeV/c)
8284 ELSE
8285 ACOF = SGTCOE (1,10)
8286 BCOF = SGTCOE (2,10)
8287 ENNE = SGTCOE (3,10)
8288 CCOF = SGTCOE (4,10)
8289 DCOF = SGTCOE (5,10)
8290* | | | Compute the total cross section:
8291 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8292 & + DCOF * ALGPLA
8293* | | | Compute the elastic cross section:
8294 SHNCEL = SKMPEL
8295* | | | Compute the inelastic cross section:
8296 SHNCIN = SHNCTT - SHNCEL
8297* | | | Number of diagrams:
8298 NDIAGR = 1
8299 END IF
8300* | | |
8301* | | +-------------------------------------------------------------*
8302* | | Now compute the chain end (anti)quark-(anti)diquark
8303 IQFSC1 = 3
8304 IQFSC2 = 0
8305 IQBSC1 = 1 + KHELP
8306 IQBSC2 = 2
8307* | |
8308* | +----------------------------------------------------------------*
8309* | | K0's: (actually only K0bar)
8310 ELSE
8311 KHELP = KTARG / 8
8312* | | +-------------------------------------------------------------*
8313* | | | Proton target: (K0bar p)in supposed to be given by
8314* | | | (K- p)in - Sig_diagr
8315 IF ( KHELP .EQ. 0 ) THEN
8316 SHNCIN = SKMPIN - SIGDIA
8317* | | | Number of diagrams:
8318 NDIAGR = 1
8319* | | |
8320* | | +-------------------------------------------------------------*
8321* | | | Neutron target: (K0bar n)in supposed to be given by
8322* | | | (K- n)in + Sig_diagr
8323* | | | besides isospin consideration it is supposed
8324* | | | that (K- n)el is almost equal to (K- p)el
8325* | | | (reasonable above 5 GeV/c)
8326 ELSE
8327 ACOF = SGTCOE (1,10)
8328 BCOF = SGTCOE (2,10)
8329 ENNE = SGTCOE (3,10)
8330 CCOF = SGTCOE (4,10)
8331 DCOF = SGTCOE (5,10)
8332* | | | Compute the total cross section:
8333 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8334 & + DCOF * ALGPLA
8335* | | | Compute the elastic cross section:
8336 SHNCEL = SKMPEL
8337* | | | Compute the inelastic cross section:
8338 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8339* | | | Number of diagrams:
8340 NDIAGR = 2
8341 END IF
8342* | | |
8343* | | +-------------------------------------------------------------*
8344* | | Now compute the chain end (anti)quark-(anti)diquark
8345 IQFSC1 = 3
8346 IQFSC2 = 0
8347 IQBSC1 = 1
8348 IQBSC2 = 1 + KHELP
8349 END IF
8350* | |
8351* | +----------------------------------------------------------------*
8352* | end Kaon's
8353* +-------------------------------------------------------------------*
8354* | Antinucleons:
8355 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8356* | For momenta between 3 and 5 GeV/c the use of tabulated data
8357* | should be implemented!
8358 ACOF = SGTCOE (1,15)
8359 BCOF = SGTCOE (2,15)
8360 ENNE = SGTCOE (3,15)
8361 CCOF = SGTCOE (4,15)
8362 DCOF = SGTCOE (5,15)
8363* | Compute the pbar p total cross section:
8364 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8365 & + DCOF * ALGPLA
8366 IF ( PLA .LT. FIVFIV ) THEN
8367 JREAC = 26
8368 ELSE
8369 JREAC = 25
8370 END IF
8371 ACOF = SGTCOE (1,JREAC)
8372 BCOF = SGTCOE (2,JREAC)
8373 ENNE = SGTCOE (3,JREAC)
8374 CCOF = SGTCOE (4,JREAC)
8375 DCOF = SGTCOE (5,JREAC)
8376* | Compute the pbar p elastic cross section:
8377 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8378 & + DCOF * ALGPLA
8379* | Compute the pbar p inelastic cross section:
8380 SAPPIN = SAPPTT - SAPPEL
8381 ACOF = SGTCOE (1,12)
8382 BCOF = SGTCOE (2,12)
8383 ENNE = SGTCOE (3,12)
8384 CCOF = SGTCOE (4,12)
8385 DCOF = SGTCOE (5,12)
8386* | Compute the p p total cross section:
8387 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8388 & + DCOF * ALGPLA
8389 ACOF = SGTCOE (1,23)
8390 BCOF = SGTCOE (2,23)
8391 ENNE = SGTCOE (3,23)
8392 CCOF = SGTCOE (4,23)
8393 DCOF = SGTCOE (5,23)
8394* | Compute the p p elastic cross section:
8395 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8396 & + DCOF * ALGPLA
8397* | Compute the K- p inelastic cross section:
8398 SPPINE = SPPTOT - SPPELA
8399 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8400 KHELP = KTARG / 8
8401* | +----------------------------------------------------------------*
8402* | | Pbar:
8403 IF ( ICHRGE (IP) .NE. 0 ) THEN
8404 NDIAGR = 5 - KHELP
8405* | | +-------------------------------------------------------------*
8406* | | | Proton target:
8407 IF ( KHELP .EQ. 0 ) THEN
8408* | | | Number of diagrams:
8409 SHNCIN = SAPPIN
8410 PUUBAR = 0.8D+00
8411* | | |
8412* | | +-------------------------------------------------------------*
8413* | | | Neutron target: it is supposed that (ap n)el is almost equal
8414* | | | to (ap p)el (reasonable above 5 GeV/c)
8415 ELSE
8416 ACOF = SGTCOE (1,16)
8417 BCOF = SGTCOE (2,16)
8418 ENNE = SGTCOE (3,16)
8419 CCOF = SGTCOE (4,16)
8420 DCOF = SGTCOE (5,16)
8421* | | | Compute the total cross section:
8422 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8423 & + DCOF * ALGPLA
8424* | | | Compute the elastic cross section:
8425 SHNCEL = SAPPEL
8426* | | | Compute the inelastic cross section:
8427 SHNCIN = SHNCTT - SHNCEL
8428 PUUBAR = HLFHLF
8429 END IF
8430* | | |
8431* | | +-------------------------------------------------------------*
8432* | | Now compute the chain end (anti)quark-(anti)diquark
8433* | | there are different possibilities, make a random choiche:
8434 IQFSC1 = -1
8435 RNCHEN = DT_RNDM(PUUBAR)
8436 IF ( RNCHEN .LT. PUUBAR ) THEN
8437 IQFSC2 = -2
8438 ELSE
8439 IQFSC2 = -1
8440 END IF
8441 IQBSC1 = -IQFSC1 + KHELP
8442 IQBSC2 = -IQFSC2
8443* | |
8444* | +----------------------------------------------------------------*
8445* | | nbar:
8446 ELSE
8447 NDIAGR = 4 + KHELP
8448* | | +-------------------------------------------------------------*
8449* | | | Proton target: (nbar p)in supposed to be given by
8450* | | | (pbar p)in - Sig_diagr
8451 IF ( KHELP .EQ. 0 ) THEN
8452 SHNCIN = SAPPIN - SIGDIA
8453 PDDBAR = HLFHLF
8454* | | |
8455* | | +-------------------------------------------------------------*
8456* | | | Neutron target: (nbar n)el is supposed to be equal to
8457* | | | (pbar p)el (reasonable above 5 GeV/c)
8458 ELSE
8459* | | | Compute the total cross section:
8460 SHNCTT = SAPPTT
8461* | | | Compute the elastic cross section:
8462 SHNCEL = SAPPEL
8463* | | | Compute the inelastic cross section:
8464 SHNCIN = SHNCTT - SHNCEL
8465 PDDBAR = 0.8D+00
8466 END IF
8467* | | |
8468* | | +-------------------------------------------------------------*
8469* | | Now compute the chain end (anti)quark-(anti)diquark
8470* | | there are different possibilities, make a random choiche:
8471 IQFSC1 = -2
8472 RNCHEN = DT_RNDM(RNCHEN)
8473 IF ( RNCHEN .LT. PDDBAR ) THEN
8474 IQFSC2 = -1
8475 ELSE
8476 IQFSC2 = -2
8477 END IF
8478 IQBSC1 = -IQFSC1 + KHELP - 1
8479 IQBSC2 = -IQFSC2
8480 END IF
8481* | |
8482* | +----------------------------------------------------------------*
8483* |
8484* +-------------------------------------------------------------------*
8485* | Others: not yet implemented
8486 ELSE
8487 SIGDIA = ZERZER
8488 SHNCIN = ONEONE
8489 NDIAGR = 0
8490 DT_PHNSCH = ZERZER
8491 RETURN
8492 END IF
8493* | end others
8494* +-------------------------------------------------------------------*
8495 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8496 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8497 & + IQECHR (IQBSC2)
8498 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8499 & + IQBCHR (IQBSC2)
8500 IQECHC = IQECHC / 3
8501 IQBCHC = IQBCHC / 3
8502 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8503 & + IQSCHR (IQBSC2)
8504 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8505 & + IQSCHR (MQUARK(3,IP))
8506* +-------------------------------------------------------------------*
8507* | Consistency check:
8508 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8509 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8510 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8511 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8512 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8513 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8514 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8515 END IF
8516* |
8517* +-------------------------------------------------------------------*
8518* +-------------------------------------------------------------------*
8519* | Consistency check:
8520 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8521 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8522 WRITE (LUNOUT,*)
8523 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8524 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8525 WRITE (LUNERR,*)
8526 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8527 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8528 END IF
8529* |
8530* +-------------------------------------------------------------------*
8531* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8532 IF ( UMORAT .GT. ONEPLS )
8533 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8534 & - ONEONE ) * UMORAT + ONEONE )
8535 RETURN
8536*
8537 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8538 DT_SCHQUA = ONEONE
8539 JQFSC1 = IQFSC1
8540 JQFSC2 = IQFSC2
8541 JQBSC1 = IQBSC1
8542 JQBSC2 = IQBSC2
8543*=== End of function Phnsch ===========================================*
8544 RETURN
8545 END
8546
8547*$ CREATE DT_RESPT.FOR
8548*COPY DT_RESPT
8549*
8550*===respt==============================================================*
8551*
8552 SUBROUTINE DT_RESPT
8553
8554************************************************************************
8555* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8556* This version dated 18.01.95 is written by S. Roesler *
8557************************************************************************
8558
8559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8560 SAVE
8561
8562 PARAMETER ( LINP = 10 ,
8563 & LOUT = 6 ,
8564 & LDAT = 9 )
8565
8566 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8567
8568* event history
8569
8570 PARAMETER (NMXHKK=200000)
8571
8572 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575
8576* extended event history
8577 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8578 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8579 & IHIST(2,NMXHKK)
8580
8581* get index of first chain
8582 DO 1 I=NPOINT(3),NHKK
8583 IF (IDHKK(I).EQ.88888) THEN
8584 NC = I
8585 GOTO 2
8586 ENDIF
8587 1 CONTINUE
8588
8589 2 CONTINUE
8590 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8591C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8592* skip VV-,SS- systems
8593 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8594 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8595* check if both "chains" are resonances
8596 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8597 CALL DT_SAPTRE(NC,NC+3)
8598 ENDIF
8599 ENDIF
8600 ELSE
8601 GOTO 3
8602 ENDIF
8603 NC = NC+6
8604 GOTO 2
8605
8606 3 CONTINUE
8607
8608 RETURN
8609 END
8610
8611*$ CREATE DT_EVTRES.FOR
8612*COPY DT_EVTRES
8613*
8614*===evtres=============================================================*
8615*
8616 SUBROUTINE DT_EVTRES(IREJ)
8617
8618************************************************************************
8619* This version dated 14.12.94 is written by S. Roesler *
8620************************************************************************
8621
8622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8623 SAVE
8624
8625 PARAMETER ( LINP = 10 ,
8626 & LOUT = 6 ,
8627 & LDAT = 9 )
8628
8629 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8630
8631* event history
8632
8633 PARAMETER (NMXHKK=200000)
8634
8635 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8636 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8637 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8638
8639* extended event history
8640 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8641 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8642 & IHIST(2,NMXHKK)
8643
8644* flags for input different options
8645 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8646 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8647 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8648
8649* particle properties (BAMJET index convention)
8650 CHARACTER*8 ANAME
8651 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8652 & IICH(210),IIBAR(210),K1(210),K2(210)
8653
8654 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8655
8656 IREJ = 0
8657
8658 DO 1 I=NPOINT(3),NHKK
8659 IF (ABS(IDRES(I)).GE.100) THEN
8660 AMMX = 0.0D0
8661 DO 2 J=NPOINT(3),NHKK
8662 IF (IDHKK(J).EQ.88888) THEN
8663 IF (PHKK(5,J).GT.AMMX) THEN
8664 AMMX = PHKK(5,J)
8665 IMMX = J
8666 ENDIF
8667 ENDIF
8668 2 CONTINUE
8669 IF (IDRES(IMMX).NE.0) THEN
8670 IF (IOULEV(3).GT.0) THEN
8671 WRITE(LOUT,'(1X,A)')
8672 & 'EVTRES: no chain for correc. found'
8673C GOTO 6
8674 GOTO 9999
8675 ELSE
8676 GOTO 9999
8677 ENDIF
8678 ENDIF
8679 IMO11 = JMOHKK(1,I)
8680 IMO12 = JMOHKK(2,I)
8681 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8682 IMO11 = JMOHKK(2,I)
8683 IMO12 = JMOHKK(1,I)
8684 ENDIF
8685 IMO21 = JMOHKK(1,IMMX)
8686 IMO22 = JMOHKK(2,IMMX)
8687 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8688 IMO21 = JMOHKK(2,IMMX)
8689 IMO22 = JMOHKK(1,IMMX)
8690 ENDIF
8691 AMCH1 = PHKK(5,I)
8692 AMCH1N = AAM(IDXRES(I))
8693
8694 IFPR1 = IDHKK(IMO11)
8695 IFPR2 = IDHKK(IMO21)
8696 IFTA1 = IDHKK(IMO12)
8697 IFTA2 = IDHKK(IMO22)
8698 DO 4 J=1,4
8699 PP1(J) = PHKK(J,IMO11)
8700 PP2(J) = PHKK(J,IMO21)
8701 PT1(J) = PHKK(J,IMO12)
8702 PT2(J) = PHKK(J,IMO22)
8703 4 CONTINUE
8704* store initial configuration for energy-momentum cons. check
8705 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8706* correct kinematics of second chain
8707 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8708 & AMCH1,AMCH1N,AMCH2,IREJ1)
8709 IF (IREJ1.NE.0) GOTO 9999
8710* check now this chain for resonance mass
8711 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8712 IFP(2) = 0
8713 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8714 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8715 IFT(2) = 0
8716 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8717 IDCH2 = 2
8718 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8719 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8720 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8721 & AMCH2,AMCH2N,IDCH2,IREJ1)
8722 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8723 IF (IOULEV(1).GT.0)
8724 & WRITE(LOUT,*) ' correction for resonance not poss.'
8725**sr test
8726C GOTO 1
8727C GOTO 9999
8728**
8729 ENDIF
8730* store final configuration for energy-momentum cons. check
8731 IF (LEMCCK) THEN
8732 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8733 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8734 IF (IREJ1.NE.0) GOTO 9999
8735 ENDIF
8736 DO 5 J=1,4
8737 PHKK(J,IMO11) = PP1(J)
8738 PHKK(J,IMO21) = PP2(J)
8739 PHKK(J,IMO12) = PT1(J)
8740 PHKK(J,IMO22) = PT2(J)
8741 5 CONTINUE
8742* correct entries of chains
8743 DO 3 K=1,4
8744 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8745 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8746 3 CONTINUE
8747 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8748 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8749 & PHKK(3,IMMX)**2
8750* ?? the following should now be obsolete
8751**sr test
8752C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8753 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8754**
8755 WRITE(LOUT,'(1X,A,4G10.3)')
8756 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8757C GOTO 9999
8758 GOTO 1
8759 ENDIF
8760 PHKK(5,I) = SQRT(AM1)
8761 PHKK(5,IMMX) = SQRT(AM2)
8762 IDRES(I) = IDRES(I)/100
8763 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8764 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8765 WRITE(LOUT,'(1X,A,4G10.3)')
8766 & 'EVTRES: inconsistent chain-masses',
8767 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8768 GOTO 9999
8769 ENDIF
8770 ENDIF
8771 1 CONTINUE
8772 6 CONTINUE
8773 RETURN
8774
8775 9999 CONTINUE
8776 IREJ = 1
8777 RETURN
8778 END
8779
8780*$ CREATE DT_GETSPT.FOR
8781*COPY DT_GETSPT
8782*
8783*===getspt=============================================================*
8784*
8785 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8786 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8787 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8788
8789************************************************************************
8790* This version dated 12.12.94 is written by S. Roesler *
8791************************************************************************
8792
8793 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8794 SAVE
8795
8796 PARAMETER ( LINP = 10 ,
8797 & LOUT = 6 ,
8798 & LDAT = 9 )
8799
8800 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8801
8802* various options for treatment of partons (DTUNUC 1.x)
8803* (chain recombination, Cronin,..)
8804 LOGICAL LCO2CR,LINTPT
8805 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8806 & LCO2CR,LINTPT
8807
8808* flags for input different options
8809 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8810 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8811 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8812
8813* flags for diffractive interactions (DTUNUC 1.x)
8814 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8815
8816 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8817 & PT2(4),PT2I(4),P1(4),P2(4),
8818 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8819 & PTOTI(4),PTOTF(4),DIFF(4)
8820
8821 IC = 0
8822 IREJ = 0
8823C B33P = 4.0D0
8824C B33T = 4.0D0
8825C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8826C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8827 REDU = 1.0D0
8828C B33P = 3.5D0
8829C B33T = 3.5D0
8830 B33P = 4.0D0
8831 B33T = 4.0D0
8832 IF (IDIFF.NE.0) THEN
8833 B33P = 16.0D0
8834 B33T = 16.0D0
8835 ENDIF
8836
8837 DO 1 I=1,4
8838 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8839 PP1(I) = PP1I(I)
8840 PP2(I) = PP2I(I)
8841 PT1(I) = PT1I(I)
8842 PT2(I) = PT2I(I)
8843 1 CONTINUE
8844* get initial chain masses
8845 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8846 & +(PP1(3)+PT1(3))**2)
8847 ECH = PP1(4)+PT1(4)
8848 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8849 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8850 & +(PP2(3)+PT2(3))**2)
8851 ECH = PP2(4)+PT2(4)
8852 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8853 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8854 IF (IOULEV(1).GT.0)
8855 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8856 & AM1,AM2
8857 GOTO 9999
8858 ENDIF
8859 AM1 = SQRT(AM1)
8860 AM2 = SQRT(AM2)
8861 AM1N = ZERO
8862 AM2N = ZERO
8863
8864 MODE = 0
8865C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8866C MODE = 0
8867C ELSE
8868C MODE = 1
8869C IF (AM1.LT.0.6) THEN
8870C B33P = 10.0D0
8871C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8872CC B33P = 4.0D0
8873C ENDIF
8874C IF (AM2.LT.0.6) THEN
8875C B33T = 10.0D0
8876C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8877CC B33T = 4.0D0
8878C ENDIF
8879C ENDIF
8880
8881* check chain masses for very low mass chains
8882C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8883C & AM1,DUM,-IDCH1,IREJ1)
8884C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8885C & AM2,DUM,-IDCH2,IREJ2)
8886C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8887C B33P = 20.0D0
8888C B33T = 20.0D0
8889C ENDIF
8890
8891 JMSHL = IMSHL
8892
8893 2 CONTINUE
8894 IC = IC+1
8895 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8896 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8897 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8898C IF (MOD(IC,19).EQ.0) JMSHL = 0
8899 IF (MOD(IC,20).EQ.0) GOTO 7
8900C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8901C RETURN
8902C GOTO 9999
8903C ENDIF
8904
8905* get transverse momentum
8906 IF (LINTPT) THEN
8907 ES = -2.0D0/(B33P**2)
8908 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8909 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8910 HPSP = HPSP*REDU
8911 ES = -2.0D0/(B33T**2)
8912 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8913 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8914 HPST = HPST*REDU
8915 ELSE
8916 HPSP = ZERO
8917 HPST = ZERO
8918 ENDIF
8919 CALL DT_DSFECF(SFE1,CFE1)
8920 CALL DT_DSFECF(SFE2,CFE2)
8921 IF (MODE.EQ.0) THEN
8922 PP1(1) = PP1I(1)+HPSP*CFE1
8923 PP1(2) = PP1I(2)+HPSP*SFE1
8924 PP2(1) = PP2I(1)-HPSP*CFE1
8925 PP2(2) = PP2I(2)-HPSP*SFE1
8926 PT1(1) = PT1I(1)+HPST*CFE2
8927 PT1(2) = PT1I(2)+HPST*SFE2
8928 PT2(1) = PT2I(1)-HPST*CFE2
8929 PT2(2) = PT2I(2)-HPST*SFE2
8930 ELSE
8931 PP1(1) = PP1I(1)+HPSP*CFE1
8932 PP1(2) = PP1I(2)+HPSP*SFE1
8933 PT1(1) = PT1I(1)-HPSP*CFE1
8934 PT1(2) = PT1I(2)-HPSP*SFE1
8935 PP2(1) = PP2I(1)+HPST*CFE2
8936 PP2(2) = PP2I(2)+HPST*SFE2
8937 PT2(1) = PT2I(1)-HPST*CFE2
8938 PT2(2) = PT2I(2)-HPST*SFE2
8939 ENDIF
8940
8941* put partons on mass shell
8942 XMP1 = 0.0D0
8943 XMT1 = 0.0D0
8944 IF (JMSHL.EQ.1) THEN
8945
8946 XMP1 = PYMASS(IFPR1)
8947 XMT1 = PYMASS(IFTA1)
8948
8949 ENDIF
8950 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8951 IF (IREJ1.NE.0) GOTO 2
8952 DO 3 I=1,4
8953 PTOTF(I) = P1(I)+P2(I)
8954 PP1(I) = P1(I)
8955 PT1(I) = P2(I)
8956 3 CONTINUE
8957 XMP2 = 0.0D0
8958 XMT2 = 0.0D0
8959 IF (JMSHL.EQ.1) THEN
8960
8961 XMP2 = PYMASS(IFPR2)
8962 XMT2 = PYMASS(IFTA2)
8963
8964 ENDIF
8965 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8966 IF (IREJ1.NE.0) GOTO 2
8967 DO 4 I=1,4
8968 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8969 PP2(I) = P1(I)
8970 PT2(I) = P2(I)
8971 4 CONTINUE
8972
8973* check consistency
8974 DO 5 I=1,4
8975 DIFF(I) = PTOTI(I)-PTOTF(I)
8976 5 CONTINUE
8977 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8978 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8979 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8980 GOTO 9999
8981 ENDIF
8982 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8983 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8984 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8985 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8986 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8987 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8988 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8989 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8990 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8991 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8992 & THEN
8993 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8994 & 'GETSPT: inconsistent masses',
8995 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8996* sr 22.11.00: commented. It should only have inconsistent masses for
8997* ultrahigh energies due to rounding problems
8998C GOTO 9999
8999 ENDIF
9000
9001* get chain masses
9002 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9003 & +(PP1(3)+PT1(3))**2)
9004 ECH = PP1(4)+PT1(4)
9005 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
9006 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9007 & +(PP2(3)+PT2(3))**2)
9008 ECH = PP2(4)+PT2(4)
9009 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
9010 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9011 IF (IOULEV(1).GT.0)
9012 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9013 & AM1N,AM2N
9014 GOTO 2
9015 ENDIF
9016 AM1N = SQRT(AM1N)
9017 AM2N = SQRT(AM2N)
9018
9019* check chain masses for very low mass chains
9020 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9021 & AM1N,DUM,-IDCH1,IREJ1)
9022 IF (IREJ1.NE.0) GOTO 2
9023 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9024 & AM2N,DUM,-IDCH2,IREJ2)
9025 IF (IREJ2.NE.0) GOTO 2
9026
9027 7 CONTINUE
9028 IF (AM1N.GT.ZERO) THEN
9029 AM1 = AM1N
9030 AM2 = AM2N
9031 ENDIF
9032 DO 6 I=1,4
9033 PP1I(I) = PP1(I)
9034 PP2I(I) = PP2(I)
9035 PT1I(I) = PT1(I)
9036 PT2I(I) = PT2(I)
9037 6 CONTINUE
9038
9039 RETURN
9040
9041 9999 CONTINUE
9042 IREJ = 1
9043 RETURN
9044 END
9045
9046*$ CREATE DT_SAPTRE.FOR
9047*COPY DT_SAPTRE
9048*
9049*===saptre=============================================================*
9050*
9051 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9052
9053************************************************************************
9054* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9055* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9056* Adopted from the original SAPTRE written by J. Ranft. *
9057* This version dated 18.01.95 is written by S. Roesler *
9058************************************************************************
9059
9060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9061 SAVE
9062
9063 PARAMETER ( LINP = 10 ,
9064 & LOUT = 6 ,
9065 & LDAT = 9 )
9066
9067 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9068
9069* event history
9070
9071 PARAMETER (NMXHKK=200000)
9072
9073 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9074 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9075 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9076
9077* extended event history
9078 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9079 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9080 & IHIST(2,NMXHKK)
9081
9082* flags for input different options
9083 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9084 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9085 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9086
9087 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9088
9089 DATA B3 /4.0D0/
9090
9091 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9092 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9093 ESMAX = MIN(ESMAX1,ESMAX2)
9094 IF (ESMAX.LE.0.05D0) RETURN
9095
9096 HMA = PHKK(5,IDX1)
9097 DO 1 K=1,4
9098 PA1(K) = PHKK(K,IDX1)
9099 PA2(K) = PHKK(K,IDX2)
9100 1 CONTINUE
9101
9102 IF (LEMCCK) THEN
9103 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9104 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9105 ENDIF
9106
9107 EXEB = 0.0D0
9108 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9109 BEXP = HMA*(1.0D0-EXEB)/B3
9110 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9111 WA = AXEXP/(BEXP+AXEXP)
9112 XAB = DT_RNDM(WA)
9113 10 CONTINUE
9114* ES is the transverse kinetic energy
9115 IF (XAB.LT.WA)THEN
9116 X = DT_RNDM(WA)
9117 Y = DT_RNDM(WA)
9118 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9119 ELSE
9120 X = DT_RNDM(Y)
9121 ES = ABS(-LOG(X+TINY7)/B3)
9122 ENDIF
9123 IF (ES.GT.ESMAX) GOTO 10
9124 ES = ES+HMA
9125* transverse momentum
9126 HPS = SQRT((ES-HMA)*(ES+HMA))
9127
9128 CALL DT_DSFECF(SFE,CFE)
9129 HPX = HPS*CFE
9130 HPY = HPS*SFE
9131 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9132 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9133 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9134
9135C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9136C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9137 PA1(1) = PA1(1)+HPX
9138 PA1(2) = PA1(2)+HPY
9139 PA2(1) = PA2(1)-HPX
9140 PA2(2) = PA2(2)-HPY
9141
9142* put resonances on mass-shell again
9143 XM1 = PHKK(5,IDX1)
9144 XM2 = PHKK(5,IDX2)
9145 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9146 IF (IREJ1.NE.0) RETURN
9147
9148 IF (LEMCCK) THEN
9149 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9150 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9151 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9152 IF (IREJ1.NE.0) RETURN
9153 ENDIF
9154
9155 DO 2 K=1,4
9156 PHKK(K,IDX1) = P1(K)
9157 PHKK(K,IDX2) = P2(K)
9158 2 CONTINUE
9159
9160 RETURN
9161 END
9162
9163*$ CREATE DT_CRONIN.FOR
9164*COPY DT_CRONIN
9165*
9166*===cronin=============================================================*
9167*
9168 SUBROUTINE DT_CRONIN(INCL)
9169
9170************************************************************************
9171* Cronin-Effect. Multiple scattering of partons at chain ends. *
9172* INCL = 1 multiple sc. in projectile *
9173* = 2 multiple sc. in target *
9174* This version dated 05.01.96 is written by S. Roesler. *
9175************************************************************************
9176
9177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9178 SAVE
9179
9180 PARAMETER ( LINP = 10 ,
9181 & LOUT = 6 ,
9182 & LDAT = 9 )
9183
9184 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9185
9186* event history
9187
9188 PARAMETER (NMXHKK=200000)
9189
9190 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9191 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9192 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9193
9194* extended event history
9195 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9196 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9197 & IHIST(2,NMXHKK)
9198
9199* rejection counter
9200 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9201 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9202 & IREXCI(3),IRDIFF(2),IRINC
9203
9204* Glauber formalism: collision properties
9205 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9206 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9207
9208 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9209
9210 DO 1 K=1,4
9211 DEV(K) = ZERO
9212 1 CONTINUE
9213
9214 DO 2 I=NPOINT(2),NHKK
9215 IF (ISTHKK(I).LT.0) THEN
9216* get z-position of the chain
9217 R(1) = VHKK(1,I)*1.0D12
9218 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9219 R(2) = VHKK(2,I)*1.0D12
9220 IDXNU = JMOHKK(1,I)
9221 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9222 & IDXNU = JMOHKK(1,I-1)
9223 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9224 & IDXNU = JMOHKK(1,I+1)
9225 R(3) = VHKK(3,IDXNU)*1.0D12
9226* position of target parton the chain is connected to
9227 DO 3 K=1,4
9228 PIN(K) = PHKK(K,I)
9229 3 CONTINUE
9230* multiple scattering of parton with DTEVT1-index I
9231 CALL DT_CROMSC(PIN,R,POUT,INCL)
9232**testprint
9233C IF (NEVHKK.EQ.5) THEN
9234C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9235C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9236C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9237C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9238C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9239C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9240C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9241C ENDIF
9242**
9243* increase accumulator by energy-momentum difference
9244 DO 4 K=1,4
9245 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9246 PHKK(K,I) = POUT(K)
9247 4 CONTINUE
9248 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9249 & PHKK(2,I)**2-PHKK(3,I)**2))
9250 ENDIF
9251 2 CONTINUE
9252
9253* dump accumulator to momenta of valence partons
9254 NVAL = 0
9255 ETOT = 0.0D0
9256 DO 5 I=NPOINT(2),NHKK
9257 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9258 NVAL = NVAL+1
9259 ETOT = ETOT+PHKK(4,I)
9260 ENDIF
9261 5 CONTINUE
9262C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9263 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9264 & 9X,4E12.4)
9265 DO 6 I=NPOINT(2),NHKK
9266 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9267 E = PHKK(4,I)
9268 DO 7 K=1,4
9269C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9270 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9271 7 CONTINUE
9272 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9273 & PHKK(2,I)**2-PHKK(3,I)**2))
9274 ENDIF
9275 6 CONTINUE
9276
9277 RETURN
9278 END
9279
9280*$ CREATE DT_CROMSC.FOR
9281*COPY DT_CROMSC
9282*
9283*===cromsc=============================================================*
9284*
9285 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9286
9287************************************************************************
9288* Cronin-Effect. Multiple scattering of one parton passing through *
9289* nuclear matter. *
9290* PIN(4) input 4-momentum of parton *
9291* POUT(4) 4-momentum of parton after mult. scatt. *
9292* R(3) spatial position of parton in target nucleus *
9293* INCL = 1 multiple sc. in projectile *
9294* = 2 multiple sc. in target *
9295* This is a revised version of the original version written by J. Ranft*
9296* This version dated 17.01.95 is written by S. Roesler. *
9297************************************************************************
9298
9299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9300 SAVE
9301
9302 PARAMETER ( LINP = 10 ,
9303 & LOUT = 6 ,
9304 & LDAT = 9 )
9305
9306 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9307
9308 LOGICAL LSTART
9309
9310* rejection counter
9311 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9312 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9313 & IREXCI(3),IRDIFF(2),IRINC
9314
9315* Glauber formalism: collision properties
9316 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9317 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9318
9319* various options for treatment of partons (DTUNUC 1.x)
9320* (chain recombination, Cronin,..)
9321 LOGICAL LCO2CR,LINTPT
9322 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9323 & LCO2CR,LINTPT
9324
9325 DIMENSION PIN(4),POUT(4),R(3)
9326
9327 DATA LSTART /.TRUE./
9328
9329 IRCRON(1) = IRCRON(1)+1
9330
9331 IF (LSTART) THEN
9332 WRITE(LOUT,1000) CRONCO
9333 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9334 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9335 LSTART = .FALSE.
9336 ENDIF
9337
9338 NCBACK = 0
9339 RNCL = RPROJ
9340 IF (INCL.EQ.2) RNCL = RTARG
9341
9342* Lorentz-transformation into Lab.
9343 MODE = -(INCL+1)
9344 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9345
9346 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9347 IF (PTOT.LE.8.0D0) GOTO 9997
9348
9349* direction cosines of parton before mult. scattering
9350 COSX = PIN(1)/PTOT
9351 COSY = PIN(2)/PTOT
9352 COSZ = PZ/PTOT
9353
9354 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9355 IF (RTESQ.GE.-TINY3) GOTO 9999
9356
9357* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9358* in the direction of particle motion
9359
9360 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9361 TMP = A**2-RTESQ
9362 IF (TMP.LT.ZERO) GOTO 9998
9363 DIST = -A+SQRT(TMP)
9364
9365* multiple scattering angle
9366 THETO = CRONCO*SQRT(DIST)/PTOT
9367 IF (THETO.GT.0.1D0) THETO=0.1D0
9368
9369 1 CONTINUE
9370* Gaussian sampling of spatial angle
9371 CALL DT_RANNOR(R1,R2)
9372 THETA = ABS(R1*THETO)
9373 IF (THETA.GT.0.3D0) GOTO 9997
9374 CALL DT_DSFECF(SFE,CFE)
9375 COSTH = COS(THETA)
9376 SINTH = SIN(THETA)
9377
9378* new direction cosines
9379 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9380 & COSXN,COSYN,COSZN)
9381
9382 POUT(1) = COSXN*PTOT
9383 POUT(2) = COSYN*PTOT
9384 PZ = COSZN*PTOT
9385* Lorentz-transformation into nucl.-nucl. cms
9386 MODE = INCL+1
9387 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9388
9389C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9390C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9391 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9392 THETO = THETO/2.0D0
9393 NCBACK = NCBACK+1
9394 IF (MOD(NCBACK,200).EQ.0) THEN
9395 WRITE(LOUT,1001) THETO,PIN,POUT
9396 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9397 & E12.4,/,1X,' PIN :',4E12.4,/,
9398 & 1X,' POUT:',4E12.4)
9399 GOTO 9997
9400 ENDIF
9401 GOTO 1
9402 ENDIF
9403
9404 RETURN
9405
9406 9997 IRCRON(2) = IRCRON(2)+1
9407 GOTO 9999
9408 9998 IRCRON(3) = IRCRON(3)+1
9409
9410 9999 CONTINUE
9411 DO 100 K=1,4
9412 POUT(K) = PIN(K)
9413 100 CONTINUE
9414 RETURN
9415 END
9416
9417*$ CREATE DT_COM2CR.FOR
9418*COPY DT_COM2CR
9419*
9420*===com2sr=============================================================*
9421*
9422 SUBROUTINE DT_COM2CR
9423
9424************************************************************************
9425* COMbine q-aq chains to Color Ropes (qq-aqaq). *
9426* CUTOF parameter determining minimum number of not *
9427* combined q-aq chains *
9428* This subroutine replaces KKEVCC etc. *
9429* This version dated 11.01.95 is written by S. Roesler. *
9430************************************************************************
9431
9432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9433 SAVE
9434
9435 PARAMETER ( LINP = 10 ,
9436 & LOUT = 6 ,
9437 & LDAT = 9 )
9438
9439* event history
9440
9441 PARAMETER (NMXHKK=200000)
9442
9443 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9444 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9445 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9446
9447* extended event history
9448 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9449 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9450 & IHIST(2,NMXHKK)
9451
9452* statistics
9453 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9454 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9455 & ICEVTG(8,0:30)
9456
9457* various options for treatment of partons (DTUNUC 1.x)
9458* (chain recombination, Cronin,..)
9459 LOGICAL LCO2CR,LINTPT
9460 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9461 & LCO2CR,LINTPT
9462
9463 DIMENSION IDXQA(248),IDXAQ(248)
9464
9465 ICCHAI(1,9) = ICCHAI(1,9)+1
9466 NQA = 0
9467 NAQ = 0
9468* scan DTEVT1 for q-aq, aq-q chains
9469 DO 10 I=NPOINT(3),NHKK
9470* skip "chains" which are resonances
9471 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9472 MO1 = JMOHKK(1,I)
9473 MO2 = JMOHKK(2,I)
9474 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9475* q-aq, aq-q chain found, keep index
9476 IF (IDHKK(MO1).GT.0) THEN
9477 NQA = NQA+1
9478 IDXQA(NQA) = I
9479 ELSE
9480 NAQ = NAQ+1
9481 IDXAQ(NAQ) = I
9482 ENDIF
9483 ENDIF
9484 ENDIF
9485 10 CONTINUE
9486
9487* minimum number of q-aq chains requested for the same projectile/
9488* target
9489 NCHMIN = IDT_NPOISS(CUTOF)
9490
9491* combine q-aq chains of the same projectile
9492 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9493* combine q-aq chains of the same target
9494 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9495* combine aq-q chains of the same projectile
9496 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9497* combine aq-q chains of the same target
9498 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9499
9500 RETURN
9501 END
9502
9503*$ CREATE DT_SCN4CR.FOR
9504*COPY DT_SCN4CR
9505*
9506*===scn4cr=============================================================*
9507*
9508 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9509
9510************************************************************************
9511* SCan q-aq chains for Color Ropes. *
9512* This version dated 11.01.95 is written by S. Roesler. *
9513************************************************************************
9514
9515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9516 SAVE
9517
9518 PARAMETER ( LINP = 10 ,
9519 & LOUT = 6 ,
9520 & LDAT = 9 )
9521
9522* event history
9523
9524 PARAMETER (NMXHKK=200000)
9525
9526 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9527 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9528 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9529
9530* extended event history
9531 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9532 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9533 & IHIST(2,NMXHKK)
9534
9535 DIMENSION IDXCH(248),IDXJN(248)
9536
9537 DO 1 I=1,NCH
9538 IF (IDXCH(I).GT.0) THEN
9539 NJOIN = 1
9540 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9541 IDXJN(NJOIN) = I
9542 IF (I.LT.NCH) THEN
9543 DO 2 J=I+1,NCH
9544 IF (IDXCH(J).GT.0) THEN
9545 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9546 IF (IDXMO.EQ.IDXMO1) THEN
9547 NJOIN = NJOIN+1
9548 IDXJN(NJOIN) = J
9549 ENDIF
9550 ENDIF
9551 2 CONTINUE
9552 ENDIF
9553 IF (NJOIN.GE.NCHMIN+2) THEN
9554 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9555 DO 3 J=1,2*NJ,2
9556 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9557 IF (IREJ1.NE.0) GOTO 3
9558 IDXCH(IDXJN(J)) = 0
9559 IDXCH(IDXJN(J+1)) = 0
9560 3 CONTINUE
9561 ENDIF
9562 ENDIF
9563 1 CONTINUE
9564
9565 RETURN
9566 END
9567
9568*$ CREATE DT_JOIN.FOR
9569*COPY DT_JOIN
9570*
9571*===join===============================================================*
9572*
9573 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9574
9575************************************************************************
9576* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9577* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9578* This version dated 11.01.95 is written by S. Roesler. *
9579************************************************************************
9580
9581 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9582 SAVE
9583
9584 PARAMETER ( LINP = 10 ,
9585 & LOUT = 6 ,
9586 & LDAT = 9 )
9587
9588* event history
9589
9590 PARAMETER (NMXHKK=200000)
9591
9592 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9593 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9594 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9595
9596* extended event history
9597 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9598 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9599 & IHIST(2,NMXHKK)
9600
9601* flags for input different options
9602 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9603 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9604 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9605
9606* statistics
9607 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9608 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9609 & ICEVTG(8,0:30)
9610
9611 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9612
9613 IREJ = 0
9614
9615 IDX(1) = IDX1
9616 IDX(2) = IDX2
9617 DO 1 I=1,2
9618 DO 2 J=1,2
9619 MO(I,J) = JMOHKK(J,IDX(I))
9620 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9621 2 CONTINUE
9622 1 CONTINUE
9623
9624* check consistency
9625 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9626 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9627 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9628 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9629 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9630 & MO(2,2)
9631 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9632 & 2I5,' chain ',I4,':',2I5)
9633 ENDIF
9634
9635* join chains
9636 DO 3 K=1,4
9637 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9638 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9639 3 CONTINUE
9640 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9641 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9642 IST1 = ISTHKK(MO(1,1))
9643 IST2 = ISTHKK(MO(1,2))
9644
9645* put partons again on mass shell
9646 XM1 = 0.0D0
9647 XM2 = 0.0D0
9648 IF (IMSHL.EQ.1) THEN
9649
9650 XM1 = PYMASS(IF1)
9651 XM2 = PYMASS(IF2)
9652
9653 ENDIF
9654 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9655 IF (IREJ1.NE.0) GOTO 9999
9656 DO 4 I=1,4
9657 PP(I) = P1(I)
9658 PT(I) = P2(I)
9659 4 CONTINUE
9660
9661* store new partons in DTEVT1
9662 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9663 & 0,0,0)
9664 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9665 & 0,0,0)
9666 DO 5 K=1,4
9667 PCH(K) = PP(K)+PT(K)
9668 5 CONTINUE
9669
9670* check new chain for lower mass limit
9671 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9672 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9673 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9674 & AMCH,AMCHN,3,IREJ1)
9675 IF (IREJ1.NE.0) THEN
9676 NHKK = NHKK-2
9677 GOTO 9999
9678 ENDIF
9679 ENDIF
9680
9681 ICCHAI(2,9) = ICCHAI(2,9)+1
9682* store new chain in DTEVT1
9683 KCH = 191
9684 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9685 IDHKK(IDX(1)) = 22222
9686 IDHKK(IDX(2)) = 22222
9687* special treatment for space-time coordinates
9688 DO 6 K=1,4
9689 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9690 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9691 6 CONTINUE
9692 RETURN
9693
9694 9999 CONTINUE
9695 IREJ = 1
9696 RETURN
9697 END
9698*$ CREATE DT_XSGLAU.FOR
9699*COPY DT_XSGLAU
9700*
9701*===xsglau=============================================================*
9702*
9703 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9704
9705************************************************************************
9706* Total, elastic, quasi-elastic, inelastic cross sections according to *
9707* Glauber's approach. *
9708* NA / NB mass numbers of proj./target nuclei *
9709* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9710* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9711* IE,IQ indices of energy and virtuality (the latter for gamma *
9712* projectiles only) *
9713* NIDX index of projectile/target nucleus *
9714* This version dated 17.3.98 is written by S. Roesler *
9715************************************************************************
9716
9717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9718 SAVE
9719
9720 PARAMETER ( LINP = 10 ,
9721 & LOUT = 6 ,
9722 & LDAT = 9 )
9723
9724 COMPLEX*16 CZERO,CONE,CTWO
9725 CHARACTER*12 CFILE
9726 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9727 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9728 PARAMETER (TWOPI = 6.283185307179586454D+00,
9729 & PI = TWOPI/TWO,
9730 & GEV2MB = 0.38938D0,
9731 & GEV2FM = 0.1972D0,
9732 & ALPHEM = ONE/137.0D0,
9733* proton mass
9734 & AMP = 0.938D0,
9735 & AMP2 = AMP**2,
9736* approx. nucleon radius
9737 & RNUCLE = 1.12D0)
9738
9739* particle properties (BAMJET index convention)
9740 CHARACTER*8 ANAME
9741 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9742 & IICH(210),IIBAR(210),K1(210),K2(210)
9743
9744 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9745
9746 PARAMETER ( MAXNCL = 260,
9747
9748 & MAXVQU = MAXNCL,
9749 & MAXSQU = 20*MAXVQU,
9750 & MAXINT = MAXVQU+MAXSQU)
9751
9752* Glauber formalism: parameters
9753 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9754 & BMAX(NCOMPX),BSTEP(NCOMPX),
9755 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9756 & NSITEB,NSTATB
9757
9758* Glauber formalism: cross sections
9759 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9760 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9761 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9762 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9763 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9764 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9765 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9766 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9767 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9768 & BSLOPE,NEBINI,NQBINI
9769
9770* Glauber formalism: flags and parameters for statistics
9771 LOGICAL LPROD
9772 CHARACTER*8 CGLB
9773 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9774
9775* nucleon-nucleon event-generator
9776 CHARACTER*8 CMODEL
9777 LOGICAL LPHOIN
9778 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9779
9780* VDM parameter for photon-nucleus interactions
9781 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9782
9783* parameters for hA-diffraction
9784 COMMON /DTDIHA/ DIBETA,DIALPH
9785
9786 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9787 & OMPP11,OMPP12,OMPP21,OMPP22,
9788 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9789 & PPTMP1,PPTMP2
9790 COMPLEX*16 C,CA,CI
9791 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9792 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9793 & BPROD(KSITEB)
9794
9795 PARAMETER (NPOINT=16)
9796 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9797
9798 LOGICAL LFIRST,LOPEN
9799 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9800
9801 NTARG = ABS(NIDX)
9802* for quasi-elastic neutrino scattering set projectile to proton
9803* it should not have an effect since the whole Glauber-formalism is
9804* not needed for these interactions..
9805 IF (MCGENE.EQ.4) THEN
9806 IJPROJ = 1
9807 ELSE
9808 IJPROJ = JJPROJ
9809 ENDIF
9810
9811 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9812 I = INDEX(CGLB,' ')
9813 IF (I.EQ.0) THEN
9814 CFILE = CGLB//'.glb'
9815 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9816 ELSEIF (I.GT.1) THEN
9817 CFILE = CGLB(1:I-1)//'.glb'
9818 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9819 ELSE
9820 STOP 'XSGLAU 1'
9821 ENDIF
9822 LOPEN = .TRUE.
9823 ENDIF
9824
9825 CZERO = DCMPLX(ZERO,ZERO)
9826 CONE = DCMPLX(ONE,ZERO)
9827 CTWO = DCMPLX(TWO,ZERO)
9828 NEBINI = IE
9829 NQBINI = IQ
9830
9831* re-define kinematics
9832 S = ECMI**2
9833 Q2 = Q2I
9834 X = XI
9835* g(Q2=0)-A, h-A, A-A scattering
9836 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9837 Q2 = 0.0001D0
9838 X = Q2/(S+Q2-AMP2)
9839* g(Q2>0)-A scattering
9840 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9841 X = Q2/(S+Q2-AMP2)
9842 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9843 Q2 = (S-AMP2)*X/(ONE-X)
9844 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9845 S = Q2*(ONE-X)/X+AMP2
9846 ELSE
9847 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9848 STOP
9849 ENDIF
9850 ECMNN(IE) = SQRT(S)
9851 Q2G(IQ) = Q2
9852 XNU = (S+Q2-AMP2)/(TWO*AMP)
9853
9854* parameters determining statistics in evaluating Glauber-xsection
9855 NSTATB = JSTATB
9856 NSITEB = JBINSB
9857 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9858
9859* set up interaction geometry (common /DTGLAM/)
9860* projectile/target radii
9861 RPRNCL = DT_RNCLUS(NA)
9862 RTANCL = DT_RNCLUS(NB)
9863 IF (IJPROJ.EQ.7) THEN
9864 RASH(1) = ZERO
9865 RBSH(NTARG) = RTANCL
9866 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9867 ELSE
9868 IF (NIDX.LE.-1) THEN
9869 RASH(1) = RPRNCL
9870 RBSH(NTARG) = RTANCL
9871 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9872 ELSE
9873 RASH(NTARG) = RPRNCL
9874 RBSH(1) = RTANCL
9875 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9876 ENDIF
9877 ENDIF
9878* maximum impact-parameter
9879 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9880
9881* slope, rho ( Re(f(0))/Im(f(0)) )
9882 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9883 IF (MCGENE.EQ.2) THEN
9884 ZERO1 = ZERO
9885 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9886 & BSLOPE,0)
9887 ELSE
9888 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9889 ENDIF
9890 IF (ECMNN(IE).LE.3.0D0) THEN
9891 ROSH = -0.43D0
9892 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9893 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9894 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9895 ROSH = 0.1D0
9896 ENDIF
9897 ELSEIF (IJPROJ.EQ.7) THEN
9898 ROSH = 0.1D0
9899 ELSE
9900 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9901 ROSH = 0.01D0
9902 ENDIF
9903
9904* projectile-nucleon xsection (in fm)
9905 IF (IJPROJ.EQ.7) THEN
9906 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9907 ELSE
9908 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9909 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9910C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9911 DUMZER = ZERO
9912 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9913 SIGSH = SIGSH/10.0D0
9914 ENDIF
9915
9916* parameters for projectile diffraction (hA scattering only)
9917 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9918 & .AND.(DIBETA.GE.ZERO)) THEN
9919 ZERO1 = ZERO
9920 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9921C DIBETA = SDIF1/STOT
9922 DIBETA = 0.2D0
9923 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9924 IF (DIBETA.LE.ZERO) THEN
9925 ALPGAM = ONE
9926 ELSE
9927 ALPGAM = DIALPH/DIGAMM
9928 ENDIF
9929 FACDI1 = ONE-ALPGAM
9930 FACDI2 = ONE+ALPGAM
9931 FACDI = SQRT(FACDI1*FACDI2)
9932 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9933 ELSE
9934 DIBETA = -1.0D0
9935 DIALPH = ZERO
9936 DIGAMM = ZERO
9937 FACDI1 = ZERO
9938 FACDI2 = 2.0D0
9939 FACDI = ZERO
9940 ENDIF
9941
9942* initializations
9943 DO 10 I=1,NSITEB
9944 BSITE( 0,IQ,NTARG,I) = ZERO
9945 BSITE(IE,IQ,NTARG,I) = ZERO
9946 BPROD(I) = ZERO
9947 10 CONTINUE
9948 STOT = ZERO
9949 STOT2 = ZERO
9950 SELA = ZERO
9951 SELA2 = ZERO
9952 SQEP = ZERO
9953 SQEP2 = ZERO
9954 SQET = ZERO
9955 SQET2 = ZERO
9956 SQE2 = ZERO
9957 SQE22 = ZERO
9958 SPRO = ZERO
9959 SPRO2 = ZERO
9960 SDEL = ZERO
9961 SDEL2 = ZERO
9962 SDQE = ZERO
9963 SDQE2 = ZERO
9964 FACN = ONE/DBLE(NSTATB)
9965
9966 IPNT = 0
9967 RPNT = ZERO
9968
9969* initialize Gauss-integration for photon-proj.
9970 JPOINT = 1
9971 IF (IJPROJ.EQ.7) THEN
9972 IF (INTRGE(1).EQ.1) THEN
9973 AMLO2 = (3.0D0*AAM(13))**2
9974 ELSEIF (INTRGE(1).EQ.2) THEN
9975 AMLO2 = AAM(33)**2
9976 ELSE
9977 AMLO2 = AAM(96)**2
9978 ENDIF
9979 IF (INTRGE(2).EQ.1) THEN
9980 AMHI2 = S/TWO
9981 ELSEIF (INTRGE(2).EQ.2) THEN
9982 AMHI2 = S/4.0D0
9983 ELSE
9984 AMHI2 = S
9985 ENDIF
9986 AMHI20 = (ECMNN(IE)-AMP)**2
9987 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9988 XAMLO = LOG( AMLO2+Q2 )
9989 XAMHI = LOG( AMHI2+Q2 )
9990**PHOJET105a
9991C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9992**PHOJET112
9993
9994 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9995
9996**
9997 JPOINT = NPOINT
9998* ratio direct/total photon-nucleon xsection
9999 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10000 ENDIF
10001
10002* read pre-initialized profile-function from file
10003 IF (IOGLB.EQ.1) THEN
10004 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10005 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10006 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10007 & NA,NB,NSTATB,NSITEB
10008 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10009 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10010 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
10011 STOP
10012 ENDIF
10013 IF (LFIRST) WRITE(LOUT,1001) CFILE
10014 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10015 & 'file ',A12,/)
10016 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10017 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10018 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10019 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10020 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10021 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10022 NLINES = INT(DBLE(NSITEB)/7.0D0)
10023 IF (NLINES.GT.0) THEN
10024 DO 21 I=1,NLINES
10025 ISTART = 7*I-6
10026 READ(LDAT,'(7E11.4)')
10027 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10028 21 CONTINUE
10029 ENDIF
10030 ISTART = 7*NLINES+1
10031 IF (ISTART.LE.NSITEB) THEN
10032 READ(LDAT,'(7E11.4)')
10033 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10034 ENDIF
10035 LFIRST = .FALSE.
10036 GOTO 100
10037* variable projectile/target/energy runs:
10038* read pre-initialized profile-functions from file
10039 ELSEIF (IOGLB.EQ.100) THEN
10040 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10041 GOTO 100
10042 ENDIF
10043
10044* cross sections averaged over NSTATB nucleon configurations
10045 DO 11 IS=1,NSTATB
10046C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10047 STOTN = ZERO
10048 SELAN = ZERO
10049 SQEPN = ZERO
10050 SQETN = ZERO
10051 SQE2N = ZERO
10052 SPRON = ZERO
10053 SDELN = ZERO
10054 SDQEN = ZERO
10055
10056 IF (NIDX.LE.-1) THEN
10057 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10058 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10059 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10060 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10061 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10062 ENDIF
10063 ELSE
10064 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10065 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10066 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10067 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10068 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10069 ENDIF
10070 ENDIF
10071
10072* integration over impact parameter B
10073 DO 12 IB=1,NSITEB-1
10074 STOTB = ZERO
10075 SELAB = ZERO
10076 SQEPB = ZERO
10077 SQETB = ZERO
10078 SQE2B = ZERO
10079 SPROB = ZERO
10080 SDIR = ZERO
10081 SDELB = ZERO
10082 SDQEB = ZERO
10083 B = DBLE(IB)*BSTEP(NTARG)
10084 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10085
10086* integration over M_V^2 for photon-proj.
10087 DO 14 IM=1,JPOINT
10088 PP11(1) = CONE
10089 PP12(1) = CONE
10090 PP21(1) = CONE
10091 PP22(1) = CONE
10092 IF (IJPROJ.EQ.7) THEN
10093 DO 13 K=2,NB
10094 PP11(K) = CONE
10095 PP12(K) = CONE
10096 PP21(K) = CONE
10097 PP22(K) = CONE
10098 13 CONTINUE
10099 ENDIF
10100 SHI = ZERO
10101 FACM = ONE
10102 DCOH = 1.0D10
10103
10104 IF (IJPROJ.EQ.7) THEN
10105 AMV2 = EXP(ABSZX(IM))-Q2
10106 AMV = SQRT(AMV2)
10107 IF (AMV2.LT.16.0D0) THEN
10108 R = TWO
10109 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10110 R = 10.0D0/3.0D0
10111 ELSE
10112 R = 11.0D0/3.0D0
10113 ENDIF
10114* define M_V dependent properties of nucleon scattering amplitude
10115* V_M-nucleon xsection
10116 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10117 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10118* slope-parametrisation a la Kaidalov
10119 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10120 & +0.25D0*LOG(S/(AMV2+Q2)))
10121* coherence length
10122 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10123* integration weight factor
10124 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10125 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10126 ENDIF
10127 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10128 GAM = GSH
10129 IF (IJPROJ.EQ.7) THEN
10130 RCA = GAM*SIGMV/TWOPI
10131 ELSE
10132 RCA = GAM*SIGSH/TWOPI
10133 ENDIF
10134 FCA = -ROSH*RCA
10135 CA = DCMPLX(RCA,FCA)
10136 CI = CONE
10137
10138 DO 15 INA=1,NA
10139 KK1 = 1
10140 INT1 = 1
10141 KK2 = 1
10142 INT2 = 1
10143 DO 16 INB=1,NB
10144* photon-projectile: check for supression by coherence length
10145 IF (IJPROJ.EQ.7) THEN
10146 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10147 KK1 = INB
10148 INT1 = INT1+1
10149 ENDIF
10150 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10151 KK2 = INB
10152 INT2 = INT2+1
10153 ENDIF
10154 ENDIF
10155
10156 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10157 Y11 = COOT1(2,INB)-COOP1(2,INA)
10158 XY11 = GAM*(X11*X11+Y11*Y11)
10159 IF (XY11.LE.15.0D0) THEN
10160 C = CONE-CA*EXP(-XY11)
10161 AR = DBLE(PP11(INT1))
10162 AI = DIMAG(PP11(INT1))
10163 IF (ABS(AR).LT.TINY25) AR = ZERO
10164 IF (ABS(AI).LT.TINY25) AI = ZERO
10165 PP11(INT1) = DCMPLX(AR,AI)
10166 PP11(INT1) = PP11(INT1)*C
10167 AR = DBLE(C)
10168 AI = DIMAG(C)
10169 SHI = SHI+LOG(AR*AR+AI*AI)
10170 ENDIF
10171 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10172 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10173 Y12 = COOT2(2,INB)-COOP1(2,INA)
10174 XY12 = GAM*(X12*X12+Y12*Y12)
10175 IF (XY12.LE.15.0D0) THEN
10176 C = CONE-CA*EXP(-XY12)
10177 AR = DBLE(PP12(INT2))
10178 AI = DIMAG(PP12(INT2))
10179 IF (ABS(AR).LT.TINY25) AR = ZERO
10180 IF (ABS(AI).LT.TINY25) AI = ZERO
10181 PP12(INT2) = DCMPLX(AR,AI)
10182 PP12(INT2) = PP12(INT2)*C
10183 ENDIF
10184 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10185 Y21 = COOT1(2,INB)-COOP2(2,INA)
10186 XY21 = GAM*(X21*X21+Y21*Y21)
10187 IF (XY21.LE.15.0D0) THEN
10188 C = CONE-CA*EXP(-XY21)
10189 AR = DBLE(PP21(INT1))
10190 AI = DIMAG(PP21(INT1))
10191 IF (ABS(AR).LT.TINY25) AR = ZERO
10192 IF (ABS(AI).LT.TINY25) AI = ZERO
10193 PP21(INT1) = DCMPLX(AR,AI)
10194 PP21(INT1) = PP21(INT1)*C
10195 ENDIF
10196 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10197 Y22 = COOT2(2,INB)-COOP2(2,INA)
10198 XY22 = GAM*(X22*X22+Y22*Y22)
10199 IF (XY22.LE.15.0D0) THEN
10200 C = CONE-CA*EXP(-XY22)
10201 AR = DBLE(PP22(INT2))
10202 AI = DIMAG(PP22(INT2))
10203 IF (ABS(AR).LT.TINY25) AR = ZERO
10204 IF (ABS(AI).LT.TINY25) AI = ZERO
10205 PP22(INT2) = DCMPLX(AR,AI)
10206 PP22(INT2) = PP22(INT2)*C
10207 ENDIF
10208 ENDIF
10209 16 CONTINUE
10210 15 CONTINUE
10211
10212 OMPP11 = CZERO
10213 OMPP21 = CZERO
10214 DIPP11 = CZERO
10215 DIPP21 = CZERO
10216 DO 17 K=1,INT1
10217 IF (PP11(K).EQ.CZERO) THEN
10218 PPTMP1 = CZERO
10219 PPTMP2 = CZERO
10220 ELSE
10221 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10222 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10223 ENDIF
10224 AVDIPP = 0.5D0*
10225 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10226 OMPP11 = OMPP11+AVDIPP
10227C OMPP11 = OMPP11+(CONE-PP11(K))
10228 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10229 DIPP11 = DIPP11+AVDIPP
10230 IF (PP21(K).EQ.CZERO) THEN
10231 PPTMP1 = CZERO
10232 PPTMP2 = CZERO
10233 ELSE
10234 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10235 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10236 ENDIF
10237 AVDIPP = 0.5D0*
10238 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10239 OMPP21 = OMPP21+AVDIPP
10240C OMPP21 = OMPP21+(CONE-PP21(K))
10241 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10242 DIPP21 = DIPP21+AVDIPP
10243 17 CONTINUE
10244 OMPP12 = CZERO
10245 OMPP22 = CZERO
10246 DIPP12 = CZERO
10247 DIPP22 = CZERO
10248 DO 18 K=1,INT2
10249 IF (PP12(K).EQ.CZERO) THEN
10250 PPTMP1 = CZERO
10251 PPTMP2 = CZERO
10252 ELSE
10253 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10254 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10255 ENDIF
10256 AVDIPP = 0.5D0*
10257 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10258 OMPP12 = OMPP12+AVDIPP
10259C OMPP12 = OMPP12+(CONE-PP12(K))
10260 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10261 DIPP12 = DIPP12+AVDIPP
10262 IF (PP22(K).EQ.CZERO) THEN
10263 PPTMP1 = CZERO
10264 PPTMP2 = CZERO
10265 ELSE
10266 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10267 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10268 ENDIF
10269 AVDIPP = 0.5D0*
10270 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10271 OMPP22 = OMPP22+AVDIPP
10272C OMPP22 = OMPP22+(CONE-PP22(K))
10273 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10274 DIPP22 = DIPP22+AVDIPP
10275 18 CONTINUE
10276
10277 SPROM = ONE-EXP(SHI)
10278 SPROB = SPROB+FACM*SPROM
10279 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10280 STOTM = DBLE(OMPP11+OMPP22)
10281 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10282 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10283 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10284 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10285 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10286 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10287 STOTB = STOTB+FACM*STOTM
10288 SELAB = SELAB+FACM*SELAM
10289 SDELB = SDELB+FACM*SDELM
10290 IF (NB.GT.1) THEN
10291 SQEPB = SQEPB+FACM*SQEPM
10292 SDQEB = SDQEB+FACM*SDQEM
10293 ENDIF
10294 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10295 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10296 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10297 ENDIF
10298
10299 14 CONTINUE
10300
10301 STOTN = STOTN+FACB*STOTB
10302 SELAN = SELAN+FACB*SELAB
10303 SQEPN = SQEPN+FACB*SQEPB
10304 SQETN = SQETN+FACB*SQETB
10305 SQE2N = SQE2N+FACB*SQE2B
10306 SPRON = SPRON+FACB*SPROB
10307 SDELN = SDELN+FACB*SDELB
10308 SDQEN = SDQEN+FACB*SDQEB
10309
10310 IF (IJPROJ.EQ.7) THEN
10311 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10312 ELSE
10313 IF (DIBETA.GT.ZERO) THEN
10314 BPROD(IB+1)= BPROD(IB+1)
10315 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10316 ELSE
10317 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10318 ENDIF
10319 ENDIF
10320
10321 12 CONTINUE
10322
10323 STOT = STOT +FACN*STOTN
10324 STOT2 = STOT2+FACN*STOTN**2
10325 SELA = SELA +FACN*SELAN
10326 SELA2 = SELA2+FACN*SELAN**2
10327 SQEP = SQEP +FACN*SQEPN
10328 SQEP2 = SQEP2+FACN*SQEPN**2
10329 SQET = SQET +FACN*SQETN
10330 SQET2 = SQET2+FACN*SQETN**2
10331 SQE2 = SQE2 +FACN*SQE2N
10332 SQE22 = SQE22+FACN*SQE2N**2
10333 SPRO = SPRO +FACN*SPRON
10334 SPRO2 = SPRO2+FACN*SPRON**2
10335 SDEL = SDEL +FACN*SDELN
10336 SDEL2 = SDEL2+FACN*SDELN**2
10337 SDQE = SDQE +FACN*SDQEN
10338 SDQE2 = SDQE2+FACN*SDQEN**2
10339
10340 11 CONTINUE
10341
10342* final cross sections
10343* 1) total
10344 XSTOT(IE,IQ,NTARG) = STOT
10345 IF (IJPROJ.EQ.7)
10346 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10347* 2) elastic
10348 XSELA(IE,IQ,NTARG) = SELA
10349* 3) quasi-el.: A+B-->A+X (excluding 2)
10350 XSQEP(IE,IQ,NTARG) = SQEP
10351* 4) quasi-el.: A+B-->X+B (excluding 2)
10352 XSQET(IE,IQ,NTARG) = SQET
10353* 5) quasi-el.: A+B-->X (excluding 2-4)
10354 XSQE2(IE,IQ,NTARG) = SQE2
10355* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10356 IF (SDEL.GT.ZERO) THEN
10357 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10358 ELSE
10359 XSPRO(IE,IQ,NTARG) = SPRO
10360 ENDIF
10361* 7) projectile diffraction (el. scatt. off target)
10362 XSDEL(IE,IQ,NTARG) = SDEL
10363* 8) projectile diffraction (quasi-el. scatt. off target)
10364 XSDQE(IE,IQ,NTARG) = SDQE
10365* stat. errors
10366 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10367 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10368 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10369 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10370 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10371 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10372 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10373 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10374
10375 IF (IJPROJ.EQ.7) THEN
10376 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10377 & -XSQEP(IE,IQ,NTARG)
10378 ELSE
10379 BNORM = XSPRO(IE,IQ,NTARG)
10380 ENDIF
10381 DO 19 I=2,NSITEB
10382 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10383 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10384 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10385 19 CONTINUE
10386
10387* write profile function data into file
10388 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10389 WRITE(LDAT,'(5I10,1P,E15.5)')
10390 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10391 WRITE(LDAT,'(1P,6E12.5)')
10392 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10393 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10394 WRITE(LDAT,'(1P,6E12.5)')
10395 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10396 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10397 NLINES = INT(DBLE(NSITEB)/7.0D0)
10398 IF (NLINES.GT.0) THEN
10399 DO 20 I=1,NLINES
10400 ISTART = 7*I-6
10401 WRITE(LDAT,'(1P,7E11.4)')
10402 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10403 20 CONTINUE
10404 ENDIF
10405 ISTART = 7*NLINES+1
10406 IF (ISTART.LE.NSITEB) THEN
10407 WRITE(LDAT,'(1P,7E11.4)')
10408 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10409 ENDIF
10410 ENDIF
10411
10412 100 CONTINUE
10413
10414C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10415
10416 RETURN
10417 END
10418
10419*$ CREATE DT_GETBXS.FOR
10420*COPY DT_GETBXS
10421*
10422*===getbxs=============================================================*
10423*
10424 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10425
10426************************************************************************
10427* Biasing in impact parameter space. *
10428* XSFRAC = 0 : BLO - minimum impact parameter (input) *
10429* BHI - maximum impact parameter (input) *
10430* XSFRAC - fraction of cross section corresponding *
10431* to impact parameter range (BLO,BHI) *
10432* (output) *
10433* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10434* BHI - maximum impact parameter giving requested *
10435* fraction of cross section in impact *
10436* parameter range (0,BMAX) (output) *
10437* This version dated 17.03.00 is written by S. Roesler *
10438************************************************************************
10439
10440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10441 SAVE
10442
10443 PARAMETER ( LINP = 10 ,
10444 & LOUT = 6 ,
10445 & LDAT = 9 )
10446
10447 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10448
10449* Glauber formalism: parameters
10450 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10451 & BMAX(NCOMPX),BSTEP(NCOMPX),
10452 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10453 & NSITEB,NSTATB
10454
10455 NTARG = ABS(NIDX)
10456 IF (XSFRAC.LE.0.0D0) THEN
10457 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10458 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10459 IF (ILO.GE.IHI) THEN
10460 XSFRAC = 0.0D0
10461 RETURN
10462 ENDIF
10463 IF (ILO.EQ.NSITEB-1) THEN
10464 FRCLO = BSITE(0,1,NTARG,NSITEB)
10465 ELSE
10466 FRCLO = BSITE(0,1,NTARG,ILO+1)
10467 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10468 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10469 ENDIF
10470 IF (IHI.EQ.NSITEB-1) THEN
10471 FRCHI = BSITE(0,1,NTARG,NSITEB)
10472 ELSE
10473 FRCHI = BSITE(0,1,NTARG,IHI+1)
10474 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10475 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10476 ENDIF
10477 XSFRAC = FRCHI-FRCLO
10478 ELSE
10479 BLO = 0.0D0
10480 BHI = BMAX(NTARG)
10481 DO 1 I=1,NSITEB-1
10482 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10483 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10484 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10485 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10486 GOTO 2
10487 ENDIF
10488 1 CONTINUE
10489 2 CONTINUE
10490 ENDIF
10491
10492 RETURN
10493 END
10494
10495*$ CREATE DT_CONUCL.FOR
10496*COPY DT_CONUCL
10497*
10498*===conucl=============================================================*
10499*
10500 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10501
10502************************************************************************
10503* Calculation of coordinates of nucleons within nuclei. *
10504* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10505* N / R number of nucleons / radius of nucleus (input) *
10506* MODE = 0 coordinates not sorted *
10507* = 1 coordinates sorted with increasing X(3,i) *
10508* = 2 coordinates sorted with decreasing X(3,i) *
10509* This version dated 26.10.95 is revised by S. Roesler *
10510************************************************************************
10511
10512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10513 SAVE
10514
10515 PARAMETER ( LINP = 10 ,
10516 & LOUT = 6 ,
10517 & LDAT = 9 )
10518
10519 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10520 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10521
10522 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10523
10524 PARAMETER (NSRT=10)
10525 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10526 DIMENSION X(3,N),XTMP(3,260)
10527
10528 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10529
10530 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10531 K = 0
10532 DO 1 I=1,NSRT
10533 IF (MODE.EQ.2) THEN
10534 ISRT = NSRT+1-I
10535 ELSE
10536 ISRT = I
10537 ENDIF
10538 K1 = K
10539 DO 2 J=1,ICSRT(ISRT)
10540 K = K+1
10541 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10542 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10543 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10544 2 CONTINUE
10545 IF (ICSRT(ISRT).GT.1) THEN
10546 I0 = K1+1
10547 I1 = K
10548 CALL DT_SORT(X,N,I0,I1,MODE)
10549 ENDIF
10550 1 CONTINUE
10551 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10552 DO 3 I=1,N
10553 X(1,I) = XTMP(1,I)
10554 X(2,I) = XTMP(2,I)
10555 X(3,I) = XTMP(3,I)
10556 3 CONTINUE
10557 CALL DT_SORT(X,N,1,N,MODE)
10558 ELSE
10559 DO 4 I=1,N
10560 X(1,I) = XTMP(1,I)
10561 X(2,I) = XTMP(2,I)
10562 X(3,I) = XTMP(3,I)
10563 4 CONTINUE
10564 ENDIF
10565
10566 RETURN
10567 END
10568
10569*$ CREATE DT_COORDI.FOR
10570*COPY DT_COORDI
10571*
10572*===coordi=============================================================*
10573*
10574 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10575
10576************************************************************************
10577* Calculation of coordinates of nucleons within nuclei. *
10578* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10579* N / R number of nucleons / radius of nucleus (input) *
10580* Based on the original version by Shmakov et al. *
10581* This version dated 26.10.95 is revised by S. Roesler *
10582************************************************************************
10583
10584 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10585 SAVE
10586
10587 PARAMETER ( LINP = 10 ,
10588 & LOUT = 6 ,
10589 & LDAT = 9 )
10590
10591 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10592 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10593
10594 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10595
10596 LOGICAL LSTART
10597
10598 PARAMETER (NSRT=10)
10599 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10600 DIMENSION X(3,260),WD(4),RD(3)
10601
10602 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10603 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10604 DATA RD /2.09D0, 0.935D0, 0.697D0/
10605
10606 X1SUM = ZERO
10607 X2SUM = ZERO
10608 X3SUM = ZERO
10609
10610 IF (N.EQ.1) THEN
10611 X(1,1) = ZERO
10612 X(2,1) = ZERO
10613 X(3,1) = ZERO
10614 ELSEIF (N.EQ.2) THEN
10615 EPS = DT_RNDM(RD(1))
10616 DO 30 I=1,3
10617 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10618 30 CONTINUE
10619 40 CONTINUE
10620 DO 50 J=1,3
10621 CALL DT_RANNOR(X1,X2)
10622 X(J,1) = RD(I)*X1
10623 X(J,2) = -X(J,1)
10624 50 CONTINUE
10625 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10626 SIGMA = R/SQRTWO
10627 LSTART = .TRUE.
10628 CALL DT_RANNOR(X3,X4)
10629 DO 100 I=1,N
10630 CALL DT_RANNOR(X1,X2)
10631 X(1,I) = SIGMA*X1
10632 X(2,I) = SIGMA*X2
10633 IF (LSTART) GOTO 80
10634 X(3,I) = SIGMA*X4
10635 CALL DT_RANNOR(X3,X4)
10636 GOTO 90
10637 80 CONTINUE
10638 X(3,I) = SIGMA*X3
10639 90 CONTINUE
10640 LSTART = .NOT.LSTART
10641 X1SUM = X1SUM+X(1,I)
10642 X2SUM = X2SUM+X(2,I)
10643 X3SUM = X3SUM+X(3,I)
10644 100 CONTINUE
10645 X1SUM = X1SUM/DBLE(N)
10646 X2SUM = X2SUM/DBLE(N)
10647 X3SUM = X3SUM/DBLE(N)
10648 DO 101 I=1,N
10649 X(1,I) = X(1,I)-X1SUM
10650 X(2,I) = X(2,I)-X2SUM
10651 X(3,I) = X(3,I)-X3SUM
10652 101 CONTINUE
10653 ELSE
10654
10655* maximum nuclear radius for coordinate sampling
10656 RMAX = R+4.605D0*PDIF
10657
10658* initialize pre-sorting
10659 DO 121 I=1,NSRT
10660 ICSRT(I) = 0
10661 121 CONTINUE
10662 DR = TWO*RMAX/DBLE(NSRT)
10663
10664* sample coordinates for N nucleons
10665 DO 140 I=1,N
10666 120 CONTINUE
10667 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10668 F = DT_DENSIT(N,RAD,R)
10669 IF (DT_RNDM(RAD).GT.F) GOTO 120
10670* theta, phi uniformly distributed
10671 CT = ONE-TWO*DT_RNDM(F)
10672 ST = SQRT((ONE-CT)*(ONE+CT))
10673 CALL DT_DSFECF(SFE,CFE)
10674 X(1,I) = RAD*ST*CFE
10675 X(2,I) = RAD*ST*SFE
10676 X(3,I) = RAD*CT
10677* ensure that distance between two nucleons is greater than R2MIN
10678 IF (I.LT.2) GOTO 122
10679 I1 = I-1
10680 DO 130 I2=1,I1
10681 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10682 & (X(3,I)-X(3,I2))**2
10683 IF (DIST2.LE.R2MIN) GOTO 120
10684 130 CONTINUE
10685 122 CONTINUE
10686* save index according to z-bin
10687 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10688 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10689 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10690 X1SUM = X1SUM+X(1,I)
10691 X2SUM = X2SUM+X(2,I)
10692 X3SUM = X3SUM+X(3,I)
10693 140 CONTINUE
10694 X1SUM = X1SUM/DBLE(N)
10695 X2SUM = X2SUM/DBLE(N)
10696 X3SUM = X3SUM/DBLE(N)
10697 DO 141 I=1,N
10698 X(1,I) = X(1,I)-X1SUM
10699 X(2,I) = X(2,I)-X2SUM
10700 X(3,I) = X(3,I)-X3SUM
10701 141 CONTINUE
10702
10703 ENDIF
10704
10705 RETURN
10706 END
10707
10708*$ CREATE DT_DENSIT.FOR
10709*COPY DT_DENSIT
10710*
10711*===densit=============================================================*
10712*
10713 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10714
10715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10716 SAVE
10717
10718 PARAMETER ( LINP = 10 ,
10719 & LOUT = 6 ,
10720 & LDAT = 9 )
10721
10722 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10723 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10724 & PI = TWOPI/TWO)
10725
10726 DIMENSION R0(18),FNORM(18)
10727 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10728 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10729 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10730 & 2.72D0, 2.66D0, 2.79D0/
10731 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10732 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10733 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10734 & .1214D+01,.1265D+01,.1318D+01/
10735 DATA PDIF /0.545D0/
10736
10737 DT_DENSIT = ZERO
10738* shell model
10739 IF (NA.LE.4) THEN
10740 STOP 'DT_DENSIT-0'
10741 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10742 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10743 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10744 & *EXP(-(R/R1)**2)/FNORM(NA)
10745* Woods-Saxon
10746 ELSEIF (NA.GT.18) THEN
10747 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10748 ENDIF
10749
10750 RETURN
10751 END
10752
10753*$ CREATE DT_RNCLUS.FOR
10754*COPY DT_RNCLUS
10755*
10756*===rnclus=============================================================*
10757*
10758 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10759
10760************************************************************************
10761* Nuclear radius for nucleus with mass number N. *
10762* This version dated 26.9.00 is written by S. Roesler *
10763************************************************************************
10764
10765 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10766 SAVE
10767
10768 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10769
10770* nucleon radius
10771 PARAMETER (RNUCLE = 1.12D0)
10772
10773* nuclear radii for selected nuclei
10774 DIMENSION RADNUC(18)
10775 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10776 & 2.58D0,2.71D0,2.66D0,2.71D0/
10777
10778 IF (N.LE.18) THEN
10779 IF (RADNUC(N).GT.0.0D0) THEN
10780 DT_RNCLUS = RADNUC(N)
10781 ELSE
10782 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10783 ENDIF
10784 ELSE
10785 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10786 ENDIF
10787
10788 RETURN
10789 END
10790
10791*$ CREATE DT_DENTST.FOR
10792*COPY DT_DENTST
10793*
10794*===dentst=============================================================*
10795*
10796C PROGRAM DT_DENTST
10797 SUBROUTINE DT_DENTST
10798
10799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10800 SAVE
10801
10802 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10803 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10804
10805 RMIN = 0.0D0
10806 RMAX = 8.0D0
10807 NBINS = 500.0D0
10808 DR = (RMAX-RMIN)/DBLE(NBINS)
10809 DO 1 IA=5,18
10810 FMAX = 0.0D0
10811 DO 2 IR=1,NBINS+1
10812 R = RMIN+DBLE(IR-1)*DR
10813 F = DT_DENSIT(IA,R,R)
10814 IF (F.GT.FMAX) FMAX = F
10815 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10816 2 CONTINUE
10817 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10818 1 CONTINUE
10819
10820 CLOSE(40)
10821 CLOSE(41)
10822
10823 END
10824
10825*$ CREATE DT_SHMAKI.FOR
10826*COPY DT_SHMAKI
10827*
10828*===shmaki=============================================================*
10829*
10830 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10831
10832************************************************************************
10833* Initialisation of Glauber formalism. This subroutine has to be *
10834* called once (in case of target emulsions as often as many different *
10835* target nuclei are considered) before events are sampled. *
10836* NA / NCA mass number/charge of projectile nucleus *
10837* NB / NCB mass number/charge of target nucleus *
10838* IJP identity of projectile (hadrons/leptons/photons) *
10839* PPN projectile momentum (for projectile nuclei: *
10840* momentum per nucleon) in target rest system *
10841* MODE = 0 Glauber formalism invoked *
10842* = 1 fitted results are loaded from data-file *
10843* = 99 NTARG is forced to be 1 *
10844* (used in connection with GLAUBERI-card only) *
10845* This version dated 22.03.96 is based on the original SHMAKI-routine *
10846* and revised by S. Roesler. *
10847************************************************************************
10848
10849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10850 SAVE
10851
10852 PARAMETER ( LINP = 10 ,
10853 & LOUT = 6 ,
10854 & LDAT = 9 )
10855
10856 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10857 & THREE=3.0D0)
10858
10859 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10860
10861* Glauber formalism: parameters
10862 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10863 & BMAX(NCOMPX),BSTEP(NCOMPX),
10864 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10865 & NSITEB,NSTATB
10866
10867* Lorentz-parameters of the current interaction
10868 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10869 & UMO,PPCM,EPROJ,PPROJ
10870
10871* properties of photon/lepton projectiles
10872 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10873
10874* kinematical cuts for lepton-nucleus interactions
10875 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10876 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10877
10878* Glauber formalism: cross sections
10879 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10880 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10881 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10882 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10883 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10884 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10885 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10886 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10887 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10888 & BSLOPE,NEBINI,NQBINI
10889
10890* cuts for variable energy runs
10891 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10892
10893* nucleon-nucleon event-generator
10894 CHARACTER*8 CMODEL
10895 LOGICAL LPHOIN
10896 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10897
10898* Glauber formalism: flags and parameters for statistics
10899 LOGICAL LPROD
10900 CHARACTER*8 CGLB
10901 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10902
10903 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10904
10905C CALL DT_HISHAD
10906C STOP
10907
10908 NTARG = NTARG+1
10909 IF (MODE.EQ.99) NTARG = 1
10910 NIDX = -NTARG
10911 IF (MODE.EQ.-1) NIDX = NTARG
10912
10913 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10914 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10915 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10916 & ' initialization',/,12X,'--------------------------',
10917 & '-------------------------',/)
10918
10919 IF (MODE.EQ.2) THEN
10920 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10921 CALL DT_SHFAST(MODE,PPN,IBACK)
10922 STOP ' Glauber pre-initialization done'
10923 ENDIF
10924 IF (MODE.EQ.1) THEN
10925 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10926 ELSE
10927 IBACK = 1
10928 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10929 IF (IBACK.EQ.1) THEN
10930* lepton-nucleus (variable energy runs)
10931 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10932 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10933 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10934 & WRITE(LOUT,1002) NB,NCB
10935 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10936 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10937 & 'E_cm (GeV) Q^2 (GeV^2)',
10938 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10939 & '--------------------------------',
10940 & '------------------------------')
10941 AECMLO = LOG10(MIN(UMO,ECMLI))
10942 AECMHI = LOG10(MIN(UMO,ECMHI))
10943 IESTEP = NEB-1
10944 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10945 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10946 DO 1 I=1,IESTEP+1
10947 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10948 IF (Q2HI.GT.0.1D0) THEN
10949 IF (Q2LI.LT.0.01D0) THEN
10950 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10951 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10952 & WRITE(LOUT,1003)
10953 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10954 Q2LI = 0.01D0
10955 IBIN = 2
10956 ELSE
10957 IBIN = 1
10958 ENDIF
10959 IQSTEP = NQB-IBIN
10960 AQ2LO = LOG10(Q2LI)
10961 AQ2HI = LOG10(Q2HI)
10962 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10963 DO 2 J=IBIN,IQSTEP+IBIN
10964 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10965 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10966 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10967 & WRITE(LOUT,1003) ECMNN(I),
10968 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10969 2 CONTINUE
10970 ELSE
10971 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10972 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10973 & WRITE(LOUT,1003)
10974 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10975 ENDIF
10976 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10977 1 CONTINUE
10978 IVEOUT = 1
10979 ELSE
10980* hadron/photon/nucleus-nucleus
10981 IF ((ABS(VAREHI).GT.ZERO).AND.
10982 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10983 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10984 WRITE(LOUT,1004) NA,NB,NCB
10985 1004 FORMAT(1X,'variable energy run: projectile-id:',
10986 & I3,' target A/Z: ',I3,' /',I3,/)
10987 WRITE(LOUT,1005)
10988 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10989 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10990 & ' -------------------------------------',
10991 & '--------------------------------------')
10992 ENDIF
10993 AECMLO = LOG10(VARCLO)
10994 AECMHI = LOG10(VARCHI)
10995 IESTEP = NEB-1
10996 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10997 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10998 DO 3 I=1,IESTEP+1
10999 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11000 AMP = 0.938D0
11001 AMT = 0.938D0
11002 AMP2 = AMP**2
11003 AMT2 = AMT**2
11004 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11005 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11006 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11007 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11008 & WRITE(LOUT,1006)
11009 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11010 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11011 3 CONTINUE
11012 IVEOUT = 1
11013 ELSE
11014 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11015 ENDIF
11016 ENDIF
11017 ENDIF
11018 ENDIF
11019
11020 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11021 & (IOGLB.NE.100)) THEN
11022 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11023 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11024 1001 FORMAT(38X,'projectile',
11025 & ' target',/,1X,'Mass number / charge',
11026 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11027 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11028 & 'Parameters of elastic scattering amplitude:',/,5X,
11029 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11030 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11031 & 'statistics at each b-step',4X,I5,/,/,1X,
11032 & 'Prod. cross section ',5X,F10.4,' mb',/)
11033 ENDIF
11034
11035 RETURN
11036 END
11037
11038*$ CREATE DT_PROFBI.FOR
11039*COPY DT_PROFBI
11040*
11041*===profbi=============================================================*
11042*
11043 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11044
11045************************************************************************
11046* Integral over profile function (to be used for impact-parameter *
11047* sampling during event generation). *
11048* Fitted results are used. *
11049* NA / NB mass numbers of proj./target nuclei *
11050* PPN projectile momentum (for projectile nuclei: *
11051* momentum per nucleon) in target rest system *
11052* NTARG index of target material (i.e. kind of nucleus) *
11053* This version dated 31.05.95 is revised by S. Roesler *
11054************************************************************************
11055
11056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11057 SAVE
11058
11059 PARAMETER ( LINP = 10 ,
11060 & LOUT = 6 ,
11061 & LDAT = 9 )
11062
11063 SAVE
11064
11065 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11066
11067 LOGICAL LSTART
11068 CHARACTER CNAME*80
11069
11070 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11071
11072* Glauber formalism: parameters
11073 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11074 & BMAX(NCOMPX),BSTEP(NCOMPX),
11075 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11076 & NSITEB,NSTATB
11077
11078* Glauber formalism: cross sections
11079 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11080 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11081 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11082 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11083 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11084 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11085 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11086 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11087 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11088 & BSLOPE,NEBINI,NQBINI
11089
11090 PARAMETER (NGLMAX=8000)
11091 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11092 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11093
11094 DATA LSTART /.TRUE./
11095
11096 IF (LSTART) THEN
11097* read fit-parameters from file
11098 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11099 I = 0
11100 1 CONTINUE
11101 READ(47,'(A80)') CNAME
11102 IF (CNAME.EQ.'STOP') GOTO 2
11103 I = I+1
11104 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11105 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11106 & GLAFIT(4,I),GLAFIT(5,I)
11107 IF (I+1.GT.NGLMAX) THEN
11108 WRITE(LOUT,1000)
11109 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11110 & 'program stopped')
11111 STOP
11112 ENDIF
11113 GOTO 1
11114 2 CONTINUE
11115 NGLPAR = I
11116 LSTART = .FALSE.
11117 ENDIF
11118
11119 NNA = NA
11120 NNB = NB
11121 IF (NA.GT.NB) THEN
11122 NNA = NB
11123 NNB = NA
11124 ENDIF
11125 IDXGLA = 0
11126 DO 3 J=1,NGLPAR
11127 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11128 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11129 DO 4 K=1,J-1
11130 IPOINT = J-K
11131 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11132 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11133 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11134 IF (IPOINT.EQ.1) IPOINT = 0
11135 NATMP = NGLIP(IPOINT+1)
11136 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11137 IDXGLA = IPOINT+1
11138 GOTO 6
11139 ELSE
11140 J1BEG = IPOINT+1
11141 J1END = J
11142C IF (J.EQ.NGLPAR) THEN
11143C J1BEG = IPOINT
11144C J1END = J
11145C ENDIF
11146 DO 5 J1=J1BEG,J1END
11147 IF (NGLIP(J1).EQ.NATMP) THEN
11148 IF (PPN.LT.GLAPPN(J1)) THEN
11149 IDXGLA = J1
11150 GOTO 6
11151 ENDIF
11152 ELSE
11153 IDXGLA = J1-1
11154 GOTO 6
11155 ENDIF
11156 5 CONTINUE
11157 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11158 & IDXGLA = NGLPAR
11159 ENDIF
11160 ENDIF
11161 4 CONTINUE
11162 ENDIF
11163 3 CONTINUE
11164
11165 6 CONTINUE
11166 IF (IDXGLA.EQ.0) THEN
11167 WRITE(LOUT,1001) NNA,NNB,PPN
11168 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11169 & 2I4,F6.0,') not found ')
11170 STOP
11171 ENDIF
11172
11173* no interpolation yet available
11174 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11175
11176 BSITE(1,1,NTARG,1) = ZERO
11177 DO 10 I=2,NSITEB
11178 XX = DBLE(I)
11179 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11180 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11181 & GLAFIT(5,IDXGLA)*XX**4
11182 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11183 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11184 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11185 10 CONTINUE
11186
11187 RETURN
11188 END
11189
11190*$ CREATE DT_GLAUBE.FOR
11191*COPY DT_GLAUBE
11192*
11193*===glaube=============================================================*
11194*
11195 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11196
11197************************************************************************
11198* Calculation of configuartion of interacting nucleons for one event. *
11199* NB / NB mass numbers of proj./target nuclei (input) *
11200* B impact parameter (output) *
11201* INTT total number of wounded nucleons " *
11202* INTA / INTB number of wounded nucleons in proj. / target " *
11203* JS / JT(i) number of collisions proj. / target nucleon i is *
11204* involved (output) *
11205* NIDX index of projectile/target material (input) *
11206* = -2 call within FLUKA transport calculation *
11207* This is an update of the original routine SHMAKO by J.Ranft/HJM *
11208* This version dated 22.03.96 is revised by S. Roesler *
11209* *
11210* Last change 27.12.2006 by S. Roesler. *
11211************************************************************************
11212
11213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11214 SAVE
11215
11216 PARAMETER ( LINP = 10 ,
11217 & LOUT = 6 ,
11218 & LDAT = 9 )
11219
11220 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11221 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11222
11223 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11224
11225 PARAMETER ( MAXNCL = 260,
11226
11227 & MAXVQU = MAXNCL,
11228 & MAXSQU = 20*MAXVQU,
11229 & MAXINT = MAXVQU+MAXSQU)
11230
11231* Glauber formalism: parameters
11232 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11233 & BMAX(NCOMPX),BSTEP(NCOMPX),
11234 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11235 & NSITEB,NSTATB
11236
11237* Glauber formalism: cross sections
11238 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11239 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11240 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11241 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11242 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11243 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11244 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11245 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11246 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11247 & BSLOPE,NEBINI,NQBINI
11248
11249* Lorentz-parameters of the current interaction
11250 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11251 & UMO,PPCM,EPROJ,PPROJ
11252
11253* properties of photon/lepton projectiles
11254 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11255
11256* Glauber formalism: collision properties
11257 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11258 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11259
11260* Glauber formalism: flags and parameters for statistics
11261 LOGICAL LPROD
11262 CHARACTER*8 CGLB
11263 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11264
11265 DIMENSION JS(MAXNCL),JT(MAXNCL)
11266
11267 NTARG = ABS(NIDX)
11268
11269* get actual energy from /DTLTRA/
11270 ECMNOW = UMO
11271 Q2 = VIRT
11272*
11273* new patch for pre-initialized variable projectile/target/energy runs,
11274* bypassed for use within FLUKA (Nidx=-2)
11275 IF (IOGLB.EQ.100) THEN
11276 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11277*
11278* variable energy run, interpolate profile function
11279 ELSE
11280 I1 = 1
11281 I2 = 1
11282 RATE = ONE
11283 IF (NEBINI.GT.1) THEN
11284 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11285 I1 = NEBINI
11286 I2 = NEBINI
11287 RATE = ONE
11288 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11289 DO 1 I=2,NEBINI
11290 IF (ECMNOW.LT.ECMNN(I)) THEN
11291 I1 = I-1
11292 I2 = I
11293 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11294 GOTO 2
11295 ENDIF
11296 1 CONTINUE
11297 2 CONTINUE
11298 ENDIF
11299 ENDIF
11300 J1 = 1
11301 J2 = 1
11302 RATQ = ONE
11303 IF (NQBINI.GT.1) THEN
11304 IF (Q2.GE.Q2G(NQBINI)) THEN
11305 J1 = NQBINI
11306 J2 = NQBINI
11307 RATQ = ONE
11308 ELSEIF (Q2.GT.Q2G(1)) THEN
11309 DO 3 I=2,NQBINI
11310 IF (Q2.LT.Q2G(I)) THEN
11311 J1 = I-1
11312 J2 = I
11313 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11314 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11315C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11316 GOTO 4
11317 ENDIF
11318 3 CONTINUE
11319 4 CONTINUE
11320 ENDIF
11321 ENDIF
11322
11323 DO 5 I=1,KSITEB
11324 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11325 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11326 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11327 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11328 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11329 5 CONTINUE
11330 ENDIF
11331
11332 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11333 IF (NIDX.LE.-1) THEN
11334 RPROJ = RASH(1)
11335 RTARG = RBSH(NTARG)
11336 ELSE
11337 RPROJ = RASH(NTARG)
11338 RTARG = RBSH(1)
11339 ENDIF
11340
11341 RETURN
11342 END
11343
11344*$ CREATE DT_DIAGR.FOR
11345*COPY DT_DIAGR
11346*
11347*===diagr==============================================================*
11348*
11349 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11350 & NIDX)
11351
11352************************************************************************
11353* Based on the original version by Shmakov et al. *
11354* This version dated 21.04.95 is revised by S. Roesler *
11355************************************************************************
11356
11357 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11358 SAVE
11359
11360 PARAMETER ( LINP = 10 ,
11361 & LOUT = 6 ,
11362 & LDAT = 9 )
11363
11364 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11365 PARAMETER (TWOPI = 6.283185307179586454D+00,
11366 & PI = TWOPI/TWO,
11367 & GEV2MB = 0.38938D0,
11368 & GEV2FM = 0.1972D0,
11369 & ALPHEM = ONE/137.0D0,
11370* proton mass
11371 & AMP = 0.938D0,
11372 & AMP2 = AMP**2,
11373* rho0 mass
11374 & AMRHO0 = 0.77D0)
11375
11376 COMPLEX*16 C,CA,CI
11377
11378 PARAMETER ( MAXNCL = 260,
11379
11380 & MAXVQU = MAXNCL,
11381 & MAXSQU = 20*MAXVQU,
11382 & MAXINT = MAXVQU+MAXSQU)
11383
11384* particle properties (BAMJET index convention)
11385 CHARACTER*8 ANAME
11386 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11387 & IICH(210),IIBAR(210),K1(210),K2(210)
11388
11389 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11390
11391* emulsion treatment
11392 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11393 & NCOMPO,IEMUL
11394
11395* Glauber formalism: parameters
11396 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11397 & BMAX(NCOMPX),BSTEP(NCOMPX),
11398 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11399 & NSITEB,NSTATB
11400
11401* Glauber formalism: cross sections
11402 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11403 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11404 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11405 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11406 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11407 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11408 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11409 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11410 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11411 & BSLOPE,NEBINI,NQBINI
11412
11413* VDM parameter for photon-nucleus interactions
11414 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11415
11416* nucleon-nucleon event-generator
11417 CHARACTER*8 CMODEL
11418 LOGICAL LPHOIN
11419 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11420**PHOJET105a
11421C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11422**PHOJET112
11423
11424C obsolete cut-off information
11425 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11426 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11427**
11428
11429* coordinates of nucleons
11430 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11431
11432* interface between Glauber formalism and DPM
11433 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11434 & INTER1(MAXINT),INTER2(MAXINT)
11435
11436* statistics: Glauber-formalism
11437 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11438
11439* n-n cross section fluctuations
11440 PARAMETER (NBINS = 1000)
11441 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11442
11443 DIMENSION JS(MAXNCL),JT(MAXNCL),
11444 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11445 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11446 DIMENSION NWA(0:210),NWB(0:210)
11447
11448 LOGICAL LFIRST
11449 DATA LFIRST /.TRUE./
11450
11451 DATA NTARGO,ICNT /0,0/
11452
11453 NTARG = ABS(NIDX)
11454
11455 IF (LFIRST) THEN
11456 LFIRST = .FALSE.
11457 IF (NCOMPO.EQ.0) THEN
11458 NCALL = 0
11459 NWAMAX = NA
11460 NWBMAX = NB
11461 DO 17 I=0,210
11462 NWA(I) = 0
11463 NWB(I) = 0
11464 17 CONTINUE
11465 ENDIF
11466 ENDIF
11467 IF (NTARG.EQ.-1) THEN
11468 IF (NCOMPO.EQ.0) THEN
11469 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11470 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11471 & NCALL,NWAMAX,NWBMAX
11472 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11473 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11474 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11475 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11476 18 CONTINUE
11477 ENDIF
11478 RETURN
11479 ENDIF
11480
11481 DCOH = 1.0D10
11482 IPNT = 0
11483
11484 SQ2 = Q2
11485 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11486 S = ECMNOW**2
11487 X = SQ2/(S+SQ2-AMP2)
11488 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11489* photon projectiles: recalculate photon-nucleon amplitude
11490 IF (IJPROJ.EQ.7) THEN
11491 15 CONTINUE
11492* VDM assumption: mass of V-meson
11493 AMV2 = DT_SAM2(SQ2,ECMNOW)
11494 AMV = SQRT(AMV2)
11495 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11496* check for pointlike interaction
11497 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11498**sr 27.10.
11499C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11500 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11501**
11502 ROSH = 0.1D0
11503 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11504 & +0.25D0*LOG(S/(AMV2+SQ2)))
11505* coherence length
11506 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11507 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11508 IF (MCGENE.EQ.2) THEN
11509 ZERO1 = ZERO
11510 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11511 & BSLOPE,0)
11512 ELSE
11513 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11514 ENDIF
11515 IF (ECMNOW.LE.3.0D0) THEN
11516 ROSH = -0.43D0
11517 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11518 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11519 ELSEIF (ECMNOW.GT.50.0D0) THEN
11520 ROSH = 0.1D0
11521 ENDIF
11522 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11523 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11524 IF (MCGENE.EQ.2) THEN
11525 ZERO1 = ZERO
11526 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11527 & BDUM,0)
11528 SIGSH = SIGSH/10.0D0
11529 ELSE
11530C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11531 DUMZER = ZERO
11532 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11533 SIGSH = SIGSH/10.0D0
11534 ENDIF
11535 ELSE
11536 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11537 ROSH = 0.01D0
11538 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11539 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11540C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11541 DUMZER = ZERO
11542 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11543 SIGSH = SIGSH/10.0D0
11544 ENDIF
11545 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11546 GAM = GSH
11547 RCA = GAM*SIGSH/TWOPI
11548 FCA = -ROSH*RCA
11549 CA = DCMPLX(RCA,FCA)
11550 CI = DCMPLX(ONE,ZERO)
11551
11552 16 CONTINUE
11553* impact parameter
11554 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11555
11556 NTRY = 0
11557 3 CONTINUE
11558 NTRY = NTRY+1
11559* initializations
11560 JNT = 0
11561 DO 1 I=1,NA
11562 JS(I) = 0
11563 1 CONTINUE
11564 DO 2 I=1,NB
11565 JT(I) = 0
11566 2 CONTINUE
11567 IF (IJPROJ.EQ.7) THEN
11568 DO 8 I=1,MAXNCL
11569 JS0(I) = 0
11570 JNT0(I)= 0
11571 DO 9 J=1,NB
11572 JT0(I,J) = 0
11573 9 CONTINUE
11574 8 CONTINUE
11575 ENDIF
11576
11577* nucleon configuration
11578C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11579 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11580C CALL DT_CONUCL(PKOO,NA,RASH,2)
11581C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11582 IF (NIDX.LE.-1) THEN
11583 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11584 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11585 ELSE
11586 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11587 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11588 ENDIF
11589 NTARGO = NTARG
11590 ENDIF
11591 ICNT = ICNT+1
11592
11593* LEPTO: pick out one struck nucleon
11594 IF (MCGENE.EQ.3) THEN
11595 JNT = 1
11596 JS(1) = 1
11597 IDX = INT(DT_RNDM(X)*NB)+1
11598 JT(IDX) = 1
11599 B = ZERO
11600 GOTO 19
11601 ENDIF
11602
11603 DO 4 INA=1,NA
11604* cross section fluctuations
11605 AFLUC = ONE
11606 IF (IFLUCT.EQ.1) THEN
11607 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11608 AFLUC = FLUIXX(IFLUK)
11609 ENDIF
11610 KK1 = 1
11611 KINT = 1
11612 DO 5 INB=1,NB
11613* photon-projectile: check for supression by coherence length
11614 IF (IJPROJ.EQ.7) THEN
11615 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11616 KK1 = INB
11617 KINT = KINT+1
11618 ENDIF
11619 ENDIF
11620 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11621 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11622 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11623 IF (XY.LE.15.0D0) THEN
11624 C = CI-CA*AFLUC*EXP(-XY)
11625 AR = DBLE(C)
11626 AI = DIMAG(C)
11627 P = AR*AR+AI*AI
11628 IF (DT_RNDM(XY).GE.P) THEN
11629 JNT = JNT+1
11630 IF (IJPROJ.EQ.7) THEN
11631 JNT0(KINT) = JNT0(KINT)+1
11632 IF (JNT0(KINT).GT.MAXNCL) THEN
11633 WRITE(LOUT,1001) MAXNCL
11634 1001 FORMAT(1X,
11635 & 'DIAGR: no. of requested interactions',
11636 & ' exceeds array dimensions ',I4)
11637 STOP
11638 ENDIF
11639 JS0(KINT) = JS0(KINT)+1
11640 JT0(KINT,INB) = JT0(KINT,INB)+1
11641 JI1(KINT,JNT0(KINT)) = INA
11642 JI2(KINT,JNT0(KINT)) = INB
11643 ELSE
11644 IF (JNT.GT.MAXINT) THEN
11645 WRITE(LOUT,1000) JNT, MAXINT
11646 1000 FORMAT(1X,
11647 & 'DIAGR: no. of requested interactions ('
11648 & ,I4,') exceeds array dimensions (',I4,')')
11649 STOP
11650 ENDIF
11651 JS(INA) = JS(INA)+1
11652 JT(INB) = JT(INB)+1
11653 INTER1(JNT) = INA
11654 INTER2(JNT) = INB
11655 ENDIF
11656 ENDIF
11657 ENDIF
11658 5 CONTINUE
11659 4 CONTINUE
11660
11661 IF (JNT.EQ.0) THEN
11662 IF (NTRY.LT.500) THEN
11663 GOTO 3
11664 ELSE
11665C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11666 GOTO 16
11667 ENDIF
11668 ENDIF
11669
11670 IDIREC = 0
11671 IF (IJPROJ.EQ.7) THEN
11672 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11673 10 CONTINUE
11674 IF (JNT0(K).EQ.0) THEN
11675 K = K+1
11676 IF (K.GT.KINT) K = 1
11677 GOTO 10
11678 ENDIF
11679* supress Glauber-cascade by direct photon processes
11680 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11681 IF (IPNT.GT.0) THEN
11682 JNT = 1
11683 JS(1) = 1
11684 DO 11 INB=1,NB
11685 JT(INB) = JT0(K,INB)
11686 IF (JT(INB).GT.0) GOTO 12
11687 11 CONTINUE
11688 12 CONTINUE
11689 INTER1(1) = 1
11690 INTER2(1) = INB
11691 IDIREC = IPNT
11692 ELSE
11693 JNT = JNT0(K)
11694 JS(1) = JS0(K)
11695 DO 13 INB=1,NB
11696 JT(INB) = JT0(K,INB)
11697 13 CONTINUE
11698 DO 14 I=1,JNT
11699 INTER1(I) = JI1(K,I)
11700 INTER2(I) = JI2(K,I)
11701 14 CONTINUE
11702 ENDIF
11703 ENDIF
11704
11705 19 CONTINUE
11706 INTA = 0
11707 INTB = 0
11708 DO 6 I=1,NA
11709 IF (JS(I).NE.0) INTA=INTA+1
11710 6 CONTINUE
11711 DO 7 I=1,NB
11712 IF (JT(I).NE.0) INTB=INTB+1
11713 7 CONTINUE
11714 ICWPG = INTA
11715 ICWTG = INTB
11716 ICIG = JNT
11717 IPGLB = IPGLB+INTA
11718 ITGLB = ITGLB+INTB
11719 NGLB = NGLB+1
11720
11721 IF (NCOMPO.EQ.0) THEN
11722 NCALL = NCALL+1
11723 NWA(INTA) = NWA(INTA)+1
11724 NWB(INTB) = NWB(INTB)+1
11725 ENDIF
11726
11727 RETURN
11728 END
11729
11730*$ CREATE DT_MODB.FOR
11731*COPY DT_MODB
11732*
11733*===modb===============================================================*
11734*
11735 SUBROUTINE DT_MODB(B,NIDX)
11736
11737************************************************************************
11738* Sampling of impact parameter of collision. *
11739* B impact parameter (output) *
11740* NIDX index of projectile/target material (input)*
11741* Based on the original version by Shmakov et al. *
11742* This version dated 21.04.95 is revised by S. Roesler *
11743* *
11744* Last change 27.12.2006 by S. Roesler. *
11745************************************************************************
11746
11747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11748 SAVE
11749
11750 PARAMETER ( LINP = 10 ,
11751 & LOUT = 6 ,
11752 & LDAT = 9 )
11753
11754 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11755
11756 LOGICAL LEFT,LFIRST
11757
11758* central particle production, impact parameter biasing
11759 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11760
11761 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11762
11763* Glauber formalism: parameters
11764 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11765 & BMAX(NCOMPX),BSTEP(NCOMPX),
11766 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11767 & NSITEB,NSTATB
11768
11769* Glauber formalism: cross sections
11770 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11771 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11772 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11773 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11774 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11775 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11776 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11777 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11778 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11779 & BSLOPE,NEBINI,NQBINI
11780
11781 DATA LFIRST /.TRUE./
11782
11783 NTARG = ABS(NIDX)
11784 IF (NIDX.LE.-1) THEN
11785 RA = RASH(1)
11786 RB = RBSH(NTARG)
11787 ELSE
11788 RA = RASH(NTARG)
11789 RB = RBSH(1)
11790 ENDIF
11791
11792 IF (ICENTR.EQ.2) THEN
11793 IF (RA.EQ.RB) THEN
11794 BB = DT_RNDM(B)*(0.3D0*RA)**2
11795 B = SQRT(BB)
11796 ELSEIF(RA.LT.RB)THEN
11797 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11798 B = SQRT(BB)
11799 ELSEIF(RA.GT.RB)THEN
11800 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11801 B = SQRT(BB)
11802 ENDIF
11803 ELSE
11804 9 CONTINUE
11805 Y = DT_RNDM(BB)
11806 I0 = 1
11807 I2 = NSITEB
11808 10 CONTINUE
11809 I1 = (I0+I2)/2
11810 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11811 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11812 IF (LEFT) GOTO 20
11813 I0 = I1
11814 GOTO 30
11815 20 CONTINUE
11816 I2 = I1
11817 30 CONTINUE
11818 IF (I2-I0-2) 40,50,60
11819 40 CONTINUE
11820 I1 = I2+1
11821 IF (I1.GT.NSITEB) I1 = I0-1
11822 GOTO 70
11823 50 CONTINUE
11824 I1 = I0+1
11825 GOTO 70
11826 60 CONTINUE
11827 GOTO 10
11828 70 CONTINUE
11829 X0 = DBLE(I0-1)*BSTEP(NTARG)
11830 X1 = DBLE(I1-1)*BSTEP(NTARG)
11831 X2 = DBLE(I2-1)*BSTEP(NTARG)
11832 Y0 = BSITE(0,1,NTARG,I0)
11833 Y1 = BSITE(0,1,NTARG,I1)
11834 Y2 = BSITE(0,1,NTARG,I2)
11835 80 CONTINUE
11836 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11837 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11838 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11839**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11840 B = B+0.5D0*BSTEP(NTARG)
11841 IF (B.LT.ZERO) B = X1
11842 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11843 IF (ICENTR.LT.0) THEN
11844 IF (LFIRST) THEN
11845 LFIRST = .FALSE.
11846 IF (ICENTR.LE.-100) THEN
11847 BIMIN = 0.0D0
11848 ELSE
11849 XSFRAC = 0.0D0
11850 ENDIF
11851 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11852 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11853 & BIMIN,BIMAX,XSFRAC*100.0D0,
11854 & XSFRAC*XSPRO(1,1,NTARG)
11855 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11856 & /,15X,'---------------------------'/,/,4X,
11857 & 'average radii of proj / targ :',F10.3,' fm /',
11858 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11859 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11860 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11861 & ' cross section :',F10.3,' %',/,5X,
11862 & 'corresponding cross section :',F10.3,' mb',/)
11863 ENDIF
11864 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11865 B = BIMIN
11866 ELSE
11867 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11868 ENDIF
11869 ENDIF
11870 ENDIF
11871
11872 RETURN
11873 END
11874
11875*$ CREATE DT_SHFAST.FOR
11876*COPY DT_SHFAST
11877*
11878*===shfast=============================================================*
11879*
11880 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11881
11882 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11883 SAVE
11884
11885 PARAMETER ( LINP = 10 ,
11886 & LOUT = 6 ,
11887 & LDAT = 9 )
11888
11889 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11890 & ONE=1.0D0,TWO=2.0D0)
11891
11892 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11893
11894* Glauber formalism: parameters
11895 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11896 & BMAX(NCOMPX),BSTEP(NCOMPX),
11897 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11898 & NSITEB,NSTATB
11899
11900* properties of interacting particles
11901 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11902
11903* Glauber formalism: cross sections
11904 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11905 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11906 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11907 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11908 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11909 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11910 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11911 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11912 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11913 & BSLOPE,NEBINI,NQBINI
11914
11915 IBACK = 0
11916
11917 IF (MODE.EQ.2) THEN
11918 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11919 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11920 1000 FORMAT(1X,8I5,E15.5)
11921 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11922 1001 FORMAT(1X,4E15.5)
11923 WRITE(47,1002) SIGSH,ROSH,GSH
11924 1002 FORMAT(1X,3E15.5)
11925 DO 10 I=1,100
11926 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11927 10 CONTINUE
11928 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11929 1003 FORMAT(1X,2I10,3E15.5)
11930 CLOSE(47)
11931 ELSE
11932 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11933 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11934 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11935 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11936 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11937 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11938 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11939 READ(47,1002) SIGSH,ROSH,GSH
11940 DO 11 I=1,100
11941 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11942 11 CONTINUE
11943 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11944 ELSE
11945 IBACK = 1
11946 ENDIF
11947 CLOSE(47)
11948 ENDIF
11949
11950 RETURN
11951 END
11952
11953*$ CREATE DT_POILIK.FOR
11954*COPY DT_POILIK
11955*
11956*===poilik=============================================================*
11957*
11958 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11959
11960 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11961 SAVE
11962
11963 PARAMETER ( LINP = 10 ,
11964 & LOUT = 6 ,
11965 & LDAT = 9 )
11966
11967 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11968 PARAMETER (NE = 8)
11969
11970**PHOJET105a
11971C CHARACTER*8 MDLNA
11972C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11973C PARAMETER (IEETAB=10)
11974C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11975**PHOJET110
11976
11977C model switches and parameters
11978 CHARACTER*8 MDLNA
11979 INTEGER ISWMDL,IPAMDL
11980 DOUBLE PRECISION PARMDL
11981 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11982
11983C energy-interpolation table
11984 INTEGER IEETA2
11985 PARAMETER ( IEETA2 = 20 )
11986 INTEGER ISIMAX
11987 DOUBLE PRECISION SIGTAB,SIGECM
11988 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11989**
11990
11991* VDM parameter for photon-nucleus interactions
11992 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11993**sr 22.7.97
11994
11995 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11996
11997* Glauber formalism: cross sections
11998 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11999 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12000 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12001 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12002 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12003 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12004 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12005 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12006 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12007 & BSLOPE,NEBINI,NQBINI
12008**
12009
12010 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12011
12012 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12013
12014* load cross sections from interpolation table
12015 IP = 1
12016 IF(ECM.LE.SIGECM(IP,1)) THEN
12017 I1 = 1
12018 I2 = 1
12019 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12020 DO 50 I=2,ISIMAX
12021 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12022 50 CONTINUE
12023 200 CONTINUE
12024 I1 = I-1
12025 I2 = I
12026 ELSE
12027 WRITE(LOUT,'(/1X,A,2E12.3)')
12028 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12029 I1 = ISIMAX
12030 I2 = ISIMAX
12031 ENDIF
12032 FAC2 = ZERO
12033 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12034 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12035 FAC1 = ONE-FAC2
12036
12037 SIGANO = DT_SANO(ECM)
12038
12039* cross section dependence on photon virtuality
12040 FSUP1 = ZERO
12041 DO 150 I=1,3
12042 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12043 & /(ONE+VIRT/PARMDL(30+I))**2
12044 150 CONTINUE
12045 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12046 FAC1 = FAC1*FSUP1
12047 FAC2 = FAC2*FSUP1
12048 FSUP2 = ONE
12049
12050 ECMOLD = ECM
12051 Q2OLD = VIRT
12052
12053 3 CONTINUE
12054
12055C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12056 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12057 IF (ISHAD(1).EQ.1) THEN
12058 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12059 ELSE
12060 SIGDIR = ZERO
12061 ENDIF
12062 SIGANO = FSUP1*FSUP2*SIGANO
12063 SIGTOT = SIGTOT-SIGDIR-SIGANO
12064 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12065 SIGANO = SIGANO/(FSUP1*FSUP2)
12066 SIGTOT = SIGTOT+SIGDIR+SIGANO
12067
12068 RR = DT_RNDM(SIGTOT)
12069 IF (RR.LT.SIGDIR/SIGTOT) THEN
12070 IPNT = 1
12071 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12072 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12073 IPNT = 2
12074 ELSE
12075 IPNT = 0
12076 ENDIF
12077 RPNT = (SIGDIR+SIGANO)/SIGTOT
12078C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12079C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12080C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12081C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12082 IF (MODE.EQ.1) RETURN
12083
12084**sr 22.7.97
12085 K1 = 1
12086 K2 = 1
12087 RATE = ZERO
12088 IF (ECM.GE.ECMNN(NEBINI)) THEN
12089 K1 = NEBINI
12090 K2 = NEBINI
12091 RATE = ONE
12092 ELSEIF (ECM.GT.ECMNN(1)) THEN
12093 DO 10 I=2,NEBINI
12094 IF (ECM.LT.ECMNN(I)) THEN
12095 K1 = I-1
12096 K2 = I
12097 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12098 GOTO 11
12099 ENDIF
12100 10 CONTINUE
12101 11 CONTINUE
12102 ENDIF
12103 J1 = 1
12104 J2 = 1
12105 RATQ = ZERO
12106 IF (NQBINI.GT.1) THEN
12107 IF (VIRT.GE.Q2G(NQBINI)) THEN
12108 J1 = NQBINI
12109 J2 = NQBINI
12110 RATQ = ONE
12111 ELSEIF (VIRT.GT.Q2G(1)) THEN
12112 DO 12 I=2,NQBINI
12113 IF (VIRT.LT.Q2G(I)) THEN
12114 J1 = I-1
12115 J2 = I
12116 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12117 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12118 GOTO 13
12119 ENDIF
12120 12 CONTINUE
12121 13 CONTINUE
12122 ENDIF
12123 ENDIF
12124 SGA = XSPRO(K1,J1,NTARG)+
12125 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12126 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12127 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12128 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12129 SDI = DBLE(NB)*SIGDIR
12130 SAN = DBLE(NB)*SIGANO
12131 SPL = SDI+SAN
12132 RR = DT_RNDM(SPL)
12133 IF (RR.LT.SDI/SGA) THEN
12134 IPNT = 1
12135 ELSEIF ((RR.GE.SDI/SGA).AND.
12136 & (RR.LT.SPL/SGA)) THEN
12137 IPNT = 2
12138 ELSE
12139 IPNT = 0
12140 ENDIF
12141 RPNT = SPL/SGA
12142C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12143**
12144
12145 RETURN
12146 END
12147
12148*$ CREATE DT_GLBINI.FOR
12149*COPY DT_GLBINI
12150*
12151*===glbini=============================================================*
12152*
12153 SUBROUTINE DT_GLBINI(WHAT)
12154
12155************************************************************************
12156* Pre-initialization of profile function *
12157* This version dated 28.11.00 is written by S. Roesler. *
12158* *
12159* Last change 27.12.2006 by S. Roesler. *
12160************************************************************************
12161
12162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12163 SAVE
12164
12165 PARAMETER ( LINP = 10 ,
12166 & LOUT = 6 ,
12167 & LDAT = 9 )
12168
12169 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12170
12171 LOGICAL LCMS
12172
12173* particle properties (BAMJET index convention)
12174 CHARACTER*8 ANAME
12175 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12176 & IICH(210),IIBAR(210),K1(210),K2(210)
12177
12178* properties of interacting particles
12179 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12180
12181 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12182
12183* emulsion treatment
12184 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12185 & NCOMPO,IEMUL
12186
12187* Glauber formalism: flags and parameters for statistics
12188 LOGICAL LPROD
12189 CHARACTER*8 CGLB
12190 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12191
12192* number of data sets other than protons and nuclei
12193* at the moment = 2 (pions and kaons)
12194 PARAMETER (MAXOFF=2)
12195 DIMENSION IJPINI(5),IOFFST(25)
12196 DATA IJPINI / 13, 15, 0, 0, 0/
12197* Glauber data-set to be used for hadron projectiles
12198* (0=proton, 1=pion, 2=kaon)
12199 DATA (IOFFST(K),K=1,25) /
12200 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12201 & 0, 0, 1, 2, 2/
12202* Acceptance interval for target nucleus mass
12203 PARAMETER (KBACC = 6)
12204
12205* flags for input different options
12206 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12207 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12208 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12209
12210 PARAMETER (MAXMSS = 100)
12211 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12212 DIMENSION WHAT(6)
12213
12214 DATA JPEACH,JPSTEP / 18, 5 /
12215
12216* temporary patch until fix has been implemented in phojet:
12217* maximum energy for pion projectile
12218 DATA ECMXPI / 100000.0D0 /
12219*
12220*--------------------------------------------------------------------------
12221* general initializations
12222*
12223* steps in projectile mass number for initialization
12224 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12225 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12226*
12227* energy range and binning
12228 ELO = ABS(WHAT(1))
12229 EHI = ABS(WHAT(2))
12230 IF (ELO.GT.EHI) ELO = EHI
12231 NEBIN = MAX(INT(WHAT(3)),1)
12232 IF (ELO.EQ.EHI) NEBIN = 0
12233 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12234 IF (LCMS) THEN
12235 ECMINI = EHI
12236 ELSE
12237 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12238 & +2.0D0*AAM(IJTARG)*EHI)
12239 ENDIF
12240*
12241* default arguments for Glauber-routine
12242 XI = ZERO
12243 Q2I = ZERO
12244*
12245* initialize nuclear parameters, etc.
12246
12247* initialize evaporation if the code is not used as Fluka event generator
12248 IF (ITRSPT.NE.1) THEN
12249 CALL NCDTRD
12250 CALL INCINI
12251 ENDIF
12252
12253*
12254* open Glauber-data output file
12255 IDX = INDEX(CGLB,' ')
12256 K = 12
12257 IF (IDX.GT.1) K = IDX-1
12258 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12259*
12260*--------------------------------------------------------------------------
12261* Glauber-initialization for proton and nuclei projectiles
12262*
12263* initialize phojet for proton-proton interactions
12264 ELAB = ZERO
12265 PLAB = ZERO
12266 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12267 CALL DT_PHOINI
12268*
12269* record projectile masses
12270 NASAV = 0
12271 NPROJ = MIN(IP,JPEACH)
12272 DO 10 KPROJ=1,NPROJ
12273 NASAV = NASAV+1
12274 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12275 IASAV(NASAV) = KPROJ
12276 10 CONTINUE
12277 IF (IP.GT.JPEACH) THEN
12278 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12279 IF (NPROJ.EQ.0) THEN
12280 NASAV = NASAV+1
12281 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12282 IASAV(NASAV) = IP
12283 ELSE
12284 DO 11 IPROJ=1,NPROJ
12285 KPROJ = JPEACH+IPROJ*JPSTEP
12286 NASAV = NASAV+1
12287 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12288 IASAV(NASAV) = KPROJ
12289 11 CONTINUE
12290 IF (KPROJ.LT.IP) THEN
12291 NASAV = NASAV+1
12292 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12293 IASAV(NASAV) = IP
12294 ENDIF
12295 ENDIF
12296 ENDIF
12297*
12298* record target masses
12299 NBSAV = 0
12300 NTARG = 1
12301 IF (NCOMPO.GT.0) NTARG = NCOMPO
12302 DO 12 ITARG=1,NTARG
12303 NBSAV = NBSAV+1
12304 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12305 IF (NCOMPO.GT.0) THEN
12306 IBSAV(NBSAV) = IEMUMA(ITARG)
12307 ELSE
12308 IBSAV(NBSAV) = IT
12309 ENDIF
12310 12 CONTINUE
12311*
12312* print masses
12313 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12314 1000 FORMAT(I4,A,1P,2E13.5)
12315 NLINES = DBLE(NASAV)/18.0D0
12316 IF (NLINES.GT.0) THEN
12317 DO 13 I=1,NLINES
12318 IF (I.EQ.1) THEN
12319 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12320 ELSE
12321 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12322 ENDIF
12323 13 CONTINUE
12324 ENDIF
12325 I0 = 18*NLINES+1
12326 IF (I0.LE.NASAV) THEN
12327 IF (I0.EQ.1) THEN
12328 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12329 ELSE
12330 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12331 ENDIF
12332 ENDIF
12333 NLINES = DBLE(NBSAV)/18.0D0
12334 IF (NLINES.GT.0) THEN
12335 DO 14 I=1,NLINES
12336 IF (I.EQ.1) THEN
12337 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12338 ELSE
12339 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12340 ENDIF
12341 14 CONTINUE
12342 ENDIF
12343 I0 = 18*NLINES+1
12344 IF (I0.LE.NBSAV) THEN
12345 IF (I0.EQ.1) THEN
12346 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12347 ELSE
12348 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12349 ENDIF
12350 ENDIF
12351*
12352* calculate Glauber-data for each energy and mass combination
12353*
12354* loop over energy bins
12355 ELO = LOG10(ELO)
12356 EHI = LOG10(EHI)
12357 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12358 DO 1 IE=1,NEBIN+1
12359 E = ELO+DBLE(IE-1)*DEBIN
12360 E = 10**E
12361 IF (LCMS) THEN
12362 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12363 ECM = E
12364 ELSE
12365 PLAB = ZERO
12366 ECM = ZERO
12367 E = MAX(AAM(IJPROJ)+0.1D0,E)
12368 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12369 ENDIF
12370*
12371* loop over projectile and target masses
12372 DO 2 ITARG=1,NBSAV
12373 DO 3 IPROJ=1,NASAV
12374 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12375 & XI,Q2I,ECM,1,1,-1)
12376 3 CONTINUE
12377 2 CONTINUE
12378*
12379 1 CONTINUE
12380*
12381*--------------------------------------------------------------------------
12382* Glauber-initialization for pion, kaon, ... projectiles
12383*
12384 DO 6 IJ=1,MAXOFF
12385*
12386* initialize phojet for this interaction
12387 ELAB = ZERO
12388 PLAB = ZERO
12389 IJPROJ = IJPINI(IJ)
12390 IP = 1
12391 IPZ = 1
12392*
12393* temporary patch until fix has been implemented in phojet:
12394 IF (ECMINI.GT.ECMXPI) THEN
12395 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12396 ELSE
12397 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12398 ENDIF
12399 CALL DT_PHOINI
12400*
12401* calculate Glauber-data for each energy and mass combination
12402*
12403* loop over energy bins
12404 DO 4 IE=1,NEBIN+1
12405 E = ELO+DBLE(IE-1)*DEBIN
12406 E = 10**E
12407 IF (LCMS) THEN
12408 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12409 ECM = E
12410 ELSE
12411 PLAB = ZERO
12412 ECM = ZERO
12413 E = MAX(AAM(IJPROJ)+TINY14,E)
12414 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12415 ENDIF
12416*
12417* loop over projectile and target masses
12418 DO 5 ITARG=1,NBSAV
12419 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12420 5 CONTINUE
12421*
12422 4 CONTINUE
12423*
12424 6 CONTINUE
12425
12426*--------------------------------------------------------------------------
12427* close output unit(s), etc.
12428*
12429 CLOSE(LDAT)
12430
12431 RETURN
12432 END
12433
12434*$ CREATE DT_GLBSET.FOR
12435*COPY DT_GLBSET
12436*
12437*===glbset=============================================================*
12438*
12439 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12440************************************************************************
12441* Interpolation of pre-initialized profile functions *
12442* This version dated 28.11.00 is written by S. Roesler. *
12443************************************************************************
12444
12445 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12446 SAVE
12447
12448 PARAMETER ( LINP = 10 ,
12449 & LOUT = 6 ,
12450 & LDAT = 9 )
12451
12452 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12453
12454 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12455
12456* particle properties (BAMJET index convention)
12457 CHARACTER*8 ANAME
12458 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12459 & IICH(210),IIBAR(210),K1(210),K2(210)
12460
12461* Glauber formalism: flags and parameters for statistics
12462 LOGICAL LPROD
12463 CHARACTER*8 CGLB
12464 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12465
12466 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12467
12468* Glauber formalism: parameters
12469 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12470 & BMAX(NCOMPX),BSTEP(NCOMPX),
12471 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12472 & NSITEB,NSTATB
12473
12474* Glauber formalism: cross sections
12475 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12476 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12477 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12478 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12479 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12480 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12481 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12482 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12483 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12484 & BSLOPE,NEBINI,NQBINI
12485
12486* number of data sets other than protons and nuclei
12487* at the moment = 2 (pions and kaons)
12488 PARAMETER (MAXOFF=2)
12489 DIMENSION IJPINI(5),IOFFST(25)
12490 DATA IJPINI / 13, 15, 0, 0, 0/
12491* Glauber data-set to be used for hadron projectiles
12492* (0=proton, 1=pion, 2=kaon)
12493 DATA (IOFFST(K),K=1,25) /
12494 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12495 & 0, 0, 1, 2, 2/
12496* Acceptance interval for target nucleus mass
12497 PARAMETER (KBACC = 6)
12498
12499* emulsion treatment
12500 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12501 & NCOMPO,IEMUL
12502
12503 PARAMETER (MAXSET=5000,
12504 & MAXBIN=100)
12505 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12506 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12507 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12508 & IAIDX(10)
12509
12510 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12511*
12512* read data from file
12513*
12514 IF (MODE.EQ.0) THEN
12515
12516 IF (LREAD) RETURN
12517
12518 DO 1 I=1,MAXSET
12519 DO 2 J=1,6
12520 XSIG(I,J) = ZERO
12521 XERR(I,J) = ZERO
12522 2 CONTINUE
12523 DO 3 J=1,KSITEB
12524 BPROFL(I,J) = ZERO
12525 3 CONTINUE
12526 1 CONTINUE
12527 DO 4 I=1,MAXBIN
12528 IABIN(I) = 0
12529 IBBIN(I) = 0
12530 4 CONTINUE
12531 DO 5 I=1,KSITEB
12532 BPRO0(I) = ZERO
12533 BPRO1(I) = ZERO
12534 BPRO(I) = ZERO
12535 5 CONTINUE
12536
12537 IDX = INDEX(CGLB,' ')
12538 K = 12
12539 IF (IDX.GT.1) K = IDX-1
12540 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12541 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12542 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12543 & 'file ',A12,/)
12544*
12545* read binning information
12546 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12547* return lower energy threshold to Fluka-interface
12548 ELAB = ELO
12549 LCMS = ELO.LT.ZERO
12550 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12551 IF (LCMS) THEN
12552 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12553 ELSE
12554 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12555 ENDIF
12556 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12557 & 'No. of bins:',I5,/)
12558 ELO = LOG10(ABS(ELO))
12559 EHI = LOG10(ABS(EHI))
12560 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12561 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12562 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12563 IF (NABIN.LT.18) THEN
12564 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12565 ELSE
12566 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12567 ENDIF
12568 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12569 IF (NABIN.GT.18) THEN
12570 NLINES = DBLE(NABIN-18)/18.0D0
12571 IF (NLINES.GT.0) THEN
12572 DO 7 I=1,NLINES
12573 I0 = 18*(I+1)-17
12574 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12575 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12576 7 CONTINUE
12577 ENDIF
12578 I0 = 18*(NLINES+1)+1
12579 IF (I0.LE.NABIN) THEN
12580 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12581 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12582 ENDIF
12583 ENDIF
12584 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12585 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12586 IF (NBBIN.LT.18) THEN
12587 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12588 ELSE
12589 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12590 ENDIF
12591 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12592 IF (NBBIN.GT.18) THEN
12593 NLINES = DBLE(NBBIN-18)/18.0D0
12594 IF (NLINES.GT.0) THEN
12595 DO 8 I=1,NLINES
12596 I0 = 18*(I+1)-17
12597 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12598 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12599 8 CONTINUE
12600 ENDIF
12601 I0 = 18*(NLINES+1)+1
12602 IF (I0.LE.NBBIN) THEN
12603 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12604 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12605 ENDIF
12606 ENDIF
12607* number of data sets to follow in the Glauber data file
12608* this variable is used for checks of consistency of projectile
12609* and target mass configurations given in header of Glauber data
12610* file and the data-sets which follow in this file
12611 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12612*
12613* read profile function data
12614 NSET = 0
12615 NAIDX = 0
12616 IPOLD = 0
12617 10 CONTINUE
12618 NSET = NSET+1
12619 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12620 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12621 1002 FORMAT(5I10,E15.5)
12622 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12623 NAIDX = NAIDX+1
12624 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12625 IAIDX(NAIDX) = IP
12626 IPOLD = IP
12627 ENDIF
12628 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12629 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12630 NLINES = INT(DBLE(ISITEB)/7.0D0)
12631 IF (NLINES.GT.0) THEN
12632 DO 11 I=1,NLINES
12633 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12634 11 CONTINUE
12635 ENDIF
12636 I0 = 7*NLINES+1
12637 IF (I0.LE.ISITEB)
12638 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12639 GOTO 10
12640 100 CONTINUE
12641 NSET = NSET-1
12642 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12643 WRITE(LOUT,'(/,1X,A)')
12644 & ' projectiles other than protons and nuclei: (particle index)'
12645 IF (NAIDX.GT.0) THEN
12646 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12647 ELSE
12648 WRITE(LOUT,'(6X,A)') 'none'
12649 ENDIF
12650*
12651 CLOSE(LDAT)
12652 WRITE(LOUT,*)
12653 LREAD = .TRUE.
12654
12655 IF (NCOMPO.EQ.0) THEN
12656 DO 12 J=1,NBBIN
12657 NCOMPO = NCOMPO+1
12658 IEMUMA(NCOMPO) = IBBIN(J)
12659 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12660 EMUFRA(NCOMPO) = 1.0D0
12661 12 CONTINUE
12662 IEMUL = 1
12663 ENDIF
12664*
12665* calculate profile function for certain set of parameters
12666*
12667 ELSE
12668
12669c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12670*
12671* check for type of projectile and set index-offset to entry in
12672* Glauber data array correspondingly
12673 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12674 IF (IOFFST(IDPROJ).EQ.-1) THEN
12675 STOP ' GLBSET: no data for this projectile !'
12676 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12677 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12678 ELSE
12679 IDXOFF = 0
12680 ENDIF
12681*
12682* get energy bin and interpolation factor
12683 IF (LCMS) THEN
12684 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12685 ELSE
12686 E = ELAB
12687 ENDIF
12688 E = LOG10(E)
12689 IF (E.LT.ELO) THEN
12690 IF (LFRST1) THEN
12691 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12692 LFRST1 = .FALSE.
12693 ENDIF
12694 E = ELO
12695 ENDIF
12696 IF (E.GT.EHI) THEN
12697 IF (LFRST2) THEN
12698 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12699 LFRST2 = .FALSE.
12700 ENDIF
12701 E = EHI
12702 ENDIF
12703 IE0 = (E-ELO)/DEBIN+1
12704 IE1 = IE0+1
12705 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12706*
12707* get target nucleus index
12708 KB = 0
12709 NBACC = KBACC
12710 DO 20 I=1,NBBIN
12711 NBDIFF = ABS(NB-IBBIN(I))
12712 IF (NB.EQ.IBBIN(I)) THEN
12713 KB = I
12714 GOTO 21
12715 ELSEIF (NBDIFF.LE.NBACC) THEN
12716 KB = I
12717 NBACC = NBDIFF
12718 ENDIF
12719 20 CONTINUE
12720 IF (KB.NE.0) GOTO 21
12721 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12722 STOP
12723 21 CONTINUE
12724*
12725* get projectile nucleus bin and interpolation factor
12726 KA0 = 0
12727 KA1 = 0
12728 FACNA = 0
12729 IF (IDXOFF.GT.0) THEN
12730 KA0 = 1
12731 KA1 = 1
12732 KABIN = 1
12733 ELSE
12734 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12735 DO 22 I=1,NABIN
12736 IF (NA.EQ.IABIN(I)) THEN
12737 KA0 = I
12738 KA1 = I
12739 GOTO 23
12740 ELSEIF (NA.LT.IABIN(I)) THEN
12741 KA0 = I-1
12742 KA1 = I
12743 GOTO 23
12744 ENDIF
12745 22 CONTINUE
12746 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12747 STOP
12748 23 CONTINUE
12749 IF (KA0.NE.KA1)
12750 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12751 KABIN = NABIN
12752 ENDIF
12753*
12754* interpolate profile functions for interactions ka0-kb and ka1-kb
12755* for energy E separately
12756 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12757 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12758 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12759 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12760 DO 30 I=1,ISITEB
12761 BPRO0(I) = BPROFL(IDX0,I)
12762 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12763 BPRO1(I) = BPROFL(IDY0,I)
12764 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12765 30 CONTINUE
12766 RADB = DT_RNCLUS(NB)
12767 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12768 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12769*
12770* interpolate cross sections for energy E and projectile mass
12771 DO 31 I=1,6
12772 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12773 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12774 XS(I) = XS0+FACNA*(XS1-XS0)
12775 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12776 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12777 XE(I) = XE0+FACNA*(XE1-XE0)
12778 31 CONTINUE
12779*
12780* interpolate between ka0 and ka1
12781 RADA = DT_RNCLUS(NA)
12782 BMX = 2.0D0*(RADA+RADB)
12783 BSTP = BMX/DBLE(ISITEB-1)
12784 BPRO(1) = ZERO
12785 DO 32 I=1,ISITEB-1
12786 B = DBLE(I)*BSTP
12787*
12788* calculate values of profile functions at B
12789 IDX0 = B/BSTP0+1
12790 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12791 IDX1 = MIN(IDX0+1,ISITEB)
12792 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12793 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12794 IDX0 = B/BSTP1+1
12795 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12796 IDX1 = MIN(IDX0+1,ISITEB)
12797 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12798 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12799*
12800 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12801 32 CONTINUE
12802*
12803* fill common dtglam
12804 NSITEB = ISITEB
12805 RASH(1) = RADA
12806 RBSH(1) = RADB
12807 BMAX(1) = BMX
12808 BSTEP(1) = BSTP
12809 DO 33 I=1,KSITEB
12810 BSITE(0,1,1,I) = BPRO(I)
12811 33 CONTINUE
12812*
12813* fill common dtglxs
12814 XSTOT(1,1,1) = XS(1)
12815 XSELA(1,1,1) = XS(2)
12816 XSQEP(1,1,1) = XS(3)
12817 XSQET(1,1,1) = XS(4)
12818 XSQE2(1,1,1) = XS(5)
12819 XSPRO(1,1,1) = XS(6)
12820 XETOT(1,1,1) = XE(1)
12821 XEELA(1,1,1) = XE(2)
12822 XEQEP(1,1,1) = XE(3)
12823 XEQET(1,1,1) = XE(4)
12824 XEQE2(1,1,1) = XE(5)
12825 XEPRO(1,1,1) = XE(6)
12826
12827 ENDIF
12828
12829 RETURN
12830 END
12831*$ CREATE DT_XKSAMP.FOR
12832*COPY DT_XKSAMP
12833*
12834*===xksamp=============================================================*
12835*
12836 SUBROUTINE DT_XKSAMP(NN,ECM)
12837
12838************************************************************************
12839* Sampling of parton x-values and chain system for one interaction. *
12840* processed by S. Roesler, 9.8.95 *
12841************************************************************************
12842
12843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12844 SAVE
12845
12846 PARAMETER ( LINP = 10 ,
12847 & LOUT = 6 ,
12848 & LDAT = 9 )
12849
12850 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12851 SAVE
12852
12853 PARAMETER (
12854* lower cuts for (valence-sea/sea-valence) chain masses
12855* antiquark-quark (u/d-sea quark) (s-sea quark)
12856 & AMIU = 0.5D0, AMIS = 0.8D0,
12857* quark-diquark (u/d-sea quark) (s-sea quark)
12858 & AMAU = 2.6D0, AMAS = 2.6D0,
12859* maximum lower valence-x threshold
12860 & XVMAX = 0.98D0,
12861* fraction of sea-diquarks sampled out of sea-partons
12862**test
12863C & FRCDIQ = 0.9D0,
12864**
12865*
12866 & SQMA = 0.7D0,
12867*
12868* maximum number of trials to generate x's for the required number
12869* of sea quark pairs for a given hadron
12870 & NSEATY = 12
12871C & NSEATY = 3
12872 & )
12873
12874 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12875
12876 PARAMETER ( MAXNCL = 260,
12877
12878 & MAXVQU = MAXNCL,
12879 & MAXSQU = 20*MAXVQU,
12880 & MAXINT = MAXVQU+MAXSQU)
12881
12882* event history
12883
12884 PARAMETER (NMXHKK=200000)
12885
12886 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12887 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12888 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12889
12890* particle properties (BAMJET index convention)
12891 CHARACTER*8 ANAME
12892 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12893 & IICH(210),IIBAR(210),K1(210),K2(210)
12894
12895* interface between Glauber formalism and DPM
12896 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12897 & INTER1(MAXINT),INTER2(MAXINT)
12898
12899* properties of interacting particles
12900 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12901
12902* threshold values for x-sampling (DTUNUC 1.x)
12903 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12904 & SSMIMQ,VVMTHR
12905
12906* x-values of partons (DTUNUC 1.x)
12907 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12908 & XTVQ(MAXVQU),XTVD(MAXVQU),
12909 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12910 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12911
12912* flavors of partons (DTUNUC 1.x)
12913 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12914 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12915 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12916 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12917 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12918 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12919 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12920
12921* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12922 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12923 & IXPV,IXPS,IXTV,IXTS,
12924 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12925 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12926 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12927 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12928 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12929 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12930 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12931 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12932
12933* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12934 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12935 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12936
12937* auxiliary common for chain system storage (DTUNUC 1.x)
12938 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12939
12940* flags for input different options
12941 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12942 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12943 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12944
12945* various options for treatment of partons (DTUNUC 1.x)
12946* (chain recombination, Cronin,..)
12947 LOGICAL LCO2CR,LINTPT
12948 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12949 & LCO2CR,LINTPT
12950
12951 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12952 & INTLO(MAXINT)
12953
12954* (1) initializations
12955*-----------------------------------------------------------------------
12956
12957**test
12958 IF (ECM.LT.4.5D0) THEN
12959C FRCDIQ = 0.6D0
12960 FRCDIQ = 0.4D0
12961 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12962C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12963 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12964 ELSE
12965C FRCDIQ = 0.9D0
12966 FRCDIQ = 0.7D0
12967 ENDIF
12968**
12969 DO 30 I=1,MAXSQU
12970 ZUOSP(I) = .FALSE.
12971 ZUOST(I) = .FALSE.
12972 IF (I.LE.MAXVQU) THEN
12973 ZUOVP(I) = .FALSE.
12974 ZUOVT(I) = .FALSE.
12975 ENDIF
12976 30 CONTINUE
12977
12978* lower thresholds for x-selection
12979* sea-quarks (default: CSEA=0.2)
12980 IF (ECM.LT.10.0D0) THEN
12981**!!test
12982 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12983C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12984 NSEA = NSEATY
12985C XSTHR = ONE/ECM**2
12986 ELSE
12987**sr 30.3.98
12988C XSTHR = CSEA/ECM
12989 XSTHR = CSEA/ECM**2
12990C XSTHR = ONE/ECM**2
12991**
12992 IF ((IP.GE.150).AND.(IT.GE.150))
12993 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12994 NSEA = NSEATY
12995 ENDIF
12996* (default: SSMIMA=0.14) used for sea-diquarks (?)
12997 XSSTHR = SSMIMA/ECM
12998 BSQMA = SQMA/ECM
12999* valence-quarks (default: CVQ=1.0)
13000 XVTHR = CVQ/ECM
13001* valence-diquarks (default: CDQ=2.0)
13002 XDTHR = CDQ/ECM
13003
13004* maximum-x for sea-quarks
13005 XVCUT = XVTHR+XDTHR
13006 IF (XVCUT.GT.XVMAX) THEN
13007 XVCUT = XVMAX
13008 XVTHR = XVCUT/3.0D0
13009 XDTHR = XVCUT-XVTHR
13010 ENDIF
13011 XXSEAM = ONE-XVCUT
13012**sr 18.4. test: DPMJET
13013C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13014C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13015C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13016**
13017* maximum number of sea-pairs allowed kinematically
13018C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13019 RNSMAX = OHALF*XXSEAM/XSTHR
13020 IF (RNSMAX.GT.10000.0D0) THEN
13021 NSMAX = 10000
13022 ELSE
13023 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13024 ENDIF
13025* check kinematical limit for valence-x thresholds
13026* (should be obsolete now)
13027 IF (XVCUT.GT.XVMAX) THEN
13028 WRITE(LOUT,1000) XVCUT,ECM
13029 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13030 & ' thresholds not allowed (',2E9.3,')')
13031C XVTHR = XVMAX-XDTHR
13032C IF (XVTHR.LT.ZERO) STOP
13033 STOP
13034 ENDIF
13035
13036* set eta for valence-x sampling (BETREJ)
13037* (UNON per default, UNOM used for projectile mesons only)
13038 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13039 UNOPRV = UNOM
13040 ELSE
13041 UNOPRV = UNON
13042 ENDIF
13043
13044* (2) select parton x-values of interacting projectile nucleons
13045*-----------------------------------------------------------------------
13046
13047 IXPV = 0
13048 IXPS = 0
13049
13050 DO 100 IPP=1,IP
13051* get interacting projectile nucleon as sampled by Glauber
13052 IF (JSSH(IPP).NE.0) THEN
13053 IXSTMP = IXPS
13054 IXVTMP = IXPV
13055 99 CONTINUE
13056 IXPS = IXSTMP
13057 IXPV = IXVTMP
13058* JIPP is the actual number of sea-pairs sampled for this nucleon
13059 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13060 41 CONTINUE
13061 XXSEA = ZERO
13062 IF (JIPP.GT.0) THEN
13063 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13064*???
13065 IF (XSTHR.GE.XSMAX) THEN
13066 JIPP = JIPP-1
13067 GOTO 41
13068 ENDIF
13069
13070*>>>get x-values of sea-quark pairs
13071 NSCOUN = 0
13072 PLW = 0.5D0
13073 40 CONTINUE
13074* accumulator for sea x-values
13075 XXSEA = ZERO
13076 NSCOUN = NSCOUN+1
13077 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13078 IF (NSCOUN.GT.NSEA) THEN
13079* decrease the number of interactions after NSEA trials
13080 JIPP = JIPP-1
13081 NSCOUN = 0
13082 ENDIF
13083 DO 70 ISQ=1,JIPP
13084* sea-quarks
13085 IF (IPSQ(IXPS+1).LE.2) THEN
13086**sr 8.4.98 (1/sqrt(x))
13087C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13088C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13089 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13090**
13091 ELSE
13092 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13093 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13094 ELSE
13095**sr 8.4.98 (1/sqrt(x))
13096C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13097C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13098 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13099**
13100 ENDIF
13101 ENDIF
13102* sea-antiquarks
13103 IF (IPSAQ(IXPS+1).GE.-2) THEN
13104**sr 8.4.98 (1/sqrt(x))
13105C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13106C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13107 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13108**
13109 ELSE
13110 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13111 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13112 ELSE
13113**sr 8.4.98 (1/sqrt(x))
13114C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13115C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13116 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13117**
13118 ENDIF
13119 ENDIF
13120 XXSEA = XXSEA+XPSQI+XPSAQI
13121* check for maximum allowed sea x-value
13122 IF (XXSEA.GE.XXSEAM) THEN
13123 IXPS = IXPS-ISQ+1
13124 GOTO 40
13125 ENDIF
13126* accept this sea-quark pair
13127 IXPS = IXPS+1
13128 XPSQ(IXPS) = XPSQI
13129 XPSAQ(IXPS) = XPSAQI
13130 IFROSP(IXPS) = IPP
13131 ZUOSP(IXPS) = .TRUE.
13132 70 CONTINUE
13133 ENDIF
13134
13135*>>>get x-values of valence partons
13136* valence quark
13137 IF (XVTHR.GT.0.05D0) THEN
13138 XVHI = ONE-XXSEA-XDTHR
13139 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13140 ELSE
13141 90 CONTINUE
13142 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13143 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13144 & GOTO 90
13145 ENDIF
13146* valence diquark
13147 XPVDI = ONE-XPVQI-XXSEA
13148* reject according to x**1.5
13149 XDTMP = XPVDI**1.5D0
13150 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13151* accept these valence partons
13152 IXPV = IXPV+1
13153 XPVQ(IXPV) = XPVQI
13154 XPVD(IXPV) = XPVDI
13155 IFROVP(IXPV) = IPP
13156 ITOVP(IPP) = IXPV
13157 ZUOVP(IXPV) = .TRUE.
13158
13159 ENDIF
13160 100 CONTINUE
13161
13162* (3) select parton x-values of interacting target nucleons
13163*-----------------------------------------------------------------------
13164
13165 IXTV = 0
13166 IXTS = 0
13167
13168 DO 170 ITT=1,IT
13169* get interacting target nucleon as sampled by Glauber
13170 IF (JTSH(ITT).NE.0) THEN
13171 IXSTMP = IXTS
13172 IXVTMP = IXTV
13173 169 CONTINUE
13174 IXTS = IXSTMP
13175 IXTV = IXVTMP
13176* JITT is the actual number of sea-pairs sampled for this nucleon
13177 JITT = MIN(JTSH(ITT)-1,NSMAX)
13178 111 CONTINUE
13179 XXSEA = ZERO
13180 IF (JITT.GT.0) THEN
13181 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13182*???
13183 IF (XSTHR.GE.XSMAX) THEN
13184 JITT = JITT-1
13185 GOTO 111
13186 ENDIF
13187
13188*>>>get x-values of sea-quark pairs
13189 NSCOUN = 0
13190 PLW = 0.5D0
13191 110 CONTINUE
13192* accumulator for sea x-values
13193 XXSEA = ZERO
13194 NSCOUN = NSCOUN+1
13195 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13196 IF (NSCOUN.GT.NSEA)THEN
13197* decrease the number of interactions after NSEA trials
13198 JITT = JITT-1
13199 NSCOUN = 0
13200 ENDIF
13201 DO 140 ISQ=1,JITT
13202* sea-quarks
13203 IF (ITSQ(IXTS+1).LE.2) THEN
13204**sr 8.4.98 (1/sqrt(x))
13205C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13206C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13207 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13208**
13209 ELSE
13210 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13211 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13212 ELSE
13213**sr 8.4.98 (1/sqrt(x))
13214C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13215C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13216 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13217**
13218 ENDIF
13219 ENDIF
13220* sea-antiquarks
13221 IF (ITSAQ(IXTS+1).GE.-2) THEN
13222**sr 8.4.98 (1/sqrt(x))
13223C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13224C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13225 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13226**
13227 ELSE
13228 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13229 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13230 ELSE
13231**sr 8.4.98 (1/sqrt(x))
13232C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13233C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13234 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13235**
13236 ENDIF
13237 ENDIF
13238 XXSEA = XXSEA+XTSQI+XTSAQI
13239* check for maximum allowed sea x-value
13240 IF (XXSEA.GE.XXSEAM) THEN
13241 IXTS = IXTS-ISQ+1
13242 GOTO 110
13243 ENDIF
13244* accept this sea-quark pair
13245 IXTS = IXTS+1
13246 XTSQ(IXTS) = XTSQI
13247 XTSAQ(IXTS) = XTSAQI
13248 IFROST(IXTS) = ITT
13249 ZUOST(IXTS) = .TRUE.
13250 140 CONTINUE
13251 ENDIF
13252
13253*>>>get x-values of valence partons
13254* valence quark
13255 IF (XVTHR.GT.0.05D0) THEN
13256 XVHI = ONE-XXSEA-XDTHR
13257 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13258 ELSE
13259 160 CONTINUE
13260 XTVQI = DT_DBETAR(OHALF,UNON)
13261 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13262 & GOTO 160
13263 ENDIF
13264* valence diquark
13265 XTVDI = ONE-XTVQI-XXSEA
13266* reject according to x**1.5
13267 XDTMP = XTVDI**1.5D0
13268 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13269* accept these valence partons
13270 IXTV = IXTV+1
13271 XTVQ(IXTV) = XTVQI
13272 XTVD(IXTV) = XTVDI
13273 IFROVT(IXTV) = ITT
13274 ITOVT(ITT) = IXTV
13275 ZUOVT(IXTV) = .TRUE.
13276
13277 ENDIF
13278 170 CONTINUE
13279
13280* (4) get valence-valence chains
13281*-----------------------------------------------------------------------
13282
13283 NVV = 0
13284 DO 240 I=1,NN
13285 INTLO(I) = .TRUE.
13286 IPVAL = ITOVP(INTER1(I))
13287 ITVAL = ITOVT(INTER2(I))
13288 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13289 INTLO(I) = .FALSE.
13290 ZUOVP(IPVAL) = .FALSE.
13291 ZUOVT(ITVAL) = .FALSE.
13292 NVV = NVV+1
13293 ISKPCH(8,NVV) = 0
13294 INTVV1(NVV) = IPVAL
13295 INTVV2(NVV) = ITVAL
13296 ENDIF
13297 240 CONTINUE
13298
13299* (5) get sea-valence chains
13300*-----------------------------------------------------------------------
13301
13302 NSV = 0
13303 NDV = 0
13304 PLW = 0.5D0
13305 DO 270 I=1,NN
13306 IF (INTLO(I)) THEN
13307 IPVAL = ITOVP(INTER1(I))
13308 ITVAL = ITOVT(INTER2(I))
13309 DO 250 J=1,IXPS
13310 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13311 & ZUOVT(ITVAL)) THEN
13312 ZUOSP(J) = .FALSE.
13313 ZUOVT(ITVAL) = .FALSE.
13314 INTLO(I) = .FALSE.
13315 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13316* sample sea-diquark pair
13317 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13318 IF (IREJ1.EQ.0) GOTO 260
13319 ENDIF
13320 NSV = NSV+1
13321 ISKPCH(4,NSV) = 0
13322 INTSV1(NSV) = J
13323 INTSV2(NSV) = ITVAL
13324
13325*>>>correct chain kinematics according to minimum chain masses
13326* the actual chain masses
13327 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13328 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13329* get lower mass cuts
13330 IF (IPSQ(J).EQ.3) THEN
13331* q being s-quark
13332 AMCHK1 = AMAS
13333 AMCHK2 = AMIS
13334 ELSE
13335* q being u/d-quark
13336 AMCHK1 = AMAU
13337 AMCHK2 = AMIU
13338 ENDIF
13339* q-qq chain
13340* chain mass above minimum - resampling of sea-q x-value
13341 IF (AMSVQ1.GT.AMCHK1) THEN
13342 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13343**sr 8.4.98 (1/sqrt(x))
13344C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13345C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13346 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13347**
13348 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13349 XPSQ(J) = XPSQXX
13350* chain mass below minimum - reset sea-q x-value and correct
13351* diquark-x of the same nucleon
13352 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13353 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13354 DXPSQ = XPSQW-XPSQ(J)
13355 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13356 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13357 XPSQ(J) = XPSQW
13358 ENDIF
13359 ENDIF
13360* aq-q chain
13361* chain mass below minimum - reset sea-aq x-value and correct
13362* diquark-x of the same nucleon
13363 IF (AMSVQ2.LT.AMCHK2) THEN
13364 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13365 DXPSQ = XPSQW-XPSAQ(J)
13366 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13367 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13368 XPSAQ(J) = XPSQW
13369 ENDIF
13370 ENDIF
13371*>>>end of chain mass correction
13372
13373 GOTO 260
13374 ENDIF
13375 250 CONTINUE
13376 ENDIF
13377 260 CONTINUE
13378 270 CONTINUE
13379
13380* (6) get valence-sea chains
13381*-----------------------------------------------------------------------
13382
13383 NVS = 0
13384 NVD = 0
13385 DO 300 I=1,NN
13386 IF (INTLO(I)) THEN
13387 IPVAL = ITOVP(INTER1(I))
13388 ITVAL = ITOVT(INTER2(I))
13389 DO 280 J=1,IXTS
13390 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13391 & (IFROST(J).EQ.INTER2(I))) THEN
13392 ZUOST(J) = .FALSE.
13393 ZUOVP(IPVAL) = .FALSE.
13394 INTLO(I) = .FALSE.
13395 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13396* sample sea-diquark pair
13397 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13398 IF (IREJ1.EQ.0) GOTO 290
13399 ENDIF
13400 NVS = NVS + 1
13401 ISKPCH(6,NVS) = 0
13402 INTVS1(NVS) = IPVAL
13403 INTVS2(NVS) = J
13404
13405*>>>correct chain kinematics according to minimum chain masses
13406* the actual chain masses
13407 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13408 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13409* get lower mass cuts
13410 IF (ITSQ(J).EQ.3) THEN
13411* q being s-quark
13412 AMCHK1 = AMIS
13413 AMCHK2 = AMAS
13414 ELSE
13415* q being u/d-quark
13416 AMCHK1 = AMIU
13417 AMCHK2 = AMAU
13418 ENDIF
13419* q-aq chain
13420* chain mass below minimum - reset sea-aq x-value and correct
13421* diquark-x of the same nucleon
13422 IF (AMVSQ1.LT.AMCHK1) THEN
13423 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13424 DXTSQ = XTSQW-XTSAQ(J)
13425 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13426 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13427 XTSAQ(J) = XTSQW
13428 ENDIF
13429 ENDIF
13430* qq-q chain
13431* chain mass above minimum - resampling of sea-q x-value
13432 IF (AMVSQ2.GT.AMCHK2) THEN
13433 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13434**sr 8.4.98 (1/sqrt(x))
13435C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13436C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13437 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13438**
13439 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13440 XTSQ(J) = XTSQXX
13441* chain mass below minimum - reset sea-q x-value and correct
13442* diquark-x of the same nucleon
13443 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13444 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13445 DXTSQ = XTSQW-XTSQ(J)
13446 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13447 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13448 XTSQ(J) = XTSQW
13449 ENDIF
13450 ENDIF
13451*>>>end of chain mass correction
13452
13453 GOTO 290
13454 ENDIF
13455 280 CONTINUE
13456 ENDIF
13457 290 CONTINUE
13458 300 CONTINUE
13459
13460* (7) get sea-sea chains
13461*-----------------------------------------------------------------------
13462
13463 NSS = 0
13464 NDS = 0
13465 NSD = 0
13466 DO 420 I=1,NN
13467 IF (INTLO(I)) THEN
13468 IPVAL = ITOVP(INTER1(I))
13469 ITVAL = ITOVT(INTER2(I))
13470* loop over target partons not yet matched
13471 DO 400 J=1,IXTS
13472 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13473* loop over projectile partons not yet matched
13474 DO 390 JJ=1,IXPS
13475 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13476 ZUOSP(JJ) = .FALSE.
13477 ZUOST(J) = .FALSE.
13478 INTLO(I) = .FALSE.
13479 NSS = NSS+1
13480 ISKPCH(1,NSS) = 0
13481 INTSS1(NSS) = JJ
13482 INTSS2(NSS) = J
13483
13484*---->chain recombination option
13485 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13486 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13487 & THEN
13488* sea-sea chains may recombine with valence-valence chains
13489* only if they have the same projectile or target nucleon
13490 DO 4201 IVV=1,NVV
13491 IF (ISKPCH(8,IVV).NE.99) THEN
13492 IXVPR = INTVV1(IVV)
13493 IXVTA = INTVV2(IVV)
13494 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13495 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13496* recombination possible, drop old v-v and s-s chains
13497 ISKPCH(1,NSS) = 99
13498 ISKPCH(8,IVV) = 99
13499
13500* (a) assign new s-v chains
13501* ~~~~~~~~~~~~~~~~~~~~~~~~~
13502 IF (LSEADI.AND.
13503 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13504 & THEN
13505* sample sea-diquark pair
13506 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13507 & IREJ1)
13508 IF (IREJ1.EQ.0) GOTO 4202
13509 ENDIF
13510 NSV = NSV+1
13511 ISKPCH(4,NSV) = 0
13512 INTSV1(NSV) = JJ
13513 INTSV2(NSV) = IXVTA
13514*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13515* the actual chain masses
13516 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13517 & *ECM**2
13518 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13519 & *ECM**2
13520* get lower mass cuts
13521 IF (IPSQ(JJ).EQ.3) THEN
13522* q being s-quark
13523 AMCHK1 = AMAS
13524 AMCHK2 = AMIS
13525 ELSE
13526* q being u/d-quark
13527 AMCHK1 = AMAU
13528 AMCHK2 = AMIU
13529 ENDIF
13530* q-qq chain
13531* chain mass above minimum - resampling of sea-q x-value
13532 IF (AMSVQ1.GT.AMCHK1) THEN
13533 XPSQTH =
13534 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13535**sr 8.4.98 (1/sqrt(x))
13536 XPSQXX =
13537 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13538C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13539C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13540**
13541 XPVD(IPVAL) =
13542 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13543 XPSQ(JJ) = XPSQXX
13544* chain mass below minimum - reset sea-q x-value and correct
13545* diquark-x of the same nucleon
13546 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13547 XPSQW =
13548 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13549 DXPSQ = XPSQW-XPSQ(JJ)
13550 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13551 & THEN
13552 XPVD(IPVAL) =
13553 & XPVD(IPVAL)-DXPSQ
13554 XPSQ(JJ) = XPSQW
13555 ENDIF
13556 ENDIF
13557* aq-q chain
13558* chain mass below minimum - reset sea-aq x-value and correct
13559* diquark-x of the same nucleon
13560 IF (AMSVQ2.LT.AMCHK2) THEN
13561 XPSQW =
13562 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13563 DXPSQ = XPSQW-XPSAQ(JJ)
13564 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13565 & THEN
13566 XPVD(IPVAL) =
13567 & XPVD(IPVAL)-DXPSQ
13568 XPSAQ(JJ) = XPSQW
13569 ENDIF
13570 ENDIF
13571*>>>>>>>>>>>end of chain mass correction
13572 4202 CONTINUE
13573
13574* (b) assign new v-s chains
13575* ~~~~~~~~~~~~~~~~~~~~~~~~~
13576 IF (LSEADI.AND.(
13577 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13578 & THEN
13579* sample sea-diquark pair
13580 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13581 & IREJ1)
13582 IF (IREJ1.EQ.0) GOTO 4203
13583 ENDIF
13584 NVS = NVS+1
13585 ISKPCH(6,NVS) = 0
13586 INTVS1(NVS) = IXVPR
13587 INTVS2(NVS) = J
13588*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13589* the actual chain masses
13590 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13591 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13592* get lower mass cuts
13593 IF (ITSQ(J).EQ.3) THEN
13594* q being s-quark
13595 AMCHK1 = AMIS
13596 AMCHK2 = AMAS
13597 ELSE
13598* q being u/d-quark
13599 AMCHK1 = AMIU
13600 AMCHK2 = AMAU
13601 ENDIF
13602* q-aq chain
13603* chain mass below minimum - reset sea-aq x-value and correct
13604* diquark-x of the same nucleon
13605 IF (AMVSQ1.LT.AMCHK1) THEN
13606 XTSQW =
13607 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13608 DXTSQ = XTSQW-XTSAQ(J)
13609 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13610 & THEN
13611 XTVD(ITVAL) =
13612 & XTVD(ITVAL)-DXTSQ
13613 XTSAQ(J) = XTSQW
13614 ENDIF
13615 ENDIF
13616 IF (AMVSQ2.GT.AMCHK2) THEN
13617 XTSQTH =
13618 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13619**sr 8.4.98 (1/sqrt(x))
13620 XTSQXX =
13621 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13622C & DT_SAMSQX(XTSQTH,XTSQ(J))
13623C & DT_SAMPEX(XTSQTH,XTSQ(J))
13624**
13625 XTVD(ITVAL) =
13626 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13627 XTSQ(J) = XTSQXX
13628 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13629 XTSQW =
13630 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13631 DXTSQ = XTSQW-XTSQ(J)
13632 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13633 & THEN
13634 XTVD(ITVAL) =
13635 & XTVD(ITVAL)-DXTSQ
13636 XTSQ(J) = XTSQW
13637 ENDIF
13638 ENDIF
13639*>>>>>>>>>end of chain mass correction
13640 4203 CONTINUE
13641* jump out of s-s chain loop
13642 GOTO 420
13643 ENDIF
13644 ENDIF
13645 4201 CONTINUE
13646 ENDIF
13647*---->end of chain recombination option
13648
13649* sample sea-diquark pair (projectile)
13650 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13651 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13652 IF (IREJ1.EQ.0) THEN
13653 ISKPCH(1,NSS) = 99
13654 GOTO 410
13655 ENDIF
13656 ENDIF
13657* sample sea-diquark pair (target)
13658 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13659 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13660 IF (IREJ1.EQ.0) THEN
13661 ISKPCH(1,NSS) = 99
13662 GOTO 410
13663 ENDIF
13664 ENDIF
13665*>>>>>correct chain kinematics according to minimum chain masses
13666* the actual chain masses
13667 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13668 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13669* check for lower mass cuts
13670 IF ((SSMA1Q.LT.SSMIMQ).OR.
13671 & (SSMA2Q.LT.SSMIMQ)) THEN
13672 IPVAL = ITOVP(INTER1(I))
13673 ITVAL = ITOVT(INTER2(I))
13674 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13675 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13676* maximum allowed x values for sea quarks
13677 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13678 & 1.2D0*XSSTHR
13679 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13680 & 1.2D0*XSSTHR
13681* resampling of x values not possible - skip sea-sea chains
13682 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13683 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13684* resampling of x for projectile sea quark pair
13685 ICOUS = 0
13686 310 CONTINUE
13687 ICOUS = ICOUS+1
13688 IF (XSSTHR.GT.0.05D0) THEN
13689 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13690 & XSPMAX)
13691 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13692 & XSPMAX)
13693 ELSE
13694 320 CONTINUE
13695 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13696 IF ((XPSQI.LT.XSSTHR).OR.
13697 & (XPSQI.GT.XSPMAX)) GOTO 320
13698 330 CONTINUE
13699 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13700 IF ((XPSAQI.LT.XSSTHR).OR.
13701 & (XPSAQI.GT.XSPMAX)) GOTO 330
13702 ENDIF
13703* final test of remaining x for projectile diquark
13704 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13705 & +XPSQ(JJ)+XPSAQ(JJ)
13706 IF (XPVDCO.LE.XDTHR) THEN
13707*!!!
13708C IF (ICOUS.LT.5) GOTO 310
13709 IF (ICOUS.LT.0.5D0) GOTO 310
13710 GOTO 380
13711 ENDIF
13712* resampling of x for target sea quark pair
13713 ICOUS = 0
13714 350 CONTINUE
13715 ICOUS = ICOUS+1
13716 IF (XSSTHR.GT.0.05D0) THEN
13717 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13718 & XSTMAX)
13719 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13720 & XSTMAX)
13721 ELSE
13722 360 CONTINUE
13723 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13724 IF ((XTSQI.LT.XSSTHR).OR.
13725 & (XTSQI.GT.XSTMAX)) GOTO 360
13726 370 CONTINUE
13727 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13728 IF ((XTSAQI.LT.XSSTHR).OR.
13729 & (XTSAQI.GT.XSTMAX)) GOTO 370
13730 ENDIF
13731* final test of remaining x for target diquark
13732 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13733 & +XTSQ(J)+XTSAQ(J)
13734 IF (XTVDCO.LT.XDTHR) THEN
13735 IF (ICOUS.LT.5) GOTO 350
13736 GOTO 380
13737 ENDIF
13738 XPVD(IPVAL) = XPVDCO
13739 XTVD(ITVAL) = XTVDCO
13740 XPSQ(JJ) = XPSQI
13741 XPSAQ(JJ) = XPSAQI
13742 XTSQ(J) = XTSQI
13743 XTSAQ(J) = XTSAQI
13744*>>>>>end of chain mass correction
13745 GOTO 410
13746 ENDIF
13747* come here to discard s-s interaction
13748* resampling of x values not allowed or unsuccessful
13749 380 CONTINUE
13750 INTLO(I) = .FALSE.
13751 ZUOST(J) = .TRUE.
13752 ZUOSP(JJ) = .TRUE.
13753 NSS = NSS-1
13754 ENDIF
13755* consider next s-s interaction
13756 GOTO 410
13757 ENDIF
13758 390 CONTINUE
13759 ENDIF
13760 400 CONTINUE
13761 ENDIF
13762 410 CONTINUE
13763 420 CONTINUE
13764
13765* correct x-values of valence quarks for non-matching sea quarks
13766 DO 430 I=1,IXPS
13767 IF (ZUOSP(I)) THEN
13768 IPVAL = ITOVP(IFROSP(I))
13769 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13770 XPSQ(I) = ZERO
13771 XPSAQ(I) = ZERO
13772 ZUOSP(I) = .FALSE.
13773 ENDIF
13774 430 CONTINUE
13775 DO 440 I=1,IXTS
13776 IF (ZUOST(I)) THEN
13777 ITVAL = ITOVT(IFROST(I))
13778 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13779 XTSQ(I) = ZERO
13780 XTSAQ(I) = ZERO
13781 ZUOST(I) = .FALSE.
13782 ENDIF
13783 440 CONTINUE
13784 DO 450 I=1,IXPV
13785 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13786 450 CONTINUE
13787 DO 460 I=1,IXTV
13788 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13789 460 CONTINUE
13790
13791 RETURN
13792 END
13793
13794*$ CREATE DT_SAMSDQ.FOR
13795*COPY DT_SAMSDQ
13796*
13797*===samsdq=============================================================*
13798*
13799 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13800
13801************************************************************************
13802* SAMpling of Sea-DiQuarks *
13803* ECM cm-energy of the nucleon-nucleon system *
13804* IDX1,2 indices of x-values of the participating *
13805* partons (IDX2 is always the sea-q-pair to be *
13806* changed to sea-qq-pair) *
13807* MODE = 1 valence-q - sea-diq *
13808* = 2 sea-diq - valence-q *
13809* = 3 sea-q - sea-diq *
13810* = 4 sea-diq - sea-q *
13811* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13812* This version dated 17.10.95 is written by S. Roesler *
13813************************************************************************
13814
13815 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13816 SAVE
13817
13818 PARAMETER (ZERO=0.0D0)
13819
13820* threshold values for x-sampling (DTUNUC 1.x)
13821 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13822 & SSMIMQ,VVMTHR
13823
13824* various options for treatment of partons (DTUNUC 1.x)
13825* (chain recombination, Cronin,..)
13826 LOGICAL LCO2CR,LINTPT
13827 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13828 & LCO2CR,LINTPT
13829
13830 PARAMETER ( MAXNCL = 260,
13831
13832 & MAXVQU = MAXNCL,
13833 & MAXSQU = 20*MAXVQU,
13834 & MAXINT = MAXVQU+MAXSQU)
13835
13836* x-values of partons (DTUNUC 1.x)
13837 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13838 & XTVQ(MAXVQU),XTVD(MAXVQU),
13839 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13840 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13841
13842* flavors of partons (DTUNUC 1.x)
13843 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13844 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13845 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13846 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13847 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13848 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13849 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13850
13851* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13852 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13853 & IXPV,IXPS,IXTV,IXTS,
13854 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13855 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13856 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13857 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13858 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13859 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13860 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13861 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13862
13863* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13864 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13865 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13866
13867* auxiliary common for chain system storage (DTUNUC 1.x)
13868 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13869
13870 IREJ = 0
13871* threshold-x for valence diquarks
13872 XDTHR = CDQ/ECM
13873
13874 GOTO (1,2,3,4) MODE
13875
13876*---------------------------------------------------------------------
13877* proj. valence partons - targ. sea partons
13878* get x-values and flavors for target sea-diquark pair
13879
13880 1 CONTINUE
13881 IDXVP = IDX1
13882 IDXST = IDX2
13883
13884* index of corr. val-diquark-x in target nucleon
13885 IDXVT = ITOVT(IFROST(IDXST))
13886* available x above diquark thresholds for valence- and sea-diquarks
13887 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13888
13889 IF (XXD.GE.ZERO) THEN
13890* x-values for the three diquarks of the target nucleon
13891 RR1 = DT_RNDM(XXD)
13892 RR2 = DT_RNDM(RR1)
13893 RR3 = DT_RNDM(RR2)
13894 SR123 = RR1+RR2+RR3
13895 XXTV = XDTHR+RR1*XXD/SR123
13896 XXTSQ = XDTHR+RR2*XXD/SR123
13897 XXTSAQ = XDTHR+RR3*XXD/SR123
13898 ELSE
13899 XXTV = XTVD(IDXVT)
13900 XXTSQ = XTSQ(IDXST)
13901 XXTSAQ = XTSAQ(IDXST)
13902 ENDIF
13903* flavor of the second quarks in the sea-diquark pair
13904 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13905 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13906* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13907 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13908 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13909 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13910* ss-asas pair
13911 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13912 IREJ = 1
13913 RETURN
13914 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13915* at least one strange quark
13916 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13917 IREJ = 1
13918 RETURN
13919 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13920 IREJ = 1
13921 RETURN
13922 ENDIF
13923* accept the new sea-diquark
13924 XTVD(IDXVT) = XXTV
13925 XTSQ(IDXST) = XXTSQ
13926 XTSAQ(IDXST) = XXTSAQ
13927 NVD = NVD+1
13928 INTVD1(NVD) = IDXVP
13929 INTVD2(NVD) = IDXST
13930 ISKPCH(7,NVD) = 0
13931 RETURN
13932
13933*---------------------------------------------------------------------
13934* proj. sea partons - targ. valence partons
13935* get x-values and flavors for projectile sea-diquark pair
13936
13937 2 CONTINUE
13938 IDXSP = IDX2
13939 IDXVT = IDX1
13940
13941* index of corr. val-diquark-x in projectile nucleon
13942 IDXVP = ITOVP(IFROSP(IDXSP))
13943* available x above diquark thresholds for valence- and sea-diquarks
13944 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13945
13946 IF (XXD.GE.ZERO) THEN
13947* x-values for the three diquarks of the projectile nucleon
13948 RR1 = DT_RNDM(XXD)
13949 RR2 = DT_RNDM(RR1)
13950 RR3 = DT_RNDM(RR2)
13951 SR123 = RR1+RR2+RR3
13952 XXPV = XDTHR+RR1*XXD/SR123
13953 XXPSQ = XDTHR+RR2*XXD/SR123
13954 XXPSAQ = XDTHR+RR3*XXD/SR123
13955 ELSE
13956 XXPV = XPVD(IDXVP)
13957 XXPSQ = XPSQ(IDXSP)
13958 XXPSAQ = XPSAQ(IDXSP)
13959 ENDIF
13960* flavor of the second quarks in the sea-diquark pair
13961 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13962 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13963* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13964 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13965 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13966 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13967* ss-asas pair
13968 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13969 IREJ = 1
13970 RETURN
13971 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13972* at least one strange quark
13973 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13974 IREJ = 1
13975 RETURN
13976 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13977 IREJ = 1
13978 RETURN
13979 ENDIF
13980* accept the new sea-diquark
13981 XPVD(IDXVP) = XXPV
13982 XPSQ(IDXSP) = XXPSQ
13983 XPSAQ(IDXSP) = XXPSAQ
13984 NDV = NDV+1
13985 INTDV1(NDV) = IDXSP
13986 INTDV2(NDV) = IDXVT
13987 ISKPCH(5,NDV) = 0
13988 RETURN
13989
13990*---------------------------------------------------------------------
13991* proj. sea partons - targ. sea partons
13992* get x-values and flavors for target sea-diquark pair
13993
13994 3 CONTINUE
13995 IDXSP = IDX1
13996 IDXST = IDX2
13997
13998* index of corr. val-diquark-x in target nucleon
13999 IDXVT = ITOVT(IFROST(IDXST))
14000* available x above diquark thresholds for valence- and sea-diquarks
14001 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14002
14003 IF (XXD.GE.ZERO) THEN
14004* x-values for the three diquarks of the target nucleon
14005 RR1 = DT_RNDM(XXD)
14006 RR2 = DT_RNDM(RR1)
14007 RR3 = DT_RNDM(RR2)
14008 SR123 = RR1+RR2+RR3
14009 XXTV = XDTHR+RR1*XXD/SR123
14010 XXTSQ = XDTHR+RR2*XXD/SR123
14011 XXTSAQ = XDTHR+RR3*XXD/SR123
14012 ELSE
14013 XXTV = XTVD(IDXVT)
14014 XXTSQ = XTSQ(IDXST)
14015 XXTSAQ = XTSAQ(IDXST)
14016 ENDIF
14017* flavor of the second quarks in the sea-diquark pair
14018 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14019 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14020* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14021 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14022 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14023 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14024* ss-asas pair
14025 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14026 IREJ = 1
14027 RETURN
14028 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14029* at least one strange quark
14030 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14031 IREJ = 1
14032 RETURN
14033 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14034 IREJ = 1
14035 RETURN
14036 ENDIF
14037* accept the new sea-diquark
14038 XTVD(IDXVT) = XXTV
14039 XTSQ(IDXST) = XXTSQ
14040 XTSAQ(IDXST) = XXTSAQ
14041 NSD = NSD+1
14042 INTSD1(NSD) = IDXSP
14043 INTSD2(NSD) = IDXST
14044 ISKPCH(3,NSD) = 0
14045 RETURN
14046
14047*---------------------------------------------------------------------
14048* proj. sea partons - targ. sea partons
14049* get x-values and flavors for projectile sea-diquark pair
14050
14051 4 CONTINUE
14052 IDXSP = IDX2
14053 IDXST = IDX1
14054
14055* index of corr. val-diquark-x in projectile nucleon
14056 IDXVP = ITOVP(IFROSP(IDXSP))
14057* available x above diquark thresholds for valence- and sea-diquarks
14058 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14059
14060 IF (XXD.GE.ZERO) THEN
14061* x-values for the three diquarks of the projectile nucleon
14062 RR1 = DT_RNDM(XXD)
14063 RR2 = DT_RNDM(RR1)
14064 RR3 = DT_RNDM(RR2)
14065 SR123 = RR1+RR2+RR3
14066 XXPV = XDTHR+RR1*XXD/SR123
14067 XXPSQ = XDTHR+RR2*XXD/SR123
14068 XXPSAQ = XDTHR+RR3*XXD/SR123
14069 ELSE
14070 XXPV = XPVD(IDXVP)
14071 XXPSQ = XPSQ(IDXSP)
14072 XXPSAQ = XPSAQ(IDXSP)
14073 ENDIF
14074* flavor of the second quarks in the sea-diquark pair
14075 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14076 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14077* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14078 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14079 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14080 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14081* ss-asas pair
14082 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14083 IREJ = 1
14084 RETURN
14085 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14086* at least one strange quark
14087 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14088 IREJ = 1
14089 RETURN
14090 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14091 IREJ = 1
14092 RETURN
14093 ENDIF
14094* accept the new sea-diquark
14095 XPVD(IDXVP) = XXPV
14096 XPSQ(IDXSP) = XXPSQ
14097 XPSAQ(IDXSP) = XXPSAQ
14098 NDS = NDS+1
14099 INTDS1(NDS) = IDXSP
14100 INTDS2(NDS) = IDXST
14101 ISKPCH(2,NDS) = 0
14102 RETURN
14103 END
14104*$ CREATE DT_DIFEVT.FOR
14105*COPY DT_DIFEVT
14106*
14107*===difevt=============================================================*
14108*
14109 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14110 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14111
14112************************************************************************
14113* Interface to treatment of diffractive interactions. *
14114* (input) IFP1/2 PDG-indizes of projectile partons *
14115* (baryon: IFP2 - adiquark) *
14116* PP(4) projectile 4-momentum *
14117* IFT1/2 PDG-indizes of target partons *
14118* (baryon: IFT1 - adiquark) *
14119* PT(4) target 4-momentum *
14120* (output) JDIFF = 0 no diffraction *
14121* = 1/-1 LMSD/LMDD *
14122* = 2/-2 HMSD/HMDD *
14123* NCSY counter for two-chain systems *
14124* dumped to DTEVT1 *
14125* This version dated 14.02.95 is written by S. Roesler *
14126************************************************************************
14127
14128 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14129 SAVE
14130
14131 PARAMETER ( LINP = 10 ,
14132 & LOUT = 6 ,
14133 & LDAT = 9 )
14134
14135 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14136 & OHALF=0.5D0)
14137
14138* event history
14139
14140 PARAMETER (NMXHKK=200000)
14141
14142 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14143 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14144 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14145
14146* extended event history
14147 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14148 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14149 & IHIST(2,NMXHKK)
14150
14151* flags for diffractive interactions (DTUNUC 1.x)
14152 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14153
14154 DIMENSION PP(4),PT(4)
14155
14156 LOGICAL LFIRST
14157 DATA LFIRST /.TRUE./
14158
14159 IREJ = 0
14160 JDIFF = 0
14161 IFLAGD = JDIFF
14162
14163* cm. energy
14164 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14165 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14166* identities of projectile hadron / target nucleon
14167 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14168 KTARG = IDT_ICIHAD(IDHKK(MOT))
14169
14170* single diffractive xsections
14171 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14172* double diffractive xsections
14173**!! no double diff yet
14174C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14175 DDTOT = 0.0D0
14176 DDHM = 0.0D0
14177**!!
14178* total inelastic xsection
14179C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14180 DUMZER = ZERO
14181 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14182 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14183
14184* fraction of diffractive processes
14185 FRADIF = (SDTOT+DDTOT)/SIGIN
14186
14187 IF (LFIRST) THEN
14188 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14189 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14190 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14191 & F5.1,' mb',/)
14192 LFIRST = .FALSE.
14193 ENDIF
14194
14195 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14196 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14197* diffractive interaction requested by x-section or by user
14198 FRASD = SDTOT/(SDTOT+DDTOT)
14199 FRASDH = SDHM/SDTOT
14200**sr needs to be specified!!
14201C FRADDH = DDHM/DDTOT
14202 FRADDH = 1.0D0
14203**
14204 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14205* single diffraction
14206 KDIFF = 1
14207 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14208 KP = 2
14209 KT = 0
14210 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14211 & ISINGD.NE.3) THEN
14212 KP = 0
14213 KT = 2
14214 ENDIF
14215 ELSE
14216 KP = 1
14217 KT = 0
14218 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14219 & ISINGD.NE.3) THEN
14220 KP = 0
14221 KT = 1
14222 ENDIF
14223 ENDIF
14224 ELSE
14225* double diffraction
14226 KDIFF = -1
14227 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14228 KP = 2
14229 KT = 2
14230 ELSE
14231 KP = 1
14232 KT = 1
14233 ENDIF
14234 ENDIF
14235 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14236 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14237 IF (IREJ1.EQ.0) THEN
14238 IFLAGD = 2*KDIFF
14239 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14240 ELSE
14241 GOTO 9999
14242 ENDIF
14243 ENDIF
14244 JDIFF = IFLAGD
14245
14246 RETURN
14247
14248 9999 CONTINUE
14249 IREJ = 1
14250 RETURN
14251 END
14252
14253*$ CREATE DT_DIFFKI.FOR
14254*COPY DT_DIFFKI
14255*
14256*===difkin=============================================================*
14257*
14258 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14259 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14260
14261************************************************************************
14262* Kinematics of diffractive nucleon-nucleon interaction. *
14263* IFP1/2 PDG-indizes of projectile partons *
14264* (baryon: IFP2 - adiquark) *
14265* PP(4) projectile 4-momentum *
14266* IFT1/2 PDG-indizes of target partons *
14267* (baryon: IFT1 - adiquark) *
14268* PT(4) target 4-momentum *
14269* KP = 0 projectile quasi-elastically scattered *
14270* = 1 excited to low-mass diff. state *
14271* = 2 excited to high-mass diff. state *
14272* KT = 0 target quasi-elastically scattered *
14273* = 1 excited to low-mass diff. state *
14274* = 2 excited to high-mass diff. state *
14275* This version dated 12.02.95 is written by S. Roesler *
14276************************************************************************
14277
14278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14279 SAVE
14280
14281 PARAMETER ( LINP = 10 ,
14282 & LOUT = 6 ,
14283 & LDAT = 9 )
14284
14285 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14286
14287 LOGICAL LSTART
14288
14289* particle properties (BAMJET index convention)
14290 CHARACTER*8 ANAME
14291 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14292 & IICH(210),IIBAR(210),K1(210),K2(210)
14293
14294* flags for input different options
14295 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14296 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14297 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14298
14299* rejection counter
14300 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14301 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14302 & IREXCI(3),IRDIFF(2),IRINC
14303
14304* kinematics of diffractive interactions (DTUNUC 1.x)
14305 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14306 & PPF(4),PTF(4),
14307 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14308 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14309
14310 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14311 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14312
14313 DATA LSTART /.TRUE./
14314
14315 IF (LSTART) THEN
14316 WRITE(LOUT,2000)
14317 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14318 LSTART = .FALSE.
14319 ENDIF
14320
14321 IREJ = 0
14322
14323* initialize common /DTDIKI/
14324 CALL DT_DIFINI
14325* store momenta of initial incoming particles for emc-check
14326 IF (LEMCCK) THEN
14327 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14328 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14329 ENDIF
14330
14331* masses of initial particles
14332 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14333 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14334 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14335 XMP = SQRT(XMP2)
14336 XMT = SQRT(XMT2)
14337* check quark-input (used to adjust coherence cond. for M-selection)
14338 IBP = 0
14339 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14340 IBT = 0
14341 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14342
14343* parameter for Lorentz-transformation into nucleon-nucleon cms
14344 DO 3 K=1,4
14345 PITOT(K) = PP(K)+PT(K)
14346 3 CONTINUE
14347 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14348 IF (XMTOT2.LE.ZERO) THEN
14349 WRITE(LOUT,1000) XMTOT2
14350 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14351 & 'XMTOT2 = ',E12.3)
14352 GOTO 9999
14353 ENDIF
14354 XMTOT = SQRT(XMTOT2)
14355 DO 4 K=1,4
14356 BGTOT(K) = PITOT(K)/XMTOT
14357 4 CONTINUE
14358* transformation of nucleons into cms
14359 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14360 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14361 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14362 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14363* rotation angles
14364 COD = PP1(3)/PPTOT
14365C SID = SQRT((ONE-COD)*(ONE+COD))
14366 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14367 SID = PPT/PPTOT
14368 COF = ONE
14369 SIF = ZERO
14370 IF(PPTOT*SID.GT.TINY10) THEN
14371 COF = PP1(1)/(SID*PPTOT)
14372 SIF = PP1(2)/(SID*PPTOT)
14373 ANORF = SQRT(COF*COF+SIF*SIF)
14374 COF = COF/ANORF
14375 SIF = SIF/ANORF
14376 ENDIF
14377* check consistency
14378 DO 5 K=1,4
14379 DEV1(K) = ABS(PP1(K)+PT1(K))
14380 5 CONTINUE
14381 DEV1(4) = ABS(DEV1(4)-XMTOT)
14382 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14383 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14384 WRITE(LOUT,1001) DEV1
14385 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14386 & /,8X,4E12.3)
14387 GOTO 9999
14388 ENDIF
14389
14390* select x-fractions in high-mass diff. interactions
14391 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14392
14393* select diffractive masses
14394* - projectile
14395 IF (KP.EQ.1) THEN
14396 XMPF = DT_XMLMD(XMTOT)
14397 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14398 IF (IREJ1.GT.0) GOTO 9999
14399 ELSEIF (KP.EQ.2) THEN
14400 XMPF = DT_XMHMD(XMTOT,IBP,1)
14401 ELSE
14402 XMPF = XMP
14403 ENDIF
14404* - target
14405 IF (KT.EQ.1) THEN
14406 XMTF = DT_XMLMD(XMTOT)
14407 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14408 IF (IREJ1.GT.0) GOTO 9999
14409 ELSEIF (KT.EQ.2) THEN
14410 XMTF = DT_XMHMD(XMTOT,IBT,2)
14411 ELSE
14412 XMTF = XMT
14413 ENDIF
14414
14415* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14416 XMPF2 = XMPF**2
14417 XMTF2 = XMTF**2
14418 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14419 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14420
14421* select momentum transfer (all t-values used here are <0)
14422* minimum absolute value to produce diffractive masses
14423 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14424 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14425 IF (IREJ1.GT.0) GOTO 9999
14426
14427* longitudinal momentum of excited/elastically scattered projectile
14428 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14429* total transverse momentum due to t-selection
14430 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14431 IF (PPBLT2.LT.ZERO) THEN
14432 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14433 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14434 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14435 GOTO 9999
14436 ENDIF
14437 CALL DT_DSFECF(SINPHI,COSPHI)
14438 PPBLT = SQRT(PPBLT2)
14439 PPBLOB(1) = COSPHI*PPBLT
14440 PPBLOB(2) = SINPHI*PPBLT
14441
14442* rotate excited/elastically scattered projectile into n-n cms.
14443 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14444 & XX,YY,ZZ)
14445 PPBLOB(1) = XX
14446 PPBLOB(2) = YY
14447 PPBLOB(3) = ZZ
14448
14449* 4-momentum of excited/elastically scattered target and of exchanged
14450* Pomeron
14451 DO 6 K=1,4
14452 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14453 PPOM1(K) = PP1(K)-PPBLOB(K)
14454 6 CONTINUE
14455 PTBLOB(4) = XMTOT-PPBLOB(4)
14456
14457* Lorentz-transformation back into system of initial diff. collision
14458 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14459 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14460 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14461 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14462 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14463 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14464 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14465 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14466 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14467
14468* store 4-momentum of elastically scattered particle (in single diff.
14469* events)
14470 IF (KP.EQ.0) THEN
14471 DO 7 K=1,4
14472 PSC(K) = PPF(K)
14473 7 CONTINUE
14474 ELSEIF (KT.EQ.0) THEN
14475 DO 8 K=1,4
14476 PSC(K) = PTF(K)
14477 8 CONTINUE
14478 ENDIF
14479
14480* check consistency of kinematical treatment so far
14481 IF (LEMCCK) THEN
14482 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14483 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14484 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14485 IF (IREJ1.NE.0) GOTO 9999
14486 ENDIF
14487 DO 9 K=1,4
14488 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14489 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14490 9 CONTINUE
14491 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14492 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14493 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14494 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14495 WRITE(LOUT,1003) DEV1,DEV2
14496 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14497 & 2(/,8X,4E12.3))
14498 GOTO 9999
14499 ENDIF
14500
14501* kinematical treatment for low-mass diffraction
14502 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14503 IF (IREJ1.NE.0) GOTO 9999
14504
14505* dump diffractive chains into DTEVT1
14506 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14507 IF (IREJ1.NE.0) GOTO 9999
14508
14509 RETURN
14510
14511 9999 CONTINUE
14512 IRDIFF(1) = IRDIFF(1)+1
14513 IREJ = 1
14514 RETURN
14515 END
14516
14517*$ CREATE DT_XMHMD.FOR
14518*COPY DT_XMHMD
14519*
14520*===xmhmd==============================================================*
14521*
14522 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14523
14524************************************************************************
14525* Diffractive mass in high mass single/double diffractive events. *
14526* This version dated 11.02.95 is written by S. Roesler *
14527************************************************************************
14528
14529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14530 SAVE
14531
14532 PARAMETER ( LINP = 10 ,
14533 & LOUT = 6 ,
14534 & LDAT = 9 )
14535
14536 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14537
14538* kinematics of diffractive interactions (DTUNUC 1.x)
14539 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14540 & PPF(4),PTF(4),
14541 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14542 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14543
14544C DATA XCOLOW /0.05D0/
14545 DATA XCOLOW /0.15D0/
14546
14547 DT_XMHMD = ZERO
14548 XH = XPH(2)
14549 IF (MODE.EQ.2) XH = XTH(2)
14550
14551* minimum Pomeron-x for high-mass diffraction
14552* (adjusted to get a smooth transition between HM and LM component)
14553 R = DT_RNDM(XH)
14554 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14555 IF (ECM.LE.300.0D0) THEN
14556 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14557 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14558 ENDIF
14559* maximum Pomeron-x for high-mass diffraction
14560* (coherence condition, adjusted to fit to experimental data)
14561 IF (IB.NE.0) THEN
14562* baryon-diffraction
14563 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14564 ELSE
14565* meson-diffraction
14566 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14567 ENDIF
14568* check boundaries
14569 IF (XDIMIN.GE.XDIMAX) THEN
14570 XDIMIN = OHALF*XDIMAX
14571 ENDIF
14572
14573 KLOOP = 0
14574 1 CONTINUE
14575 KLOOP = KLOOP+1
14576 IF (KLOOP.GT.20) RETURN
14577* sample Pomeron-x from 1/x-distribution (critical Pomeron)
14578 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14579* corr. diffr. mass
14580 DT_XMHMD = ECM*SQRT(XDIFF)
14581 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14582
14583 RETURN
14584 END
14585
14586*$ CREATE DT_XMLMD.FOR
14587*COPY DT_XMLMD
14588*
14589*===xmlmd==============================================================*
14590*
14591 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14592
14593************************************************************************
14594* Diffractive mass in high mass single/double diffractive events. *
14595* This version dated 11.02.95 is written by S. Roesler *
14596************************************************************************
14597
14598 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14599 SAVE
14600
14601 PARAMETER ( LINP = 10 ,
14602 & LOUT = 6 ,
14603 & LDAT = 9 )
14604
14605* minimum Pomeron-x for low-mass diffraction
14606C AMO = 1.5D0
14607 AMO = 2.0D0
14608* maximum Pomeron-x for low-mass diffraction
14609* (adjusted to get a smooth transition between HM and LM component)
14610 R = DT_RNDM(AMO)
14611 SAM = 1.0D0
14612 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14613 R = DT_RNDM(AMO)*SAM
14614 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14615 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14616
14617* selection of diffractive mass
14618* (adjusted to get a smooth transition between HM and LM component)
14619 R = DT_RNDM(AMU)
14620 IF (ECM.LE.50.0D0) THEN
14621 DT_XMLMD = AMO*(AMU/AMO)**R
14622 ELSE
14623 A = 0.7D0
14624 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14625 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14626 ENDIF
14627
14628 RETURN
14629 END
14630
14631*$ CREATE DT_TDIFF.FOR
14632*COPY DT_TDIFF
14633*
14634*===tdiff==============================================================*
14635*
14636 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14637
14638************************************************************************
14639* t-selection for single/double diffractive interactions. *
14640* ECM cm. energy *
14641* TMIN minimum momentum transfer to produce diff. masses *
14642* XM1/XM2 diffractively produced masses *
14643* (for single diffraction XM2 is obsolete) *
14644* K1/K2= 0 not excited *
14645* = 1 low-mass excitation *
14646* = 2 high-mass excitation *
14647* This version dated 11.02.95 is written by S. Roesler *
14648************************************************************************
14649
14650 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14651 SAVE
14652
14653 PARAMETER ( LINP = 10 ,
14654 & LOUT = 6 ,
14655 & LDAT = 9 )
14656
14657 PARAMETER (ZERO=0.0D0)
14658
14659 PARAMETER ( BTP0 = 3.7D0,
14660 & ALPHAP = 0.24D0 )
14661
14662 IREJ = 0
14663 NCLOOP = 0
14664 DT_TDIFF = ZERO
14665
14666 IF (K1.GT.0) THEN
14667 XM1 = XM1I
14668 XM2 = XM2I
14669 ELSE
14670 XM1 = XM2I
14671 ENDIF
14672 XDI = (XM1/ECM)**2
14673 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14674* slope for single diffraction
14675 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14676 ELSE
14677* slope for double diffraction
14678 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14679 ENDIF
14680
14681 1 CONTINUE
14682 NCLOOP = NCLOOP+1
14683 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14684 Y = DT_RNDM(XDI)
14685 T = -LOG(1.0D0-Y)/SLOPE
14686 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14687 DT_TDIFF = -ABS(T)
14688
14689 RETURN
14690
14691 9999 CONTINUE
14692 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14693 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14694 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14695 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14696 IREJ = 1
14697 RETURN
14698 END
14699
14700*$ CREATE DT_XVALHM.FOR
14701*COPY DT_XVALHM
14702*
14703*===xvalhm=============================================================*
14704*
14705 SUBROUTINE DT_XVALHM(KP,KT)
14706
14707************************************************************************
14708* Sampling of parton x-values in high-mass diffractive interactions. *
14709* This version dated 12.02.95 is written by S. Roesler *
14710************************************************************************
14711
14712 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14713 SAVE
14714
14715 PARAMETER ( LINP = 10 ,
14716 & LOUT = 6 ,
14717 & LDAT = 9 )
14718
14719 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14720
14721* kinematics of diffractive interactions (DTUNUC 1.x)
14722 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14723 & PPF(4),PTF(4),
14724 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14725 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14726
14727* various options for treatment of partons (DTUNUC 1.x)
14728* (chain recombination, Cronin,..)
14729 LOGICAL LCO2CR,LINTPT
14730 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14731 & LCO2CR,LINTPT
14732
14733 DATA UNON,XVQTHR /2.0D0,0.8D0/
14734
14735 IF (KP.EQ.2) THEN
14736* x-fractions of projectile valence partons
14737 1 CONTINUE
14738 XPH(1) = DT_DBETAR(OHALF,UNON)
14739 IF (XPH(1).GE.XVQTHR) GOTO 1
14740 XPH(2) = ONE-XPH(1)
14741* x-fractions of Pomeron q-aq-pair
14742 XPOLO = TINY2
14743 XPOHI = ONE-TINY2
14744 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14745 XPPO(2) = ONE-XPPO(1)
14746* flavors of Pomeron q-aq-pair
14747 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14748 IFPPO(1) = IFLAV
14749 IFPPO(2) = -IFLAV
14750 IF (DT_RNDM(UNON).GT.OHALF) THEN
14751 IFPPO(1) = -IFLAV
14752 IFPPO(2) = IFLAV
14753 ENDIF
14754 ENDIF
14755
14756 IF (KT.EQ.2) THEN
14757* x-fractions of projectile target partons
14758 2 CONTINUE
14759 XTH(1) = DT_DBETAR(OHALF,UNON)
14760 IF (XTH(1).GE.XVQTHR) GOTO 2
14761 XTH(2) = ONE-XTH(1)
14762* x-fractions of Pomeron q-aq-pair
14763 XPOLO = TINY2
14764 XPOHI = ONE-TINY2
14765 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14766 XTPO(2) = ONE-XTPO(1)
14767* flavors of Pomeron q-aq-pair
14768 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14769 IFTPO(1) = IFLAV
14770 IFTPO(2) = -IFLAV
14771 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14772 IFTPO(1) = -IFLAV
14773 IFTPO(2) = IFLAV
14774 ENDIF
14775 ENDIF
14776
14777 RETURN
14778 END
14779
14780*$ CREATE DT_LM2RES.FOR
14781*COPY DT_LM2RES
14782*
14783*===lm2res=============================================================*
14784*
14785 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14786
14787************************************************************************
14788* Check low-mass diffractive excitation for resonance mass. *
14789* (input) IF1/2 PDG-indizes of valence partons *
14790* (in/out) XM diffractive mass requested/corrected *
14791* (output) IDR/IDXR id./BAMJET-index of resonance *
14792* This version dated 12.02.95 is written by S. Roesler *
14793************************************************************************
14794
14795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14796 SAVE
14797
14798 PARAMETER ( LINP = 10 ,
14799 & LOUT = 6 ,
14800 & LDAT = 9 )
14801
14802 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14803
14804* kinematics of diffractive interactions (DTUNUC 1.x)
14805 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14806 & PPF(4),PTF(4),
14807 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14808 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14809
14810 IREJ = 0
14811 IF1B = 0
14812 IF2B = 0
14813 XMI = XM
14814
14815* BAMJET indices of partons
14816 IF1A = IDT_IPDG2B(IF1,1,2)
14817 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14818 IF2A = IDT_IPDG2B(IF2,1,2)
14819 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14820
14821* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14822 IDCH = 2
14823 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14824
14825* check for resonance mass
14826 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14827 IF (IREJ1.NE.0) GOTO 9999
14828
14829 XM = XMN
14830 RETURN
14831
14832 9999 CONTINUE
14833 IREJ = 1
14834 RETURN
14835 END
14836
14837*$ CREATE DT_LMKINE.FOR
14838*COPY DT_LMKINE
14839*
14840*===lmkine=============================================================*
14841*
14842 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14843
14844************************************************************************
14845* Kinematical treatment of low-mass excitations. *
14846* This version dated 12.02.95 is written by S. Roesler *
14847************************************************************************
14848
14849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14850 SAVE
14851
14852 PARAMETER ( LINP = 10 ,
14853 & LOUT = 6 ,
14854 & LDAT = 9 )
14855
14856 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14857
14858* flags for input different options
14859 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14860 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14861 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14862
14863* kinematics of diffractive interactions (DTUNUC 1.x)
14864 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14865 & PPF(4),PTF(4),
14866 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14867 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14868
14869 DIMENSION P1(4),P2(4)
14870
14871 IREJ = 0
14872
14873 IF (KP.EQ.1) THEN
14874 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14875 POE = PPF(4)/PABS
14876 FAC1 = OHALF*(POE+ONE)
14877 FAC2 = -OHALF*(POE-ONE)
14878 DO 1 K=1,3
14879 PPLM1(K) = FAC1*PPF(K)
14880 PPLM2(K) = FAC2*PPF(K)
14881 1 CONTINUE
14882 PPLM1(4) = FAC1*PABS
14883 PPLM2(4) = -FAC2*PABS
14884 IF (IMSHL.EQ.1) THEN
14885
14886 XM1 = PYMASS(IFP1)
14887 XM2 = PYMASS(IFP2)
14888
14889 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14890 IF (IREJ1.NE.0) GOTO 9999
14891 DO 2 K=1,4
14892 PPLM1(K) = P1(K)
14893 PPLM2(K) = P2(K)
14894 2 CONTINUE
14895 ENDIF
14896 ENDIF
14897
14898 IF (KT.EQ.1) THEN
14899 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14900 POE = PTF(4)/PABS
14901 FAC1 = OHALF*(POE+ONE)
14902 FAC2 = -OHALF*(POE-ONE)
14903 DO 3 K=1,3
14904 PTLM2(K) = FAC1*PTF(K)
14905 PTLM1(K) = FAC2*PTF(K)
14906 3 CONTINUE
14907 PTLM2(4) = FAC1*PABS
14908 PTLM1(4) = -FAC2*PABS
14909 IF (IMSHL.EQ.1) THEN
14910
14911 XM1 = PYMASS(IFT1)
14912 XM2 = PYMASS(IFT2)
14913
14914 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14915 IF (IREJ1.NE.0) GOTO 9999
14916 DO 4 K=1,4
14917 PTLM1(K) = P1(K)
14918 PTLM2(K) = P2(K)
14919 4 CONTINUE
14920 ENDIF
14921 ENDIF
14922
14923 RETURN
14924
14925 9999 CONTINUE
14926 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14927 IREJ = 1
14928 RETURN
14929 END
14930
14931*$ CREATE DT_DIFINI.FOR
14932*COPY DT_DIFINI
14933*
14934*===difini=============================================================*
14935*
14936 SUBROUTINE DT_DIFINI
14937
14938************************************************************************
14939* Initialization of common /DTDIKI/ *
14940* This version dated 12.02.95 is written by S. Roesler *
14941************************************************************************
14942
14943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14944 SAVE
14945
14946 PARAMETER ( LINP = 10 ,
14947 & LOUT = 6 ,
14948 & LDAT = 9 )
14949
14950 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14951
14952* kinematics of diffractive interactions (DTUNUC 1.x)
14953 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14954 & PPF(4),PTF(4),
14955 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14956 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14957
14958 DO 1 K=1,4
14959 PPOM(K) = ZERO
14960 PSC(K) = ZERO
14961 PPF(K) = ZERO
14962 PTF(K) = ZERO
14963 PPLM1(K) = ZERO
14964 PPLM2(K) = ZERO
14965 PTLM1(K) = ZERO
14966 PTLM2(K) = ZERO
14967 1 CONTINUE
14968 DO 2 K=1,2
14969 XPH(K) = ZERO
14970 XPPO(K) = ZERO
14971 XTH(K) = ZERO
14972 XTPO(K) = ZERO
14973 IFPPO(K) = 0
14974 IFTPO(K) = 0
14975 2 CONTINUE
14976 IDPR = 0
14977 IDXPR = 0
14978 IDTR = 0
14979 IDXTR = 0
14980
14981 RETURN
14982 END
14983
14984*$ CREATE DT_DIFPUT.FOR
14985*COPY DT_DIFPUT
14986*
14987*===difput=============================================================*
14988*
14989 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14990 & IREJ)
14991
14992************************************************************************
14993* Dump diffractive chains into DTEVT1 *
14994* This version dated 12.02.95 is written by S. Roesler *
14995************************************************************************
14996
14997 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14998 SAVE
14999
15000 PARAMETER ( LINP = 10 ,
15001 & LOUT = 6 ,
15002 & LDAT = 9 )
15003
15004 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15005
15006 LOGICAL LCHK
15007
15008* kinematics of diffractive interactions (DTUNUC 1.x)
15009 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15010 & PPF(4),PTF(4),
15011 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15012 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15013
15014* event history
15015
15016 PARAMETER (NMXHKK=200000)
15017
15018 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15019 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15020 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15021
15022* extended event history
15023 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15024 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15025 & IHIST(2,NMXHKK)
15026
15027* rejection counter
15028 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15029 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15030 & IREXCI(3),IRDIFF(2),IRINC
15031
15032 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15033 & P1(4),P2(4),P3(4),P4(4)
15034
15035 IREJ = 0
15036
15037 IF (KP.EQ.1) THEN
15038 DO 1 K=1,4
15039 PCH(K) = PPLM1(K)+PPLM2(K)
15040 1 CONTINUE
15041 ID1 = IFP1
15042 ID2 = IFP2
15043 IF (DT_RNDM(PT).GT.OHALF) THEN
15044 ID1 = IFP2
15045 ID2 = IFP1
15046 ENDIF
15047 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15048 & PPLM1(4),0,0,0)
15049 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15050 & PPLM2(4),0,0,0)
15051 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15052 & IDPR,IDXPR,8)
15053 ELSEIF (KP.EQ.2) THEN
15054 DO 2 K=1,4
15055 PP1(K) = XPH(1)*PP(K)
15056 PP2(K) = XPH(2)*PP(K)
15057 PT1(K) = -XPPO(1)*PPOM(K)
15058 PT2(K) = -XPPO(2)*PPOM(K)
15059 2 CONTINUE
15060 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15061 XM1 = ZERO
15062 XM2 = ZERO
15063 IF (LCHK) THEN
15064 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15065 IF (IREJ1.NE.0) GOTO 9999
15066 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15067 IF (IREJ1.NE.0) GOTO 9999
15068 DO 3 K=1,4
15069 PP1(K) = P1(K)
15070 PT1(K) = P2(K)
15071 PP2(K) = P3(K)
15072 PT2(K) = P4(K)
15073 3 CONTINUE
15074 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15075 & 0,0,8)
15076 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15077 & PT1(4),0,0,8)
15078 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(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 ELSE
15083 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15084 IF (IREJ1.NE.0) GOTO 9999
15085 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15086 IF (IREJ1.NE.0) GOTO 9999
15087 DO 4 K=1,4
15088 PP1(K) = P1(K)
15089 PT2(K) = P2(K)
15090 PP2(K) = P3(K)
15091 PT1(K) = P4(K)
15092 4 CONTINUE
15093 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15094 & 0,0,8)
15095 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15096 & PT2(4),0,0,8)
15097 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15098 & 0,0,8)
15099 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15100 & PT1(4),0,0,8)
15101 ENDIF
15102 NCSY = NCSY+1
15103 ELSE
15104 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15105 & 0,0,0)
15106 ENDIF
15107
15108 IF (KT.EQ.1) THEN
15109 DO 5 K=1,4
15110 PCH(K) = PTLM1(K)+PTLM2(K)
15111 5 CONTINUE
15112 ID1 = IFT1
15113 ID2 = IFT2
15114 IF (DT_RNDM(PT).GT.OHALF) THEN
15115 ID1 = IFT2
15116 ID2 = IFT1
15117 ENDIF
15118 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15119 & PTLM1(4),0,0,0)
15120 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15121 & PTLM2(4),0,0,0)
15122 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15123 & IDTR,IDXTR,8)
15124 ELSEIF (KT.EQ.2) THEN
15125 DO 6 K=1,4
15126 PP1(K) = XTPO(1)*PPOM(K)
15127 PP2(K) = XTPO(2)*PPOM(K)
15128 PT1(K) = XTH(2)*PT(K)
15129 PT2(K) = XTH(1)*PT(K)
15130 6 CONTINUE
15131 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15132 XM1 = ZERO
15133 XM2 = ZERO
15134 IF (LCHK) THEN
15135 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15136 IF (IREJ1.NE.0) GOTO 9999
15137 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15138 IF (IREJ1.NE.0) GOTO 9999
15139 DO 7 K=1,4
15140 PP1(K) = P1(K)
15141 PT1(K) = P2(K)
15142 PP2(K) = P3(K)
15143 PT2(K) = P4(K)
15144 7 CONTINUE
15145 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15146 & PP1(4),0,0,8)
15147 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15148 & 0,0,8)
15149 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15150 & PP2(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 ELSE
15154 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15155 IF (IREJ1.NE.0) GOTO 9999
15156 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15157 IF (IREJ1.NE.0) GOTO 9999
15158 DO 8 K=1,4
15159 PP1(K) = P1(K)
15160 PT2(K) = P2(K)
15161 PP2(K) = P3(K)
15162 PT1(K) = P4(K)
15163 8 CONTINUE
15164 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15165 & PP1(4),0,0,8)
15166 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15167 & 0,0,8)
15168 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15169 & PP2(4),0,0,8)
15170 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15171 & 0,0,8)
15172 ENDIF
15173 NCSY = NCSY+1
15174 ELSE
15175 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15176 & 0,0,0)
15177 ENDIF
15178
15179 RETURN
15180
15181 9999 CONTINUE
15182 IRDIFF(2) = IRDIFF(2)+1
15183 IREJ = 1
15184 RETURN
15185 END
15186*$ CREATE DT_EVTFRG.FOR
15187*COPY DT_EVTFRG
15188*
15189*===evtfrg=============================================================*
15190*
15191 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15192
15193************************************************************************
15194* Hadronization of chains in DTEVT1. *
15195* *
15196* Input: *
15197* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15198* = 2 hadronization of DTUNUC-chains (id=88xxx) *
15199* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15200* hadronized with one PYEXEC call *
15201* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15202* with one PYEXEC call *
15203* Output: *
15204* NPYMEM number of entries in JETSET-common after hadronization *
15205* IREJ rejection flag *
15206* *
15207* This version dated 17.09.00 is written by S. Roesler *
15208************************************************************************
15209
15210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15211 SAVE
15212
15213 PARAMETER ( LINP = 10 ,
15214 & LOUT = 6 ,
15215 & LDAT = 9 )
15216
15217 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15218 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15219
15220 LOGICAL LACCEP
15221
15222 PARAMETER (MXJOIN=200)
15223
15224* event history
15225
15226 PARAMETER (NMXHKK=200000)
15227
15228 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15229 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15230 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15231
15232* extended event history
15233 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15234 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15235 & IHIST(2,NMXHKK)
15236
15237* flags for input different options
15238 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15239 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15240 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15241
15242* statistics
15243 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15244 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15245 & ICEVTG(8,0:30)
15246
15247* flags for diffractive interactions (DTUNUC 1.x)
15248 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15249
15250* nucleon-nucleon event-generator
15251 CHARACTER*8 CMODEL
15252 LOGICAL LPHOIN
15253 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15254* phojet
15255
15256C model switches and parameters
15257 CHARACTER*8 MDLNA
15258 INTEGER ISWMDL,IPAMDL
15259 DOUBLE PRECISION PARMDL
15260 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15261* jetset
15262
15263 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15264 PARAMETER (MAXLND=4000)
15265 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15266
15267 INTEGER PYK
15268
15269 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15270
15271 MODE = KMODE
15272 ISTSTG = 7
15273 IF (MODE.NE.1) ISTSTG = 8
15274 IREJ = 0
15275
15276 IP = 0
15277 ISH = 0
15278 INIEMC = 1
15279 NEND = NHKK
15280 NACCEP = 0
15281 IFRG = 0
15282 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15283 DO 10 I=NPOINT(3),NEND
15284* sr 14.02.00: seems to be not necessary anymore, commented
15285C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15286C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15287 LACCEP = .TRUE.
15288* pick up chains from dtevt1
15289 IDCHK = IDHKK(I)/10000
15290 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15291 IF (IDCHK.EQ.7) THEN
15292 IPJE = IDHKK(I)-IDCHK*10000
15293 IF (IPJE.NE.IFRG) THEN
15294 IFRG = IPJE
15295 IF (IFRG.GT.NFRG) GOTO 16
15296 ENDIF
15297 ELSE
15298 IPJE = 1
15299 IFRG = IFRG+1
15300 IF (IFRG.GT.NFRG) THEN
15301 NFRG = -1
15302 GOTO 16
15303 ENDIF
15304 ENDIF
15305* statistics counter
15306c IF (IDCH(I).LE.8)
15307c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15308c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15309* special treatment for small chains already corrected to hadrons
15310 IF (IDRES(I).NE.0) THEN
15311 IF (IDRES(I).EQ.11) THEN
15312 ID = IDXRES(I)
15313 ELSE
15314 ID = IDT_IPDGHA(IDXRES(I))
15315 ENDIF
15316 IF (LEMCCK) THEN
15317 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15318 & PHKK(4,I),INIEMC,IDUM,IDUM)
15319 INIEMC = 2
15320 ENDIF
15321 IP = IP+1
15322 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15323 P(IP,1) = PHKK(1,I)
15324 P(IP,2) = PHKK(2,I)
15325 P(IP,3) = PHKK(3,I)
15326 P(IP,4) = PHKK(4,I)
15327 P(IP,5) = PHKK(5,I)
15328 K(IP,1) = 1
15329 K(IP,2) = ID
15330 K(IP,3) = 0
15331 K(IP,4) = 0
15332 K(IP,5) = 0
15333 IHIST(2,I) = 10000*IPJE+IP
15334 IF (IHIST(1,I).LE.-100) THEN
15335 ISH = ISH+1
15336 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15337 ISJOIN(ISH) = I
15338 ENDIF
15339 N = IP
15340 IHISMO(IP) = I
15341 ELSE
15342 IJ = 0
15343 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15344 IF (LEMCCK) THEN
15345 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15346 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15347 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15348 INIEMC = 2
15349 ENDIF
15350 ID = IDHKK(KK)
15351 IF (ID.EQ.0) ID = 21
15352c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15353c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15354
15355c AMRQ = PYMASS(ID)
15356
15357c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15358c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15359c & (ABS(IDIFF).EQ.0)) THEN
15360cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15361c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15362c PHKK(4,KK) = PHKK(4,KK)+DELTA
15363c PTOT1 = PTOT-DELTA
15364c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15365c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15366c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15367c PHKK(5,KK) = AMRQ
15368c ENDIF
15369 IP = IP+1
15370 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15371 P(IP,1) = PHKK(1,KK)
15372 P(IP,2) = PHKK(2,KK)
15373 P(IP,3) = PHKK(3,KK)
15374 P(IP,4) = PHKK(4,KK)
15375 P(IP,5) = PHKK(5,KK)
15376 K(IP,1) = 1
15377 K(IP,2) = ID
15378 K(IP,3) = 0
15379 K(IP,4) = 0
15380 K(IP,5) = 0
15381 IHIST(2,KK) = 10000*IPJE+IP
15382 IF (IHIST(1,KK).LE.-100) THEN
15383 ISH = ISH+1
15384 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15385 ISJOIN(ISH) = KK
15386 ENDIF
15387 IJ = IJ+1
15388 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15389 IJOIN(IJ) = IP
15390 IHISMO(IP) = I
15391 11 CONTINUE
15392 N = IP
15393* join the two-parton system
15394
15395 CALL PYJOIN(IJ,IJOIN)
15396
15397 ENDIF
15398 IDHKK(I) = 99999
15399 ENDIF
15400 10 CONTINUE
15401 16 CONTINUE
15402 N = IP
15403
15404 IF (IP.GT.0) THEN
15405
15406* final state parton shower
15407 DO 136 NPJE=1,IPJE
15408 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15409 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15410 DO 130 K1=1,ISH
15411 IF (ISJOIN(K1).EQ.0) GOTO 130
15412 I = ISJOIN(K1)
15413 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15414 & GOTO 130
15415 IH1 = IHIST(2,I)/10000
15416 IF (IH1.NE.NPJE) GOTO 130
15417 IH1 = IHIST(2,I)-IH1*10000
15418 DO 135 K2=K1+1,ISH
15419 IF (ISJOIN(K2).EQ.0) GOTO 135
15420 II = ISJOIN(K2)
15421 IH2 = IHIST(2,II)/10000
15422 IF (IH2.NE.NPJE) GOTO 135
15423 IH2 = IHIST(2,II)-IH2*10000
15424 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15425 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15426 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15427
15428 RQLUN = MIN(PT1,PT2)
15429 CALL PYSHOW(IH1,IH2,RQLUN)
15430
15431 ISJOIN(K1) = 0
15432 ISJOIN(K2) = 0
15433 GOTO 130
15434 ENDIF
15435 135 CONTINUE
15436 130 CONTINUE
15437 ENDIF
15438 ENDIF
15439 136 CONTINUE
15440
15441 CALL DT_INITJS(MODE)
15442* hadronization
15443
15444 CALL PYEXEC
15445
15446 IF (MSTU(24).NE.0) THEN
15447 WRITE(LOUT,*) ' JETSET-reject at event',
15448 & NEVHKK,MSTU(24),KMODE
15449C CALL DT_EVTOUT(4)
15450
15451C CALL PYLIST(2)
15452
15453 GOTO 9999
15454 ENDIF
15455
15456* number of entries in LUJETS
15457
15458 NLINES = PYK(0,1)
15459
15460 NPYMEM = NLINES
15461
15462 DO 12 I=1,NLINES
15463 IFLG(I) = 0
15464 12 CONTINUE
15465
15466 DO 13 II=1,NLINES
15467
15468 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15469
15470* pick up mother resonance if possible and put it together with
15471* their decay-products into the common
15472 IDXMOR = K(II,3)
15473 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15474 KFMOR = K(IDXMOR,2)
15475 ISMOR = K(IDXMOR,1)
15476 ELSE
15477 KFMOR = 91
15478 ISMOR = 1
15479 ENDIF
15480 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15481 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15482 ID = K(IDXMOR,2)
15483 MO = IHISMO(PYK(IDXMOR,15))
15484 PX = PYP(IDXMOR,1)
15485 PY = PYP(IDXMOR,2)
15486 PZ = PYP(IDXMOR,3)
15487 PE = PYP(IDXMOR,4)
15488
15489 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15490 IFLG(IDXMOR) = 1
15491 MO = NHKK
15492 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15493 IF (PYK(JDAUG,7).EQ.1) THEN
15494 ID = PYK(JDAUG,8)
15495 PX = PYP(JDAUG,1)
15496 PY = PYP(JDAUG,2)
15497 PZ = PYP(JDAUG,3)
15498 PE = PYP(JDAUG,4)
15499
15500 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15501 IF (LEMCCK) THEN
15502 PX = -PYP(JDAUG,1)
15503 PY = -PYP(JDAUG,2)
15504 PZ = -PYP(JDAUG,3)
15505 PE = -PYP(JDAUG,4)
15506
15507 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15508 ENDIF
15509 IFLG(JDAUG) = 1
15510 ENDIF
15511 15 CONTINUE
15512 ELSE
15513* there was no mother resonance
15514 MO = IHISMO(PYK(II,15))
15515 ID = PYK(II,8)
15516 PX = PYP(II,1)
15517 PY = PYP(II,2)
15518 PZ = PYP(II,3)
15519 PE = PYP(II,4)
15520
15521 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15522 IF (LEMCCK) THEN
15523 PX = -PYP(II,1)
15524 PY = -PYP(II,2)
15525 PZ = -PYP(II,3)
15526 PE = -PYP(II,4)
15527
15528 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15529 ENDIF
15530 ENDIF
15531 ENDIF
15532 13 CONTINUE
15533 IF (LEMCCK) THEN
15534 CHKLEV = TINY1
15535 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15536C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15537 ENDIF
15538
15539* global energy-momentum & flavor conservation check
15540**sr 16.5. this check is skipped in case of phojet-treatment
15541 IF (MCGENE.EQ.1)
15542 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15543
15544* update statistics-counter for diffraction
15545c IF (IFLAGD.NE.0) THEN
15546c ICDIFF(1) = ICDIFF(1)+1
15547c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15548c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15549c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15550c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15551c ENDIF
15552
15553 ENDIF
15554
15555 RETURN
15556
15557 9999 CONTINUE
15558 IREJ = 1
15559 RETURN
15560 END
15561
15562*$ CREATE DT_DECAYS.FOR
15563*COPY DT_DECAYS
15564*
15565*===decay==============================================================*
15566*
15567 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15568
15569************************************************************************
15570* Resonance-decay. *
15571* This subroutine replaces DDECAY/DECHKK. *
15572* PIN(4) 4-momentum of resonance (input) *
15573* IDXIN BAMJET-index of resonance (input) *
15574* POUT(20,4) 4-momenta of decay-products (output) *
15575* IDXOUT(20) BAMJET-indices of decay-products (output) *
15576* NSEC number of secondaries (output) *
15577* Adopted from the original version DECHKK. *
15578* This version dated 09.01.95 is written by S. Roesler *
15579************************************************************************
15580
15581 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15582 SAVE
15583
15584 PARAMETER ( LINP = 10 ,
15585 & LOUT = 6 ,
15586 & LDAT = 9 )
15587
15588 PARAMETER (TINY17=1.0D-17)
15589
15590* HADRIN: decay channel information
15591 PARAMETER (IDMAX9=602)
15592 CHARACTER*8 ZKNAME
15593 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15594
15595* particle properties (BAMJET index convention)
15596 CHARACTER*8 ANAME
15597 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15598 & IICH(210),IIBAR(210),K1(210),K2(210)
15599
15600* flags for input different options
15601 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15602 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15603 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15604
15605 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15606 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15607 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15608
15609* ISTAB = 1 strong and weak decays
15610* = 2 strong decays only
15611* = 3 strong decays, weak decays for charmed particles and tau
15612* leptons only
15613 DATA ISTAB /2/
15614
15615 IREJ = 0
15616 NSEC = 0
15617* put initial resonance to stack
15618 NSTK = 1
15619 IDXSTK(NSTK) = IDXIN
15620 DO 5 I=1,4
15621 PI(NSTK,I) = PIN(I)
15622 5 CONTINUE
15623
15624* store initial configuration for energy-momentum cons. check
15625 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15626 & PI(NSTK,4),1,IDUM,IDUM)
15627
15628 100 CONTINUE
15629* get particle from stack
15630 IDXI = IDXSTK(NSTK)
15631* skip stable particles
15632 IF (ISTAB.EQ.1) THEN
15633 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15634 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15635 ELSEIF (ISTAB.EQ.2) THEN
15636 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15637 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15638 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15639 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15640 IF ( IDXI.EQ.109) GOTO 10
15641 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15642 ELSEIF (ISTAB.EQ.3) THEN
15643 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15644 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15645 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15646 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15647 ENDIF
15648
15649* calculate direction cosines and Lorentz-parameter of decaying part.
15650 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15651 PTOT = MAX(PTOT,TINY17)
15652 DO 1 I=1,3
15653 DCOS(I) = PI(NSTK,I)/PTOT
15654 1 CONTINUE
15655 GAM = PI(NSTK,4)/AAM(IDXI)
15656 BGAM = PTOT/AAM(IDXI)
15657
15658* get decay-channel
15659 KCHAN = K1(IDXI)-1
15660 2 CONTINUE
15661 KCHAN = KCHAN+1
15662 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15663
15664* identities of secondaries
15665 IDX(1) = NZK(KCHAN,1)
15666 IDX(2) = NZK(KCHAN,2)
15667 IF (IDX(2).LT.1) GOTO 9999
15668 IDX(3) = NZK(KCHAN,3)
15669
15670* handle decay in rest system of decaying particle
15671 IF (IDX(3).EQ.0) THEN
15672* two-particle decay
15673 NDEC = 2
15674 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15675 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15676 & AAM(IDX(1)),AAM(IDX(2)))
15677 ELSE
15678* three-particle decay
15679 NDEC = 3
15680 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15681 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15682 & CODF(3),COFF(3),SIFF(3),
15683 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15684 ENDIF
15685 NSTK = NSTK-1
15686
15687* transform decay products back
15688 DO 3 I=1,NDEC
15689 NSTK = NSTK+1
15690 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15691 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15692 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15693* add particle to stack
15694 IDXSTK(NSTK) = IDX(I)
15695 DO 4 J=1,3
15696 PI(NSTK,J) = DCOSF(J)*PFF(I)
15697 4 CONTINUE
15698 3 CONTINUE
15699 GOTO 100
15700
15701 10 CONTINUE
15702* stable particle, put to output-arrays
15703 NSEC = NSEC+1
15704 DO 6 I=1,4
15705 POUT(NSEC,I) = PI(NSTK,I)
15706 6 CONTINUE
15707 IDXOUT(NSEC) = IDXSTK(NSTK)
15708* store secondaries for energy-momentum conservation check
15709 IF (LEMCCK)
15710 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15711 & -POUT(NSEC,4),2,IDUM,IDUM)
15712 NSTK = NSTK-1
15713 IF (NSTK.GT.0) GOTO 100
15714
15715* check energy-momentum conservation
15716 IF (LEMCCK) THEN
15717 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15718 IF (IREJ1.NE.0) GOTO 9999
15719 ENDIF
15720
15721 RETURN
15722
15723 9999 CONTINUE
15724 IREJ = 1
15725 RETURN
15726 END
15727
15728*$ CREATE DT_DECAY1.FOR
15729*COPY DT_DECAY1
15730*
15731*===decay1=============================================================*
15732*
15733 SUBROUTINE DT_DECAY1
15734
15735************************************************************************
15736* Decay of resonances stored in DTEVT1. *
15737* This version dated 20.01.95 is written by S. Roesler *
15738************************************************************************
15739
15740 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15741 SAVE
15742
15743 PARAMETER ( LINP = 10 ,
15744 & LOUT = 6 ,
15745 & LDAT = 9 )
15746
15747* event history
15748
15749 PARAMETER (NMXHKK=200000)
15750
15751 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15752 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15753 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15754
15755* extended event history
15756 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15757 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15758 & IHIST(2,NMXHKK)
15759
15760 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15761
15762 NEND = NHKK
15763C DO 1 I=NPOINT(5),NEND
15764 DO 1 I=NPOINT(4),NEND
15765 IF (ABS(ISTHKK(I)).EQ.1) THEN
15766 DO 2 K=1,4
15767 PIN(K) = PHKK(K,I)
15768 2 CONTINUE
15769 IDXIN = IDBAM(I)
15770 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15771 IF (NSEC.GT.1) THEN
15772 DO 3 N=1,NSEC
15773 IDHAD = IDT_IPDGHA(IDXOUT(N))
15774 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15775 & POUT(N,3),POUT(N,4),0,0,0)
15776 3 CONTINUE
15777 ENDIF
15778 ENDIF
15779 1 CONTINUE
15780
15781 RETURN
15782 END
15783
15784*$ CREATE DT_DECPI0.FOR
15785*COPY DT_DECPI0
15786*
15787*===decpi0=============================================================*
15788*
15789 SUBROUTINE DT_DECPI0
15790
15791************************************************************************
15792* Decay of pi0 handled with JETSET. *
15793* This version dated 18.02.96 is written by S. Roesler *
15794************************************************************************
15795
15796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15797 SAVE
15798
15799 PARAMETER ( LINP = 10 ,
15800 & LOUT = 6 ,
15801 & LDAT = 9 )
15802
15803 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15804
15805* event history
15806
15807 PARAMETER (NMXHKK=200000)
15808
15809 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15810 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15811 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15812
15813* extended event history
15814 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15815 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15816 & IHIST(2,NMXHKK)
15817
004932dd 15818 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 15819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15820 PARAMETER (MAXLND=4000)
15821 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15822
15823* flags for input different options
15824 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15825 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15826 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15827
15828 INTEGER PYCOMP,PYK
15829
15830 DIMENSION IHISMO(NMXHKK),P1(4)
15831
15832 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15833
15834 CALL DT_INITJS(2)
15835* allow pi0 decay
15836
15837 KC = PYCOMP(111)
15838
15839 MDCY(KC,1) = 1
15840
15841 NN = 0
15842 INI = 0
15843 DO 1 I=1,NHKK
15844 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15845 IF (INI.EQ.0) THEN
15846 INI = 1
15847 ELSE
15848 INI = 2
15849 ENDIF
15850 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15851 & PHKK(4,I),INI,IDUM,IDUM)
15852 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15853 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15854 COSTH = PHKK(3,I)/(PTOT+TINY10)
15855 IF (COSTH.GT.ONE) THEN
15856 THETA = ZERO
15857 ELSEIF (COSTH.LT.-ONE) THEN
15858 THETA = TWOPI/2.0D0
15859 ELSE
15860 THETA = ACOS(COSTH)
15861 ENDIF
15862 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15863 IF (PHKK(1,I).LT.0.0D0)
15864
15865 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15866
15867 ENER = PHKK(4,I)
15868 NN = NN+1
15869 KTEMP = MSTU(10)
15870 MSTU(10)= 1
15871 P(NN,5) = PHKK(5,I)
15872
15873 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15874
15875 MSTU(10) = KTEMP
15876 IHISMO(NN)= I
15877 ENDIF
15878 1 CONTINUE
15879 IF (NN.GT.0) THEN
15880
15881 CALL PYEXEC
15882
15883 NLINES = PYK(0,1)
15884
15885 DO 2 II=1,NLINES
15886
15887 IF (PYK(II,7).EQ.1) THEN
15888
15889 DO 3 KK=1,4
15890
15891 P1(KK) = PYP(II,KK)
15892
15893 3 CONTINUE
15894
15895 ID = PYK(II,8)
15896 MO = IHISMO(PYK(II,15))
15897
15898 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15899 IF (LEMCCK)
15900 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15901 & IDUM,IDUM)
15902*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15903 ISTHKK(MO) = -2
15904 ENDIF
15905 2 CONTINUE
15906 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15907 ENDIF
15908 MDCY(KC,1) = 0
15909
15910 RETURN
15911 END
15912
15913*$ CREATE DT_DTWOPD.FOR
15914*COPY DT_DTWOPD
15915*
15916*===dtwopd=============================================================*
15917*
15918 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15919 & COF2,SIF2,AM1,AM2)
15920
15921************************************************************************
15922* Two-particle decay. *
15923* UMO cm-energy of the decaying system (input) *
15924* AM1/AM2 masses of the decay products (input) *
15925* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15926* COD,COF,SIF direction cosines of the decay prod. (output) *
15927* Revised by S. Roesler, 20.11.95 *
15928************************************************************************
15929
15930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15931 SAVE
15932
15933 PARAMETER ( LINP = 10 ,
15934 & LOUT = 6 ,
15935 & LDAT = 9 )
15936
15937 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15938
15939 IF (UMO.LT.(AM1+AM2)) THEN
15940 WRITE(LOUT,1000) UMO,AM1,AM2
15941 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15942 & 3E12.3)
15943 STOP
15944 ENDIF
15945
15946 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15947 ECM2 = UMO-ECM1
15948 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15949 PCM2 = PCM1
15950 CALL DT_DSFECF(SIF1,COF1)
15951 COD1 = TWO*DT_RNDM(PCM2)-ONE
15952 COD2 = -COD1
15953 COF2 = -COF1
15954 SIF2 = -SIF1
15955
15956 RETURN
15957 END
15958
15959*$ CREATE DT_DTHREP.FOR
15960*COPY DT_DTHREP
15961*
15962*===dthrep=============================================================*
15963*
15964 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15965 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15966
15967************************************************************************
15968* Three-particle decay. *
15969* UMO cm-energy of the decaying system (input) *
15970* AM1/2/3 masses of the decay products (input) *
15971* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15972* COD,COF,SIF direction cosines of the decay prod. (output) *
15973* *
15974* Threpd89: slight revision by A. Ferrari *
15975* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15976* Revised by S. Roesler, 20.11.95 *
15977************************************************************************
15978
15979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15980 SAVE
15981
15982 PARAMETER ( LINP = 10 ,
15983 & LOUT = 6 ,
15984 & LDAT = 9 )
15985
15986 PARAMETER ( ANGLSQ = 2.5D-31 )
15987 PARAMETER ( AZRZRZ = 1.0D-30 )
15988 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15989 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15990 PARAMETER ( ONEONE = 1.D+00 )
15991 PARAMETER ( TWOTWO = 2.D+00 )
15992 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15993
15994 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15995
15996* flags for input different options
15997 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15998 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15999 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16000
16001 DIMENSION F(5),XX(5)
16002 DATA EPS /AZRZRZ/
16003
16004 UMOO=UMO+UMO
16005C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16006C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16007C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16008 UUMO=UMO
16009 AAM1=AM1
16010 AAM2=AM2
16011 AAM3=AM3
16012 GU=(AM2+AM3)**2
16013 GO=(UMO-AM1)**2
16014* UFAK=1.0000000000001D0
16015* IF (GU.GT.GO) UFAK=0.9999999999999D0
16016 IF (GU.GT.GO) THEN
16017 UFAK=ONEMNS
16018 ELSE
16019 UFAK=ONEPLS
16020 END IF
16021 OFAK=2.D0-UFAK
16022 GU=GU*UFAK
16023 GO=GO*OFAK
16024 DS2=(GO-GU)/99.D0
16025 AM11=AM1*AM1
16026 AM22=AM2*AM2
16027 AM33=AM3*AM3
16028 UMO2=UMO*UMO
16029 RHO2=0.D0
16030 S22=GU
16031 DO 124 I=1,100
16032 S21=S22
16033 S22=GU+(I-1.D0)*DS2
16034 RHO1=RHO2
16035 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16036 * (S22+EPS)
16037 IF(RHO2.LT.RHO1) GO TO 125
16038 124 CONTINUE
16039 125 S2SUP=(S22-S21)*.5D0+S21
16040 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16041 * (S2SUP+EPS)
16042 SUPRHO=SUPRHO*1.05D0
16043 XO=S21-DS2
16044 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16045 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16046 XX(1)=XO
16047 XX(3)=S22
16048 X1=(XO+S22)*0.5D0
16049 XX(2)=X1
16050 F(3)=RHO2
16051 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16052 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16053 DO 126 I=1,16
16054 X4=(XX(1)+XX(2))*0.5D0
16055 X5=(XX(2)+XX(3))*0.5D0
16056 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16057 * (X4+EPS)
16058 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16059 * (X5+EPS)
16060 XX(4)=X4
16061 XX(5)=X5
16062 DO 128 II=1,5
16063 IA=II
16064 DO 128 III=IA,5
16065 IF (F (II).GE.F (III)) GO TO 128
16066 FH=F(II)
16067 F(II)=F(III)
16068 F(III)=FH
16069 FH=XX(II)
16070 XX(II)=XX(III)
16071 XX(III)=FH
16072128 CONTINUE
16073 SUPRHO=F(1)
16074 S2SUP=XX(1)
16075 DO 129 II=1,3
16076 IA=II
16077 DO 129 III=IA,3
16078 IF (XX(II).GE.XX(III)) GO TO 129
16079 FH=F(II)
16080 F(II)=F(III)
16081 F(III)=FH
16082 FH=XX(II)
16083 XX(II)=XX(III)
16084 XX(III)=FH
16085129 CONTINUE
16086126 CONTINUE
16087 AM23=(AM2+AM3)**2
16088 ITH=0
16089 REDU=2.D0
16090 1 CONTINUE
16091 ITH=ITH+1
16092 IF (ITH.GT.200) REDU=-9.D0
16093 IF (ITH.GT.200) GO TO 400
16094 C=DT_RNDM(REDU)
16095* S2=AM23+C*((UMO-AM1)**2-AM23)
16096 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16097 Y=DT_RNDM(S2)
16098 Y=Y*SUPRHO
16099 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16100 IF(Y.GT.RHO) GO TO 1
16101C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16102 S1=DT_RNDM(S2)
16103 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16104 &RHO*.5D0
16105 S3=UMO2+AM11+AM22+AM33-S1-S2
16106 ECM1=(UMO2+AM11-S2)/UMOO
16107 ECM2=(UMO2+AM22-S3)/UMOO
16108 ECM3=(UMO2+AM33-S1)/UMOO
16109 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16110 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16111 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16112 CALL DT_DSFECF(SFE,CFE)
16113C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16114C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16115 PCM12 = PCM1 * PCM2
16116 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16117 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16118 GO TO 300
16119 200 CONTINUE
16120 UW=DT_RNDM(S1)
16121 COSTH=(UW-0.5D+00)*2.D+00
16122 300 CONTINUE
16123* IF(ABS(COSTH).GT.0.9999999999999999D0)
16124* &COSTH=SIGN(0.9999999999999999D0,COSTH)
16125 IF(ABS(COSTH).GT.ONEONE)
16126 &COSTH=SIGN(ONEONE,COSTH)
16127 IF (REDU.LT.1.D+00) RETURN
16128 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16129* IF(ABS(COSTH2).GT.0.9999999999999999D0)
16130* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16131 IF(ABS(COSTH2).GT.ONEONE)
16132 &COSTH2=SIGN(ONEONE,COSTH2)
16133 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16134 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16135 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16136 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16137C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16138C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16139C***THE DIRECTION OF PARTICLE 3
16140C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16141 CX11=-COSTH1
16142 CY11=SINTH1*CFE
16143 CZ11=SINTH1*SFE
16144 CX22=-COSTH2
16145 CY22=-SINTH2*CFE
16146 CZ22=-SINTH2*SFE
16147 CALL DT_DSFECF(SIF3,COF3)
16148 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16149 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16150 2 FORMAT(5F20.15)
16151 COD1=CX11*COD3+CZ11*SID3
16152 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16153 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16154 &CX11,CZ11
16155 SID1=SQRT(CHLP)
16156 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16157 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16158 COD2=CX22*COD3+CZ22*SID3
16159 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16160 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16161 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16162 400 CONTINUE
16163* === Energy conservation check: === *
16164 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16165* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16166* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16167* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16168 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16169 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16170 & + PCM3 * COF3 * SID3
16171 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16172 & + PCM3 * SIF3 * SID3
16173 EOCMPR = 1.D-12 * UMO
16174 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16175 & .GT. EOCMPR ) THEN
16176**sr 5.5.95 output-unit changed
16177 IF (IOULEV(1).GT.0) THEN
16178 WRITE(LOUT,*)
16179 & ' *** Threpd: energy/momentum conservation failure! ***',
16180 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16181 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16182 ENDIF
16183**
16184 END IF
16185 RETURN
16186 END
16187
16188*$ CREATE DT_DBKLAS.FOR
16189*COPY DT_DBKLAS
16190*
16191*===dbklas=============================================================*
16192*
16193 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16194
16195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16196 SAVE
16197
16198 PARAMETER ( LINP = 10 ,
16199 & LOUT = 6 ,
16200 & LDAT = 9 )
16201
16202* quark-content to particle index conversion (DTUNUC 1.x)
16203 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16204 & IA08(6,21),IA10(6,21)
16205
16206 IF (I) 20,20,10
16207* baryons
16208 10 CONTINUE
16209 CALL DT_INDEXD(J,K,IND)
16210 I8 = IB08(I,IND)
16211 I10 = IB10(I,IND)
16212 IF (I8.LE.0) I8 = I10
16213 RETURN
16214* antibaryons
16215 20 CONTINUE
16216 II = IABS(I)
16217 JJ = IABS(J)
16218 KK = IABS(K)
16219 CALL DT_INDEXD(JJ,KK,IND)
16220 I8 = IA08(II,IND)
16221 I10 = IA10(II,IND)
16222 IF (I8.LE.0) I8 = I10
16223
16224 RETURN
16225 END
16226
16227*$ CREATE DT_INDEXD.FOR
16228*COPY DT_INDEXD
16229*
16230*===indexd=============================================================*
16231*
16232 SUBROUTINE DT_INDEXD(KA,KB,IND)
16233
16234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16235 SAVE
16236
16237 PARAMETER ( LINP = 10 ,
16238 & LOUT = 6 ,
16239 & LDAT = 9 )
16240
16241 KP = KA*KB
16242 KS = KA+KB
16243 IF (KP.EQ.1) IND=1
16244 IF (KP.EQ.2) IND=2
16245 IF (KP.EQ.3) IND=3
16246 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16247 IF (KP.EQ.5) IND=5
16248 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16249 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16250 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16251 IF (KP.EQ.8) IND=9
16252 IF (KP.EQ.10) IND=10
16253 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16254 IF (KP.EQ.9) IND=12
16255 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16256 IF (KP.EQ.15) IND=14
16257 IF (KP.EQ.18) IND=15
16258 IF (KP.EQ.16) IND=16
16259 IF (KP.EQ.20) IND=17
16260 IF (KP.EQ.24) IND=18
16261 IF (KP.EQ.25) IND=19
16262 IF (KP.EQ.30) IND=20
16263 IF (KP.EQ.36) IND=21
16264
16265 RETURN
16266 END
16267
16268*$ CREATE DT_DCHANT.FOR
16269*COPY DT_DCHANT
16270*
16271*===dchant=============================================================*
16272*
16273 SUBROUTINE DT_DCHANT
16274
16275 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16276 SAVE
16277
16278 PARAMETER ( LINP = 10 ,
16279 & LOUT = 6 ,
16280 & LDAT = 9 )
16281
16282 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16283
16284* HADRIN: decay channel information
16285 PARAMETER (IDMAX9=602)
16286 CHARACTER*8 ZKNAME
16287 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16288
16289* particle properties (BAMJET index convention)
16290 CHARACTER*8 ANAME
16291 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16292 & IICH(210),IIBAR(210),K1(210),K2(210)
16293
16294 DIMENSION HWT(IDMAX9)
16295
16296* change of weights wt from absolut values into the sum of wt of a dec.
16297 DO 10 J=1,IDMAX9
16298 HWT(J) = ZERO
16299 10 CONTINUE
16300C DO 999 KKK=1,210
16301C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16302C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16303C & K1(KKK),K2(KKK)
16304C 999 CONTINUE
16305C STOP
16306 DO 30 I=1,210
16307 IK1 = K1(I)
16308 IK2 = K2(I)
16309 HV = ZERO
16310 DO 20 J=IK1,IK2
16311 HV = HV+WT(J)
16312 HWT(J) = HV
16313**sr 13.1.95
16314 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16315 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16316 20 CONTINUE
16317 30 CONTINUE
16318 DO 40 J=1,IDMAX9
16319 WT(J) = HWT(J)
16320 40 CONTINUE
16321
16322 RETURN
16323 END
16324
16325*$ CREATE DT_DDATAR.FOR
16326*COPY DT_DDATAR
16327*
16328*===ddatar=============================================================*
16329*
16330 SUBROUTINE DT_DDATAR
16331
16332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16333 SAVE
16334
16335 PARAMETER ( LINP = 10 ,
16336 & LOUT = 6 ,
16337 & LDAT = 9 )
16338
16339 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16340
16341* quark-content to particle index conversion (DTUNUC 1.x)
16342 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16343 & IA08(6,21),IA10(6,21)
16344
16345 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16346
16347 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16348 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16349 & 128,129,14*0/
16350 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16351 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16352 & 121,122,14*0/
16353 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16354 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16355 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16356 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16357 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16358 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16359 & 0, 0, 0,140,137,138,146, 0, 0,142,
16360 & 139,147, 0, 0,145,148, 50*0/
16361 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16362 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16363 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16364 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16365 & 0, 0,104,105,107,164, 0, 0,106,108,
16366 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16367 & 0, 0, 0,161,162,164,167, 0, 0,163,
16368 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16369 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16370 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16371 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16372 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16373 & 0, 0, 99,100,102,150, 0, 0,101,103,
16374 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16375 & 0, 0, 0,152,149,150,158, 0, 0,154,
16376 & 151,159, 0, 0,157,160, 50*0/
16377 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16378 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16379 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16380 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16381 & 0, 0,110,111,113,174, 0, 0,112,114,
16382 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16383 & 0, 0, 0,171,172,174,177, 0, 0,173,
16384 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16385
16386 L=0
16387 DO 2 I=1,6
16388 DO 1 J=1,6
16389 L = L+1
16390 IMPS(I,J) = IP(L)
16391 IMVE(I,J) = IV(L)
16392 1 CONTINUE
16393 2 CONTINUE
16394 L=0
16395 DO 4 I=1,6
16396 DO 3 J=1,21
16397 L = L+1
16398 IB08(I,J) = IB(L)
16399 IB10(I,J) = IBB(L)
16400 IA08(I,J) = IA(L)
16401 IA10(I,J) = IAA(L)
16402 3 CONTINUE
16403 4 CONTINUE
16404C A1 = 0.88D0
16405C B1 = 3.0D0
16406C B2 = 3.0D0
16407C B3 = 8.0D0
16408C LT = 0
16409C LB = 0
16410C BET = 12.0D0
16411C AS = 0.25D0
16412C B8 = 0.33D0
16413C AME = 0.95D0
16414C DIQ = 0.375D0
16415C ISU = 4
16416
16417 RETURN
16418 END
16419
16420*$ CREATE DT_INITJS.FOR
16421*COPY DT_INITJS
16422*
16423*===initjs=============================================================*
16424*
16425 SUBROUTINE DT_INITJS(MODE)
16426
16427************************************************************************
16428* Initialize JETSET paramters. *
16429* MODE = 0 default settings *
16430* = 1 PHOJET settings *
16431* = 2 DTUNUC settings *
16432* This version dated 16.02.96 is written by S. Roesler *
16433* *
16434* Last change 27.12.2006 by S. Roesler. *
16435************************************************************************
16436
16437 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16438 SAVE
16439
16440 PARAMETER ( LINP = 10 ,
16441 & LOUT = 6 ,
16442 & LDAT = 9 )
16443
16444 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16445
16446 LOGICAL LFIRST,LFIRDT,LFIRPH
16447
16448* INCLUDE '(DIMPAR)'
16449* DIMPAR taken from FLUKA
16450 PARAMETER ( MXXRGN =20000 )
16451 PARAMETER ( MXXMDF = 710 )
16452 PARAMETER ( MXXMDE = 702 )
16453 PARAMETER ( MFSTCK =40000 )
16454 PARAMETER ( MESTCK = 100 )
16455 PARAMETER ( MOSTCK = 2000 )
16456 PARAMETER ( MXPRSN = 100 )
16457 PARAMETER ( MXPDPM = 800 )
16458 PARAMETER ( MXPSCS =30000 )
16459 PARAMETER ( MXGLWN = 300 )
16460 PARAMETER ( MXOUTU = 50 )
16461 PARAMETER ( NALLWP = 64 )
16462 PARAMETER ( NELEMX = 80 )
16463 PARAMETER ( MPDPDX = 18 )
16464 PARAMETER ( MXHTTR = 260 )
16465 PARAMETER ( MXSEAX = 20 )
16466 PARAMETER ( MXHTNC = MXSEAX + 1 )
16467 PARAMETER ( ICOMAX = 2400 )
16468 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16469 PARAMETER ( NSTBIS = 304 )
16470 PARAMETER ( NQSTIS = 46 )
16471 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16472 PARAMETER ( MXPABL = 120 )
16473 PARAMETER ( IDMAXP = 450 )
16474 PARAMETER ( IDMXDC = 2000 )
16475 PARAMETER ( MXMCIN = 410 )
16476 PARAMETER ( IHYPMX = 4 )
16477 PARAMETER ( MKBMX1 = 11 )
16478 PARAMETER ( MKBMX2 = 11 )
16479 PARAMETER ( MXIRRD = 2500 )
16480 PARAMETER ( MXTRDC = 1500 )
16481 PARAMETER ( NKTL = 17 )
16482 PARAMETER ( NBLNMX = 40000000 )
16483
16484* INCLUDE '(PART)'
16485* PART taken from FLUKA
16486 PARAMETER ( KPETA0 = 31 )
16487 PARAMETER ( KPRHOP = 32 )
16488 PARAMETER ( KPRHO0 = 33 )
16489 PARAMETER ( KPRHOM = 34 )
16490 PARAMETER ( KPOME0 = 35 )
16491 PARAMETER ( KPPHI0 = 96 )
16492 PARAMETER ( KPDEPP = 53 )
16493 PARAMETER ( KPDELP = 54 )
16494 PARAMETER ( KPDEL0 = 55 )
16495 PARAMETER ( KPDELM = 56 )
16496 PARAMETER ( KPN14P = 91 )
16497 PARAMETER ( KPN140 = 92 )
16498* Low mass diffraction partners:
16499 PARAMETER ( KDETA0 = 0 )
16500 PARAMETER ( KDRHOP = 0 )
16501 PARAMETER ( KDRHO0 = 210 )
16502 PARAMETER ( KDRHOM = 0 )
16503 PARAMETER ( KDOME0 = 210 )
16504 PARAMETER ( KDPHI0 = 210 )
16505 PARAMETER ( KDDEPP = 0 )
16506 PARAMETER ( KDDELP = 0 )
16507 PARAMETER ( KDDEL0 = 0 )
16508 PARAMETER ( KDDELM = 0 )
16509 PARAMETER ( KDN14P = 0 )
16510 PARAMETER ( KDN140 = 0 )
16511*
16512 CHARACTER*8 ANAME
16513 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16514 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16515 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16516 & ATXN14, ATMN14, RNRN14 (-10:10),
16517 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16518 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16519 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16520 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16521 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16522 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16523
16524 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16525 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
004932dd 16526 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 16527
16528* flags for particle decays
16529 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16530 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16531 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16532
16533* flags for input different options
16534 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16535 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16536 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16537
16538 INTEGER PYCOMP
16539
16540 DIMENSION IDXSTA(40)
16541 DATA IDXSTA
16542* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16543 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16544* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16545 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16546* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16547 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16548* Ksic0 aKsic+aKsic0 sig0 asig0
16549 & 4132,-4232,-4132, 3212,-3212, 5*0/
16550
16551 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16552
16553 IF (LFIRST) THEN
16554* save default settings
16555 PDEF1 = PARJ(1)
16556 PDEF2 = PARJ(2)
16557 PDEF3 = PARJ(3)
16558 PDEF5 = PARJ(5)
16559 PDEF6 = PARJ(6)
16560 PDEF7 = PARJ(7)
16561 PDEF18 = PARJ(18)
16562 PDEF19 = PARJ(19)
16563 PDEF21 = PARJ(21)
16564 PDEF42 = PARJ(42)
16565 MDEF12 = MSTJ(12)
16566* LUJETS / PYJETS array-dimensions
16567
16568 MSTU(4) = 4000
16569
16570* increase maximum number of JETSET-error prints
16571 MSTU(22) = 50000
16572* prevent particles decaying
16573 DO 1 I=1,35
16574 IF (I.LT.34) THEN
16575
16576 KC = PYCOMP(IDXSTA(I))
16577
16578 IF (KC.GT.0) THEN
16579 IF (I.EQ.2) THEN
16580* pi0 decay
16581C MDCY(KC,1) = 1
16582 MDCY(KC,1) = 0
16583**cr mode
16584C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16585C & (I.EQ.8).OR.(I.EQ.10)) THEN
16586C ELSEIF (I.EQ.4) THEN
16587C MDCY(KC,1) = 1
16588**
16589 ELSE
16590 MDCY(KC,1) = 0
16591 ENDIF
16592 ENDIF
16593 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16594
16595 KC = PYCOMP(IDXSTA(I))
16596
16597 IF (KC.GT.0) THEN
16598 MDCY(KC,1) = 0
16599 ENDIF
16600 ENDIF
16601 1 CONTINUE
16602*
16603
16604* as Fluka event-generator: allow only paprop particles to be stable
16605* and let all other particles decay (i.e. those with strong decays)
16606 IF (ITRSPT.EQ.1) THEN
16607 DO 5 I=1,IDMAXP
16608 IF (KPTOIP(I).NE.0) THEN
16609 IDPDG = MPDGHA(I)
16610
16611 KC = PYCOMP(IDPDG)
16612
16613 IF (KC.GT.0) THEN
16614 IF (MDCY(KC,1).EQ.1) THEN
16615 WRITE(LOUT,*)
16616 & ' DT_INITJS: Decay flag for FLUKA-',
16617 & 'transport : particle should not ',
16618 & 'decay : ',IDPDG,' ',ANAME(I)
16619 MDCY(KC,1) = 0
16620 ENDIF
16621 ENDIF
16622 ENDIF
16623 5 CONTINUE
16624 DO 6 KC=1,500
16625 IDPDG = KCHG(KC,4)
16626 KP = MCIHAD(IDPDG)
16627 IF (KP.GT.0) THEN
16628 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16629 & (ANAME(KP).NE.'BLANK ').AND.
16630 & (ANAME(KP).NE.'RNDFLV ')) THEN
16631 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16632 & 'transport: particle should decay ',
16633 & ': ',IDPDG,' ',ANAME(KP)
16634 MDCY(KC,1) = 1
16635 ENDIF
16636 ENDIF
16637 6 CONTINUE
16638 ENDIF
16639
16640*
16641* popcorn:
16642 IF (PDB.LE.ZERO) THEN
16643* no popcorn-mechanism
16644 MSTJ(12) = 1
16645 ELSE
16646 MSTJ(12) = 3
16647 PARJ(5) = PDB
16648 ENDIF
16649* set JETSET-parameter requested by input cards
16650 IF (NMSTU.GT.0) THEN
16651 DO 2 I=1,NMSTU
16652 MSTU(IMSTU(I)) = MSTUX(I)
16653 2 CONTINUE
16654 ENDIF
16655 IF (NMSTJ.GT.0) THEN
16656 DO 3 I=1,NMSTJ
16657 MSTJ(IMSTJ(I)) = MSTJX(I)
16658 3 CONTINUE
16659 ENDIF
16660 IF (NPARU.GT.0) THEN
16661 DO 4 I=1,NPARU
16662 PARU(IPARU(I)) = PARUX(I)
16663 4 CONTINUE
16664 ENDIF
16665 LFIRST = .FALSE.
16666 ENDIF
16667*
16668* PARJ(1) suppression of qq-aqaq pair prod. compared to
16669* q-aq pair prod. (default: 0.1)
16670* PARJ(2) strangeness suppression (default: 0.3)
16671* PARJ(3) extra suppression of strange diquarks (default: 0.4)
16672* PARJ(6) extra suppression of sas-pair shared by B and
16673* aB in BMaB (default: 0.5)
16674* PARJ(7) extra suppression of strange meson M in BMaB
16675* configuration (default: 0.5)
16676* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16677* PARJ(21) width sigma in Gaussian p_x, p_y transverse
16678* momentum distrib. for prim. hadrons (default: 0.35)
16679* PARJ(42) b-parameter for symmetric Lund-fragmentation
16680* function (default: 0.9 GeV^-2)
16681*
16682* PHOJET settings
16683 IF (MODE.EQ.1) THEN
16684* JETSET default
16685C PARJ(1) = PDEF1
16686C PARJ(2) = PDEF2
16687C PARJ(3) = PDEF3
16688C PARJ(6) = PDEF6
16689C PARJ(7) = PDEF7
16690C PARJ(18) = PDEF18
16691C PARJ(21) = PDEF21
16692C PARJ(42) = PDEF42
16693**sr 18.11.98 parameter tuning
16694C PARJ(1) = 0.092D0
16695C PARJ(2) = 0.25D0
16696C PARJ(3) = 0.45D0
16697C PARJ(19) = 0.3D0
16698C PARJ(21) = 0.45D0
16699C PARJ(42) = 1.0D0
16700**sr 28.04.99 parameter tuning (May 99 minor modifications)
16701 PARJ(1) = 0.085D0
16702 PARJ(2) = 0.26D0
16703 PARJ(3) = 0.8D0
16704 PARJ(11) = 0.38D0
16705 PARJ(18) = 0.3D0
16706 PARJ(19) = 0.4D0
16707 PARJ(21) = 0.36D0
16708 PARJ(41) = 0.3D0
16709 PARJ(42) = 0.86D0
16710 IF (NPARJ.GT.0) THEN
16711 DO 10 I=1,NPARJ
16712 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16713 10 CONTINUE
16714 ENDIF
16715 IF (LFIRPH) THEN
16716 WRITE(LOUT,'(1X,A)')
16717 & 'DT_INITJS: JETSET-parameter for PHOJET'
16718 CALL DT_JSPARA(0)
16719 LFIRPH = .FALSE.
16720 ENDIF
16721* DTUNUC settings
16722 ELSEIF (MODE.EQ.2) THEN
16723 IF (IFRAG(2).EQ.1) THEN
16724**sr parameters before 9.3.96
16725C PARJ(2) = 0.27D0
16726C PARJ(3) = 0.6D0
16727C PARJ(6) = 0.75D0
16728C PARJ(7) = 0.75D0
16729C PARJ(21) = 0.55D0
16730C PARJ(42) = 1.3D0
16731**sr 18.11.98 parameter tuning
16732C PARJ(1) = 0.05D0
16733C PARJ(2) = 0.27D0
16734C PARJ(3) = 0.4D0
16735C PARJ(19) = 0.2D0
16736C PARJ(21) = 0.45D0
16737C PARJ(42) = 1.0D0
16738**sr 28.04.99 parameter tuning
16739 PARJ(1) = 0.11D0
16740 PARJ(2) = 0.36D0
16741 PARJ(3) = 0.8D0
16742 PARJ(19) = 0.2D0
16743 PARJ(21) = 0.3D0
16744 PARJ(41) = 0.3D0
16745 PARJ(42) = 0.58D0
16746 IF (NPARJ.GT.0) THEN
16747 DO 20 I=1,NPARJ
16748 IF (IPARJ(I).LT.0) THEN
16749 IDX = ABS(IPARJ(I))
16750 PARJ(IDX) = PARJX(I)
16751 ENDIF
16752 20 CONTINUE
16753 ENDIF
16754 IF (LFIRDT) THEN
16755 WRITE(LOUT,'(1X,A)')
16756 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16757 CALL DT_JSPARA(0)
16758 LFIRDT = .FALSE.
16759 ENDIF
16760 ELSEIF (IFRAG(2).EQ.2) THEN
16761 PARJ(1) = 0.11D0
16762 PARJ(2) = 0.27D0
16763 PARJ(3) = 0.3D0
16764 PARJ(6) = 0.35D0
16765 PARJ(7) = 0.45D0
16766 PARJ(18) = 0.66D0
16767C PARJ(21) = 0.55D0
16768C PARJ(42) = 1.0D0
16769 PARJ(21) = 0.60D0
16770 PARJ(42) = 1.3D0
16771 ELSE
16772 PARJ(1) = PDEF1
16773 PARJ(2) = PDEF2
16774 PARJ(3) = PDEF3
16775 PARJ(6) = PDEF6
16776 PARJ(7) = PDEF7
16777 PARJ(18) = PDEF18
16778 PARJ(21) = PDEF21
16779 PARJ(42) = PDEF42
16780 ENDIF
16781 ELSE
16782 PARJ(1) = PDEF1
16783 PARJ(2) = PDEF2
16784 PARJ(3) = PDEF3
16785 PARJ(5) = PDEF5
16786 PARJ(6) = PDEF6
16787 PARJ(7) = PDEF7
16788 PARJ(18) = PDEF18
16789 PARJ(19) = PDEF19
16790 PARJ(21) = PDEF21
16791 PARJ(42) = PDEF42
16792 MSTJ(12) = MDEF12
16793 ENDIF
16794
16795 RETURN
16796 END
16797
16798*$ CREATE DT_JSPARA.FOR
16799*COPY DT_JSPARA
16800*
16801*===jspara=============================================================*
16802*
16803 SUBROUTINE DT_JSPARA(MODE)
16804
16805 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16806 SAVE
16807
16808 PARAMETER ( LINP = 10 ,
16809 & LOUT = 6 ,
16810 & LDAT = 9 )
16811
16812 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16813 & ONE=1.0D0,ZERO=0.0D0)
16814
16815 LOGICAL LFIRST
16816
16817 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16818
16819 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16820
16821 DATA LFIRST /.TRUE./
16822
16823* save the default JETSET-parameter on the first call
16824 IF (LFIRST) THEN
16825 DO 1 I=1,200
16826 ISTU(I) = MSTU(I)
16827 QARU(I) = PARU(I)
16828 ISTJ(I) = MSTJ(I)
16829 QARJ(I) = PARJ(I)
16830 1 CONTINUE
16831 LFIRST = .FALSE.
16832 ENDIF
16833
16834 WRITE(LOUT,1000)
16835 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16836
16837* compare the default JETSET-parameter with the present values
16838 DO 2 I=1,200
16839 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16840 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16841C ISTU(I) = MSTU(I)
16842 ENDIF
16843 DIFF = ABS(PARU(I)-QARU(I))
16844 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16845 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16846C QARU(I) = PARU(I)
16847 ENDIF
16848 IF (MSTJ(I).NE.ISTJ(I)) THEN
16849 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16850C ISTJ(I) = MSTJ(I)
16851 ENDIF
16852 DIFF = ABS(PARJ(I)-QARJ(I))
16853 IF (DIFF.GE.1.0D-5) THEN
16854 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16855C QARJ(I) = PARJ(I)
16856 ENDIF
16857 2 CONTINUE
16858 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16859 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16860
16861 RETURN
16862 END
16863*$ CREATE DT_FOZOCA.FOR
16864*COPY DT_FOZOCA
16865*
16866*===fozoca=============================================================*
16867*
16868 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16869
16870************************************************************************
16871* This subroutine treats the complete FOrmation ZOne supressed intra- *
16872* nuclear CAscade. *
16873* LFZC = .true. cascade has been treated *
16874* = .false. cascade skipped *
16875* This is a completely revised version of the original FOZOKL. *
16876* This version dated 18.11.95 is written by S. Roesler *
16877************************************************************************
16878
16879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16880 SAVE
16881
16882 PARAMETER ( LINP = 10 ,
16883 & LOUT = 6 ,
16884 & LDAT = 9 )
16885
16886 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16887 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16888
16889 LOGICAL LSTART,LCAS,LFZC
16890
16891* event history
16892
16893 PARAMETER (NMXHKK=200000)
16894
16895 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16896 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16897 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16898
16899* extended event history
16900 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16901 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16902 & IHIST(2,NMXHKK)
16903
16904* rejection counter
16905 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16906 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16907 & IREXCI(3),IRDIFF(2),IRINC
16908
16909* properties of interacting particles
16910 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16911
16912* Glauber formalism: collision properties
16913 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16914 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16915
16916* flags for input different options
16917 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16918 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16919 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16920
16921* final state after intranuclear cascade step
16922 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16923
16924* parameter for intranuclear cascade
16925 LOGICAL LPAULI
16926 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16927
16928 DIMENSION NCWOUN(2)
16929
16930 DATA LSTART /.TRUE./
16931
16932 LFZC = .TRUE.
16933 IREJ = 0
16934
16935* skip cascade if hadron-hadron interaction or if supressed by user
16936 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16937* skip cascade if not all possible chains systems are hadronized
16938 DO 1 I=1,8
16939 IF (.NOT.LHADRO(I)) GOTO 9999
16940 1 CONTINUE
16941
16942 IF (LSTART) THEN
16943 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16944 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16945 & 'maximum of',I4,' generations',/,10X,'formation time ',
16946 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16947 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16948 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16949 1001 FORMAT(10X,'p_t dependent formation zone',/)
16950 1002 FORMAT(10X,'constant formation zone',/)
16951 LSTART = .FALSE.
16952 ENDIF
16953
16954* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16955* which may interact with final state particles are stored in a seperate
16956* array - here all proj./target nucleon-indices (just for simplicity)
16957 NOINC = 0
16958 DO 9 I=1,NPOINT(1)-1
16959 NOINC = NOINC+1
16960 IDXINC(NOINC) = I
16961 9 CONTINUE
16962
16963* initialize Pauli-principle treatment (find wounded nucleons)
16964 NWOUND(1) = 0
16965 NWOUND(2) = 0
16966 NCWOUN(1) = 0
16967 NCWOUN(2) = 0
16968 DO 2 J=1,NPOINT(1)
16969 DO 3 I=1,2
16970 IF (ISTHKK(J).EQ.10+I) THEN
16971 NWOUND(I) = NWOUND(I)+1
16972 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16973 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16974 ENDIF
16975 3 CONTINUE
16976 2 CONTINUE
16977
16978* modify nuclear potential for wounded nucleons
16979 IPRCL = IP -NWOUND(1)
16980 IPZRCL = IPZ-NCWOUN(1)
16981 ITRCL = IT -NWOUND(2)
16982 ITZRCL = ITZ-NCWOUN(2)
16983 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16984
16985 NSTART = NPOINT(4)
16986 NEND = NHKK
16987
16988 7 CONTINUE
16989 DO 8 I=NSTART,NEND
16990
16991 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16992* select nucleus the cascade starts first (proj. - 1, target - -1)
16993 NCAS = 1
16994* projectile/target with probab. 1/2
16995 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16996 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16997* in the nucleus with highest mass
16998 ELSEIF (INCMOD.EQ.2) THEN
16999 IF (IP.GT.IT) THEN
17000 NCAS = -NCAS
17001 ELSEIF (IP.EQ.IT) THEN
17002 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17003 ENDIF
17004* the nucleus the cascade starts first is requested to be the one
17005* moving in the direction of the secondary
17006 ELSEIF (INCMOD.EQ.3) THEN
17007 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17008 ENDIF
17009* check that the selected "nucleus" is not a hadron
17010 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17011 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
17012
17013* treat intranuclear cascade in the nucleus selected first
17014 LCAS = .FALSE.
17015 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17016 IF (IREJ1.NE.0) GOTO 9998
17017* treat intranuclear cascade in the other nucleus if this isn't a had.
17018 NCAS = -NCAS
17019 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17020 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17021 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17022 IF (IREJ1.NE.0) GOTO 9998
17023 ENDIF
17024
17025 ENDIF
17026
17027 8 CONTINUE
17028 NSTART = NEND+1
17029 NEND = NHKK
17030 IF (NSTART.LE.NEND) GOTO 7
17031
17032 RETURN
17033
17034 9998 CONTINUE
17035* reject this event
17036 IRINC = IRINC+1
17037 IREJ = 1
17038
17039 9999 CONTINUE
17040* intranucl. cascade not treated because of interaction properties or
17041* it is supressed by user or it was rejected or...
17042 LFZC = .FALSE.
17043* reset flag characterizing direction of motion in n-n-cms
17044**sr14-11-95
17045C DO 9990 I=NPOINT(5),NHKK
17046C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17047C9990 CONTINUE
17048
17049 RETURN
17050 END
17051
17052*$ CREATE DT_INUCAS.FOR
17053*COPY DT_INUCAS
17054*
17055*===inucas=============================================================*
17056*
17057 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17058
17059************************************************************************
17060* Formation zone supressed IntraNUclear CAScade for one final state *
17061* particle. *
17062* IT, IP mass numbers of target, projectile nuclei *
17063* IDXCAS index of final state particle in DTEVT1 *
17064* NCAS = 1 intranuclear cascade in projectile *
17065* = -1 intranuclear cascade in target *
17066* This version dated 18.11.95 is written by S. Roesler *
17067************************************************************************
17068
17069 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17070 SAVE
17071
17072 PARAMETER ( LINP = 10 ,
17073 & LOUT = 6 ,
17074 & LDAT = 9 )
17075
17076 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17077 & OHALF=0.5D0,ONE=1.0D0)
17078 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17079 PARAMETER (TWOPI=6.283185307179586454D+00)
17080 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17081
17082 LOGICAL LABSOR,LCAS
17083
17084* event history
17085
17086 PARAMETER (NMXHKK=200000)
17087
17088 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17089 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17090 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17091
17092* extended event history
17093 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17094 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17095 & IHIST(2,NMXHKK)
17096
17097* final state after inc step
17098 PARAMETER (MAXFSP=10)
17099 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17100
17101* flags for input different options
17102 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17103 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17104 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17105
17106* particle properties (BAMJET index convention)
17107 CHARACTER*8 ANAME
17108 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17109 & IICH(210),IIBAR(210),K1(210),K2(210)
17110
17111* Glauber formalism: collision properties
17112 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17113 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17114
17115* nuclear potential
17116 LOGICAL LFERMI
17117 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17118 & EBINDP(2),EBINDN(2),EPOT(2,210),
17119 & ETACOU(2),ICOUL,LFERMI
17120
17121* parameter for intranuclear cascade
17122 LOGICAL LPAULI
17123 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17124
17125* final state after intranuclear cascade step
17126 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17127
17128* nucleon-nucleon event-generator
17129 CHARACTER*8 CMODEL
17130 LOGICAL LPHOIN
17131 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17132
17133* statistics: residual nuclei
17134 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17135 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17136 & NINCST(2,4),NINCEV(2),
17137 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17138 & NRESPB(2),NRESCH(2),NRESEV(4),
17139 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17140 & NEVAFI(2,2)
17141
17142 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17143 & PCAS1(5),PNUC(5),BGTA(4),
17144 & BGCAS(2),GACAS(2),BECAS(2),
17145 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17146
17147 DATA PDIF /0.545D0/
17148
17149 IREJ = 0
17150
17151* update counter
17152 IF (NINCEV(1).NE.NEVHKK) THEN
17153 NINCEV(1) = NEVHKK
17154 NINCEV(2) = NINCEV(2)+1
17155 ENDIF
17156
17157* "BAMJET-index" of this hadron
17158 IDCAS = IDBAM(IDXCAS)
17159 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17160
17161* skip gammas, electrons, etc..
17162 IF (AAM(IDCAS).LT.TINY2) RETURN
17163
17164* Lorentz-trsf. into projectile rest system
17165 IF (IP.GT.1) THEN
17166 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17167 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17168 & PCAS(1,4),IDCAS,-2)
17169 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17170 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17171 IF (PCAS(1,5).GT.ZERO) THEN
17172 PCAS(1,5) = SQRT(PCAS(1,5))
17173 ELSE
17174 PCAS(1,5) = AAM(IDCAS)
17175 ENDIF
17176 DO 20 K=1,3
17177 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17178 20 CONTINUE
17179* Lorentz-parameters
17180* particle rest system --> projectile rest system
17181 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17182 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17183 BECAS(1) = BGCAS(1)/GACAS(1)
17184 ELSE
17185 DO 21 K=1,5
17186 PCAS(1,K) = ZERO
17187 IF (K.LE.3) COSCAS(1,K) = ZERO
17188 21 CONTINUE
17189 PTOCAS(1) = ZERO
17190 BGCAS(1) = ZERO
17191 GACAS(1) = ZERO
17192 BECAS(1) = ZERO
17193 ENDIF
17194* Lorentz-trsf. into target rest system
17195 IF (IT.GT.1) THEN
17196* LEPTO: final state particles are already in target rest frame
17197C IF (MCGENE.EQ.3) THEN
17198C PCAS(2,1) = PHKK(1,IDXCAS)
17199C PCAS(2,2) = PHKK(2,IDXCAS)
17200C PCAS(2,3) = PHKK(3,IDXCAS)
17201C PCAS(2,4) = PHKK(4,IDXCAS)
17202C ELSE
17203 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17204 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17205 & PCAS(2,4),IDCAS,-3)
17206C ENDIF
17207 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17208 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17209 IF (PCAS(2,5).GT.ZERO) THEN
17210 PCAS(2,5) = SQRT(PCAS(2,5))
17211 ELSE
17212 PCAS(2,5) = AAM(IDCAS)
17213 ENDIF
17214 DO 22 K=1,3
17215 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17216 22 CONTINUE
17217* Lorentz-parameters
17218* particle rest system --> target rest system
17219 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17220 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17221 BECAS(2) = BGCAS(2)/GACAS(2)
17222 ELSE
17223 DO 23 K=1,5
17224 PCAS(2,K) = ZERO
17225 IF (K.LE.3) COSCAS(2,K) = ZERO
17226 23 CONTINUE
17227 PTOCAS(2) = ZERO
17228 BGCAS(2) = ZERO
17229 GACAS(2) = ZERO
17230 BECAS(2) = ZERO
17231 ENDIF
17232
17233* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17234* potential (see CONUCL)
17235 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17236 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17237* impact parameter (the projectile moving along z)
17238 BIMPC(1) = ZERO
17239 BIMPC(2) = BIMPAC*FM2MM
17240
17241* get position of initial hadron in projectile/target rest-syst.
17242 DO 3 K=1,4
17243 VTXCAS(1,K) = WHKK(K,IDXCAS)
17244 VTXCAS(2,K) = VHKK(K,IDXCAS)
17245 3 CONTINUE
17246
17247 ICAS = 1
17248 I2 = 2
17249 IF (NCAS.EQ.-1) THEN
17250 ICAS = 2
17251 I2 = 1
17252 ENDIF
17253
17254 IF (PTOCAS(ICAS).LT.TINY10) THEN
17255 WRITE(LOUT,1000) PTOCAS
17256 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17257 & ' hadron ',/,20X,2E12.4)
17258 GOTO 9999
17259 ENDIF
17260
17261* reset spectator flags
17262 NSPE = 0
17263 IDXSPE(1) = 0
17264 IDXSPE(2) = 0
17265 IDSPE(1) = 0
17266 IDSPE(2) = 0
17267
17268* formation length (in fm)
17269C IF (LCAS) THEN
17270C DEL0 = ZERO
17271C ELSE
17272 DEL0 = TAUFOR*BGCAS(ICAS)
17273 IF (ITAUVE.EQ.1) THEN
17274 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17275 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17276 ENDIF
17277C ENDIF
17278* sample from exp(-del/del0)
17279 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17280* save formation time
17281 TAUSA1 = DEL1/BGCAS(ICAS)
17282 REL1 = TAUSA1*BGCAS(I2)
17283
17284 DEL = DEL1
17285 TAUSAM = DEL/BGCAS(ICAS)
17286 REL = TAUSAM*BGCAS(I2)
17287
17288* special treatment for negative particles unable to escape
17289* nuclear potential (implemented for ap, pi-, K- only)
17290 LABSOR = .FALSE.
17291 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17292* threshold energy = nuclear potential + Coulomb potential
17293* (nuclear potential for hadron-nucleus interactions only)
17294 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17295 IF (PCAS(ICAS,4).LT.ETHR) THEN
17296 DO 4 K=1,5
17297 PCAS1(K) = PCAS(ICAS,K)
17298 4 CONTINUE
17299* "absorb" negative particle in nucleus
17300 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17301 IF (IREJ1.NE.0) GOTO 9999
17302 IF (NSPE.GE.1) LABSOR = .TRUE.
17303 ENDIF
17304 ENDIF
17305
17306* if the initial particle has not been absorbed proceed with
17307* "normal" cascade
17308 IF (.NOT.LABSOR) THEN
17309
17310* calculate coordinates of hadron at the end of the formation zone
17311* transport-time and -step in the rest system where this step is
17312* treated
17313 DSTEP = DEL*FM2MM
17314 DTIME = DSTEP/BECAS(ICAS)
17315 RSTEP = REL*FM2MM
17316 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17317 RTIME = RSTEP/BECAS(I2)
17318 ELSE
17319 RTIME = ZERO
17320 ENDIF
17321* save step whithout considering the overlapping region
17322 DSTEP1 = DEL1*FM2MM
17323 DTIME1 = DSTEP1/BECAS(ICAS)
17324 RSTEP1 = REL1*FM2MM
17325 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17326 RTIME1 = RSTEP1/BECAS(I2)
17327 ELSE
17328 RTIME1 = ZERO
17329 ENDIF
17330* transport to the end of the formation zone in this system
17331 DO 5 K=1,3
17332 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17333 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17334 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17335 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17336 5 CONTINUE
17337 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17338 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17339 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17340 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17341
17342 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17343 XCAS = VTXCAS(ICAS,1)
17344 YCAS = VTXCAS(ICAS,2)
17345 XNCLTA = BIMPAC*FM2MM
17346 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17347 RNCLTA = (RTARG+RNUCLE)*FM2MM
17348C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17349C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17350C RNCLPR = (RPROJ)*FM2MM
17351C RNCLTA = (RTARG)*FM2MM
17352 RCASPR = SQRT( XCAS**2 +YCAS**2)
17353 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17354 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17355 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17356 ENDIF
17357 ENDIF
17358
17359* check if particle is already outside of the corresp. nucleus
17360 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17361 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17362 IF (RDIST.GE.RNUC(ICAS)) THEN
17363* here: IDCH is the generation of the final state part. starting
17364* with zero for hadronization products
17365* flag particles of generation 0 being outside the nuclei after
17366* formation time (to be used for excitation energy calculation)
17367 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17368 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17369 GOTO 9997
17370 ENDIF
17371 DIST = DLARGE
17372 DISTP = DLARGE
17373 DISTN = DLARGE
17374 IDXP = 0
17375 IDXN = 0
17376
17377* already here: skip particles being outside HADRIN "energy-window"
17378* to avoid wasting of time
17379 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17380 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17381 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17382C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17383C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17384C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17385C & E12.4,', above or below HADRIN-thresholds',I6)
17386 NSPE = 0
17387 GOTO 9997
17388 ENDIF
17389
17390 DO 7 IDXHKK=1,NOINC
17391 I = IDXINC(IDXHKK)
17392* scan DTEVT1 for unwounded or excited nucleons
17393 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17394 DO 8 K=1,3
17395 IF (ICAS.EQ.1) THEN
17396 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17397 ELSEIF (ICAS.EQ.2) THEN
17398 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17399 ENDIF
17400 8 CONTINUE
17401 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17402 & VTXDST(2)*COSCAS(ICAS,2)+
17403 & VTXDST(3)*COSCAS(ICAS,3)
17404* check if nucleon is situated in forward direction
17405 IF (POSNUC.GT.ZERO) THEN
17406* distance between hadron and this nucleon
17407 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17408 & VTXDST(3)**2)
17409* impact parameter
17410 BIMNU2 = DISTNU**2-POSNUC**2
17411 IF (BIMNU2.LT.ZERO) THEN
17412 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17413 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17414 & ' parameter ',/,20X,3E12.4)
17415 GOTO 7
17416 ENDIF
17417 BIMNU = SQRT(BIMNU2)
17418* maximum impact parameter to have interaction
17419 IDNUC = IDT_ICIHAD(IDHKK(I))
17420 IDNUC1 = IDT_MCHAD(IDNUC)
17421 IDCAS1 = IDT_MCHAD(IDCAS)
17422 DO 19 K=1,5
17423 PCAS1(K) = PCAS(ICAS,K)
17424 PNUC(K) = PHKK(K,I)
17425 19 CONTINUE
17426* Lorentz-parameter for trafo into rest-system of target
17427 DO 18 K=1,4
17428 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17429 18 CONTINUE
17430* transformation of projectile into rest-system of target
17431 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17432 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17433 & PPTOT,PX,PY,PZ,PE)
17434**
17435C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17436C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17437 DUMZER = ZERO
17438 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17439 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17440 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17441 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17442 SIGIN = SIGTOT-SIGEL-SIGAB
17443C SIGTOT = SIGIN+SIGEL+SIGAB
17444**
17445 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17446* check if interaction is possible
17447 IF (BIMNU.LE.BIMMAX) THEN
17448* get nucleon with smallest distance and kind of interaction
17449* (elastic/inelastic)
17450 IF (DISTNU.LT.DIST) THEN
17451 DIST = DISTNU
17452 BINT = BIMNU
17453 IF (IDNUC.NE.IDSPE(1)) THEN
17454 IDSPE(2) = IDSPE(1)
17455 IDXSPE(2) = IDXSPE(1)
17456 IDSPE(1) = IDNUC
17457 ENDIF
17458 IDXSPE(1) = I
17459 NSPE = 1
17460**sr
17461 SELA = SIGEL
17462 SABS = SIGAB
17463 STOT = SIGTOT
17464C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17465C SELA = SIGEL
17466C STOT = SIGIN+SIGEL
17467C ELSE
17468C SELA = SIGEL+0.75D0*SIGIN
17469C STOT = 0.25D0*SIGIN+SELA
17470C ENDIF
17471**
17472 ENDIF
17473 ENDIf
17474 ENDIF
17475 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17476 & VTXDST(3)**2)
17477 IDNUC = IDT_ICIHAD(IDHKK(I))
17478 IF (IDNUC.EQ.1) THEN
17479 IF (DISTNU.LT.DISTP) THEN
17480 DISTP = DISTNU
17481 IDXP = I
17482 POSP = POSNUC
17483 ENDIF
17484 ELSEIF (IDNUC.EQ.8) THEN
17485 IF (DISTNU.LT.DISTN) THEN
17486 DISTN = DISTNU
17487 IDXN = I
17488 POSN = POSNUC
17489 ENDIF
17490 ENDIF
17491 ENDIF
17492 7 CONTINUE
17493
17494* there is no nucleon for a secondary interaction
17495 IF (NSPE.EQ.0) GOTO 9997
17496
17497C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17498C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17499 IF (IDXSPE(2).EQ.0) THEN
17500 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17501C DO 80 K=1,3
17502C IF (ICAS.EQ.1) THEN
17503C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17504C ELSEIF (ICAS.EQ.2) THEN
17505C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17506C ENDIF
17507C 80 CONTINUE
17508C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17509C & VTXDST(3)**2)
17510C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17511 IDXSPE(2) = IDXN
17512 IDSPE(2) = 8
17513C ELSE
17514C STOT = STOT-SABS
17515C SABS = ZERO
17516C ENDIF
17517 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17518C DO 81 K=1,3
17519C IF (ICAS.EQ.1) THEN
17520C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17521C ELSEIF (ICAS.EQ.2) THEN
17522C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17523C ENDIF
17524C 81 CONTINUE
17525C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17526C & VTXDST(3)**2)
17527C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17528 IDXSPE(2) = IDXP
17529 IDSPE(2) = 1
17530C ELSE
17531C STOT = STOT-SABS
17532C SABS = ZERO
17533C ENDIF
17534 ELSE
17535 STOT = STOT-SABS
17536 SABS = ZERO
17537 ENDIF
17538 ENDIF
17539 RR = DT_RNDM(DIST)
17540 IF (RR.LT.SELA/STOT) THEN
17541 IPROC = 2
17542 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17543 IPROC = 3
17544 ELSE
17545 IPROC = 1
17546 ENDIF
17547
17548 DO 9 K=1,5
17549 PCAS1(K) = PCAS(ICAS,K)
17550 PNUC(K) = PHKK(K,IDXSPE(1))
17551 9 CONTINUE
17552 IF (IPROC.EQ.3) THEN
17553* 2-nucleon absorption of pion
17554 NSPE = 2
17555 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17556 IF (IREJ1.NE.0) GOTO 9999
17557 IF (NSPE.GE.1) LABSOR = .TRUE.
17558 ELSE
17559* sample secondary interaction
17560 IDNUC = IDBAM(IDXSPE(1))
17561 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17562 IF (IREJ1.EQ.1) GOTO 9999
17563 IF (IREJ1.GT.1) GOTO 9998
17564 ENDIF
17565 ENDIF
17566
17567* update arrays to include Pauli-principle
17568 DO 10 I=1,NSPE
17569 IF (NWOUND(ICAS).LE.299) THEN
17570 NWOUND(ICAS) = NWOUND(ICAS)+1
17571 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17572 ENDIF
17573 10 CONTINUE
17574
17575* dump initial hadron for energy-momentum conservation check
17576 IF (LEMCCK)
17577 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17578 & PCAS(ICAS,4),1,IDUM,IDUM)
17579
17580* dump final state particles into DTEVT1
17581
17582* check if Pauli-principle is fulfilled
17583 NPAULI = 0
17584 NWTMP(1) = NWOUND(1)
17585 NWTMP(2) = NWOUND(2)
17586 DO 111 I=1,NFSP
17587 NPAULI = 0
17588 J1 = 2
17589 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17590 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17591 DO 117 J=1,J1
17592 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17593 IF (J.EQ.1) THEN
17594 IDX = ICAS
17595 PE = PFSP(4,I)
17596 ELSE
17597 IDX = I2
17598 MODE = 1
17599 IF (IDX.EQ.1) MODE = -1
17600 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17601 ENDIF
17602* first check if cascade step is forbidden due to Pauli-principle
17603* (in case of absorpion this step is forced)
17604 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17605 & (IDFSP(I).EQ.8))) THEN
17606* get nuclear potential barrier
17607 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17608 IF (IDFSP(I).EQ.1) THEN
17609 POTLOW = POT-EBINDP(IDX)
17610 ELSE
17611 POTLOW = POT-EBINDN(IDX)
17612 ENDIF
17613* final state particle not able to escape nucleus
17614 IF (PE.LE.POTLOW) THEN
17615* check if there are wounded nucleons
17616 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17617 & EWOUND(IDX,NWOUND(IDX)))) THEN
17618 NPAULI = NPAULI+1
17619 NWOUND(IDX) = NWOUND(IDX)-1
17620 ELSE
17621* interaction prohibited by Pauli-principle
17622 NWOUND(1) = NWTMP(1)
17623 NWOUND(2) = NWTMP(2)
17624 GOTO 9997
17625 ENDIF
17626 ENDIF
17627 ENDIF
17628 117 CONTINUE
17629 111 CONTINUE
17630
17631 NPAULI = 0
17632 NWOUND(1) = NWTMP(1)
17633 NWOUND(2) = NWTMP(2)
17634
17635 DO 11 I=1,NFSP
17636
17637 IST = ISTHKK(IDXCAS)
17638
17639 NPAULI = 0
17640 J1 = 2
17641 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17642 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17643 DO 17 J=1,J1
17644 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17645 IDX = ICAS
17646 PE = PFSP(4,I)
17647 IF (J.EQ.2) THEN
17648 IDX = I2
17649 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17650 ENDIF
17651* first check if cascade step is forbidden due to Pauli-principle
17652* (in case of absorpion this step is forced)
17653 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17654 & (IDFSP(I).EQ.8))) THEN
17655* get nuclear potential barrier
17656 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17657 IF (IDFSP(I).EQ.1) THEN
17658 POTLOW = POT-EBINDP(IDX)
17659 ELSE
17660 POTLOW = POT-EBINDN(IDX)
17661 ENDIF
17662* final state particle not able to escape nucleus
17663 IF (PE.LE.POTLOW) THEN
17664* check if there are wounded nucleons
17665 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17666 & EWOUND(IDX,NWOUND(IDX)))) THEN
17667 NWOUND(IDX) = NWOUND(IDX)-1
17668 NPAULI = NPAULI+1
17669 IST = 14+IDX
17670 ELSE
17671* interaction prohibited by Pauli-principle
17672 NWOUND(1) = NWTMP(1)
17673 NWOUND(2) = NWTMP(2)
17674 GOTO 9997
17675 ENDIF
17676**sr
17677c ELSEIF (PE.LE.POT) THEN
17678cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17679cC NWOUND(IDX) = NWOUND(IDX)-1
17680c**
17681c NPAULI = NPAULI+1
17682c IST = 14+IDX
17683 ENDIF
17684 ENDIF
17685 17 CONTINUE
17686
17687* dump final state particles for energy-momentum conservation check
17688 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17689 & -PFSP(4,I),2,IDUM,IDUM)
17690
17691 PX = PFSP(1,I)
17692 PY = PFSP(2,I)
17693 PZ = PFSP(3,I)
17694 PE = PFSP(4,I)
17695 IF (ABS(IST).EQ.1) THEN
17696* transform particles back into n-n cms
17697* LEPTO: leave final state particles in target rest frame
17698C IF (MCGENE.EQ.3) THEN
17699C PFSP(1,I) = PX
17700C PFSP(2,I) = PY
17701C PFSP(3,I) = PZ
17702C PFSP(4,I) = PE
17703C ELSE
17704 IMODE = ICAS+1
17705 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17706 & PFSP(4,I),IDFSP(I),IMODE)
17707C ENDIF
17708 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17709* target cascade but fsp got stuck in proj. --> transform it into
17710* proj. rest system
17711 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17712 & PFSP(4,I),IDFSP(I),-1)
17713 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17714* proj. cascade but fsp got stuck in target --> transform it into
17715* target rest system
17716 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17717 & PFSP(4,I),IDFSP(I),1)
17718 ENDIF
17719
17720* dump final state particles into DTEVT1
17721 IGEN = IDCH(IDXCAS)+1
17722 ID = IDT_IPDGHA(IDFSP(I))
17723 IXR = 0
17724 IF (LABSOR) IXR = 99
17725 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17726 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17727
17728* update the counter for particles which got stuck inside the nucleus
17729 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17730 NOINC = NOINC+1
17731 IDXINC(NOINC) = NHKK
17732 ENDIF
17733 IF (LABSOR) THEN
17734* in case of absorption the spatial treatment is an approximate
17735* solution anyway (the positions of the nucleons which "absorb" the
17736* cascade particle are not taken into consideration) therefore the
17737* particles are produced at the position of the cascade particle
17738 DO 12 K=1,4
17739 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17740 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17741 12 CONTINUE
17742 ELSE
17743* DDISTL - distance the cascade particle moves to the intera. point
17744* (the position where impact-parameter = distance to the interacting
17745* nucleon), DIST - distance to the interacting nucleon at the time of
17746* formation of the cascade particle, BINT - impact-parameter of this
17747* cascade-interaction
17748 DDISTL = SQRT(DIST**2-BINT**2)
17749 DTIME = DDISTL/BECAS(ICAS)
17750 DTIMEL = DDISTL/BGCAS(ICAS)
17751 RDISTL = DTIMEL*BGCAS(I2)
17752 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17753 RTIME = RDISTL/BECAS(I2)
17754 ELSE
17755 RTIME = ZERO
17756 ENDIF
17757* RDISTL, RTIME are this step and time in the rest system of the other
17758* nucleus
17759 DO 13 K=1,3
17760 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17761 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17762 13 CONTINUE
17763 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17764 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17765* position of particle production is half the impact-parameter to
17766* the interacting nucleon
17767 DO 14 K=1,3
17768 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17769 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17770 14 CONTINUE
17771* time of production of secondary = time of interaction
17772 WHKK(4,NHKK) = VTXCA1(1,4)
17773 VHKK(4,NHKK) = VTXCA1(2,4)
17774 ENDIF
17775
17776 11 CONTINUE
17777
17778* modify status and position of cascade particle (the latter for
17779* statistics reasons only)
17780 ISTHKK(IDXCAS) = 2
17781 IF (LABSOR) ISTHKK(IDXCAS) = 19
17782 IF (.NOT.LABSOR) THEN
17783 DO 15 K=1,4
17784 WHKK(K,IDXCAS) = VTXCA1(1,K)
17785 VHKK(K,IDXCAS) = VTXCA1(2,K)
17786 15 CONTINUE
17787 ENDIF
17788
17789 DO 16 I=1,NSPE
17790 IS = IDXSPE(I)
17791* dump interacting nucleons for energy-momentum conservation check
17792 IF (LEMCCK)
17793 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17794 & 2,IDUM,IDUM)
17795* modify entry for interacting nucleons
17796 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17797 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17798 IF (I.GE.2) THEN
17799 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17800 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17801 ENDIF
17802 16 CONTINUE
17803
17804* check energy-momentum conservation
17805 IF (LEMCCK) THEN
17806 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17807 IF (IREJ1.NE.0) GOTO 9999
17808 ENDIF
17809
17810* update counter
17811 IF (LABSOR) THEN
17812 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17813 ELSE
17814 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17815 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17816 ENDIF
17817
17818 RETURN
17819
17820 9997 CONTINUE
17821 9998 CONTINUE
17822* transport-step but no cascade step due to configuration (i.e. there
17823* is no nucleon for interaction etc.)
17824 IF (LCAS) THEN
17825 DO 100 K=1,4
17826C WHKK(K,IDXCAS) = VTXCAS(1,K)
17827C VHKK(K,IDXCAS) = VTXCAS(2,K)
17828 WHKK(K,IDXCAS) = VTXCA1(1,K)
17829 VHKK(K,IDXCAS) = VTXCA1(2,K)
17830 100 CONTINUE
17831 ENDIF
17832
17833C9998 CONTINUE
17834* no cascade-step because of configuration
17835* (i.e. hadron outside nucleus etc.)
17836 LCAS = .TRUE.
17837 RETURN
17838
17839 9999 CONTINUE
17840* rejection
17841 IREJ = 1
17842 RETURN
17843 END
17844
17845*$ CREATE DT_ABSORP.FOR
17846*COPY DT_ABSORP
17847*
17848*===absorp=============================================================*
17849*
17850 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17851
17852************************************************************************
17853* Two-nucleon absorption of antiprotons, pi-, and K-. *
17854* Antiproton absorption is handled by HADRIN. *
17855* The following channels for meson-absorption are considered: *
17856* pi- + p + p ---> n + p *
17857* pi- + p + n ---> n + n *
17858* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17859* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17860* K- + p + p ---> sigma- + n *
17861* IDCAS, PCAS identity, momentum of particle to be absorbed *
17862* NCAS = 1 intranuclear cascade in projectile *
17863* = -1 intranuclear cascade in target *
17864* NSPE number of spectator nucleons involved *
17865* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17866* Revised version of the original STOPIK written by HJM and J. Ranft. *
17867* This version dated 24.02.95 is written by S. Roesler *
17868************************************************************************
17869
17870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17871 SAVE
17872
17873 PARAMETER ( LINP = 10 ,
17874 & LOUT = 6 ,
17875 & LDAT = 9 )
17876
17877 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17878 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17879
17880* event history
17881
17882 PARAMETER (NMXHKK=200000)
17883
17884 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17885 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17886 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17887
17888* extended event history
17889 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17890 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17891 & IHIST(2,NMXHKK)
17892
17893* flags for input different options
17894 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17895 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17896 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17897
17898* final state after inc step
17899 PARAMETER (MAXFSP=10)
17900 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17901
17902* particle properties (BAMJET index convention)
17903 CHARACTER*8 ANAME
17904 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17905 & IICH(210),IIBAR(210),K1(210),K2(210)
17906
17907 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17908 & PTOT3P(4),BG3P(4),
17909 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17910
17911 IREJ = 0
17912 NFSP = 0
17913
17914* skip particles others than ap, pi-, K- for mode=0
17915 IF ((MODE.EQ.0).AND.
17916 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17917* skip particles others than pions for mode=1
17918* (2-nucleon absorption in intranuclear cascade)
17919 IF ((MODE.EQ.1).AND.
17920 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17921
17922 NUCAS = NCAS
17923 IF (NUCAS.EQ.-1) NUCAS = 2
17924
17925 IF (MODE.EQ.0) THEN
17926* scan spectator nucleons for nucleons being able to "absorb"
17927 NSPE = 0
17928 IDXSPE(1) = 0
17929 IDXSPE(2) = 0
17930 DO 1 I=1,NHKK
17931 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17932 NSPE = NSPE+1
17933 IDXSPE(NSPE) = I
17934 IDSPE(NSPE) = IDBAM(I)
17935 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17936 IF (NSPE.EQ.2) THEN
17937 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17938 & (IDSPE(2).EQ.8)) THEN
17939* there is no pi-+n+n channel
17940 NSPE = 1
17941 GOTO 1
17942 ELSE
17943 GOTO 2
17944 ENDIF
17945 ENDIF
17946 ENDIF
17947 1 CONTINUE
17948
17949 2 CONTINUE
17950 ENDIF
17951* transform excited projectile nucleons (status=15) into proj. rest s.
17952 DO 3 I=1,NSPE
17953 DO 4 K=1,5
17954 PSPE(I,K) = PHKK(K,IDXSPE(I))
17955 4 CONTINUE
17956 3 CONTINUE
17957
17958* antiproton absorption
17959 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17960 DO 5 K=1,5
17961 PSPE1(K) = PSPE(1,K)
17962 5 CONTINUE
17963 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17964 IF (IREJ1.NE.0) GOTO 9999
17965
17966* meson absorption
17967 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17968 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17969 IF (IDCAS.EQ.14) THEN
17970* pi- absorption
17971 IDFSP(1) = 8
17972 IDFSP(2) = 8
17973 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17974 ELSEIF (IDCAS.EQ.13) THEN
17975* pi+ absorption
17976 IDFSP(1) = 1
17977 IDFSP(2) = 1
17978 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17979 ELSEIF (IDCAS.EQ.23) THEN
17980* pi0 absorption
17981 IDFSP(1) = IDSPE(1)
17982 IDFSP(2) = IDSPE(2)
17983 ELSEIF (IDCAS.EQ.16) THEN
17984* K- absorption
17985 R = DT_RNDM(PCAS)
17986 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17987 IF (R.LT.ONETHI) THEN
17988 IDFSP(1) = 21
17989 IDFSP(2) = 8
17990 ELSEIF (R.LT.TWOTHI) THEN
17991 IDFSP(1) = 17
17992 IDFSP(2) = 1
17993 ELSE
17994 IDFSP(1) = 22
17995 IDFSP(2) = 1
17996 ENDIF
17997 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17998 IDFSP(1) = 20
17999 IDFSP(2) = 8
18000 ELSE
18001 IF (R.LT.ONETHI) THEN
18002 IDFSP(1) = 20
18003 IDFSP(2) = 1
18004 ELSEIF (R.LT.TWOTHI) THEN
18005 IDFSP(1) = 17
18006 IDFSP(2) = 8
18007 ELSE
18008 IDFSP(1) = 22
18009 IDFSP(2) = 8
18010 ENDIF
18011 ENDIF
18012 ENDIF
18013* dump initial particles for energy-momentum cons. check
18014 IF (LEMCCK) THEN
18015 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18016 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18017 & IDUM,IDUM)
18018 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18019 & IDUM,IDUM)
18020 ENDIF
18021* get Lorentz-parameter of 3 particle initial state
18022 DO 6 K=1,4
18023 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18024 6 CONTINUE
18025 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18026 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18027 DO 7 K=1,4
18028 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18029 7 CONTINUE
18030* 2-particle decay of the 3-particle compound system
18031 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18032 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18033 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18034 DO 8 I=1,2
18035 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18036 PX = PCMF(I)*COFF(I)*SDF
18037 PY = PCMF(I)*SIFF(I)*SDF
18038 PZ = PCMF(I)*CODF(I)
18039 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18040 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18041 & PFSP(4,I))
18042 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18043* check consistency of kinematics
18044 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18045 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18046 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18047 & ' tree-particle kinematics',/,20X,'id: ',I3,
18048 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18049 ENDIF
18050* dump final state particles for energy-momentum cons. check
18051 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18052 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18053 8 CONTINUE
18054 NFSP = 2
18055 IF (LEMCCK) THEN
18056 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18057 IF (IREJ1.NE.0) THEN
18058 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18059 & AM3P
18060 GOTO 9999
18061 ENDIF
18062 ENDIF
18063 ELSE
18064 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18065 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18066 & ' impossible',/,20X,'too few spectators (',I2,')')
18067 NSPE = 0
18068 ENDIF
18069
18070 RETURN
18071
18072 9999 CONTINUE
18073 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18074 IREJ = 1
18075 RETURN
18076 END
18077
18078*$ CREATE DT_HADRIN.FOR
18079*COPY DT_HADRIN
18080*
18081*===hadrin=============================================================*
18082*
18083 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18084
18085************************************************************************
18086* Interface to the HADRIN-routines for inelastic and elastic *
18087* scattering. *
18088* IDPR,PPR(5) identity, momentum of projectile *
18089* IDTA,PTA(5) identity, momentum of target *
18090* MODE = 1 inelastic interaction *
18091* = 2 elastic interaction *
18092* Revised version of the original FHAD. *
18093* This version dated 27.10.95 is written by S. Roesler *
18094************************************************************************
18095
18096 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18097 SAVE
18098
18099 PARAMETER ( LINP = 10 ,
18100 & LOUT = 6 ,
18101 & LDAT = 9 )
18102
18103 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18104 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18105
18106 LOGICAL LCORR,LMSSG
18107
18108* flags for input different options
18109 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18110 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18111 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18112
18113* final state after inc step
18114 PARAMETER (MAXFSP=10)
18115 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18116
18117* particle properties (BAMJET index convention)
18118 CHARACTER*8 ANAME
18119 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18120 & IICH(210),IIBAR(210),K1(210),K2(210)
18121* output-common for DHADRI/ELHAIN
18122
18123* final state from HADRIN interaction
18124 PARAMETER (MAXFIN=10)
18125 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18126 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18127
18128 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18129 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18130
18131 DATA LMSSG /.TRUE./
18132
18133 IREJ = 0
18134 NFSP = 0
18135 KCORR = 0
18136 IMCORR(1) = 0
18137 IMCORR(2) = 0
18138 LCORR = .FALSE.
18139
18140* dump initial particles for energy-momentum cons. check
18141 IF (LEMCCK) THEN
18142 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18143 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18144 ENDIF
18145
18146 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18147 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18148 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18149 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18150 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18151 IF (LMSSG.AND.(IOULEV(3).GT.0))
18152 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18153 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18154 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18155 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18156 LMSSG = .FALSE.
18157 LCORR = .TRUE.
18158 ENDIF
18159
18160* convert initial state particles into particles which can be
18161* handled by HADRIN
18162 IDHPR = IDPR
18163 IDHTA = IDTA
18164 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18165 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18166 DO 1 K=1,4
18167 P1IN(K) = PPR(K)
18168 P2IN(K) = PTA(K)
18169 1 CONTINUE
18170 XM1 = AAM(IDHPR)
18171 XM2 = AAM(IDHTA)
18172 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18173 IF (IREJ1.GT.0) THEN
18174 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18175 GOTO 9999
18176 ENDIF
18177 DO 2 K=1,4
18178 PPR(K) = P1OUT(K)
18179 PTA(K) = P2OUT(K)
18180 2 CONTINUE
18181 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18182 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18183 ENDIF
18184
18185* Lorentz-parameter for trafo into rest-system of target
18186 DO 3 K=1,4
18187 BGTA(K) = PTA(K)/PTA(5)
18188 3 CONTINUE
18189* transformation of projectile into rest-system of target
18190 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18191 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18192 & PPR1(4))
18193
18194* direction cosines of projectile in target rest system
18195 CX = PPR1(1)/PPRTO1
18196 CY = PPR1(2)/PPRTO1
18197 CZ = PPR1(3)/PPRTO1
18198
18199* sample inelastic interaction
18200 IF (MODE.EQ.1) THEN
18201 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18202 IF (IRH.EQ.1) GOTO 9998
18203* sample elastic interaction
18204 ELSEIF (MODE.EQ.2) THEN
18205 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18206 IF (IREJ1.NE.0) THEN
18207 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18208 GOTO 9999
18209 ENDIF
18210 IF (IRH.EQ.1) GOTO 9998
18211 ELSE
18212 WRITE(LOUT,1001) MODE,INTHAD
18213 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18214 & I4,' (INTHAD =',I4,')')
18215 GOTO 9999
18216 ENDIF
18217
18218* transform final state particles back into Lab.
18219 DO 4 I=1,IRH
18220 NFSP = NFSP+1
18221 PX = CXRH(I)*PLRH(I)
18222 PY = CYRH(I)*PLRH(I)
18223 PZ = CZRH(I)*PLRH(I)
18224 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18225 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18226 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18227 IDFSP(NFSP) = ITRH(I)
18228 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18229 & PFSP(3,NFSP)**2
18230 IF (AMFSP2.LT.-TINY3) THEN
18231 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18232 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18233 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18234 & I2,') with negative mass^2',/,1X,5E12.4)
18235 GOTO 9999
18236 ELSE
18237 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18238 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18239 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18240 & PFSP(5,NFSP)
18241 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18242 & ' (id = ',I2,') with inconsistent mass',/,1X,
18243 & 2E12.4)
18244 KCORR = KCORR+1
18245 IF (KCORR.GT.2) GOTO 9999
18246 IMCORR(KCORR) = NFSP
18247 ENDIF
18248 ENDIF
18249* dump final state particles for energy-momentum cons. check
18250 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18251 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18252 4 CONTINUE
18253
18254* transform momenta on mass shell in case of inconsistencies in
18255* HADRIN
18256 IF (KCORR.GT.0) THEN
18257 IF (KCORR.EQ.2) THEN
18258 I1 = IMCORR(1)
18259 I2 = IMCORR(2)
18260 ELSE
18261 IF (IMCORR(1).EQ.1) THEN
18262 I1 = 1
18263 I2 = 2
18264 ELSE
18265 I1 = 1
18266 I2 = IMCORR(1)
18267 ENDIF
18268 ENDIF
18269 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18270 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18271 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18272 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18273 DO 5 K=1,4
18274 P1IN(K) = PFSP(K,I1)
18275 P2IN(K) = PFSP(K,I2)
18276 5 CONTINUE
18277 XM1 = AAM(IDFSP(I1))
18278 XM2 = AAM(IDFSP(I2))
18279 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18280 IF (IREJ1.GT.0) THEN
18281 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18282C GOTO 9999
18283 ENDIF
18284 DO 6 K=1,4
18285 PFSP(K,I1) = P1OUT(K)
18286 PFSP(K,I2) = P2OUT(K)
18287 6 CONTINUE
18288 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18289 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18290 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18291 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18292* dump final state particles for energy-momentum cons. check
18293 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18294 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18295 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18296 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18297 ENDIF
18298
18299* check energy-momentum conservation
18300 IF (LEMCCK) THEN
18301 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18302 IF (IREJ1.NE.0) GOTO 9999
18303 ENDIF
18304
18305 RETURN
18306
18307 9998 CONTINUE
18308 IREJ = 2
18309 RETURN
18310
18311 9999 CONTINUE
18312 IREJ = 1
18313 RETURN
18314 END
18315
18316*$ CREATE DT_HADCOL.FOR
18317*COPY DT_HADCOL
18318*
18319*===hadcol=============================================================*
18320*
18321 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18322
18323************************************************************************
18324* Interface to the HADRIN-routines for inelastic and elastic *
18325* scattering. This subroutine samples hadron-nucleus interactions *
18326* below DPM-threshold. *
18327* IDPROJ BAMJET-index of projectile hadron *
18328* PPN projectile momentum in target rest frame *
18329* IDXTAR DTEVT1-index of target nucleon undergoing *
18330* interaction with projectile hadron *
18331* This subroutine replaces HADHAD. *
18332* This version dated 5.5.95 is written by S. Roesler *
18333************************************************************************
18334
18335 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18336 SAVE
18337
18338 PARAMETER ( LINP = 10 ,
18339 & LOUT = 6 ,
18340 & LDAT = 9 )
18341
18342 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18343
18344 LOGICAL LSTART
18345
18346* event history
18347
18348 PARAMETER (NMXHKK=200000)
18349
18350 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18351 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18352 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18353
18354* extended event history
18355 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18356 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18357 & IHIST(2,NMXHKK)
18358
18359* nuclear potential
18360 LOGICAL LFERMI
18361 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18362 & EBINDP(2),EBINDN(2),EPOT(2,210),
18363 & ETACOU(2),ICOUL,LFERMI
18364
18365* interface HADRIN-DPM
18366 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18367
18368* parameter for intranuclear cascade
18369 LOGICAL LPAULI
18370 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18371
18372* final state after inc step
18373 PARAMETER (MAXFSP=10)
18374 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18375
18376* particle properties (BAMJET index convention)
18377 CHARACTER*8 ANAME
18378 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18379 & IICH(210),IIBAR(210),K1(210),K2(210)
18380
18381 DIMENSION PPROJ(5),PNUC(5)
18382
18383 DATA LSTART /.TRUE./
18384
18385 IREJ = 0
18386
18387 NPOINT(1) = NHKK+1
18388
18389 TAUSAV = TAUFOR
18390**sr 6/9/01 commented
18391C TAUFOR = TAUFOR/2.0D0
18392**
18393 IF (LSTART) THEN
18394 WRITE(LOUT,1000)
18395 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18396 WRITE(LOUT,1001) TAUFOR
18397 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18398 & F5.1,' fm/c')
18399 LSTART = .FALSE.
18400 ENDIF
18401
18402 IDNUC = IDBAM(IDXTAR)
18403 IDNUC1 = IDT_MCHAD(IDNUC)
18404 IDPRO1 = IDT_MCHAD(IDPROJ)
18405
18406 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18407 IPROC = INTHAD
18408 ELSE
18409**
18410C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18411C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18412 DUMZER = ZERO
18413 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18414 SIGIN = SIGTOT-SIGEL
18415C SIGTOT = SIGIN+SIGEL
18416**
18417 IPROC = 1
18418 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18419 ENDIF
18420
18421 PPROJ(1) = ZERO
18422 PPROJ(2) = ZERO
18423 PPROJ(3) = PPN
18424 PPROJ(5) = AAM(IDPROJ)
18425 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18426 DO 1 K=1,5
18427 PNUC(K) = PHKK(K,IDXTAR)
18428 1 CONTINUE
18429
18430 ILOOP = 0
18431 2 CONTINUE
18432 ILOOP = ILOOP+1
18433 IF (ILOOP.GT.100) GOTO 9999
18434
18435 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18436 IF (IREJ1.EQ.1) GOTO 9999
18437
18438 IF (IREJ1.GT.1) THEN
18439* no interaction possible
18440* require Pauli blocking
18441 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18442 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18443 IF ((IIBAR(IDPROJ).NE.1).AND.
18444 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18445* store incoming particle as final state particle
18446 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18447 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18448 NPOINT(4) = NHKK
18449 ELSE
18450* require Pauli blocking for final state nucleons
18451 DO 4 I=1,NFSP
18452 IF ((IDFSP(I).EQ.1).AND.
18453 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18454 IF ((IDFSP(I).EQ.8).AND.
18455 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18456 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18457 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18458 4 CONTINUE
18459* store final state particles
18460 DO 5 I=1,NFSP
18461 IST = 1
18462 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18463 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18464 IDHAD = IDT_IPDGHA(IDFSP(I))
18465 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18466 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18467 & PCMS,ECMS,0,0,0)
18468 IF (I.EQ.1) NPOINT(4) = NHKK
18469 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18470 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18471 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18472 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18473 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18474 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18475 WHKK(3,NHKK) = WHKK(3,1)
18476 WHKK(4,NHKK) = WHKK(4,1)
18477 5 CONTINUE
18478 ENDIF
18479 TAUFOR = TAUSAV
18480 RETURN
18481
18482 9999 CONTINUE
18483 IREJ = 1
18484 TAUFOR = TAUSAV
18485 RETURN
18486 END
18487*$ CREATE DT_GETEMU.FOR
18488*COPY DT_GETEMU
18489*
18490*===getemu=============================================================*
18491*
18492 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18493
18494************************************************************************
18495* Sampling of emulsion component to be considered as target-nucleus. *
18496* This version dated 6.5.95 is written by S. Roesler. *
18497************************************************************************
18498
18499 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18500 SAVE
18501
18502 PARAMETER ( LINP = 10 ,
18503 & LOUT = 6 ,
18504 & LDAT = 9 )
18505
18506 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18507
18508 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18509
18510* emulsion treatment
18511 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18512 & NCOMPO,IEMUL
18513
18514* Glauber formalism: flags and parameters for statistics
18515 LOGICAL LPROD
18516 CHARACTER*8 CGLB
18517 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18518
18519 IF (MODE.EQ.0) THEN
18520 SUMFRA = ZERO
18521 RR = DT_RNDM(SUMFRA)
18522 IT = 0
18523 ITZ = 0
18524 DO 1 ICOMP=1,NCOMPO
18525 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18526 IF (SUMFRA.GT.RR) THEN
18527 IT = IEMUMA(ICOMP)
18528 ITZ = IEMUCH(ICOMP)
18529 KKMAT = ICOMP
18530 GOTO 2
18531 ENDIF
18532 1 CONTINUE
18533 2 CONTINUE
18534 IF (IT.LE.0) THEN
18535 WRITE(LOUT,'(1X,A,E12.3)')
18536 & 'Warning! norm. failure within emulsion fractions',
18537 & SUMFRA
18538 STOP
18539 ENDIF
18540 ELSEIF (MODE.EQ.1) THEN
18541 NDIFF = 10000
18542 DO 3 I=1,NCOMPO
18543 IDIFF = ABS(IT-IEMUMA(I))
18544 IF (IDIFF.LT.NDIFF) THEN
18545 KKMAT = I
18546 NDIFF = IDIFF
18547 ENDIF
18548 3 CONTINUE
18549 ELSE
18550 STOP 'DT_GETEMU'
18551 ENDIF
18552
18553* bypass for variable projectile/target/energy runs: the correct
18554* Glauber data will be always loaded on kkmat=1
18555 IF (IOGLB.EQ.100) THEN
18556 KKMAT = 1
18557 ENDIF
18558
18559 RETURN
18560 END
18561
18562*$ CREATE DT_NCLPOT.FOR
18563*COPY DT_NCLPOT
18564*
18565*===nclpot=============================================================*
18566*
18567 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18568
18569************************************************************************
18570* Calculation of Coulomb and nuclear potential for a given configurat. *
18571* IPZ, IP charge/mass number of proj. *
18572* ITZ, IT charge/mass number of targ. *
18573* AFERP,AFERT factors modifying proj./target pot. *
18574* if =0, FERMOD is used *
18575* MODE = 0 calculation of binding energy *
18576* = 1 pre-calculated binding energy is used *
18577* This version dated 16.11.95 is written by S. Roesler. *
18578* *
18579* Last change 28.12.2006 by S. Roesler. *
18580************************************************************************
18581
18582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18583 SAVE
18584
18585 PARAMETER ( LINP = 10 ,
18586 & LOUT = 6 ,
18587 & LDAT = 9 )
18588
18589 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18590 & TINY10=1.0D-10)
18591
18592 LOGICAL LSTART
18593
18594* particle properties (BAMJET index convention)
18595 CHARACTER*8 ANAME
18596 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18597 & IICH(210),IIBAR(210),K1(210),K2(210)
18598
18599* nuclear potential
18600 LOGICAL LFERMI
18601 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18602 & EBINDP(2),EBINDN(2),EPOT(2,210),
18603 & ETACOU(2),ICOUL,LFERMI
18604
18605 DIMENSION IDXPOT(14)
18606* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18607 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18608* asig0 asig+ atet0 atet+
18609 & 100, 101, 102, 103/
18610
18611 DATA AN /0.4D0/
18612 DATA LSTART /.TRUE./
18613
18614 IF (MODE.EQ.0) THEN
18615 EBINDP(1) = ZERO
18616 EBINDN(1) = ZERO
18617 EBINDP(2) = ZERO
18618 EBINDN(2) = ZERO
18619 ENDIF
18620 AIP = DBLE(IP)
18621 AIPZ = DBLE(IPZ)
18622 AIT = DBLE(IT)
18623 AITZ = DBLE(ITZ)
18624
18625 FERMIP = AFERP
18626 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18627 FERMIT = AFERT
18628 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18629
18630* Fermi momenta and binding energy for projectile
18631 IF ((IP.GT.1).AND.LFERMI) THEN
18632 IF (MODE.EQ.0) THEN
18633C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18634C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18635 BIP = AIP -ONE
18636 BIPZ = AIPZ-ONE
18637
18638C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18639C & -ENERGY(AIP,AIPZ))
18640 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18641 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18642 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18643
18644 IF (AIP.LE.AIPZ) THEN
18645 EBINDN(1) = EBINDP(1)
18646 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18647 ELSE
18648
18649C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18650C & -ENERGY(AIP,AIPZ))
18651 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18652 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18653 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18654
18655 ENDIF
18656 ENDIF
18657 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18658 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18659 ELSE
18660 PFERMP(1) = ZERO
18661 PFERMN(1) = ZERO
18662 ENDIF
18663* effective nuclear potential for projectile
18664C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18665C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18666 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18667 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18668
18669* Fermi momenta and binding energy for target
18670 IF ((IT.GT.1).AND.LFERMI) THEN
18671 IF (MODE.EQ.0) THEN
18672C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18673C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18674 BIT = AIT -ONE
18675 BITZ = AITZ-ONE
18676
18677C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18678C & -ENERGY(AIT,AITZ))
18679 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18680 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18681 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18682
18683 IF (AIT.LE.AITZ) THEN
18684 EBINDN(2) = EBINDP(2)
18685 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18686 ELSE
18687
18688C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18689C & -ENERGY(AIT,AITZ))
18690 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18691 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18692 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18693
18694 ENDIF
18695 ENDIF
18696 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18697 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18698 ELSE
18699 PFERMP(2) = ZERO
18700 PFERMN(2) = ZERO
18701 ENDIF
18702* effective nuclear potential for target
18703C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18704C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18705 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18706 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18707
18708 DO 2 I=1,14
18709 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18710 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18711 2 CONTINUE
18712
18713* Coulomb energy
18714 ETACOU(1) = ZERO
18715 ETACOU(2) = ZERO
18716 IF (ICOUL.EQ.1) THEN
18717 IF (IP.GT.1)
18718 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18719 IF (IT.GT.1)
18720 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18721 ENDIF
18722
18723 IF (LSTART) THEN
18724 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18725 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18726 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18727 & FERMOD,ETACOU
18728 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18729 & ,' effects',/,12X,'---------------------------',
18730 & '----------------',/,/,38X,'projectile',
18731 & ' target',/,/,1X,'Mass number / charge',
18732 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18733 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18734 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18735 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18736 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18737 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18738 LSTART = .FALSE.
18739 ENDIF
18740
18741 RETURN
18742 END
18743
18744*$ CREATE DT_RESNCL.FOR
18745*COPY DT_RESNCL
18746*
18747*===resncl=============================================================*
18748*
18749 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18750
18751************************************************************************
18752* Treatment of residual nuclei and nuclear effects. *
18753* MODE = 1 initializations *
18754* = 2 treatment of final state *
18755* This version dated 16.11.95 is written by S. Roesler. *
18756* *
18757* Last change 05.01.2007 by S. Roesler. *
18758************************************************************************
18759
18760 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18761 SAVE
18762
18763 PARAMETER ( LINP = 10 ,
18764 & LOUT = 6 ,
18765 & LDAT = 9 )
18766
18767 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18768 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18769 & ONETHI=ONE/THREE)
18770 PARAMETER (AMUAMU = 0.93149432D0,
18771 & FM2MM = 1.0D-12,
18772 & RNUCLE = 1.12D0)
18773 PARAMETER ( EMVGEV = 1.0 D-03 )
18774 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18775 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18776 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18777 PARAMETER ( AMELCT = 0.51099906 D-03 )
18778 PARAMETER ( HLFHLF = 0.5D+00 )
18779 PARAMETER ( FERTHO = 14.33 D-09 )
18780 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18781 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18782 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18783
18784* event history
18785
18786 PARAMETER (NMXHKK=200000)
18787
18788 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18789 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18790 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18791
18792* extended event history
18793 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18794 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18795 & IHIST(2,NMXHKK)
18796
18797* particle properties (BAMJET index convention)
18798 CHARACTER*8 ANAME
18799 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18800 & IICH(210),IIBAR(210),K1(210),K2(210)
18801
18802* flags for input different options
18803 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18804 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18805 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18806
18807* nuclear potential
18808 LOGICAL LFERMI
18809 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18810 & EBINDP(2),EBINDN(2),EPOT(2,210),
18811 & ETACOU(2),ICOUL,LFERMI
18812
18813* properties of interacting particles
18814 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18815
18816* properties of photon/lepton projectiles
18817 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18818
18819* Lorentz-parameters of the current interaction
18820 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18821 & UMO,PPCM,EPROJ,PPROJ
18822
18823* treatment of residual nuclei: wounded nucleons
18824 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18825
18826* treatment of residual nuclei: 4-momenta
18827 LOGICAL LRCLPR,LRCLTA
18828 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18829 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18830
18831 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18832 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18833 & IDXCOR(15000),IDXOTH(NMXHKK)
18834
18835 GOTO (1,2) MODE
18836
18837*------- initializations
18838 1 CONTINUE
18839
18840* initialize arrays for residual nuclei
18841 DO 10 K=1,5
18842 IF (K.LE.4) THEN
18843 PFSP(K) = ZERO
18844 ENDIF
18845 PINIPR(K) = ZERO
18846 PINITA(K) = ZERO
18847 PRCLPR(K) = ZERO
18848 PRCLTA(K) = ZERO
18849 TRCLPR(K) = ZERO
18850 TRCLTA(K) = ZERO
18851 10 CONTINUE
18852 SCPOT = ONE
18853 NLOOP = 0
18854
18855* correction of projectile 4-momentum for effective target pot.
18856* and Coulomb-energy (in case of hadron-nucleus interaction only)
18857 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18858 EPNI = EPN
18859* Coulomb-energy:
18860* positively charged hadron - check energy for Coloumb pot.
18861 IF (IICH(IJPROJ).EQ.1) THEN
18862 THRESH = ETACOU(2)+AAM(IJPROJ)
18863 IF (EPNI.LE.THRESH) THEN
18864 WRITE(LOUT,1000)
18865 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18866 & ' below Coulomb threshold - event rejected',/)
18867 ISTHKK(1) = 1
18868 RETURN
18869 ENDIF
18870* negatively charged hadron - increase energy by Coulomb energy
18871 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18872 EPNI = EPNI+ETACOU(2)
18873 ENDIF
18874 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18875* Effective target potential
18876*sr 6.6. binding energy only (to avoid negative exc. energies)
18877C EPNI = EPNI+EPOT(2,IJPROJ)
18878 EBIPOT = EBINDP(2)
18879 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18880 & EBIPOT = EBINDN(2)
18881 EPNI = EPNI+ABS(EBIPOT)
18882* re-initialization of DTLTRA
18883 DUM1 = ZERO
18884 DUM2 = ZERO
18885 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18886 ENDIF
18887 ENDIF
18888
18889* projectile in n-n cms
18890 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18891 PMASS1 = AAM(IJPROJ)
18892C* VDM assumption
18893C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18894 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18895 PMASS2 = AAM(1)
18896 PM1 = SIGN(PMASS1**2,PMASS1)
18897 PM2 = SIGN(PMASS2**2,PMASS2)
18898 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18899 PINIPR(5) = PMASS1
18900 IF (PMASS1.GT.ZERO) THEN
18901 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18902 & *(PINIPR(4)+PINIPR(5)))
18903 ELSE
18904 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18905 ENDIF
18906 AIT = DBLE(IT)
18907 AITZ = DBLE(ITZ)
18908
18909C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18910 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18911
18912 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18913 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18914 PMASS1 = AAM(1)
18915 PMASS2 = AAM(IJTARG)
18916 PM1 = SIGN(PMASS1**2,PMASS1)
18917 PM2 = SIGN(PMASS2**2,PMASS2)
18918 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18919 PINITA(5) = PMASS2
18920 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18921 & *(PINITA(4)+PINITA(5)))
18922 AIP = DBLE(IP)
18923 AIPZ = DBLE(IPZ)
18924
18925C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18926 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18927
18928 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18929 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18930 AIP = DBLE(IP)
18931 AIPZ = DBLE(IPZ)
18932
18933C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18934 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18935
18936 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18937 AIT = DBLE(IT)
18938 AITZ = DBLE(ITZ)
18939
18940C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18941 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18942
18943 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18944 ENDIF
18945
18946 RETURN
18947
18948*------- treatment of final state
18949 2 CONTINUE
18950
18951 NLOOP = NLOOP+1
18952 IF (NLOOP.GT.1) SCPOT = 0.10D0
18953C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18954
18955 JPW = NPW
18956 JPCW = NPCW
18957 JTW = NTW
18958 JTCW = NTCW
18959 DO 40 K=1,4
18960 PFSP(K) = ZERO
18961 40 CONTINUE
18962
18963 NOB = 0
18964 NOM = 0
18965 DO 900 I=NPOINT(4),NHKK
18966 IDXOTH(I) = -1
18967 IF (ISTHKK(I).EQ.1) THEN
18968 IF (IDBAM(I).EQ.7) GOTO 900
18969 IPOT = 0
18970 IOTHER = 0
18971* particle moving into forward direction
18972 IF (PHKK(3,I).GE.ZERO) THEN
18973* most likely to be effected by projectile potential
18974 IPOT = 1
18975* there is no projectile nucleus, try target
18976 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18977 IPOT = 2
18978 IF (IP.GT.1) IOTHER = 1
18979* there is no target nucleus --> skip
18980 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18981 ENDIF
18982* particle moving into backward direction
18983 ELSE
18984* most likely to be effected by target potential
18985 IPOT = 2
18986* there is no target nucleus, try projectile
18987 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18988 IPOT = 1
18989 IF (IT.GT.1) IOTHER = 1
18990* there is no projectile nucleus --> skip
18991 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18992 ENDIF
18993 ENDIF
18994 IFLG = -IPOT
18995* nobam=3: particle is in overlap-region or neither inside proj. nor target
18996* =1: particle is not in overlap-region AND is inside target (2)
18997* =2: particle is not in overlap-region AND is inside projectile (1)
18998* flag particles which are inside the nucleus ipot but not in its
18999* overlap region
19000 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19001 IF (IDBAM(I).NE.0) THEN
19002* baryons: keep all nucleons and all others where flag is set
19003 IF (IIBAR(IDBAM(I)).NE.0) THEN
19004 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19005 & THEN
19006 NOB = NOB+1
19007 PMOMB(NOB) = PHKK(3,I)
19008 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
19009 & +1000000*IOTHER+I,IFLG)
19010 ENDIF
19011* mesons: keep only those mesons where flag is set
19012 ELSE
19013 IF (IFLG.GT.0) THEN
19014 NOM = NOM+1
19015 PMOMM(NOM) = PHKK(3,I)
19016 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19017 ENDIF
19018 ENDIF
19019 ENDIF
19020 ENDIF
19021 900 CONTINUE
19022*
19023* sort particles in the arrays according to increasing long. momentum
19024 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19025 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19026*
19027* shuffle indices into one and the same array according to the later
19028* sequence of correction
19029 NCOR = 0
19030 IF (IT.GT.1) THEN
19031 DO 910 I=1,NOB
19032 IF (PMOMB(I).GT.ZERO) GOTO 911
19033 NCOR = NCOR+1
19034 IDXCOR(NCOR) = IDXB(I)
19035 910 CONTINUE
19036 911 CONTINUE
19037 IF (IP.GT.1) THEN
19038 DO 912 J=1,NOB
19039 I = NOB+1-J
19040 IF (PMOMB(I).LT.ZERO) GOTO 913
19041 NCOR = NCOR+1
19042 IDXCOR(NCOR) = IDXB(I)
19043 912 CONTINUE
19044 913 CONTINUE
19045 ELSE
19046 DO 914 I=1,NOB
19047 IF (PMOMB(I).GT.ZERO) THEN
19048 NCOR = NCOR+1
19049 IDXCOR(NCOR) = IDXB(I)
19050 ENDIF
19051 914 CONTINUE
19052 ENDIF
19053 ELSE
19054 DO 915 J=1,NOB
19055 I = NOB+1-J
19056 NCOR = NCOR+1
19057 IDXCOR(NCOR) = IDXB(I)
19058 915 CONTINUE
19059 ENDIF
19060 DO 925 I=1,NOM
19061 IF (PMOMM(I).GT.ZERO) GOTO 926
19062 NCOR = NCOR+1
19063 IDXCOR(NCOR) = IDXM(I)
19064 925 CONTINUE
19065 926 CONTINUE
19066 DO 927 J=1,NOM
19067 I = NOM+1-J
19068 IF (PMOMM(I).LT.ZERO) GOTO 928
19069 NCOR = NCOR+1
19070 IDXCOR(NCOR) = IDXM(I)
19071 927 CONTINUE
19072 928 CONTINUE
19073*
19074C IF (NEVHKK.EQ.484) THEN
19075C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19076C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19077C WRITE(LOUT,9001) NOB,NOM,NCOR
19078C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19079C WRITE(LOUT,'(/,A)') ' baryons '
19080C DO 950 I=1,NOB
19081CC J = IABS(IDXB(I))
19082CC INDEX = J-IABS(J/10000000)*10000000
19083C IPOT = IABS(IDXB(I))/10000000
19084C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19085C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19086C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19087C 950 CONTINUE
19088C WRITE(LOUT,'(/,A)') ' mesons '
19089C DO 951 I=1,NOM
19090CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19091C IPOT = IABS(IDXM(I))/10000000
19092C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19093C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19094C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19095C 951 CONTINUE
19096C 9002 FORMAT(1X,4I14,E14.5)
19097C WRITE(LOUT,'(/,A)') ' all '
19098C DO 952 I=1,NCOR
19099CC J = IABS(IDXCOR(I))
19100CC INDEX = J-IABS(J/10000000)*10000000
19101CC IPOT = IABS(IDXCOR(I))/10000000
19102C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19103C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19104C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19105C 952 CONTINUE
19106C 9003 FORMAT(1X,4I14)
19107C ENDIF
19108*
19109 DO 20 ICOR=1,NCOR
19110 IPOT = IABS(IDXCOR(ICOR))/10000000
19111 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19112 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19113 IDXOTH(I) = 1
19114
19115 IDSEC = IDBAM(I)
19116
19117* reduction of particle momentum by corresponding nuclear potential
19118* (this applies only if Fermi-momenta are requested)
19119
19120 IF (LFERMI) THEN
19121
19122* Lorentz-transformation into the rest system of the selected nucleus
19123 IMODE = -IPOT-1
19124 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19125 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19126 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19127 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19128 JPMOD = 0
19129
19130 CHKLEV = TINY3
19131 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19132 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19133 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19134 IF (IOULEV(3).GT.0)
19135 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19136 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19137 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19138 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19139 GOTO 23
19140 ENDIF
19141
19142 DO 21 K=1,4
19143 PSEC0(K) = PSEC(K)
19144 21 CONTINUE
19145
19146* the correction for nuclear potential effects is applied to as many
19147* p/n as many nucleons were wounded; the momenta of other final state
19148* particles are corrected only if they materialize inside the corresp.
19149* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19150* = 3 part. outside proj. and targ., >=10 in overlapping region)
19151 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19152 IF (IPOT.EQ.1) THEN
19153 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19154* this is most likely a wounded nucleon
19155**test
19156C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19157C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19158C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19159C RAD = RNUCLE*DBLE(IP)**ONETHI
19160C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19161C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19162**
19163 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19164 JPW = JPW-1
19165 JPMOD = 1
19166 ELSE
19167* correct only if part. was materialized inside nucleus
19168* and if it is ouside the overlapping region
19169 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19170 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19171 JPMOD = 1
19172 ENDIF
19173 ENDIF
19174 ELSEIF (IPOT.EQ.2) THEN
19175 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19176* this is most likely a wounded nucleon
19177**test
19178C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19179C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19180C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19181C RAD = RNUCLE*DBLE(IT)**ONETHI
19182C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19183C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19184**
19185 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19186 JTW = JTW-1
19187 JPMOD = 1
19188 ELSE
19189* correct only if part. was materialized inside nucleus
19190 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19191 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19192 JPMOD = 1
19193 ENDIF
19194 ENDIF
19195 ENDIF
19196 ELSE
19197 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19198 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19199 JPMOD = 1
19200 ENDIF
19201 ENDIF
19202
19203 IF (NLOOP.EQ.1) THEN
19204* Coulomb energy correction:
19205* the treatment of Coulomb potential correction is similar to the
19206* one for nuclear potential
19207 IF (IDSEC.EQ.1) THEN
19208 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19209 JPCW = JPCW-1
19210 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19211 JTCW = JTCW-1
19212 ELSE
19213 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19214 ENDIF
19215 ELSE
19216 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19217 ENDIF
19218 IF (IICH(IDSEC).EQ.1) THEN
19219* pos. particles: check if they are able to escape Coulomb potential
19220 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19221 ISTHKK(I) = 14+IPOT
19222 IF (ISTHKK(I).EQ.15) THEN
19223 DO 26 K=1,4
19224 PHKK(K,I) = PSEC0(K)
19225 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19226 26 CONTINUE
19227 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19228 IF (IDSEC.EQ.1) NPCW = NPCW-1
19229 ELSEIF (ISTHKK(I).EQ.16) THEN
19230 DO 27 K=1,4
19231 PHKK(K,I) = PSEC0(K)
19232 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19233 27 CONTINUE
19234 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19235 IF (IDSEC.EQ.1) NTCW = NTCW-1
19236 ENDIF
19237 GOTO 20
19238 ENDIF
19239 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19240* neg. particles: decrease energy by Coulomb-potential
19241 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19242 JPMOD = 1
19243 ENDIF
19244 ENDIF
19245
19246 25 CONTINUE
19247
19248 IF (PSEC(4).LT.AMSEC) THEN
19249 IF (IOULEV(6).GT.0)
19250 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19251 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19252 & ' is not allowed to escape nucleus',/,
19253 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19254 & ' mass: ',E12.3)
19255 ISTHKK(I) = 14+IPOT
19256 IF (ISTHKK(I).EQ.15) THEN
19257 DO 28 K=1,4
19258 PHKK(K,I) = PSEC0(K)
19259 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19260 28 CONTINUE
19261 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19262 IF (IDSEC.EQ.1) NPCW = NPCW-1
19263 ELSEIF (ISTHKK(I).EQ.16) THEN
19264 DO 29 K=1,4
19265 PHKK(K,I) = PSEC0(K)
19266 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19267 29 CONTINUE
19268 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19269 IF (IDSEC.EQ.1) NTCW = NTCW-1
19270 ENDIF
19271 GOTO 20
19272 ENDIF
19273
19274 IF (JPMOD.EQ.1) THEN
19275 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19276* 4-momentum after correction for nuclear potential
19277 DO 22 K=1,3
19278 PSEC(K) = PSEC(K)*PSECN/PSECO
19279 22 CONTINUE
19280
19281* store recoil momentum from particles escaping the nuclear potentials
19282 DO 30 K=1,4
19283 IF (IPOT.EQ.1) THEN
19284 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19285 ELSEIF (IPOT.EQ.2) THEN
19286 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19287 ENDIF
19288 30 CONTINUE
19289
19290* transform momentum back into n-n cms
19291 IMODE = IPOT+1
19292 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19293 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19294 & IDSEC,IMODE)
19295 ENDIF
19296
19297 ENDIF
19298
19299 23 CONTINUE
19300 DO 31 K=1,4
19301 PFSP(K) = PFSP(K)+PHKK(K,I)
19302 31 CONTINUE
19303
19304 20 CONTINUE
19305
19306 DO 33 I=NPOINT(4),NHKK
19307 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19308 PFSP(1) = PFSP(1)+PHKK(1,I)
19309 PFSP(2) = PFSP(2)+PHKK(2,I)
19310 PFSP(3) = PFSP(3)+PHKK(3,I)
19311 PFSP(4) = PFSP(4)+PHKK(4,I)
19312 ENDIF
19313 33 CONTINUE
19314
19315 DO 34 K=1,5
19316 PRCLPR(K) = TRCLPR(K)
19317 PRCLTA(K) = TRCLTA(K)
19318 34 CONTINUE
19319
19320 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19321* hadron-nucleus interactions: get residual momentum from energy-
19322* momentum conservation
19323 DO 32 K=1,4
19324 PRCLPR(K) = ZERO
19325 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19326 32 CONTINUE
19327 ELSE
19328* nucleus-hadron, nucleus-nucleus: get residual momentum from
19329* accumulated recoil momenta of particles leaving the spectators
19330* transform accumulated recoil momenta of residual nuclei into
19331* n-n cms
19332 PZI = PRCLPR(3)
19333 PEI = PRCLPR(4)
19334 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19335 PZI = PRCLTA(3)
19336 PEI = PRCLTA(4)
19337 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19338C IF (IP.GT.1) THEN
19339 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19340 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19341C ENDIF
19342 IF (IT.GT.1) THEN
19343 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19344 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19345 ENDIF
19346 ENDIF
19347
19348* check momenta of residual nuclei
19349 IF (LEMCCK) THEN
19350 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19351 & 1,IDUM,IDUM)
19352 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19353 & 2,IDUM,IDUM)
19354 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19355 & 2,IDUM,IDUM)
19356 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19357 & 2,IDUM,IDUM)
19358 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19359**sr 19.12. changed to avoid output when used with phojet
19360C CHKLEV = TINY3
19361 CHKLEV = TINY1
19362 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19363C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19364C & CALL DT_EVTOUT(4)
19365 IF (IREJ1.GT.0) RETURN
19366 ENDIF
19367
19368 RETURN
19369 END
19370
19371*$ CREATE DT_SCN4BA.FOR
19372*COPY DT_SCN4BA
19373*
19374*===scn4ba=============================================================*
19375*
19376 SUBROUTINE DT_SCN4BA
19377
19378************************************************************************
19379* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19380* This version dated 12.12.95 is written by S. Roesler. *
19381************************************************************************
19382
19383 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19384 SAVE
19385
19386 PARAMETER ( LINP = 10 ,
19387 & LOUT = 6 ,
19388 & LDAT = 9 )
19389
19390 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19391 & TINY10=1.0D-10)
19392
19393* event history
19394
19395 PARAMETER (NMXHKK=200000)
19396
19397 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19398 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19399 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19400
19401* extended event history
19402 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19403 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19404 & IHIST(2,NMXHKK)
19405
19406* particle properties (BAMJET index convention)
19407 CHARACTER*8 ANAME
19408 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19409 & IICH(210),IIBAR(210),K1(210),K2(210)
19410
19411* properties of interacting particles
19412 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19413
19414* nuclear potential
19415 LOGICAL LFERMI
19416 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19417 & EBINDP(2),EBINDN(2),EPOT(2,210),
19418 & ETACOU(2),ICOUL,LFERMI
19419
19420* treatment of residual nuclei: wounded nucleons
19421 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19422
19423* treatment of residual nuclei: 4-momenta
19424 LOGICAL LRCLPR,LRCLTA
19425 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19426 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19427
19428 DIMENSION PLAB(2,5),PCMS(4)
19429
19430 IREJ = 0
19431
19432* get number of wounded nucleons
19433 NPW = 0
19434 NPW0 = 0
19435 NPCW = 0
19436 NPSTCK = 0
19437 NTW = 0
19438 NTW0 = 0
19439 NTCW = 0
19440 NTSTCK = 0
19441
19442 ISGLPR = 0
19443 ISGLTA = 0
19444 LRCLPR = .FALSE.
19445 LRCLTA = .FALSE.
19446
19447C DO 2 I=1,NHKK
19448 DO 2 I=1,NPOINT(1)
19449* projectile nucleons wounded in primary interaction and in fzc
19450 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19451 NPW = NPW+1
19452 IPW(NPW) = I
19453 NPSTCK = NPSTCK+1
19454 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19455 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19456C IF (IP.GT.1) THEN
19457 DO 5 K=1,4
19458 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19459 5 CONTINUE
19460C ENDIF
19461* target nucleons wounded in primary interaction and in fzc
19462 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19463 NTW = NTW+1
19464 ITW(NTW) = I
19465 NTSTCK = NTSTCK+1
19466 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19467 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19468 IF (IT.GT.1) THEN
19469 DO 6 K=1,4
19470 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19471 6 CONTINUE
19472 ENDIF
19473 ELSEIF (ISTHKK(I).EQ.13) THEN
19474 ISGLPR = I
19475 ELSEIF (ISTHKK(I).EQ.14) THEN
19476 ISGLTA = I
19477 ENDIF
19478 2 CONTINUE
19479
19480 DO 11 I=NPOINT(4),NHKK
19481* baryons which are unable to escape the nuclear potential of proj.
19482 IF (ISTHKK(I).EQ.15) THEN
19483 ISGLPR = I
19484 NPSTCK = NPSTCK-1
19485 IF (IIBAR(IDBAM(I)).NE.0) THEN
19486 NPW = NPW-1
19487 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19488 ENDIF
19489 DO 7 K=1,4
19490 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19491 7 CONTINUE
19492* baryons which are unable to escape the nuclear potential of targ.
19493 ELSEIF (ISTHKK(I).EQ.16) THEN
19494 ISGLTA = I
19495 NTSTCK = NTSTCK-1
19496 IF (IIBAR(IDBAM(I)).NE.0) THEN
19497 NTW = NTW-1
19498 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19499 ENDIF
19500 DO 8 K=1,4
19501 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19502 8 CONTINUE
19503 ENDIF
19504 11 CONTINUE
19505
19506* residual nuclei so far
19507 IRESP = IP-NPSTCK
19508 IREST = IT-NTSTCK
19509
19510* ckeck for "residual nuclei" consisting of one nucleon only
19511* treat it as final state particle
19512 IF (IRESP.EQ.1) THEN
19513 ID = IDBAM(ISGLPR)
19514 IST = ISTHKK(ISGLPR)
19515 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19516 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19517 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19518 IF (IST.EQ.13) THEN
19519 ISTHKK(ISGLPR) = 11
19520 ELSE
19521 ISTHKK(ISGLPR) = 2
19522 ENDIF
19523 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19524 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19525 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19526 NOBAM(NHKK) = NOBAM(ISGLPR)
19527 JDAHKK(1,ISGLPR) = NHKK
19528 DO 21 K=1,4
19529 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19530 21 CONTINUE
19531 ENDIF
19532 IF (IREST.EQ.1) THEN
19533 ID = IDBAM(ISGLTA)
19534 IST = ISTHKK(ISGLTA)
19535 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19536 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19537 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19538 IF (IST.EQ.14) THEN
19539 ISTHKK(ISGLTA) = 12
19540 ELSE
19541 ISTHKK(ISGLTA) = 2
19542 ENDIF
19543 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19544 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19545 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19546 NOBAM(NHKK) = NOBAM(ISGLTA)
19547 JDAHKK(1,ISGLTA) = NHKK
19548 DO 22 K=1,4
19549 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19550 22 CONTINUE
19551 ENDIF
19552
19553* get nuclear potential corresp. to the residual nucleus
19554 IPRCL = IP -NPW
19555 IPZRCL = IPZ-NPCW
19556 ITRCL = IT -NTW
19557 ITZRCL = ITZ-NTCW
19558 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19559
19560* baryons unable to escape the nuclear potential are treated as
19561* excited nucleons (ISTHKK=15,16)
19562 DO 3 I=NPOINT(4),NHKK
19563 IF (ISTHKK(I).EQ.1) THEN
19564 ID = IDBAM(I)
19565 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19566* final state n and p not being outside of both nuclei are considered
19567 NPOTP = 1
19568 NPOTT = 1
19569 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19570 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19571* Lorentz-trsf. into proj. rest sys. for those being inside proj.
19572 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19573 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19574 & PLAB(1,4),ID,-2)
19575 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19576 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19577 & (PLAB(1,4)+PLABT) ))
19578 EKIN = PLAB(1,4)-PLAB(1,5)
19579 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19580 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19581 ENDIF
19582 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19583 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19584* Lorentz-trsf. into targ. rest sys. for those being inside targ.
19585 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19586 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19587 & PLAB(2,4),ID,-3)
19588 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19589 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19590 & (PLAB(2,4)+PLABT) ))
19591 EKIN = PLAB(2,4)-PLAB(2,5)
19592 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19593 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19594 ENDIF
19595 IF (PHKK(3,I).GE.ZERO) THEN
19596 ISTHKK(I) = NPOTT
19597 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19598 ELSE
19599 ISTHKK(I) = NPOTP
19600 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19601 ENDIF
19602 IF (ISTHKK(I).NE.1) THEN
19603 J = ISTHKK(I)-14
19604 DO 4 K=1,5
19605 PHKK(K,I) = PLAB(J,K)
19606 4 CONTINUE
19607 IF (ISTHKK(I).EQ.15) THEN
19608 NPW = NPW-1
19609 IF (ID.EQ.1) NPCW = NPCW-1
19610 DO 9 K=1,4
19611 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19612 9 CONTINUE
19613 ELSEIF (ISTHKK(I).EQ.16) THEN
19614 NTW = NTW-1
19615 IF (ID.EQ.1) NTCW = NTCW-1
19616 DO 10 K=1,4
19617 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19618 10 CONTINUE
19619 ENDIF
19620 ENDIF
19621 ENDIF
19622 ENDIF
19623 3 CONTINUE
19624
19625* again: get nuclear potential corresp. to the residual nucleus
19626 IPRCL = IP -NPW
19627 IPZRCL = IPZ-NPCW
19628 ITRCL = IT -NTW
19629 ITZRCL = ITZ-NTCW
19630c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19631cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19632c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19633C AFERP = 0.0D0
19634c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19635cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19636c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19637C AFERT = 0.0D0
19638C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19639C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19640C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19641C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19642 AFERP = FERMOD+0.1D0
19643 AFERT = FERMOD+0.1D0
19644
19645 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19646
19647 RETURN
19648 END
19649
19650*$ CREATE DT_FICONF.FOR
19651*COPY DT_FICONF
19652*
19653*===ficonf=============================================================*
19654*
19655 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19656
19657************************************************************************
19658* Treatment of FInal CONFiguration including evaporation, fission and *
19659* Fermi-break-up (for light nuclei only). *
19660* Adopted from the original routine FINALE and extended to residual *
19661* projectile nuclei. *
19662* This version dated 12.12.95 is written by S. Roesler. *
19663* *
19664* Last change 27.12.2006 by S. Roesler. *
19665************************************************************************
19666
19667 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19668 SAVE
19669
19670 PARAMETER ( LINP = 10 ,
19671 & LOUT = 6 ,
19672 & LDAT = 9 )
19673
19674 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19675 PARAMETER (ANGLGB=5.0D-16)
19676
19677* event history
19678
19679 PARAMETER (NMXHKK=200000)
19680
19681 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19682 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19683 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19684
19685* extended event history
19686 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19687 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19688 & IHIST(2,NMXHKK)
19689
19690* rejection counter
19691 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19692 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19693 & IREXCI(3),IRDIFF(2),IRINC
19694
19695* central particle production, impact parameter biasing
19696 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19697
19698* particle properties (BAMJET index convention)
19699 CHARACTER*8 ANAME
19700 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19701 & IICH(210),IIBAR(210),K1(210),K2(210)
19702
19703* treatment of residual nuclei: 4-momenta
19704 LOGICAL LRCLPR,LRCLTA
19705 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19706 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19707
19708* treatment of residual nuclei: properties of residual nuclei
19709 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19710 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19711 & NTOTFI(2),NPROFI(2)
19712
19713* statistics: residual nuclei
19714 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19715 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19716 & NINCST(2,4),NINCEV(2),
19717 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19718 & NRESPB(2),NRESCH(2),NRESEV(4),
19719 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19720 & NEVAFI(2,2)
19721
19722* flags for input different options
19723 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19724 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19725 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19726
19727* INCLUDE '(DIMPAR)'
19728* DIMPAR taken from FLUKA
19729 PARAMETER ( MXXRGN =20000 )
19730 PARAMETER ( MXXMDF = 710 )
19731 PARAMETER ( MXXMDE = 702 )
19732 PARAMETER ( MFSTCK =40000 )
19733 PARAMETER ( MESTCK = 100 )
19734 PARAMETER ( MOSTCK = 2000 )
19735 PARAMETER ( MXPRSN = 100 )
19736 PARAMETER ( MXPDPM = 800 )
19737 PARAMETER ( MXPSCS =30000 )
19738 PARAMETER ( MXGLWN = 300 )
19739 PARAMETER ( MXOUTU = 50 )
19740 PARAMETER ( NALLWP = 64 )
19741 PARAMETER ( NELEMX = 80 )
19742 PARAMETER ( MPDPDX = 18 )
19743 PARAMETER ( MXHTTR = 260 )
19744 PARAMETER ( MXSEAX = 20 )
19745 PARAMETER ( MXHTNC = MXSEAX + 1 )
19746 PARAMETER ( ICOMAX = 2400 )
19747 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19748 PARAMETER ( NSTBIS = 304 )
19749 PARAMETER ( NQSTIS = 46 )
19750 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19751 PARAMETER ( MXPABL = 120 )
19752 PARAMETER ( IDMAXP = 450 )
19753 PARAMETER ( IDMXDC = 2000 )
19754 PARAMETER ( MXMCIN = 410 )
19755 PARAMETER ( IHYPMX = 4 )
19756 PARAMETER ( MKBMX1 = 11 )
19757 PARAMETER ( MKBMX2 = 11 )
19758 PARAMETER ( MXIRRD = 2500 )
19759 PARAMETER ( MXTRDC = 1500 )
19760 PARAMETER ( NKTL = 17 )
19761 PARAMETER ( NBLNMX = 40000000 )
19762
19763* INCLUDE '(GENSTK)'
19764* GENSTK taken from FLUKA
19765 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19766 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19767 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19768 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19769 & TVRECL, TVHEAV, TVBIND,
19770 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19771
19772* INCLUDE '(RESNUC)'
19773* RESNUC from FLUKA
19774 LOGICAL LRNFSS, LFRAGM
19775 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19776 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19777 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19778 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19779 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19780 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19781 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19782 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19783 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19784 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19785 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19786 & LRNFSS, LFRAGM
19787
19788 PARAMETER ( EMVGEV = 1.0 D-03 )
19789 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19790 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19791 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19792 PARAMETER ( AMELCT = 0.51099906 D-03 )
19793 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19794 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19795 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19796 & * 1.D-09 )
19797 PARAMETER ( HLFHLF = 0.5D+00 )
19798 PARAMETER ( FERTHO = 14.33 D-09 )
19799 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19800 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19801 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19802
19803* INCLUDE '(NUCDAT)'
19804* Taken from FLUKA
19805 PARAMETER ( AMUAMU = AMUGEV )
19806 PARAMETER ( AMPROT = AMPRTN )
19807 PARAMETER ( AMNEUT = AMNTRN )
19808 PARAMETER ( AMELEC = AMELCT )
19809 PARAMETER ( R0NUCL = 1.12 D+00 )
19810 PARAMETER ( RCCOUL = 1.7 D+00 )
19811 PARAMETER ( COULPR = COUGFM )
19812 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19813 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19814 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19815 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19816 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19817* Gammin : threshold for deexcitation gammas production, set to 1 keV
19818* (this means that up to 1 keV of energy unbalancing can occur
19819* during an event)
19820 PARAMETER ( GAMMIN = 1.0D-06 )
19821 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19822* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19823 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19824*
19825 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19826 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19827 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19828 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19829 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19830 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19831 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19832 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19833 & ELBNDE (0:110)
19834
19835* INCLUDE '(PAREVT)'
19836* Taken from FLUKA
19837 PARAMETER ( FRDIFF = 0.2D+00 )
19838 PARAMETER ( ETHSEA = 1.0D+00 )
19839*
19840 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19841 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19842 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19843 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19844 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19845 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19846 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19847 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19848 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19849 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19850
19851* INCLUDE '(FHEAVY)'
19852* Taken from FLUKA
19853 PARAMETER ( MXHEAV = 100 )
19854 PARAMETER ( KXHEAV = 30 )
19855 CHARACTER*8 ANHEAV
19856 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19857 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19858 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19859 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19860 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19861 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19862 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19863 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19864 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19865 COMMON / FHEAVC / ANHEAV (KXHEAV)
19866
19867* event flag
19868 COMMON /DTEVNO/ NEVENT,ICASCA
19869
19870 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19871 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19872 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19873
19874 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19875 LOGICAL LLCPOT
19876 DATA EXC,NEXC /520*ZERO,520*0/
19877 DATA EXPNUC /4.0D-3,4.0D-3/
19878
19879 IREJ = 0
19880 LRCLPR = .FALSE.
19881 LRCLTA = .FALSE.
19882
19883* skip residual nucleus treatment if not requested or in case
19884* of central collisions
19885 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19886
19887 DO 1 K=1,2
19888 IDPAR(K) = 0
19889 IDXPAR(K)= 0
19890 NTOT(K) = 0
19891 NTOTFI(K)= 0
19892 NPRO(K) = 0
19893 NPROFI(K)= 0
19894 NN(K) = 0
19895 NH(K) = 0
19896 NHPOS(K) = 0
19897 NQ(K) = 0
19898 EEXC(K) = ZERO
19899 MO1(K) = 0
19900 MO2(K) = 0
19901 DO 2 I=1,4
19902 VRCL(K,I) = ZERO
19903 WRCL(K,I) = ZERO
19904 2 CONTINUE
19905 1 CONTINUE
19906 NFSP = 0
19907 INUC(1) = IP
19908 INUC(2) = IT
19909
19910 DO 3 I=1,NHKK
19911
19912* number of final state particles
19913 IF (ABS(ISTHKK(I)).EQ.1) THEN
19914 NFSP = NFSP+1
19915 IDFSP = IDBAM(I)
19916 ENDIF
19917
19918* properties of remaining nucleon configurations
19919 KF = 0
19920 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19921 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19922 IF (KF.GT.0) THEN
19923 IF (MO1(KF).EQ.0) MO1(KF) = I
19924 MO2(KF) = I
19925* position of residual nucleus = average position of nucleons
19926 DO 4 K=1,4
19927 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19928 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19929 4 CONTINUE
19930* total number of particles contributing to each residual nucleus
19931 NTOT(KF) = NTOT(KF)+1
19932 IDTMP = IDBAM(I)
19933 IDXTMP = I
19934* total charge of residual nuclei
19935 NQ(KF) = NQ(KF)+IICH(IDTMP)
19936* number of protons
19937 IF (IDHKK(I).EQ.2212) THEN
19938 NPRO(KF) = NPRO(KF)+1
19939* number of neutrons
19940 ELSEIF (IDHKK(I).EQ.2112) THEN
19941 NN(KF) = NN(KF)+1
19942 ELSE
19943* number of baryons other than n, p
19944 IF (IIBAR(IDTMP).EQ.1) THEN
19945 NH(KF) = NH(KF)+1
19946 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19947 ELSE
19948* any other mesons (status set to 1)
19949C WRITE(LOUT,1002) KF,IDTMP
19950C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19951C & ' containing meson ',I4,', status set to 1')
19952 ISTHKK(I) = 1
19953 IDTMP = IDPAR(KF)
19954 IDXTMP = IDXPAR(KF)
19955 NTOT(KF) = NTOT(KF)-1
19956 ENDIF
19957 ENDIF
19958 IDPAR(KF) = IDTMP
19959 IDXPAR(KF) = IDXTMP
19960 ENDIF
19961 3 CONTINUE
19962
19963* reject elastic events (def: one final state particle = projectile)
19964 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19965 IREXCI(3) = IREXCI(3)+1
19966 GOTO 9999
19967C RETURN
19968 ENDIF
19969
19970* check if one nucleus disappeared..
19971C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19972C DO 5 K=1,4
19973C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19974C PRCLPR(K) = ZERO
19975C 5 CONTINUE
19976C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19977C DO 6 K=1,4
19978C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19979C PRCLTA(K) = ZERO
19980C 6 CONTINUE
19981C ENDIF
19982
19983 ICOR = 0
19984 INORCL = 0
19985 DO 7 I=1,2
19986 DO 8 K=1,4
19987* get the average of the nucleon positions
19988 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19989 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19990 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19991 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19992 8 CONTINUE
19993* mass number and charge of residual nuclei
19994 AIF(I) = DBLE(NTOT(I))
19995 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19996 IF (NTOT(I).GT.1) THEN
19997* masses of residual nuclei in ground state
19998
19999C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20000 AMRCL0(I) = AIF(I)*AMUC12
20001 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20002
20003* masses of residual nuclei
20004 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20005 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20006 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20007*
20008* M_res^2 < 0 : configuration not allowed
20009*
20010* a) re-calculate E_exc with scaled nuclear potential
20011* (conditional jump to label 9998)
20012* b) or reject event if N_loop(max) is exceeded
20013* (conditional jump to label 9999)
20014*
20015 IF (AMRCL(I).LE.ZERO) THEN
20016 IF (IOULEV(3).GT.0)
20017 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20018 & PRCL(I,4),NTOT
20019 1000 FORMAT(1X,'warning! negative excitation energy',/,
20020 & I4,4E15.4,2I4)
20021 AMRCL(I) = ZERO
20022 EEXC(I) = ZERO
20023 IF (NLOOP.LE.500) THEN
20024 GOTO 9998
20025 ELSE
20026 IREXCI(2) = IREXCI(2)+1
20027 GOTO 9999
20028 ENDIF
20029*
20030* 0 < M_res < M_res0 : mass below ground-state mass
20031*
20032* a) we had residual nuclei with mass N_tot and reasonable E_exc
20033* before- assign average E_exc of those configurations to this
20034* one ( Nexc(i,N_tot) > 0 )
20035* b) or (and this applies always if run in transport codes) go up
20036* one mass number and
20037* i) if mass now larger than proj/targ mass or if run in
20038* transport codes assign average E_exc per wounded nucleon
20039* x number of wounded nucleons (Inuc-Ntot)
20040* ii) or assign average E_exc of those configurations to this
20041* one ( Nexc(i,m) > 0 )
20042*
20043 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20044 & THEN
20045 M = MIN(NTOT(I),260)
20046 IF (NEXC(I,M).GT.0) THEN
20047 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20048 ELSE
20049 70 CONTINUE
20050 M = M+1
20051**sr corrected 27.12.06
20052* IF (M.GE.INUC(I)) THEN
20053* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20054 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20055 IF ( INUC (I) .GT. NTOT (I) ) THEN
20056 AMRCL(I) = AMRCL0(I)
20057 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20058 ELSE
20059 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20060 END IF
20061**
20062 ELSE
20063 IF (NEXC(I,M).GT.0) THEN
20064 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20065 ELSE
20066 GOTO 70
20067 ENDIF
20068 ENDIF
20069 ENDIF
20070 EEXC(I) = AMRCL(I)-AMRCL0(I)
20071 ICOR = ICOR+I
20072*
20073* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20074*
20075* a) re-calculate E_exc with scaled nuclear potential
20076* (conditional jump to label 9998)
20077* b) or reject event if N_loop(max) is exceeded
20078* (conditional jump to label 9999)
20079*
20080*
20081 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20082 IF (IOULEV(3).GT.0)
20083 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20084 1004 FORMAT(1X,'warning! too high excitation energy',/,
20085 & I4,1P,2E15.4,3I5)
20086 AMRCL(I) = ZERO
20087 EEXC(I) = ZERO
20088 IF (NLOOP.LE.500) THEN
20089 GOTO 9998
20090 ELSE
20091 IREXCI(2) = IREXCI(2)+1
20092 GOTO 9999
20093 ENDIF
20094*
20095* Otherwise (reasonable E_exc) :
20096* E_exc = M_res - M_res0
20097* in addition: calculate and save E_exc per wounded nucleon as
20098* well as E_exc in <E_exc> counter
20099*
20100 ELSE
20101* excitation energies of residual nuclei
20102 EEXC(I) = AMRCL(I)-AMRCL0(I)
20103**sr 27.12.06 new excitation energy correction by A.F.
20104*
20105* all parts with Ilcopt<3 commented since not used
20106*
20107* still to be done/decided:
20108* Increase Icor and put back both residual nuclei on mass shell
20109* with the exciting correction further below.
20110* For the moment the modification in the excitation energy is simply
20111* corrected by scaling the energy of the residual nucleus.
20112*
20113 LLCPOT = .TRUE.
20114 ILCOPT = 3
20115 IF ( LLCPOT ) THEN
20116 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20117 IF ( ILCOPT .LE. 2 ) THEN
20118C* Patch for Fermi momentum reduction correlated with impact parameter:
20119C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20120C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20121C AKPRHO = ONE - DLKPRH
20122C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20123C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20124C & 0.05D+00 )
20125C* REDORI = 0.75D+00
20126C* REDORI = ONE
20127C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20128 ELSE
20129 DLKPRH = ZERO
20130 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20131* Take out roughly one/half of the skin:
20132 RDCORE = RDCORE - 0.5D+00
20133 FRCFLL = RDCORE**3
20134 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20135 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20136 FRCFLL = ONE - PRSKIN
20137 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20138 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20139 END IF
20140 IF ( NNCHIT .GT. 0 ) THEN
20141C IF ( ILCOPT .EQ. 1 ) THEN
20142C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20143C DO 1220 NCH = 1, 10
20144C ETAETA = ( ONE - SKINRH**INUC(I)
20145C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20146C & * ( ONE - SKINRH ) )
20147C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20148C & * ( ONE - FRCFLL) * SKINRH )
20149C SKINRH = SKINRH * ( ONE + ETAETA )
20150C 1220 CONTINUE
20151C PRSKIN = SKINRH**(NNCHIT-1)
20152C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20153C PRSKIN = ONE - FRCFLL
20154C END IF
20155 REDCTN = ZERO
20156 DO 1230 NCH = 1, NNCHIT
20157 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20158 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20159 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20160 ELSE
20161 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20162 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20163 END IF
20164 REDCTN = REDCTN + PRFRMI**2
20165 1230 CONTINUE
20166 REDCTN = REDCTN / DBLE (NNCHIT)
20167 ELSE
20168 REDCTN = 0.5D+00
20169 END IF
20170 EEXC (I) = EEXC (I) * REDCTN / REDORI
20171 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20172 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20173 END IF
20174**
20175 IF (ICASCA.EQ.0) THEN
20176 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20177 M = MIN(NTOT(I),260)
20178 EXC(I,M) = EXC(I,M)+EEXC(I)
20179 NEXC(I,M) = NEXC(I,M)+1
20180 ENDIF
20181 ENDIF
20182 ELSEIF (NTOT(I).EQ.1) THEN
20183 WRITE(LOUT,1003) I
20184 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20185 GOTO 9999
20186 ELSE
20187 AMRCL0(I) = ZERO
20188 AMRCL(I) = ZERO
20189 EEXC(I) = ZERO
20190 INORCL = INORCL+I
20191 ENDIF
20192 7 CONTINUE
20193
20194 PRCLPR(5) = AMRCL(1)
20195 PRCLTA(5) = AMRCL(2)
20196
20197 IF (ICOR.GT.0) THEN
20198 IF (INORCL.EQ.0) THEN
20199* one or both residual nuclei consist of one nucleon only, transform
20200* this nucleon on mass shell
20201 DO 9 K=1,4
20202 P1IN(K) = PRCL(1,K)
20203 P2IN(K) = PRCL(2,K)
20204 9 CONTINUE
20205 XM1 = AMRCL(1)
20206 XM2 = AMRCL(2)
20207 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20208 IF (IREJ1.GT.0) THEN
20209 WRITE(LOUT,*) 'ficonf-mashel rejection'
20210 GOTO 9999
20211 ENDIF
20212 DO 10 K=1,4
20213 PRCL(1,K) = P1OUT(K)
20214 PRCL(2,K) = P2OUT(K)
20215 PRCLPR(K) = P1OUT(K)
20216 PRCLTA(K) = P2OUT(K)
20217 10 CONTINUE
20218 PRCLPR(5) = AMRCL(1)
20219 PRCLTA(5) = AMRCL(2)
20220 ELSE
20221 IF (IOULEV(3).GT.0)
20222 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20223 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20224 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20225 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20226 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20227 & ' correction',/,11X,'at event',I8,
20228 & ', nucleon config. 1:',2I4,' 2:',2I4,
20229 & 2(/,11X,3E12.3))
20230 IF (NLOOP.LE.500) THEN
20231 GOTO 9998
20232 ELSE
20233 IREXCI(1) = IREXCI(1)+1
20234 ENDIF
20235 ENDIF
20236 ENDIF
20237
20238* update counter
20239C IF (NRESEV(1).NE.NEVHKK) THEN
20240C NRESEV(1) = NEVHKK
20241C NRESEV(2) = NRESEV(2)+1
20242C ENDIF
20243 NRESEV(2) = NRESEV(2)+1
20244 DO 15 I=1,2
20245 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20246 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20247 NRESTO(I) = NRESTO(I)+NTOT(I)
20248 NRESPR(I) = NRESPR(I)+NPRO(I)
20249 NRESNU(I) = NRESNU(I)+NN(I)
20250 NRESBA(I) = NRESBA(I)+NH(I)
20251 NRESPB(I) = NRESPB(I)+NHPOS(I)
20252 NRESCH(I) = NRESCH(I)+NQ(I)
20253 15 CONTINUE
20254
20255* evaporation
20256 IF (LEVPRT) THEN
20257 DO 13 I=1,2
20258* initialize evaporation counter
20259 EEXCFI(I) = ZERO
20260 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20261 & (EEXC(I).GT.ZERO)) THEN
20262* put residual nuclei into DTEVT1
20263 IDRCL = 80000
20264 JMASS = INT( AIF(I))
20265 JCHAR = INT(AIZF(I))
20266* the following patch is required to transmit the correct excitation
20267* energy to Eventd
20268 IF (ITRSPT.EQ.1) THEN
20269 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20270 & (IOULEV(3).GT.0))
20271 & WRITE(LOUT,*)
20272 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20273 & AMRCL(I),AMRCL0(I),EEXC(I)
20274 PRCL0 = PRCL(I,4)
20275 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20276 & +PRCL(I,3)**2)
20277 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20278 WRITE(LOUT,*)
20279 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20280 ENDIF
20281 ENDIF
20282 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20283 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20284**sr 22.6.97
20285 NOBAM(NHKK) = I
20286**
20287 DO 14 J=1,4
20288 VHKK(J,NHKK) = VRCL(I,J)
20289 WHKK(J,NHKK) = WRCL(I,J)
20290 14 CONTINUE
20291* interface to evaporation module - fill final residual nucleus into
20292* common FKRESN
20293* fill resnuc only if code is not used as event generator in Fluka
20294 IF (ITRSPT.NE.1) THEN
20295 PXRES = PRCL(I,1)
20296 PYRES = PRCL(I,2)
20297 PZRES = PRCL(I,3)
20298 IBRES = NPRO(I)+NN(I)+NH(I)
20299 ICRES = NPRO(I)+NHPOS(I)
20300 ANOW = DBLE(IBRES)
20301 ZNOW = DBLE(ICRES)
20302 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20303* ground state mass of the residual nucleus (should be equal to AM0T)
20304
20305 AMNRES = AMRCL0(I)
20306 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20307
20308* common FKFINU
20309 TV = ZERO
20310* kinetic energy of residual nucleus
20311 TVRECL = PRCL(I,4)-AMRCL(I)
20312* excitation energy of residual nucleus
20313 TVCMS = EEXC(I)
20314 PTOLD = PTRES
20315 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20316 & 2.0D0*(AMMRES+TVCMS))))
20317 IF (PTOLD.LT.ANGLGB) THEN
20318 CALL DT_RACO(PXRES,PYRES,PZRES)
20319 PTOLD = ONE
20320 ENDIF
20321 PXRES = PXRES*PTRES/PTOLD
20322 PYRES = PYRES*PTRES/PTOLD
20323 PZRES = PZRES*PTRES/PTOLD
20324* zero counter of secondaries from evaporation
20325 NP = 0
20326* evaporation
20327 WE = ONE
20328
20329 NPHEAV = 0
20330 LRNFSS = .FALSE.
20331 LFRAGM = .FALSE.
20332 CALL EVEVAP(WE)
20333
20334* put evaporated particles and residual nuclei to DTEVT1
20335 MO = NHKK
20336 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20337 ENDIF
20338 EEXCFI(I) = EXCITF
20339 EXCEVA(I) = EXCEVA(I)+EXCITF
20340 ENDIF
20341 13 CONTINUE
20342 ENDIF
20343
20344 RETURN
20345
20346C9998 IREXCI(1) = IREXCI(1)+1
20347 9998 IREJ = IREJ+1
20348 9999 CONTINUE
20349 LRCLPR = .TRUE.
20350 LRCLTA = .TRUE.
20351 IREJ = IREJ+1
20352 RETURN
20353 END
20354
20355*$ CREATE DT_EVA2HE.FOR
20356*COPY DT_EVA2HE
20357* *
20358*====eva2he============================================================*
20359* *
20360 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20361
20362************************************************************************
20363* Interface between common's of evaporation module (FKFINU,FKFHVY) *
20364* and DTEVT1. *
20365* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20366* EEXCF exitation energy of residual nucleus after evaporation *
20367* IRCL = 1 projectile residual nucleus *
20368* = 2 target residual nucleus *
20369* This version dated 19.04.95 is written by S. Roesler. *
20370* *
20371* Last change 27.12.2006 by S. Roesler. *
20372************************************************************************
20373
20374 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20375 SAVE
20376
20377 PARAMETER ( LINP = 10 ,
20378 & LOUT = 6 ,
20379 & LDAT = 9 )
20380
20381 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20382
20383* event history
20384
20385 PARAMETER (NMXHKK=200000)
20386
20387 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20388 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20389 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20390* Note: DTEVT2 - special use for heavy fragments !
20391* (IDRES(I) = mass number, IDXRES(I) = charge)
20392
20393* extended event history
20394 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20395 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20396 & IHIST(2,NMXHKK)
20397
20398* particle properties (BAMJET index convention)
20399 CHARACTER*8 ANAME
20400 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20401 & IICH(210),IIBAR(210),K1(210),K2(210)
20402
20403* flags for input different options
20404 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20405 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20406 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20407
20408* statistics: residual nuclei
20409 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20410 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20411 & NINCST(2,4),NINCEV(2),
20412 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20413 & NRESPB(2),NRESCH(2),NRESEV(4),
20414 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20415 & NEVAFI(2,2)
20416
20417* treatment of residual nuclei: properties of residual nuclei
20418 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20419 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20420 & NTOTFI(2),NPROFI(2)
20421
20422* INCLUDE '(DIMPAR)'
20423* Taken from FLUKA
20424 PARAMETER ( MXXRGN =20000 )
20425 PARAMETER ( MXXMDF = 710 )
20426 PARAMETER ( MXXMDE = 702 )
20427 PARAMETER ( MFSTCK =40000 )
20428 PARAMETER ( MESTCK = 100 )
20429 PARAMETER ( MOSTCK = 2000 )
20430 PARAMETER ( MXPRSN = 100 )
20431 PARAMETER ( MXPDPM = 800 )
20432 PARAMETER ( MXPSCS =30000 )
20433 PARAMETER ( MXGLWN = 300 )
20434 PARAMETER ( MXOUTU = 50 )
20435 PARAMETER ( NALLWP = 64 )
20436 PARAMETER ( NELEMX = 80 )
20437 PARAMETER ( MPDPDX = 18 )
20438 PARAMETER ( MXHTTR = 260 )
20439 PARAMETER ( MXSEAX = 20 )
20440 PARAMETER ( MXHTNC = MXSEAX + 1 )
20441 PARAMETER ( ICOMAX = 2400 )
20442 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20443 PARAMETER ( NSTBIS = 304 )
20444 PARAMETER ( NQSTIS = 46 )
20445 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20446 PARAMETER ( MXPABL = 120 )
20447 PARAMETER ( IDMAXP = 450 )
20448 PARAMETER ( IDMXDC = 2000 )
20449 PARAMETER ( MXMCIN = 410 )
20450 PARAMETER ( IHYPMX = 4 )
20451 PARAMETER ( MKBMX1 = 11 )
20452 PARAMETER ( MKBMX2 = 11 )
20453 PARAMETER ( MXIRRD = 2500 )
20454 PARAMETER ( MXTRDC = 1500 )
20455 PARAMETER ( NKTL = 17 )
20456 PARAMETER ( NBLNMX = 40000000 )
20457
20458* INCLUDE '(GENSTK)'
20459* Taken from FLUKA
20460 PARAMETER ( MXP = MXPSCS )
20461*
20462 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20463 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20464 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20465 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20466 & TVRECL, TVHEAV, TVBIND,
20467 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20468
20469* INCLUDE '(RESNUC)'
20470 LOGICAL LRNFSS, LFRAGM
20471 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20472 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20473 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20474 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20475 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20476 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20477 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20478 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20479 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20480 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20481 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20482 & LRNFSS, LFRAGM
20483* Taken from FLUKA
20484
20485* INCLUDE '(FHEAVY)'
20486* Taken from FLUKA
20487 PARAMETER ( MXHEAV = 100 )
20488 PARAMETER ( KXHEAV = 30 )
20489 CHARACTER*8 ANHEAV
20490 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20491 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20492 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20493 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20494 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20495 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20496 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20497 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20498 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20499 COMMON / FHEAVC / ANHEAV (KXHEAV)
20500
20501 DIMENSION IPTOKP(39)
20502 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20503 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20504 & 100, 101, 97, 102, 98, 103, 109, 115 /
20505
20506 IREJ = 0
20507
20508* skip if evaporation package is not included
20509 IF (.NOT.LEVAPO) RETURN
20510
20511* update counter
20512 IF (NRESEV(3).NE.NEVHKK) THEN
20513 NRESEV(3) = NEVHKK
20514 NRESEV(4) = NRESEV(4)+1
20515 ENDIF
20516
20517 IF (LEMCCK)
20518 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20519 & IDUM,IDUM)
20520* mass number/charge of residual nucleus before evaporation
20521 IBTOT = IDRES(MO)
20522 IZTOT = IDXRES(MO)
20523
20524* protons/neutrons/gammas
20525 DO 1 I=1,NP
20526 PX = CXR(I)*PLR(I)
20527 PY = CYR(I)*PLR(I)
20528 PZ = CZR(I)*PLR(I)
20529 ID = IPTOKP(KPART(I))
20530 IDPDG = IDT_IPDGHA(ID)
20531 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20532 & (2.0D0*MAX(TKI(I),TINY10))
20533 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20534 WRITE(LOUT,1000) ID,AM,AAM(ID)
20535 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20536 & 'particle',I3,2E10.3)
20537 ENDIF
20538 PE = TKI(I)+AM
20539 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20540 NOBAM(NHKK) = IRCL
20541 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20542 IBTOT = IBTOT-IIBAR(ID)
20543 IZTOT = IZTOT-IICH(ID)
20544 1 CONTINUE
20545
20546* heavy fragments
20547 DO 2 I=1,NPHEAV
20548 PX = CXHEAV(I)*PHEAVY(I)
20549 PY = CYHEAV(I)*PHEAVY(I)
20550 PZ = CZHEAV(I)*PHEAVY(I)
20551 IDHEAV = 80000
20552 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20553 & (2.0D0*MAX(TKHEAV(I),TINY10))
20554 PE = TKHEAV(I)+AM
20555 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20556 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20557 NOBAM(NHKK) = IRCL
20558 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20559 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20560 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20561 2 CONTINUE
20562
20563 IF (IBRES.GT.0) THEN
20564* residual nucleus after evaporation
20565 IDNUC = 80000
20566 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20567 & IBRES,ICRES,0)
20568 NOBAM(NHKK) = IRCL
20569 ENDIF
20570 EEXCF = TVCMS
20571 NTOTFI(IRCL) = IBRES
20572 NPROFI(IRCL) = ICRES
20573 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20574 IBTOT = IBTOT-IBRES
20575 IZTOT = IZTOT-ICRES
20576
20577* count events with fission
20578 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20579 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20580
20581* energy-momentum conservation check
20582 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20583C IF (IREJ.GT.0) THEN
20584C CALL DT_EVTOUT(4)
20585C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20586C ENDIF
20587* baryon-number/charge conservation check
20588 IF (IBTOT+IZTOT.NE.0) THEN
20589 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20590 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20591 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20592 ENDIF
20593
20594 RETURN
20595 END
20596
20597*$ CREATE DT_EBIND.FOR
20598*COPY DT_EBIND
20599*
20600*===ebind==============================================================*
20601*
20602 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20603
20604************************************************************************
20605* Binding energy for nuclei. *
20606* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20607* IA mass number *
20608* IZ atomic number *
20609* This version dated 5.5.95 is updated by S. Roesler. *
20610************************************************************************
20611
20612 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20613 SAVE
20614
20615 PARAMETER ( LINP = 10 ,
20616 & LOUT = 6 ,
20617 & LDAT = 9 )
20618
20619 PARAMETER (ZERO=0.0D0)
20620
20621 DATA A1, A2, A3, A4, A5
20622 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20623
20624 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20625 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20626 DT_EBIND = ZERO
20627 RETURN
20628 ENDIF
20629 AA = IA
20630 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20631 & -A4*(IA-2*IZ)**2/AA
20632 IF (MOD(IA,2).EQ.1) THEN
20633 IA5 = 0
20634 ELSEIF (MOD(IZ,2).EQ.1) THEN
20635 IA5 = 1
20636 ELSE
20637 IA5 = -1
20638 ENDIF
20639 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20640
20641 RETURN
20642 END
20643
20644************************************************************************
20645* *
20646* DPMJET 3.0: cross section routines *
20647* *
20648************************************************************************
20649*
20650*
20651* SUBROUTINE DT_SHNDIF
20652* diffractive cross sections (all energies)
20653* SUBROUTINE DT_PHOXS
20654* total and inel. cross sections from PHOJET interpol. tables
20655* SUBROUTINE DT_XSHN
20656* total and el. cross sections for all energies
20657* SUBROUTINE DT_SIHNAB
20658* pion 2-nucleon absorption cross sections
20659* SUBROUTINE DT_SIGEMU
20660* cross section for target "compounds"
20661* SUBROUTINE DT_SIGGA
20662* photon nucleus cross sections
20663* SUBROUTINE DT_SIGGAT
20664* photon nucleus cross sections from tables
20665* SUBROUTINE DT_SANO
20666* anomalous hard photon-nucleon cross sections from tables
20667* SUBROUTINE DT_SIGGP
20668* photon nucleon cross sections
20669* SUBROUTINE DT_SIGVEL
20670* quasi-elastic vector meson prod. cross sections
20671* DOUBLE PRECISION FUNCTION DT_SIGVP
20672* sigma_VN(tilde)
20673* DOUBLE PRECISION FUNCTION DT_RRM2
20674* DOUBLE PRECISION FUNCTION DT_RM2
20675* DOUBLE PRECISION FUNCTION DT_SAM2
20676* SUBROUTINE DT_CKMT
20677* SUBROUTINE DT_CKMTX
20678* SUBROUTINE DT_PDF0
20679* SUBROUTINE DT_CKMTQ0
20680* SUBROUTINE DT_CKMTDE
20681* SUBROUTINE DT_CKMTPR
20682* FUNCTION DT_CKMTFF
20683*
20684* SUBROUTINE DT_FLUINI
20685* total nucleon cross section fluctuation treatment
20686*
20687* SUBROUTINE DT_SIGTBL
20688* pre-tabulation of low-energy elastic x-sec. using SIHNEL
20689* SUBROUTINE DT_XSTABL
20690* service routines
20691*
20692*
20693*$ CREATE DT_SHNDIF.FOR
20694*COPY DT_SHNDIF
20695*
20696*===shndif===============================================================*
20697*
20698 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20699
20700**********************************************************************
20701* Single diffractive hadron-nucleon cross sections *
20702* S.Roesler 14/1/93 *
20703* *
20704* The cross sections are calculated from extrapolated single *
20705* diffractive antiproton-proton cross sections (DTUJET92) using *
20706* scaling relations between total and single diffractive cross *
20707* sections. *
20708**********************************************************************
20709
20710 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20711 SAVE
20712 PARAMETER (ZERO=0.0D0)
20713
20714* particle properties (BAMJET index convention)
20715 CHARACTER*8 ANAME
20716 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20717 & IICH(210),IIBAR(210),K1(210),K2(210)
20718*
20719 CSD1 = 4.201483727D0
20720 CSD4 = -0.4763103556D-02
20721 CSD5 = 0.4324148297D0
20722*
20723 CHMSD1 = 0.8519297242D0
20724 CHMSD4 = -0.1443076599D-01
20725 CHMSD5 = 0.4014954567D0
20726*
20727 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20728 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20729*
20730 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20731 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20732 FRAC = SHMSD/SDIAPP
20733*
20734 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20735 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20736 & 10, 10, 20, 20, 20) KPROJ
20737*
20738 10 CONTINUE
20739*---------------------------- p - p , n - p , sigma0+- - p ,
20740* Lambda - p
20741 CSD1 = 6.004476070D0
20742 CSD4 = -0.1257784606D-03
20743 CSD5 = 0.2447335720D0
20744 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20745 SIGDIH = FRAC*SIGDIF
20746 RETURN
20747*
20748 20 CONTINUE
20749*
20750 KPSCAL = 2
20751 KTSCAL = 1
20752C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20753 DUMZER = ZERO
20754 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20755 F = SDIAPP/SIGTO
20756 KT = 1
20757C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20758 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20759 SIGDIF = SIGTO*F
20760 SIGDIH = FRAC*SIGDIF
20761 RETURN
20762*
20763 999 CONTINUE
20764*-------------------------- leptons..
20765 SIGDIF = 1.D-10
20766 SIGDIH = 1.D-10
20767 RETURN
20768 END
20769
20770*$ CREATE DT_PHOXS.FOR
20771*COPY DT_PHOXS
20772*
20773*===phoxs================================================================*
20774*
20775 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20776
20777************************************************************************
20778* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20779* interpolation tables. *
20780* This version dated 05.11.97 is written by S. Roesler *
20781************************************************************************
20782
20783 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20784 SAVE
20785
20786 PARAMETER ( LINP = 10 ,
20787 & LOUT = 6 ,
20788 & LDAT = 9 )
20789
20790 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20791 PARAMETER (TWOPI = 6.283185307179586454D+00,
20792 & PI = TWOPI/TWO,
20793 & GEV2MB = 0.38938D0)
20794
20795 LOGICAL LFIRST
20796 DATA LFIRST /.TRUE./
20797
20798* nucleon-nucleon event-generator
20799 CHARACTER*8 CMODEL
20800 LOGICAL LPHOIN
20801 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20802
20803* particle properties (BAMJET index convention)
20804 CHARACTER*8 ANAME
20805 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20806 & IICH(210),IIBAR(210),K1(210),K2(210)
20807
20808**PHOJET105a
20809C PARAMETER (IEETAB=10)
20810C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20811**PHOJET110
20812
20813C energy-interpolation table
20814 INTEGER IEETA2
20815 PARAMETER ( IEETA2 = 20 )
20816 INTEGER ISIMAX
20817 DOUBLE PRECISION SIGTAB,SIGECM
20818 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20819**
20820
20821 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20822 WRITE(LOUT,*) MCGENE
20823 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20824 STOP
20825 ENDIF
20826
20827 IF (ECM.LE.ZERO) THEN
20828 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20829 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20830 ENDIF
20831
20832 IF (MODE.EQ.1) THEN
20833* DL
20834 DELDL = 0.0808D0
20835 EPSDL = -0.4525D0
20836 S = ECM*ECM
20837 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20838 ALPHAP= 0.25D0
20839 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20840 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20841 SINE = STOT-SIGEL
20842 SDIF1 = ZERO
20843 ELSE
20844* Phojet
20845 IP = 1
20846 IF(ECM.LE.SIGECM(IP,1)) THEN
20847 I1 = 1
20848 I2 = 1
20849 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20850 DO 1 I=2,ISIMAX
20851 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20852 1 CONTINUE
20853 2 CONTINUE
20854 I1 = I-1
20855 I2 = I
20856 ELSE
20857 IF (LFIRST) THEN
20858 WRITE(LOUT,'(/1X,A,2E12.3)')
20859 & 'PHOXS: warning! energy above initialization limit (',
20860 & ECM,SIGECM(IP,ISIMAX)
20861 LFIRST = .FALSE.
20862 ENDIF
20863 I1 = ISIMAX
20864 I2 = ISIMAX
20865 ENDIF
20866 FAC2 = ZERO
20867 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20868 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20869 FAC1 = ONE-FAC2
20870 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20871 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20872 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20873 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20874 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20875 ENDIF
20876
20877 RETURN
20878 END
20879
20880*$ CREATE DT_XSHN.FOR
20881*COPY DT_XSHN
20882*
20883*===xshn===============================================================*
20884*
20885 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20886
20887************************************************************************
20888* Total and elastic hadron-nucleon cross section. *
20889* Below 500GeV cross sections are based on the '98 data compilation *
20890* of the PDG. At higher energies PHOJET results are used (patched to *
20891* the low energy data at 500GeV). *
20892* IP projectile index (BAMJET numbering scheme) *
20893* (should be in the range 1..25) *
20894* IT target index (BAMJET numbering scheme) *
20895* (1 = proton, 8 = neutron) *
20896* PL laboratory momentum *
20897* ECM cm. energy (ignored if PL>0) *
20898* STOT total cross section *
20899* SELA elastic cross section *
20900* Last change: 24.4.99 by S. Roesler *
20901************************************************************************
20902
20903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20904 SAVE
20905
20906 PARAMETER ( LINP = 10 ,
20907 & LOUT = 6 ,
20908 & LDAT = 9 )
20909
20910 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20911
20912 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20913 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20914 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20915
20916 LOGICAL LFIRST
20917
20918* particle properties (BAMJET index convention)
20919 CHARACTER*8 ANAME
20920 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20921 & IICH(210),IIBAR(210),K1(210),K2(210)
20922
20923* nucleon-nucleon event-generator
20924 CHARACTER*8 CMODEL
20925 LOGICAL LPHOIN
20926 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20927**PHOJET105a
20928C PARAMETER (IEETAB=10)
20929C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20930**PHOJET110
20931
20932C energy-interpolation table
20933 INTEGER IEETA2
20934 PARAMETER ( IEETA2 = 20 )
20935 INTEGER ISIMAX
20936 DOUBLE PRECISION SIGTAB,SIGECM
20937 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20938
20939 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20940 DIMENSION IDXDAT(25,2)
20941*
20942 DATA APL /
20943 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20944 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20945 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20946 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20947 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20948 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20949 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20950*
20951* total cross sections:
20952* p p
20953 DATA (ASIGTO(1,K),K=1,NPOINT) /
20954 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20955 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20956 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20957 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20958 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20959 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20960 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20961* pbar p
20962 DATA (ASIGTO(2,K),K=1,NPOINT) /
20963 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20964 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20965 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20966 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20967 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20968 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20969 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20970* n p
20971 DATA (ASIGTO(3,K),K=1,NPOINT) /
20972 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20973 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20974 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20975 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20976 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20977 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20978 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20979* pi+ p
20980 DATA (ASIGTO(4,K),K=1,NPOINT) /
20981 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20982 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20983 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20984 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20985 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20986 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20987 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20988* pi- p
20989 DATA (ASIGTO(5,K),K=1,NPOINT) /
20990 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20991 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20992 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20993 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20994 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20995 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20996 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20997* K+ p
20998 DATA (ASIGTO(6,K),K=1,NPOINT) /
20999 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21000 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21001 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21002 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21003 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21004 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21005 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21006* K- p
21007 DATA (ASIGTO(7,K),K=1,NPOINT) /
21008 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21009 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21010 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21011 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21012 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21013 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21014 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21015* K+ n
21016 DATA (ASIGTO(8,K),K=1,NPOINT) /
21017 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21018 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21019 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21020 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21021 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21022 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21023 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21024* K- n
21025 DATA (ASIGTO(9,K),K=1,NPOINT) /
21026 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21027 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21028 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21029 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21030 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21031 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21032 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21033* Lambda p
21034 DATA (ASIGTO(10,K),K=1,NPOINT) /
21035 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21036 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21037 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21038 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21039 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21040 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21041 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21042*
21043* elastic cross sections:
21044* p p
21045 DATA (ASIGEL(1,K),K=1,NPOINT) /
21046 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21047 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21048 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21049 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21050 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21051 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21052 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21053* pbar p
21054 DATA (ASIGEL(2,K),K=1,NPOINT) /
21055 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21056 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21057 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21058 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21059 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21060 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21061 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21062* n p
21063 DATA (ASIGEL(3,K),K=1,NPOINT) /
21064 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21065 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21066 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21067 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21068 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21069 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21070 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21071* pi+ p
21072 DATA (ASIGEL(4,K),K=1,NPOINT) /
21073 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21074 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21075 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21076 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21077 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21078 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21079 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21080* pi- p
21081 DATA (ASIGEL(5,K),K=1,NPOINT) /
21082 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21083 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21084 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21085 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21086 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21087 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21088 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21089* K+ p
21090 DATA (ASIGEL(6,K),K=1,NPOINT) /
21091 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21092 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21093 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21094 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21095 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21096 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21097 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21098* K- p
21099 DATA (ASIGEL(7,K),K=1,NPOINT) /
21100 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21101 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21102 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21103 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21104 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21105 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21106 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21107* K+ n
21108 DATA (ASIGEL(8,K),K=1,NPOINT) /
21109 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21110 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21111 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21112 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21113 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21114 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21115 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21116* K- n
21117 DATA (ASIGEL(9,K),K=1,NPOINT) /
21118 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21119 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21120 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21121 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21122 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21123 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21124 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21125* Lambda p
21126 DATA (ASIGEL(10,K),K=1,NPOINT) /
21127 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21128 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21129 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21130 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21131 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21132 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21133 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21134
21135 DATA (IDXDAT(K,1),K=1,25) /
21136 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21137 & 1, 3,45, 8, 9/
21138 DATA (IDXDAT(K,2),K=1,25) /
21139 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21140 & 3, 1,45, 6, 7/
21141
21142 DATA LFIRST /.TRUE./
21143
21144 IF (LFIRST) THEN
21145 APLABL = LOG10(PLABLO)
21146 APLABH = LOG10(PLABHI)
21147 APTHRE = LOG10(PTHRE)
21148 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21149 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21150 DUM0 = ZERO
21151 PHOPLA = PLABHI
21152 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21153 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21154 IF (MCGENE.EQ.2) THEN
21155 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21156 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21157 ELSE
21158 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21159 ENDIF
21160 ELSE
21161 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21162 ENDIF
21163 PHOSEL = PHOSTO-PHOSIN
21164 APHOST = LOG10(PHOSTO)
21165 APHOSE = LOG10(PHOSEL)
21166 LFIRST = .FALSE.
21167 ENDIF
21168 STOT = ZERO
21169 SELA = ZERO
21170 PLAB = PL
21171 ECMS = ECM
21172 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21173 WRITE(LOUT,1000) IP,IT
21174 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21175 & 'proj/target',2I4)
21176 STOP
21177 ENDIF
21178
21179 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21180 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21181 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21182 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21183 WRITE(LOUT,1001) PLAB,ECMS
21184 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21185 STOP
21186 ENDIF
21187
21188* index of spectrum
21189 IDXP = IP
21190 IF (IP.GT.25) THEN
21191 IF (AAM(IP).GT.ZERO) THEN
21192 IF (ABS(IIBAR(IP)).GT.0) THEN
21193 IDXP = 1
21194 ELSE
21195 IDXP = 13
21196 ENDIF
21197 ELSE
21198 IDXP = 7
21199 ENDIF
21200 ENDIF
21201 IDXT = 1
21202 IF (IT.EQ.8) IDXT = 2
21203 IDXS = IDXDAT(IDXP,IDXT)
21204 IF (IDXS.EQ.0) RETURN
21205
21206* compute momentum bin indices
21207 IF (PLAB.LT.PLABLO) THEN
21208 IDX0 = 1
21209 IDX1 = 1
21210 ELSEIF (PLAB.GE.PLABHI) THEN
21211 IDX0 = NPOINT
21212 IDX1 = NPOINT
21213 ELSE
21214 APLAB = LOG10(PLAB)
21215 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21216 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21217 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21218 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21219 ENDIF
21220 IDX1 = IDX0+1
21221 ENDIF
21222
21223* interpolate cross section
21224 IF (IDXS.GT.10) THEN
21225 IDXS1 = IDXS/10
21226 IDXS2 = IDXS-10*IDXS1
21227 IF (IDX0.EQ.IDX1) THEN
21228 IF (IDX0.EQ.1) THEN
21229 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21230 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21231 ELSE
21232 DUM0 = ZERO
21233 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21234 PHOSEL = PHOSTO-PHOSIN
21235 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21236 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21237 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21238 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21239 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21240 ASELA = 0.5D0*(ASELA1+ASELA2)
21241 ENDIF
21242 ELSE
21243 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21244 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21245 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21246 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21247 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21248 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21249 ASELA1 = ASIGEL(IDXS1,IDX0)+
21250 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21251 ASELA2 = ASIGEL(IDXS2,IDX0)+
21252 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21253 ASELA = 0.5D0*(ASELA1+ASELA2)
21254 ENDIF
21255 ELSE
21256 IF (IDX0.EQ.IDX1) THEN
21257 IF (IDX0.EQ.1) THEN
21258 ASTOT = ASIGTO(IDXS,IDX0)
21259 ASELA = ASIGEL(IDXS,IDX0)
21260 ELSE
21261 DUM0 = ZERO
21262 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21263 PHOSEL = PHOSTO-PHOSIN
21264 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21265 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21266 ENDIF
21267 ELSE
21268 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21269 ASTOT = ASIGTO(IDXS,IDX0)+
21270 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21271 ASELA = ASIGEL(IDXS,IDX0)+
21272 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21273 ENDIF
21274 ENDIF
21275 STOT = 10.0D0**ASTOT
21276 SELA = 10.0D0**ASELA
21277
21278 RETURN
21279 END
21280
21281*$ CREATE DT_SIHNAB.FOR
21282*COPY DT_SIHNAB
21283*
21284*===sihnab===============================================================*
21285*
21286 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21287
21288**********************************************************************
21289* Pion 2-nucleon absorption cross sections. *
21290* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21291* taken from Ritchie PRC 28 (1983) 926 ) *
21292* This version dated 18.05.96 is written by S. Roesler *
21293**********************************************************************
21294
21295 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21296 SAVE
21297 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21298 PARAMETER (AMPR = 938.0D0,
21299 & AMPI = 140.0D0,
21300 & AMDE = TWO*AMPR,
21301 & A = -1.2D0,
21302 & B = 3.5D0,
21303 & C = 7.4D0,
21304 & D = 5600.0D0,
21305 & ER = 2136.0D0)
21306
21307 SIGABS = ZERO
21308 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21309 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21310 PTOT = PLAB*1.0D3
21311 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21312 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21313 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21314 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21315* approximate 3N-abs., I=1-abs. etc.
21316 SIGABS = SIGABS/0.40D0
21317* pi0-absorption (rough approximation!!)
21318 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21319
21320 RETURN
21321 END
21322
21323*$ CREATE DT_SIGEMU.FOR
21324*COPY DT_SIGEMU
21325*
21326*===sigemu=============================================================*
21327*
21328 SUBROUTINE DT_SIGEMU
21329
21330************************************************************************
21331* Combined cross section for target compounds. *
21332* This version dated 6.4.98 is written by S. Roesler *
21333************************************************************************
21334
21335 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21336 SAVE
21337
21338 PARAMETER ( LINP = 10 ,
21339 & LOUT = 6 ,
21340 & LDAT = 9 )
21341
21342 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21343 & OHALF=0.5D0,ONE=1.0D0)
21344
21345 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21346
21347* Glauber formalism: cross sections
21348 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21349 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21350 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21351 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21352 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21353 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21354 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21355 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21356 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21357 & BSLOPE,NEBINI,NQBINI
21358
21359* emulsion treatment
21360 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21361 & NCOMPO,IEMUL
21362
21363* nucleon-nucleon event-generator
21364 CHARACTER*8 CMODEL
21365 LOGICAL LPHOIN
21366 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21367
21368 IF (MCGENE.NE.4) THEN
21369 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21370 WRITE(LOUT,'(15X,A)') '-----------------------'
21371 ENDIF
21372 DO 1 IE=1,NEBINI
21373 DO 2 IQ=1,NQBINI
21374 SIGTOT = ZERO
21375 SIGELA = ZERO
21376 SIGQEP = ZERO
21377 SIGQET = ZERO
21378 SIGQE2 = ZERO
21379 SIGPRO = ZERO
21380 SIGDEL = ZERO
21381 SIGDQE = ZERO
21382 ERRTOT = ZERO
21383 ERRELA = ZERO
21384 ERRQEP = ZERO
21385 ERRQET = ZERO
21386 ERRQE2 = ZERO
21387 ERRPRO = ZERO
21388 ERRDEL = ZERO
21389 ERRDQE = ZERO
21390 IF (NCOMPO.GT.0) THEN
21391 DO 3 IC=1,NCOMPO
21392 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21393 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21394 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21395 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21396 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21397 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21398 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21399 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21400 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21401 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21402 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21403 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21404 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21405 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21406 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21407 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21408 3 CONTINUE
21409 ERRTOT = SQRT(ERRTOT)
21410 ERRELA = SQRT(ERRELA)
21411 ERRQEP = SQRT(ERRQEP)
21412 ERRQET = SQRT(ERRQET)
21413 ERRQE2 = SQRT(ERRQE2)
21414 ERRPRO = SQRT(ERRPRO)
21415 ERRDEL = SQRT(ERRDEL)
21416 ERRDQE = SQRT(ERRDQE)
21417 ELSE
21418 SIGTOT = XSTOT(IE,IQ,1)
21419 SIGELA = XSELA(IE,IQ,1)
21420 SIGQEP = XSQEP(IE,IQ,1)
21421 SIGQET = XSQET(IE,IQ,1)
21422 SIGQE2 = XSQE2(IE,IQ,1)
21423 SIGPRO = XSPRO(IE,IQ,1)
21424 SIGDEL = XSDEL(IE,IQ,1)
21425 SIGDQE = XSDQE(IE,IQ,1)
21426 ERRTOT = XETOT(IE,IQ,1)
21427 ERRELA = XEELA(IE,IQ,1)
21428 ERRQEP = XEQEP(IE,IQ,1)
21429 ERRQET = XEQET(IE,IQ,1)
21430 ERRQE2 = XEQE2(IE,IQ,1)
21431 ERRPRO = XEPRO(IE,IQ,1)
21432 ERRDEL = XEDEL(IE,IQ,1)
21433 ERRDQE = XEDQE(IE,IQ,1)
21434 ENDIF
21435 IF (MCGENE.NE.4) THEN
21436 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21437 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21438 WRITE(LOUT,1001) SIGTOT,ERRTOT
21439 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21440 WRITE(LOUT,1002) SIGELA,ERRELA
21441 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21442 WRITE(LOUT,1003) SIGQEP,ERRQEP
21443 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21444 & F11.5,' mb')
21445 WRITE(LOUT,1004) SIGQET,ERRQET
21446 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21447 & F11.5,' mb')
21448 WRITE(LOUT,1005) SIGQE2,ERRQE2
21449 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21450 & ' +-',F11.5,' mb')
21451 WRITE(LOUT,1006) SIGPRO,ERRPRO
21452 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21453 WRITE(LOUT,1007) SIGDEL,ERRDEL
21454 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21455 WRITE(LOUT,1008) SIGDQE,ERRDQE
21456 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21457 ENDIF
21458
21459 2 CONTINUE
21460 1 CONTINUE
21461
21462 RETURN
21463 END
21464
21465*$ CREATE DT_SIGGA.FOR
21466*COPY DT_SIGGA
21467*
21468*===sigga==============================================================*
21469*
21470 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21471
21472************************************************************************
21473* Total/inelastic photon-nucleus cross sections. *
21474* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21475* production runs !!!! *
21476* This version dated 27.03.96 is written by S. Roesler *
21477************************************************************************
21478
21479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21480 SAVE
21481
21482 PARAMETER ( LINP = 10 ,
21483 & LOUT = 6 ,
21484 & LDAT = 9 )
21485
21486 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21487 & OHALF=0.5D0,ONE=1.0D0)
21488 PARAMETER (AMPROT = 0.938D0)
21489
21490 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21491
21492* Glauber formalism: cross sections
21493 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21494 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21495 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21496 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21497 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21498 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21499 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21500 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21501 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21502 & BSLOPE,NEBINI,NQBINI
21503
21504 NT = NTI
21505 X = XI
21506 Q2 = Q2I
21507 ECM = ECMI
21508 XNU = XNUI
21509 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21510 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21511 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21512 STOT = XSTOT(1,1,1)
21513 ETOT = XETOT(1,1,1)
21514 SIN = XSPRO(1,1,1)
21515 EIN = XEPRO(1,1,1)
21516
21517 RETURN
21518 END
21519
21520*$ CREATE DT_SIGGAT.FOR
21521*COPY DT_SIGGAT
21522*
21523*===siggat=============================================================*
21524*
21525 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21526
21527************************************************************************
21528* Total/inelastic photon-nucleus cross sections. *
21529* Uses pre-tabulated cross section. *
21530* This version dated 29.07.96 is written by S. Roesler *
21531************************************************************************
21532
21533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21534 SAVE
21535
21536 PARAMETER ( LINP = 10 ,
21537 & LOUT = 6 ,
21538 & LDAT = 9 )
21539
21540 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21541 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21542
21543 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21544
21545* Glauber formalism: cross sections
21546 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21547 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21548 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21549 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21550 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21551 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21552 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21553 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21554 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21555 & BSLOPE,NEBINI,NQBINI
21556
21557 NTARG = ABS(NT)
21558 I1 = 1
21559 I2 = 1
21560 RATE = ONE
21561 IF (NEBINI.GT.1) THEN
21562 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21563 I1 = NEBINI
21564 I2 = NEBINI
21565 RATE = ONE
21566 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21567 DO 1 I=2,NEBINI
21568 IF (ECMI.LT.ECMNN(I)) THEN
21569 I1 = I-1
21570 I2 = I
21571 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21572 GOTO 2
21573 ENDIF
21574 1 CONTINUE
21575 2 CONTINUE
21576 ENDIF
21577 ENDIF
21578 J1 = 1
21579 J2 = 1
21580 RATQ = ONE
21581 IF (NQBINI.GT.1) THEN
21582 IF (Q2I.GE.Q2G(NQBINI)) THEN
21583 J1 = NQBINI
21584 J2 = NQBINI
21585 RATQ = ONE
21586 ELSEIF (Q2I.GT.Q2G(1)) THEN
21587 DO 3 I=2,NQBINI
21588 IF (Q2I.LT.Q2G(I)) THEN
21589 J1 = I-1
21590 J2 = I
21591 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21592 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21593C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21594 GOTO 4
21595 ENDIF
21596 3 CONTINUE
21597 4 CONTINUE
21598 ENDIF
21599 ENDIF
21600
21601 STOT = XSTOT(I1,J1,NTARG)+
21602 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21603 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21604 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21605 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21606
21607 RETURN
21608 END
21609
21610*$ CREATE DT_SANO.FOR
21611*COPY DT_SANO
21612*
21613*===sigano=============================================================*
21614*
21615 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21616
21617************************************************************************
21618* This version dated 31.07.96 is written by S. Roesler *
21619************************************************************************
21620
21621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21622 SAVE
21623
21624 PARAMETER ( LINP = 10 ,
21625 & LOUT = 6 ,
21626 & LDAT = 9 )
21627
21628 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21629 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21630 PARAMETER (NE = 8)
21631
21632* VDM parameter for photon-nucleus interactions
21633 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21634
21635* properties of interacting particles
21636 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21637
21638 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21639 DATA ECMANO /
21640 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21641 & 0.100D+04,0.200D+04,0.500D+04
21642 & /
21643* fixed cut (3 GeV/c)
21644 DATA FRAANO /
21645 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21646 & 0.062D+00,0.054D+00,0.042D+00
21647 & /
21648 DATA SIGHRD /
21649 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21650 & 3.3086D-01,7.6255D-01,2.1319D+00
21651 & /
21652* running cut (based on obsolete Phojet-caluclations, bugs..)
21653C DATA FRAANO /
21654C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21655C & 0.167E+00,0.150E+00,0.131E+00
21656C & /
21657C DATA SIGHRD /
21658C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21659C & 2.5736E-01,4.5593E-01,8.2550E-01
21660C & /
21661
21662 DT_SANO = ZERO
21663 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21664 J1 = 0
21665 J2 = 0
21666 RATE = ONE
21667 IF (ECM.GE.ECMANO(NE)) THEN
21668 J1 = NE
21669 J2 = NE
21670 ELSEIF (ECM.GT.ECMANO(1)) THEN
21671 DO 1 IE=2,NE
21672 IF (ECM.LT.ECMANO(IE)) THEN
21673 J1 = IE-1
21674 J2 = IE
21675 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21676 GOTO 2
21677 ENDIF
21678 1 CONTINUE
21679 2 CONTINUE
21680 ENDIF
21681 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21682 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21683 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21684 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21685 ENDIF
21686
21687 RETURN
21688 END
21689
21690*$ CREATE DT_SIGGP.FOR
21691*COPY DT_SIGGP
21692*
21693*===siggp==============================================================*
21694*
21695 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21696
21697************************************************************************
21698* Total/inelastic photon-nucleon cross sections. *
21699* This version dated 30.04.96 is written by S. Roesler *
21700************************************************************************
21701
21702 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21703 SAVE
21704
21705 PARAMETER ( LINP = 10 ,
21706 & LOUT = 6 ,
21707 & LDAT = 9 )
21708
21709 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21710 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21711 & PI = TWOPI/TWO,
21712 & GEV2MB = 0.38938D0,
21713 & ALPHEM = ONE/137.0D0)
21714
21715* particle properties (BAMJET index convention)
21716 CHARACTER*8 ANAME
21717 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21718 & IICH(210),IIBAR(210),K1(210),K2(210)
21719
21720* VDM parameter for photon-nucleus interactions
21721 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21722
21723**PHOJET105a
21724C CHARACTER*8 MDLNA
21725C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21726C PARAMETER (IEETAB=10)
21727C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21728**PHOJET110
21729
21730C model switches and parameters
21731 CHARACTER*8 MDLNA
21732 INTEGER ISWMDL,IPAMDL
21733 DOUBLE PRECISION PARMDL
21734 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21735
21736C energy-interpolation table
21737 INTEGER IEETA2
21738 PARAMETER ( IEETA2 = 20 )
21739 INTEGER ISIMAX
21740 DOUBLE PRECISION SIGTAB,SIGECM
21741 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21742**
21743
21744C PARAMETER (NPOINT=80)
21745 PARAMETER (NPOINT=16)
21746 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21747
21748 STOT = ZERO
21749 SINE = ZERO
21750 SDIR = ZERO
21751
21752 W2 = ECMI**2
21753 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21754 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21755 Q2 = Q2I
21756 X = XI
21757* photoprod.
21758 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21759 Q2 = 0.0001D0
21760 X = Q2/(W2+Q2-AAM(1)**2)
21761* DIS
21762 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21763 X = Q2/(W2+Q2-AAM(1)**2)
21764 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21765 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21766 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21767 W2 = Q2*(ONE-X)/X+AAM(1)**2
21768 ELSE
21769 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21770 STOP
21771 ENDIF
21772 ECM = SQRT(W2)
21773
21774 IF (MODEGA.EQ.1) THEN
21775 SCALE = SQRT(Q2)
21776 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21777 & IDPDF)
21778C W = SQRT(W2)
21779
21780C ALLMF2 = PHO_ALLM97(Q2,W)
21781
21782C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21783 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21784 SINE = ZERO
21785 SDIR = ZERO
21786 ELSEIF (MODEGA.EQ.2) THEN
21787 IF (INTRGE(1).EQ.1) THEN
21788 AMLO2 = (3.0D0*AAM(13))**2
21789 ELSEIF (INTRGE(1).EQ.2) THEN
21790 AMLO2 = AAM(33)**2
21791 ELSE
21792 AMLO2 = AAM(96)**2
21793 ENDIF
21794 IF (INTRGE(2).EQ.1) THEN
21795 AMHI2 = W2/TWO
21796 ELSEIF (INTRGE(2).EQ.2) THEN
21797 AMHI2 = W2/4.0D0
21798 ELSE
21799 AMHI2 = W2
21800 ENDIF
21801 AMHI20 = (ECM-AAM(1))**2
21802 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21803 XAMLO = LOG( AMLO2+Q2 )
21804 XAMHI = LOG( AMHI2+Q2 )
21805**PHOJET105a
21806C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21807**PHOJET112
21808
21809 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21810
21811**
21812 SUM = ZERO
21813 DO 1 J=1,NPOINT
21814 AM2 = EXP(ABSZX(J))-Q2
21815 IF (AM2.LT.16.0D0) THEN
21816 R = TWO
21817 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21818 R = 10.0D0/3.0D0
21819 ELSE
21820 R = 11.0D0/3.0D0
21821 ENDIF
21822C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21823 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21824 & * (ONE+EPSPOL*Q2/AM2)
21825 SUM = SUM+WEIGHT(J)*FAC
21826 1 CONTINUE
21827 SINE = SUM
21828 SDIR = DT_SIGVP(X,Q2)
21829 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21830 SDIR = SDIR/(0.588D0+RL2+Q2)
21831C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21832 ELSEIF (MODEGA.EQ.3) THEN
21833 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21834 ELSEIF (MODEGA.EQ.4) THEN
21835* load cross sections from PHOJET interpolation table
21836 IP = 1
21837 IF(ECM.LE.SIGECM(IP,1)) THEN
21838 I1 = 1
21839 I2 = 1
21840 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21841 DO 2 I=2,ISIMAX
21842 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21843 2 CONTINUE
21844 3 CONTINUE
21845 I1 = I-1
21846 I2 = I
21847 ELSE
21848 WRITE(LOUT,'(/1X,A,2E12.3)')
21849 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21850 I1 = ISIMAX
21851 I2 = ISIMAX
21852 ENDIF
21853 FAC2 = ZERO
21854 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21855 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21856 FAC1 = ONE-FAC2
21857* cross section dependence on photon virtuality
21858 FSUP1 = ZERO
21859 DO 4 I=1,3
21860 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21861 & /(1.D0+Q2/PARMDL(30+I))**2
21862 4 CONTINUE
21863 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21864 FAC1 = FAC1*FSUP1
21865 FAC2 = FAC2*FSUP1
21866 FSUP2 = 1.0D0
21867 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21868 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21869 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21870**re:
21871 STOT = STOT-SDIR
21872**
21873 SDIR = SDIR/(FSUP1*FSUP2)
21874**re:
21875 STOT = STOT+SDIR
21876**
21877 ENDIF
21878
21879 RETURN
21880 END
21881
21882*$ CREATE DT_SIGVEL.FOR
21883*COPY DT_SIGVEL
21884*
21885*===sigvel=============================================================*
21886*
21887 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21888
21889************************************************************************
21890* Cross section for elastic vector meson production *
21891* This version dated 10.05.96 is written by S. Roesler *
21892************************************************************************
21893
21894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21895 SAVE
21896
21897 PARAMETER ( LINP = 10 ,
21898 & LOUT = 6 ,
21899 & LDAT = 9 )
21900
21901 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21902 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21903 & PI = TWOPI/TWO,
21904 & GEV2MB = 0.38938D0,
21905 & ALPHEM = ONE/137.0D0)
21906
21907* particle properties (BAMJET index convention)
21908 CHARACTER*8 ANAME
21909 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21910 & IICH(210),IIBAR(210),K1(210),K2(210)
21911
21912* VDM parameter for photon-nucleus interactions
21913 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21914
21915 W2 = ECMI**2
21916 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21917 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21918 Q2 = Q2I
21919 X = XI
21920* photoprod.
21921 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21922 Q2 = 0.0001D0
21923 X = Q2/(W2+Q2-AAM(1)**2)
21924* DIS
21925 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21926 X = Q2/(W2+Q2-AAM(1)**2)
21927 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21928 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21929 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21930 W2 = Q2*(ONE-X)/X+AAM(1)**2
21931 ELSE
21932 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21933 STOP
21934 ENDIF
21935 ECM = SQRT(W2)
21936
21937 AMV = AAM(IDXV)
21938 AMV2 = AMV**2
21939
21940 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21941 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21942 ROSH = 0.1D0
21943 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21944 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21945
21946 IF (IDXV.EQ.33) THEN
21947 COUPL = 0.00365D0
21948 ELSE
21949 STOP
21950 ENDIF
21951 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21952 SIG2 = SELVP
21953 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21954 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21955
21956 RETURN
21957 END
21958
21959*$ CREATE DT_SIGVP.FOR
21960*COPY DT_SIGVP
21961*
21962*===sigvp==============================================================*
21963*
21964 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21965
21966************************************************************************
21967* sigma_Vp *
21968************************************************************************
21969
21970 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21971 SAVE
21972
21973 PARAMETER ( LINP = 10 ,
21974 & LOUT = 6 ,
21975 & LDAT = 9 )
21976
21977 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21978 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21979 & PI = TWOPI/TWO,
21980 & GEV2MB = 0.38938D0,
21981 & AMPROT = 0.938D0,
21982 & ALPHEM = ONE/137.0D0)
21983
21984* VDM parameter for photon-nucleus interactions
21985 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21986
21987 X = XI
21988 Q2 = Q2I
21989 IF (XI.LE.ZERO) X = 0.0001D0
21990 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21991
21992 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21993
21994 SCALE = SQRT(Q2)
21995 IF (MODEGA.EQ.1) THEN
21996 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21997 & IDPDF)
21998C W = ECM
21999
22000C ALLMF2 = PHO_ALLM97(Q2,W)
22001
22002C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22003C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22004C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22005 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22006 ELSEIF (MODEGA.EQ.4) THEN
22007 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22008C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22009 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22010 ELSE
22011 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22012 ENDIF
22013
22014 RETURN
22015
22016 END
22017
22018*$ CREATE DT_RRM2.FOR
22019*COPY DT_RRM2
22020*
22021*===RRM2===============================================================*
22022*
22023 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22024
22025 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22026 SAVE
22027
22028 PARAMETER ( LINP = 10 ,
22029 & LOUT = 6 ,
22030 & LDAT = 9 )
22031
22032 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22033 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22034 & PI = TWOPI/TWO,
22035 & GEV2MB = 0.38938D0)
22036
22037* particle properties (BAMJET index convention)
22038 CHARACTER*8 ANAME
22039 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22040 & IICH(210),IIBAR(210),K1(210),K2(210)
22041
22042* VDM parameter for photon-nucleus interactions
22043 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22044
22045 S = Q2*(ONE-X)/X+AAM(1)**2
22046 ECM = SQRT(S)
22047
22048 IF (INTRGE(1).EQ.1) THEN
22049 AMLO2 = (3.0D0*AAM(13))**2
22050 ELSEIF (INTRGE(1).EQ.2) THEN
22051 AMLO2 = AAM(33)**2
22052 ELSE
22053 AMLO2 = AAM(96)**2
22054 ENDIF
22055 IF (INTRGE(2).EQ.1) THEN
22056 AMHI2 = S/TWO
22057 ELSEIF (INTRGE(2).EQ.2) THEN
22058 AMHI2 = S/4.0D0
22059 ELSE
22060 AMHI2 = S
22061 ENDIF
22062 AMHI20 = (ECM-AAM(1))**2
22063 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22064
22065 AM1C2 = 16.0D0
22066 AM2C2 = 121.0D0
22067 IF (AMHI2.LE.AM1C2) THEN
22068 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22069 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22070 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22071 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22072 ELSE
22073 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22074 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22075 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22076 ENDIF
22077
22078 RETURN
22079 END
22080
22081*$ CREATE DT_RM2.FOR
22082*COPY DT_RM2
22083*
22084*===RM2================================================================*
22085*
22086 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22087
22088 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22089 SAVE
22090
22091 PARAMETER ( LINP = 10 ,
22092 & LOUT = 6 ,
22093 & LDAT = 9 )
22094
22095 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22096 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22097 & PI = TWOPI/TWO,
22098 & GEV2MB = 0.38938D0)
22099
22100* VDM parameter for photon-nucleus interactions
22101 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22102
22103 IF (RL2.LE.ZERO) THEN
22104 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22105 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22106 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22107 ELSE
22108 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22109 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22110 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22111 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22112 & +EPSPOL*(
22113 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22114 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22115 ENDIF
22116
22117 RETURN
22118 END
22119
22120*$ CREATE DT_SAM2.FOR
22121*COPY DT_SAM2
22122*
22123*===SAM2===============================================================*
22124*
22125 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22126
22127 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22128 SAVE
22129
22130 PARAMETER ( LINP = 10 ,
22131 & LOUT = 6 ,
22132 & LDAT = 9 )
22133
22134 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22135 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22136 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22137 & PI = TWOPI/TWO,
22138 & GEV2MB = 0.38938D0)
22139
22140* particle properties (BAMJET index convention)
22141 CHARACTER*8 ANAME
22142 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22143 & IICH(210),IIBAR(210),K1(210),K2(210)
22144
22145* VDM parameter for photon-nucleus interactions
22146 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22147
22148 S = ECM**2
22149 IF (INTRGE(1).EQ.1) THEN
22150 AMLO2 = (3.0D0*AAM(13))**2
22151 ELSEIF (INTRGE(1).EQ.2) THEN
22152 AMLO2 = AAM(33)**2
22153 ELSE
22154 AMLO2 = AAM(96)**2
22155 ENDIF
22156 IF (INTRGE(2).EQ.1) THEN
22157 AMHI2 = S/TWO
22158 ELSEIF (INTRGE(2).EQ.2) THEN
22159 AMHI2 = S/4.0D0
22160 ELSE
22161 AMHI2 = S
22162 ENDIF
22163 AMHI20 = (ECM-AAM(1))**2
22164 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22165
22166 AM1C2 = 16.0D0
22167 AM2C2 = 121.0D0
22168 YLO = LOG(AMLO2+Q2)
22169 YC1 = LOG(AM1C2+Q2)
22170 YC2 = LOG(AM2C2+Q2)
22171 YHI = LOG(AMHI2+Q2)
22172 IF (AMHI2.LE.AM1C2) THEN
22173 FACHI = TWO
22174 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22175 FACHI = TENTRD
22176 ELSE
22177 FACHI = ELVTRD
22178 ENDIF
22179
22180 1 CONTINUE
22181 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22182 IF (YSAM2.LE.YC1) THEN
22183 FAC = TWO
22184 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22185 FAC = TENTRD
22186 ELSE
22187 FAC = ELVTRD
22188 ENDIF
22189 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22190 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22191 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22192
22193 DT_SAM2 = EXP(YSAM2)-Q2
22194
22195 RETURN
22196 END
22197
22198*$ CREATE DT_CKMT.FOR
22199*COPY DT_CKMT
22200*
22201*===ckmt===============================================================*
22202*
22203 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22204 & F2,IPAR)
22205
22206************************************************************************
22207* This version dated 31.01.96 is written by S. Roesler *
22208************************************************************************
22209
22210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22211 SAVE
22212
22213 PARAMETER ( LINP = 10 ,
22214 & LOUT = 6 ,
22215 & LDAT = 9 )
22216
22217 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22218
22219 PARAMETER (Q02 = 2.0D0,
22220 & DQ2 = 10.05D0,
22221 & Q12 = Q02+DQ2)
22222
22223 DIMENSION PD(-6:6),SEA(3),VAL(2)
22224
22225 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22226 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22227 ADQ2 = LOG10(Q12)-LOG10(Q02)
22228 F2P = (F2Q1-F2Q0)/ADQ2
22229 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22230 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22231 F2PP = (F2PQ1-F2PQ0)/ADQ2
22232 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22233
22234 Q2 = MAX(SCALE**2.0D0,TINY10)
22235 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22236 IF (Q2.LT.Q02) THEN
22237 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22238 UPV = VAL(1)
22239 DNV = VAL(2)
22240 USEA = SEA(1)
22241 DSEA = SEA(2)
22242 STR = SEA(3)
22243 CHM = 0.0D0
22244 BOT = 0.0D0
22245 TOP = 0.0D0
22246 GL = GLU
22247 ELSE
22248 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22249 F2 = F2*SMOOTH
22250 UPV = PD(2)-PD(3)
22251 DNV = PD(1)-PD(3)
22252 USEA = PD(3)
22253 DSEA = PD(3)
22254 STR = PD(3)
22255 CHM = PD(4)
22256 BOT = PD(5)
22257 TOP = PD(6)
22258 GL = PD(0)
22259C UPV = UPV*SMOOTH
22260C DNV = DNV*SMOOTH
22261C USEA = USEA*SMOOTH
22262C DSEA = DSEA*SMOOTH
22263C STR = STR*SMOOTH
22264C CHM = CHM*SMOOTH
22265C GL = GL*SMOOTH
22266 ENDIF
22267
22268 RETURN
22269 END
22270C
22271
22272*$ CREATE DT_CKMTX.FOR
22273*COPY DT_CKMTX
22274 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22275C**********************************************************************
22276C
22277C PDF based on Regge theory, evolved with .... by ....
22278C
22279C input: IPAR 2212 proton (not installed)
22280C 45 Pomeron
22281C 100 Deuteron
22282C
22283C output: PD(-6:6) x*f(x) parton distribution functions
22284C (PDFLIB convention: d = PD(1), u = PD(2) )
22285C
22286C**********************************************************************
22287
22288 SAVE
22289 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22290
22291 PARAMETER ( LINP = 10 ,
22292 & LOUT = 6 ,
22293 & LDAT = 9 )
22294
22295 DIMENSION QQ(7)
22296C
22297 Q2=SNGL(SCALE2)
22298 Q1S=Q2
22299 XX=SNGL(X)
22300C QCD lambda for evolution
22301 OWLAM = 0.23D0
22302 OWLAM2=OWLAM**2
22303C Q0**2 for evolution
22304 Q02 = 2.D0
22305C
22306C
22307C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22308C q(6)=x*charm, q(7)=x*gluon
22309C
22310 SB=0.
22311 IF(Q2-Q02) 1,1,2
22312 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22313 1 CONTINUE
22314 IF(IPAR.EQ.2212) THEN
22315 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22316 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22317 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22318 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22319 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22320 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22321 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22322C ELSEIF (IPAR.EQ.45) THEN
22323C CALL CKMTPO(1,0,XX,SB,QQ(1))
22324C CALL CKMTPO(2,0,XX,SB,QQ(2))
22325C CALL CKMTPO(3,0,XX,SB,QQ(3))
22326C CALL CKMTPO(4,0,XX,SB,QQ(4))
22327C CALL CKMTPO(5,0,XX,SB,QQ(5))
22328C CALL CKMTPO(8,0,XX,SB,QQ(6))
22329C CALL CKMTPO(7,0,XX,SB,QQ(7))
22330 ELSEIF (IPAR.EQ.100) THEN
22331 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22332 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22333 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22334 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22335 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22336 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22337 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22338 ELSE
22339 WRITE(LOUT,'(1X,A,I4,A)')
22340 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22341 STOP
22342 ENDIF
22343C
22344 PD(-6) = 0.D0
22345 PD(-5) = 0.D0
22346 PD(-4) = DBLE(QQ(6))
22347 PD(-3) = DBLE(QQ(3))
22348 PD(-2) = DBLE(QQ(4))
22349 PD(-1) = DBLE(QQ(5))
22350 PD(0) = DBLE(QQ(7))
22351 PD(1) = DBLE(QQ(2))
22352 PD(2) = DBLE(QQ(1))
22353 PD(3) = DBLE(QQ(3))
22354 PD(4) = DBLE(QQ(6))
22355 PD(5) = 0.D0
22356 PD(6) = 0.D0
22357 IF(IPAR.EQ.45) THEN
22358 CDN = (PD(1)-PD(-1))/2.D0
22359 CUP = (PD(2)-PD(-2))/2.D0
22360 PD(-1) = PD(-1) + CDN
22361 PD(-2) = PD(-2) + CUP
22362 PD(1) = PD(-1)
22363 PD(2) = PD(-2)
22364 ENDIF
22365 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22366 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22367 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22368 END
22369C
22370
22371*$ CREATE DT_PDF0.FOR
22372*COPY DT_PDF0
22373*
22374*===pdf0===============================================================*
22375*
22376 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22377
22378************************************************************************
22379* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22380* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22381* IPAR = 2212 proton *
22382* = 100 deuteron *
22383* This version dated 31.01.96 is written by S. Roesler *
22384************************************************************************
22385
22386 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22387 SAVE
22388
22389 PARAMETER ( LINP = 10 ,
22390 & LOUT = 6 ,
22391 & LDAT = 9 )
22392
22393 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22394
22395 PARAMETER (
22396 & AA = 0.1502D0,
22397 & BBDEU = 1.2D0,
22398 & BUD = 0.754D0,
22399 & BDD = 0.4495D0,
22400 & BUP = 1.2064D0,
22401 & BDP = 0.1798D0,
22402 & DELTA0 = 0.07684D0,
22403 & D = 1.117D0,
22404 & C = 3.5489D0,
22405 & A = 0.2631D0,
22406 & B = 0.6452D0,
22407 & ALPHAR = 0.415D0,
22408 & E = 0.1D0
22409 & )
22410
22411 PARAMETER (NPOINT=16)
22412C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22413 DIMENSION SEA(3),VAL(2)
22414
22415 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22416 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22417* proton, deuteron
22418 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22419 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22420 SEA(1) = 0.75D0*SEA0
22421 SEA(2) = SEA(1)
22422 SEA(3) = SEA(1)
22423 VAL(1) = 9.0D0/4.0D0*VALU0
22424 VAL(2) = 9.0D0*VALD0
22425 GLU0 = SEA(1)/(1.0D0-X)
22426 F2 = SEA0+VALU0+VALD0
22427 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22428 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22429 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22430 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22431 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22432 STOP
22433 ENDIF
22434**PHOJET105a
22435C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22436**PHOJET112
22437
22438C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22439
22440**
22441C SUMQ = ZERO
22442C SUMG = ZERO
22443C DO 1 J=1,NPOINT
22444C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22445C VALU0 = 9.0D0/4.0D0*VALU0
22446C VALD0 = 9.0D0*VALD0
22447C SEA0 = 0.75D0*SEA0
22448C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22449C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22450C 1 CONTINUE
22451C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22452 ELSE
22453 WRITE(LOUT,'(1X,A,I4,A)')
22454 & 'PDF0: IPAR =',IPAR,' not implemented!'
22455 STOP
22456 ENDIF
22457
22458 RETURN
22459 END
22460
22461*$ CREATE DT_CKMTQ0.FOR
22462*COPY DT_CKMTQ0
22463*
22464*===ckmtq0=============================================================*
22465*
22466 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22467
22468************************************************************************
22469* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22470* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22471* IPAR = 2212 proton *
22472* = 100 deuteron *
22473* This version dated 31.01.96 is written by S. Roesler *
22474************************************************************************
22475
22476 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22477 SAVE
22478
22479 PARAMETER ( LINP = 10 ,
22480 & LOUT = 6 ,
22481 & LDAT = 9 )
22482
22483 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22484
22485 PARAMETER (
22486 & AA = 0.1502D0,
22487 & BBDEU = 1.2D0,
22488 & BUD = 0.754D0,
22489 & BDD = 0.4495D0,
22490 & BUP = 1.2064D0,
22491 & BDP = 0.1798D0,
22492 & DELTA0 = 0.07684D0,
22493 & D = 1.117D0,
22494 & C = 3.5489D0,
22495 & A = 0.2631D0,
22496 & B = 0.6452D0,
22497 & ALPHAR = 0.415D0,
22498 & E = 0.1D0
22499 & )
22500
22501 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22502 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22503* proton, deuteron
22504 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22505 IF (IPAR.EQ.2212) THEN
22506 BU = BUP
22507 BD = BDP
22508 ELSE
22509 BU = BUD
22510 BD = BDD
22511 ENDIF
22512 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22513 & (Q2/(Q2+A))**(1.0D0+DELTA)
22514 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22515 & (Q2/(Q2+B))**(ALPHAR)
22516 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22517 & (Q2/(Q2+B))**(ALPHAR)
22518 ELSE
22519 WRITE(LOUT,'(1X,A,I4,A)')
22520 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22521 STOP
22522 ENDIF
22523 RETURN
22524 END
22525C
22526C
22527
22528*$ CREATE DT_CKMTDE.FOR
22529*COPY DT_CKMTDE
22530 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22531C
22532C**********************************************************************
22533C Deuteron - PDFs
22534C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22535C ANS = PDF(I)
22536C This version by S. Roesler, 30.01.96
22537C**********************************************************************
22538
22539 SAVE
22540 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22541 EQUIVALENCE (GF(1,1,1),DL(1))
22542 DATA DELTA/.13/
22543C
22544 DATA (DL(K),K= 1, 85) /
22545 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22546 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22547 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22548 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22549 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22550 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22551 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22552 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22553 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22554 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22555 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22556 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22557 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22558 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22559 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22560 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22561 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22562 DATA (DL(K),K= 86, 170) /
22563 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22564 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22565 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22566 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22567 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22568 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22569 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22570 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22571 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22572 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22573 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22574 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22575 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22576 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22577 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22578 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22579 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22580 DATA (DL(K),K= 171, 255) /
22581 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22582 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22583 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22584 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22585 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22586 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22587 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22588 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22589 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22590 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22591 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22592 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22593 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22594 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22595 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22596 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22597 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22598 DATA (DL(K),K= 256, 340) /
22599 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22600 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22601 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22602 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22603 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22604 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22605 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22606 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22607 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22608 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22609 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22610 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22611 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22612 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22613 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22614 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22615 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22616 DATA (DL(K),K= 341, 425) /
22617 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22618 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22619 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22620 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22621 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22622 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22623 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22624 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22625 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22626 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22627 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22628 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22629 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22630 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22631 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22632 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22633 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22634 DATA (DL(K),K= 426, 510) /
22635 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22636 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22637 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22638 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22639 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22640 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22641 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22642 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22643 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22644 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22645 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22646 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22647 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22648 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22649 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22650 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22651 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22652 DATA (DL(K),K= 511, 595) /
22653 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22654 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22655 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22656 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22657 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22658 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22659 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22660 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22661 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22662 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22663 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22664 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22665 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22666 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22667 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22668 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22669 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22670 DATA (DL(K),K= 596, 680) /
22671 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22672 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22673 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22674 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22675 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22676 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22677 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22678 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22679 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22680 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22681 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22682 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22683 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22684 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22685 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22686 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22687 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22688 DATA (DL(K),K= 681, 765) /
22689 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22690 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22691 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22692 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22693 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22694 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22695 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22696 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22697 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22698 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22699 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22700 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22701 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22702 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22703 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22704 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22705 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22706 DATA (DL(K),K= 766, 850) /
22707 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22708 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22709 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22710 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22711 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22712 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22713 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22714 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22715 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22716 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22717 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22718 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22719 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22720 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22721 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22722 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22723 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22724 DATA (DL(K),K= 851, 935) /
22725 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22726 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22727 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22728 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22729 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22730 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22731 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22732 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22733 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22734 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22735 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22736 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22737 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22738 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22739 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22740 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22741 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22742 DATA (DL(K),K= 936, 1020) /
22743 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22745 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22746 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22747 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22749 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22750 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22751 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22752 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22753 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22754 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22755 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22756 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22757 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22758 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22759 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22760 DATA (DL(K),K= 1021, 1105) /
22761 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22762 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22763 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22764 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22765 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22766 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22767 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22768 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22769 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22770 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22771 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22772 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22773 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22774 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22775 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22776 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22777 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22778 DATA (DL(K),K= 1106, 1190) /
22779 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22780 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22781 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22782 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22783 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22784 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22785 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22786 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22787 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22788 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22789 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22790 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22791 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22792 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22793 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22794 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22795 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22796 DATA (DL(K),K= 1191, 1275) /
22797 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22798 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22799 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22800 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22801 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22802 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22803 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22804 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22805 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22806 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22807 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22808 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22809 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22810 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22811 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22813 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22814 DATA (DL(K),K= 1276, 1360) /
22815 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22817 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22818 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22819 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22820 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22821 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22822 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22823 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22824 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22825 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22826 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22827 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22828 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22829 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22830 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22831 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22832 DATA (DL(K),K= 1361, 1445) /
22833 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22834 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22835 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22836 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22837 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22838 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22839 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22840 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22841 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22842 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22843 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22844 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22845 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22846 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22847 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22848 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22849 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22850 DATA (DL(K),K= 1446, 1530) /
22851 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22852 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22853 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22854 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22855 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22856 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22857 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22858 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22859 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22860 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22861 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22862 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22863 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22864 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22865 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22866 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22867 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22868 DATA (DL(K),K= 1531, 1615) /
22869 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22870 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22871 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22872 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22873 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22874 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22875 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22876 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22884 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22885 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22886 DATA (DL(K),K= 1616, 1700) /
22887 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22888 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22889 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22890 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22891 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22892 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22893 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22894 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22895 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22896 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22897 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22898 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22899 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22900 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22901 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22902 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22903 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22904 DATA (DL(K),K= 1701, 1785) /
22905 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22906 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22907 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22908 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22909 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22918 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22919 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22920 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22921 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22922 DATA (DL(K),K= 1786, 1870) /
22923 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22924 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22925 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22926 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22927 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22928 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22929 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22930 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22931 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22932 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22933 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22934 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22935 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22936 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22937 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22938 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22939 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22940 DATA (DL(K),K= 1871, 1955) /
22941 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22942 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22943 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22952 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22953 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22954 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22955 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22956 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22957 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22958 DATA (DL(K),K= 1956, 2040) /
22959 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22960 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22961 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22962 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22963 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22964 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22965 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22966 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22967 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22968 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22969 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22970 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22971 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22972 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22973 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22974 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22975 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22976 DATA (DL(K),K= 2041, 2125) /
22977 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22986 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22987 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22988 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22989 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22990 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22991 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22992 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22993 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22994 DATA (DL(K),K= 2126, 2210) /
22995 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22996 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22997 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22998 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22999 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23000 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23001 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23002 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23003 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23004 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23005 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23006 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23007 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23008 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23009 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23012 DATA (DL(K),K= 2211, 2295) /
23013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23017 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23020 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23021 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23022 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23023 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23024 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23025 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23026 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23027 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23028 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23029 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23030 DATA (DL(K),K= 2296, 2380) /
23031 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23032 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23033 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23034 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23035 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23036 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23037 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23038 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23039 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23040 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23041 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23042 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23043 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23044 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23048 DATA (DL(K),K= 2381, 2465) /
23049 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23054 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23055 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23056 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23057 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23058 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23059 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23060 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23061 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23062 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23063 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23064 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23065 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23066 DATA (DL(K),K= 2466, 2550) /
23067 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23068 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23069 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23070 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23071 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23072 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23073 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23074 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23075 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23076 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23077 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23078 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23084 DATA (DL(K),K= 2551, 2635) /
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23088 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23089 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23090 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23091 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23092 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23093 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23094 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23095 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23096 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23097 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23098 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23099 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23100 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23101 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23102 DATA (DL(K),K= 2636, 2720) /
23103 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23104 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23105 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23106 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23107 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23108 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23109 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23110 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23111 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23112 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23120 DATA (DL(K),K= 2721, 2805) /
23121 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23122 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23123 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23124 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23125 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23126 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23127 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23128 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23129 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23130 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23131 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23132 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23133 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23134 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23135 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23136 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23137 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23138 DATA (DL(K),K= 2806, 2890) /
23139 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23140 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23141 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23142 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23143 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23144 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23145 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23146 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23147 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23155 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23156 DATA (DL(K),K= 2891, 2975) /
23157 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23158 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23159 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23160 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23161 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23162 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23163 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23164 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23165 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23166 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23167 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23168 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23169 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23170 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23171 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23172 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23173 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23174 DATA (DL(K),K= 2976, 3060) /
23175 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23176 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23177 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23178 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23179 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23180 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23189 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23190 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23191 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23192 DATA (DL(K),K= 3061, 3145) /
23193 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23194 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23195 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23196 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23197 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23198 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23199 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23200 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23201 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23202 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23203 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23204 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23205 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23206 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23207 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23208 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23209 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23210 DATA (DL(K),K= 3146, 3230) /
23211 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23212 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23213 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23214 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23223 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23224 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23225 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23226 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23227 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23228 DATA (DL(K),K= 3231, 3315) /
23229 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23230 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23231 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23232 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23233 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23234 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23235 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23236 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23237 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23238 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23239 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23240 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23241 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23242 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23243 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23244 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23245 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23246 DATA (DL(K),K= 3316, 3400) /
23247 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23248 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23257 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23258 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23259 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23260 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23261 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23262 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23263 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23264 DATA (DL(K),K= 3401, 3485) /
23265 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23266 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23267 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23268 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23269 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23270 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23271 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23272 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23273 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23274 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23275 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23276 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23277 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23278 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23279 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23280 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23282 DATA (DL(K),K= 3486, 3570) /
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23291 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23292 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23293 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23294 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23295 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23296 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23297 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23298 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23299 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23300 DATA (DL(K),K= 3571, 3655) /
23301 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23302 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23303 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23304 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23305 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23306 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23307 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23308 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23309 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23310 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23311 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23312 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23313 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23314 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23315 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23318 DATA (DL(K),K= 3656, 3740) /
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23323 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23325 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23326 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23327 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23328 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23329 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23330 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23331 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23332 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23333 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23334 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23335 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23336 DATA (DL(K),K= 3741, 3825) /
23337 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23338 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23339 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23340 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23341 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23342 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23343 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23344 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23345 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23346 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23347 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23348 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23349 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23354 DATA (DL(K),K= 3826, 3910) /
23355 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23359 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23360 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23361 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23362 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23363 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23364 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23365 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23366 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23367 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23368 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23369 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23370 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23371 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23372 DATA (DL(K),K= 3911, 3995) /
23373 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23374 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23375 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23376 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23377 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23378 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23379 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23380 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23381 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23382 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23383 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23390 DATA (DL(K),K= 3996, 4000) /
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23392C
23393 ANS = 0.
23394 IF (X.GT.0.9985) RETURN
23395 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23396C
23397 IS = S/DELTA+1
23398 IS1 = IS+1
23399 DO 1 L=1,25
23400 KL = L+NDRV*25
23401 F1(L) = GF(I,IS,KL)
23402 F2(L) = GF(I,IS1,KL)
23403 1 CONTINUE
23404 A1 = DT_CKMTFF(X,F1)
23405 A2 = DT_CKMTFF(X,F2)
23406C A1=ALOG(A1)
23407C A2=ALOG(A2)
23408 S1 = (IS-1)*DELTA
23409 S2 = S1+DELTA
23410 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23411C ANS=EXP(ANS)
23412 RETURN
23413 END
23414C
23415C
23416
23417*$ CREATE DT_CKMTPR.FOR
23418*COPY DT_CKMTPR
23419 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23420C
23421C**********************************************************************
23422C Proton - PDFs
23423C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23424C ANS = PDF(I)
23425C This version by S. Roesler, 31.01.96
23426C**********************************************************************
23427
23428 SAVE
23429 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23430 EQUIVALENCE (GF(1,1,1),DL(1))
23431 DATA DELTA/.10/
23432C
23433 DATA (DL(K),K= 1, 85) /
23434 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23435 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23436 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23437 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23438 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23439 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23440 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23441 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23442 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23443 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23444 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23445 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23446 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23447 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23448 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23449 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23450 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23451 DATA (DL(K),K= 86, 170) /
23452 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23453 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23454 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23455 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23456 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23457 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23458 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23459 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23460 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23461 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23462 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23463 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23464 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23465 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23466 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23467 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23468 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23469 DATA (DL(K),K= 171, 255) /
23470 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23471 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23472 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23473 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23474 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23475 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23476 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23477 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23478 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23479 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23480 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23481 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23482 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23483 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23484 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23485 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23486 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23487 DATA (DL(K),K= 256, 340) /
23488 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23489 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23490 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23491 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23492 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23493 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23494 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23495 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23496 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23497 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23498 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23499 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23500 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23501 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23502 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23503 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23504 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23505 DATA (DL(K),K= 341, 425) /
23506 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23507 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23508 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23509 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23510 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23511 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23512 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23513 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23514 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23515 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23516 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23517 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23518 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23519 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23520 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23521 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23522 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23523 DATA (DL(K),K= 426, 510) /
23524 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23525 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23526 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23527 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23528 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23529 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23530 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23531 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23532 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23533 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23534 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23535 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23536 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23537 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23538 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23539 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23540 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23541 DATA (DL(K),K= 511, 595) /
23542 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23543 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23544 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23545 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23546 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23547 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23548 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23549 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23550 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23551 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23552 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23553 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23554 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23555 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23556 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23557 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23558 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23559 DATA (DL(K),K= 596, 680) /
23560 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23561 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23562 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23563 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23564 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23565 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23566 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23567 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23568 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23569 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23570 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23571 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23572 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23573 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23574 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23575 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23576 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23577 DATA (DL(K),K= 681, 765) /
23578 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23579 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23580 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23581 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23582 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23583 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23584 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23585 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23586 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23587 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23588 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23589 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23590 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23591 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23592 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23593 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23594 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23595 DATA (DL(K),K= 766, 850) /
23596 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23597 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23598 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23599 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23600 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23601 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23602 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23603 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23604 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23605 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23606 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23607 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23608 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23609 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23610 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23611 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23612 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23613 DATA (DL(K),K= 851, 935) /
23614 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23615 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23616 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23617 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23618 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23619 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23620 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23621 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23622 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23623 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23624 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23625 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23626 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23627 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23628 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23629 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23630 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23631 DATA (DL(K),K= 936, 1020) /
23632 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23633 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23634 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23635 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23636 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23637 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23638 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23639 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23640 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23641 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23642 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23643 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23644 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23645 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23646 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23647 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23648 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23649 DATA (DL(K),K= 1021, 1105) /
23650 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23651 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23652 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23653 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23654 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23655 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23656 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23657 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23658 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23659 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23660 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23661 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23662 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23663 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23664 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23665 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23666 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23667 DATA (DL(K),K= 1106, 1190) /
23668 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23669 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23670 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23671 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23672 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23673 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23674 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23675 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23676 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23677 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23678 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23679 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23680 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23681 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23682 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23683 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23684 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23685 DATA (DL(K),K= 1191, 1275) /
23686 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23687 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23688 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23689 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23690 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23691 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23692 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23693 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23694 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23695 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23696 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23697 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23698 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23699 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23700 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23701 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23702 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23703 DATA (DL(K),K= 1276, 1360) /
23704 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23705 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23706 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23707 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23708 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23709 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23710 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23711 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23712 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23713 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23714 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23715 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23716 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23717 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23718 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23719 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23720 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23721 DATA (DL(K),K= 1361, 1445) /
23722 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23723 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23724 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23725 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23726 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23727 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23728 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23729 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23730 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23731 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23732 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23733 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23734 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23735 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23736 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23737 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23738 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23739 DATA (DL(K),K= 1446, 1530) /
23740 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23741 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23742 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23743 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23744 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23745 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23746 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23747 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23748 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23749 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23750 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23751 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23752 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23753 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23754 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23755 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23756 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23757 DATA (DL(K),K= 1531, 1615) /
23758 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23759 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23760 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23761 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23762 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23763 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23764 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23765 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23766 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23767 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23768 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23769 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23770 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23771 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23772 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23773 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23774 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23775 DATA (DL(K),K= 1616, 1700) /
23776 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23777 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23778 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23779 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23780 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23781 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23782 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23783 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23784 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23785 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23786 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23787 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23788 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23789 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23790 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23791 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23792 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23793 DATA (DL(K),K= 1701, 1785) /
23794 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23795 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23796 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23797 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23798 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23799 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23800 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23801 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23802 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23803 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23804 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23805 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23806 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23807 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23808 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23809 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23810 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23811 DATA (DL(K),K= 1786, 1870) /
23812 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23813 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23814 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23815 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23816 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23817 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23818 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23819 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23820 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23821 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23822 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23823 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23824 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23825 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23826 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23827 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23828 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23829 DATA (DL(K),K= 1871, 1955) /
23830 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23831 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23832 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23833 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23834 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23835 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23836 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23837 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23838 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23839 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23840 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23841 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23842 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23843 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23844 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23845 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23846 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23847 DATA (DL(K),K= 1956, 2040) /
23848 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23849 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23850 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23851 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23852 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23853 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23854 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23855 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23856 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23857 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23858 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23859 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23860 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23861 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23862 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23863 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23864 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23865 DATA (DL(K),K= 2041, 2125) /
23866 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23867 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23868 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23869 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23870 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23871 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23872 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23873 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23874 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23875 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23876 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23877 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23878 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23879 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23880 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23881 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23882 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23883 DATA (DL(K),K= 2126, 2210) /
23884 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23885 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23886 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23887 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23888 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23889 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23890 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23891 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23892 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23893 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23894 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23895 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23896 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23897 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23898 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23899 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23900 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23901 DATA (DL(K),K= 2211, 2295) /
23902 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23903 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23904 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23905 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23906 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23907 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23908 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23909 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23910 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23911 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23912 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23913 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23914 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23915 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23916 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23917 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23918 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23919 DATA (DL(K),K= 2296, 2380) /
23920 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23921 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23922 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23923 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23924 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23925 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23926 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23927 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23928 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23929 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23930 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23931 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23932 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23933 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23934 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23935 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23936 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23937 DATA (DL(K),K= 2381, 2465) /
23938 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23939 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23940 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23941 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23942 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23943 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23944 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23945 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23946 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23947 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23948 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23949 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23950 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23951 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23952 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23953 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23954 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23955 DATA (DL(K),K= 2466, 2550) /
23956 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23957 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23958 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23959 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23960 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23961 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23962 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23963 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23964 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23965 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23966 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23967 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23968 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23969 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23970 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23971 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23972 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23973 DATA (DL(K),K= 2551, 2635) /
23974 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23975 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23976 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23977 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23978 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23979 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23980 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23981 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23982 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23983 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23984 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23985 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23986 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23987 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23988 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23989 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23990 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23991 DATA (DL(K),K= 2636, 2720) /
23992 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23993 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23994 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23995 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23996 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23997 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23998 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23999 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24000 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24001 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24002 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24003 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24004 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24005 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24006 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24007 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24008 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24009 DATA (DL(K),K= 2721, 2805) /
24010 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24011 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24012 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24013 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24014 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24015 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24016 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24017 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24018 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24019 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24020 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24021 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24022 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24023 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24024 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24025 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24026 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24027 DATA (DL(K),K= 2806, 2890) /
24028 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24029 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24030 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24031 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24032 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24033 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24034 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24035 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24036 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24037 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24038 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24039 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24040 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24041 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24043 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24044 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24045 DATA (DL(K),K= 2891, 2975) /
24046 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24047 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24048 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24049 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24050 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24051 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24052 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24053 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24054 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24055 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24056 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24057 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24058 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24059 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24060 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24061 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24062 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24063 DATA (DL(K),K= 2976, 3060) /
24064 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24065 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24066 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24067 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24068 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24069 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24070 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24071 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24072 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24073 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24074 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24075 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24077 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24078 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24079 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24080 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24081 DATA (DL(K),K= 3061, 3145) /
24082 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24083 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24084 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24085 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24086 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24087 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24088 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24089 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24090 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24091 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24092 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24093 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24094 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24095 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24096 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24097 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24098 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24099 DATA (DL(K),K= 3146, 3230) /
24100 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24101 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24102 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24103 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24104 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24105 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24106 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24107 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24108 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24109 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24110 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24111 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24112 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24113 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24114 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24115 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24116 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24117 DATA (DL(K),K= 3231, 3315) /
24118 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24119 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24120 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24121 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24122 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24123 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24124 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24125 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24126 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24127 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24128 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24129 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24130 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24131 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24132 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24133 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24134 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24135 DATA (DL(K),K= 3316, 3400) /
24136 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24137 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24138 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24139 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24140 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24141 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24142 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24143 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24145 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24146 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24147 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24148 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24149 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24150 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24151 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24152 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24153 DATA (DL(K),K= 3401, 3485) /
24154 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24155 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24156 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24157 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24158 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24159 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24160 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24161 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24162 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24163 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24164 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24165 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24166 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24167 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24168 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24169 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24170 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24171 DATA (DL(K),K= 3486, 3570) /
24172 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24173 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24174 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24175 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24176 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24177 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24178 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24179 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24180 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24181 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24182 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24183 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24184 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24185 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24186 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24187 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24188 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24189 DATA (DL(K),K= 3571, 3655) /
24190 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24191 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24192 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24193 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24194 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24195 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24196 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24197 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24198 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24199 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24200 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24201 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24202 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24203 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24204 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24205 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24206 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24207 DATA (DL(K),K= 3656, 3740) /
24208 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24209 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24210 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24211 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24212 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24213 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24214 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24215 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24216 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24217 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24218 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24219 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24220 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24221 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24222 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24223 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24224 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24225 DATA (DL(K),K= 3741, 3825) /
24226 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24227 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24228 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24229 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24230 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24231 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24232 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24233 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24234 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24235 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24236 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24237 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24238 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24239 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24240 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24241 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24242 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24243 DATA (DL(K),K= 3826, 3910) /
24244 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24245 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24246 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24247 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24248 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24249 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24250 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24251 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24252 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24253 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24254 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24255 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24256 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24257 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24258 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24259 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24260 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24261 DATA (DL(K),K= 3911, 3995) /
24262 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24263 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24264 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24265 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24266 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24267 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24268 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24269 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24270 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24271 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24272 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24273 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24274 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24275 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24276 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24277 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24278 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24279 DATA (DL(K),K= 3996, 4000) /
24280 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24281C
24282 ANS = 0.
24283 IF (X.GT.0.9985) RETURN
24284 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24285C
24286 IS = S/DELTA+1
24287 IS1 = IS+1
24288 DO 1 L=1,25
24289 KL = L+NDRV*25
24290 F1(L) = GF(I,IS,KL)
24291 F2(L) = GF(I,IS1,KL)
24292 1 CONTINUE
24293 A1 = DT_CKMTFF(X,F1)
24294 A2 = DT_CKMTFF(X,F2)
24295C A1=ALOG(A1)
24296C A2=ALOG(A2)
24297 S1 = (IS-1)*DELTA
24298 S2 = S1+DELTA
24299 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24300C ANS=EXP(ANS)
24301 RETURN
24302 END
24303C
24304
24305*$ CREATE DT_CKMTFF.FOR
24306*COPY DT_CKMTFF
24307 FUNCTION DT_CKMTFF(X,FVL)
24308C**********************************************************************
24309C
24310C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24311C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24312C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24313C IN MAIN ROUTINE.
24314C
24315C**********************************************************************
24316
24317 SAVE
24318 DIMENSION FVL(25),XGRID(25)
24319 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24320 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24321C
24322 DT_CKMTFF=0.
24323 DO 1 I=1,NX
24324 IF(X.LT.XGRID(I)) GO TO 2
24325 1 CONTINUE
24326 2 I=I-1
24327 IF(I.EQ.0) THEN
24328 I=I+1
24329 ELSE IF(I.GT.23) THEN
24330 I=23
24331 ENDIF
24332 J=I+1
24333 K=J+1
24334 AXI=LOG(XGRID(I))
24335 BXI=LOG(1.-XGRID(I))
24336 AXJ=LOG(XGRID(J))
24337 BXJ=LOG(1.-XGRID(J))
24338 AXK=LOG(XGRID(K))
24339 BXK=LOG(1.-XGRID(K))
24340 FI=LOG(ABS(FVL(I)) +1.E-15)
24341 FJ=LOG(ABS(FVL(J)) +1.E-16)
24342 FK=LOG(ABS(FVL(K)) +1.E-17)
24343 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24344 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24345 $ BXI))/DET
24346 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24347 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24348 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24349 1RETURN
24350C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24351C WRITE(6,2001) X,FVL
24352C 2001 FORMAT(8E12.4)
24353C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24354C ENDIF
24355 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24356 RETURN
24357 END
24358
24359*$ CREATE DT_FLUINI.FOR
24360*COPY DT_FLUINI
24361*
24362*===fluini=============================================================*
24363*
24364 SUBROUTINE DT_FLUINI
24365
24366************************************************************************
24367* Initialisation of the nucleon-nucleon cross section fluctuation *
24368* treatment. The original version by J. Ranft. *
24369* This version dated 21.04.95 is revised by S. Roesler. *
24370************************************************************************
24371
24372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24373 SAVE
24374
24375 PARAMETER ( LINP = 10 ,
24376 & LOUT = 6 ,
24377 & LDAT = 9 )
24378
24379 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24380
24381 PARAMETER ( A = 0.1D0,
24382 & B = 0.893D0,
24383 & OM = 1.1D0,
24384 & N = 6,
24385 & DX = 0.003D0)
24386
24387* n-n cross section fluctuations
24388 PARAMETER (NBINS = 1000)
24389 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24390 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24391
24392 WRITE(LOUT,1000)
24393 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24394 & 'treated')
24395
24396 FLUSU = ZERO
24397 FLUSUU = ZERO
24398
24399 DO 1 I=1,NBINS
24400 X = DBLE(I)*DX
24401 FLUIX(I) = X
24402 FLUS = ((X-B)/(OM*B))**N
24403 IF (FLUS.LE.20.0D0) THEN
24404 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24405 ELSE
24406 FLUSI(I) = ZERO
24407 ENDIF
24408 FLUSU = FLUSU+FLUSI(I)
24409 1 CONTINUE
24410 DO 2 I=1,NBINS
24411 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24412 FLUSI(I) = FLUSUU
24413 2 CONTINUE
24414
24415C WRITE(LOUT,1001)
24416C1001 FORMAT(1X,'FLUCTUATIONS')
24417C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24418
24419 DO 3 I=1,NBINS
24420 AF = DBLE(I)*0.001D0
24421 DO 4 J=1,NBINS
24422 IF (AF.LE.FLUSI(J)) THEN
24423 FLUIXX(I) = FLUIX(J)
24424 GOTO 5
24425 ENDIF
24426 4 CONTINUE
24427 5 CONTINUE
24428 3 CONTINUE
24429 FLUIXX(1) = FLUIX(1)
24430 FLUIXX(NBINS) = FLUIX(NBINS)
24431
24432 RETURN
24433 END
24434
24435*$ CREATE DT_SIGTBL.FOR
24436*COPY DT_SIGTBL
24437*
24438*===sigtab=============================================================*
24439*
24440 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24441
24442************************************************************************
24443* This version dated 18.11.95 is written by S. Roesler *
24444************************************************************************
24445
24446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24447 SAVE
24448
24449 PARAMETER ( LINP = 10 ,
24450 & LOUT = 6 ,
24451 & LDAT = 9 )
24452
24453 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24454 & OHALF=0.5D0,ONE=1.0D0)
24455 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24456
24457 LOGICAL LINIT
24458
24459* particle properties (BAMJET index convention)
24460 CHARACTER*8 ANAME
24461 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24462 & IICH(210),IIBAR(210),K1(210),K2(210)
24463
24464 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24465 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24466 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24467 & 0, 0, 5/
24468 DATA LINIT /.FALSE./
24469
24470* precalculation and tabulation of elastic cross sections
24471 IF (ABS(MODE).EQ.1) THEN
24472 IF (MODE.EQ.1)
24473 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24474 PLABLX = LOG10(PLO)
24475 PLABHX = LOG10(PHI)
24476 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24477 DO 1 I=1,NBINS+1
24478 PLAB = PLABLX+DBLE(I-1)*DPLAB
24479 PLAB = 10**PLAB
24480 DO 2 IPROJ=1,23
24481 IDX = IDSIG(IPROJ)
24482 IF (IDX.GT.0) THEN
24483C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24484C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24485 DUMZER = ZERO
24486 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24487 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24488 ENDIF
24489 2 CONTINUE
24490 IF (MODE.EQ.1) THEN
24491 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24492 & (SIGEN(IDX,I),IDX=1,5)
24493 1000 FORMAT(F5.1,10F7.2)
24494 ENDIF
24495 1 CONTINUE
24496 IF (MODE.EQ.1) CLOSE(LDAT)
24497 LINIT = .TRUE.
24498 ELSE
24499 SIGE = -ONE
24500 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24501 & .AND.(PTOT.LE.PHI) ) THEN
24502 IDX = IDSIG(JP)
24503 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24504 PLABX = LOG10(PTOT)
24505 IF (PLABX.LE.PLABLX) THEN
24506 I1 = 1
24507 I2 = 1
24508 ELSEIF (PLABX.GE.PLABHX) THEN
24509 I1 = NBINS+1
24510 I2 = NBINS+1
24511 ELSE
24512 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24513 I2 = I1+1
24514 ENDIF
24515 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24516 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24517 PBIN = PLAB2X-PLAB1X
24518 IF (PBIN.GT.TINY10) THEN
24519 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24520 ELSE
24521 RATX = ZERO
24522 ENDIF
24523 IF (JT.EQ.1) THEN
24524 SIG1 = SIGEP(IDX,I1)
24525 SIG2 = SIGEP(IDX,I2)
24526 ELSE
24527 SIG1 = SIGEN(IDX,I1)
24528 SIG2 = SIGEN(IDX,I2)
24529 ENDIF
24530 SIGE = SIG1+RATX*(SIG2-SIG1)
24531 ENDIF
24532 ENDIF
24533 ENDIF
24534
24535 RETURN
24536 END
24537
24538*$ CREATE DT_XSTABL.FOR
24539*COPY DT_XSTABL
24540*
24541*===xstabl=============================================================*
24542*
24543 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24544
24545 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24546 SAVE
24547
24548 PARAMETER ( LINP = 10 ,
24549 & LOUT = 6 ,
24550 & LDAT = 9 )
24551
24552 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24553 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24554 LOGICAL LLAB,LELOG,LQLOG
24555
24556* particle properties (BAMJET index convention)
24557 CHARACTER*8 ANAME
24558 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24559 & IICH(210),IIBAR(210),K1(210),K2(210)
24560
24561* properties of interacting particles
24562 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24563
24564 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24565
24566* Glauber formalism: cross sections
24567 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24568 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24569 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24570 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24571 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24572 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24573 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24574 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24575 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24576 & BSLOPE,NEBINI,NQBINI
24577
24578* emulsion treatment
24579 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24580 & NCOMPO,IEMUL
24581
24582 DIMENSION WHAT(6)
24583
24584 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24585 ELO = ABS(WHAT(1))
24586 EHI = ABS(WHAT(2))
24587 IF (ELO.GT.EHI) ELO = EHI
24588 LELOG = WHAT(3).LT.ZERO
24589 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24590 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24591 IF (LELOG) THEN
24592 AELO = LOG10(ELO)
24593 AEHI = LOG10(EHI)
24594 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24595 ENDIF
24596 Q2LO = WHAT(4)
24597 Q2HI = WHAT(5)
24598 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24599 LQLOG = WHAT(6).LT.ZERO
24600 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24601 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24602 IF (LQLOG) THEN
24603 AQ2LO = LOG10(Q2LO)
24604 AQ2HI = LOG10(Q2HI)
24605 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24606 ENDIF
24607
24608 IF ( ELO.EQ. EHI) NEBINS = 0
24609 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24610
24611 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24612 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24613 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24614 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24615 & ' A_p = ',I3,' A_t = ',I3,/)
24616
24617C IF (IJPROJ.NE.7) THEN
24618 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24619* normalize fractions of emulsion components
24620 IF (NCOMPO.GT.0) THEN
24621 SUMFRA = ZERO
24622 DO 10 I=1,NCOMPO
24623 SUMFRA = SUMFRA+EMUFRA(I)
24624 10 CONTINUE
24625 IF (SUMFRA.GT.ZERO) THEN
24626 DO 11 I=1,NCOMPO
24627 EMUFRA(I) = EMUFRA(I)/SUMFRA
24628 11 CONTINUE
24629 ENDIF
24630 ENDIF
24631C ELSE
24632C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24633C ENDIF
24634 DO 1 I=1,NEBINS+1
24635 IF (LELOG) THEN
24636 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24637 ELSE
24638 E = ELO+DBLE(I-1)*DEBINS
24639 ENDIF
24640 DO 2 J=1,NQBINS+1
24641 IF (LQLOG) THEN
24642 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24643 ELSE
24644 Q2 = Q2LO+DBLE(J-1)*DQBINS
24645 ENDIF
24646c IF (IJPROJ.NE.7) THEN
24647 IF (LLAB) THEN
24648 PLAB = ZERO
24649 ECM = ZERO
24650 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24651 ELSE
24652 ECM = E
24653 ENDIF
24654 XI = ZERO
24655 Q2I = ZERO
24656 IF (IJPROJ.EQ.7) Q2I = Q2
24657 IF (NCOMPO.GT.0) THEN
24658 DO 20 IC=1,NCOMPO
24659 IIT = IEMUMA(IC)
24660 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24661 20 CONTINUE
24662 ELSE
24663 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24664C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24665 ENDIF
24666 IF (NCOMPO.GT.0) THEN
24667 XTOT = ZERO
24668 ETOT = ZERO
24669 XELA = ZERO
24670 EELA = ZERO
24671 XQEP = ZERO
24672 EQEP = ZERO
24673 XQET = ZERO
24674 EQET = ZERO
24675 XQE2 = ZERO
24676 EQE2 = ZERO
24677 XPRO = ZERO
24678 EPRO = ZERO
24679 XPRO1= ZERO
24680 XDEL = ZERO
24681 EDEL = ZERO
24682 XDQE = ZERO
24683 EDQE = ZERO
24684 DO 21 IC=1,NCOMPO
24685 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24686 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24687 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24688 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24689 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24690 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24691 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24692 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24693 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24694 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24695 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24696 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24697 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24698 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24699 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24700 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24701 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24702 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24703 & -XSQE2(1,1,IC)
24704 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24705 21 CONTINUE
24706 ETOT = SQRT(ETOT)
24707 EELA = SQRT(EELA)
24708 EQEP = SQRT(EQEP)
24709 EQET = SQRT(EQET)
24710 EQE2 = SQRT(EQE2)
24711 EPRO = SQRT(EPRO)
24712 EDEL = SQRT(EDEL)
24713 EDQE = SQRT(EDQE)
24714 WRITE(LOUT,'(8E9.3)')
24715 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24716C WRITE(LOUT,'(4E9.3)')
24717C & E,XDEL,XDQE,XDEL+XDQE
24718 ELSE
24719 WRITE(LOUT,'(11E10.3)')
24720 & E,
24721 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24722 & XSQE2(1,1,1),XSPRO(1,1,1),
24723 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24724 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24725 & XSDEL(1,1,1)+XSDQE(1,1,1)
24726C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24727C & XSDEL(1,1,1)+XSDQE(1,1,1)
24728 ENDIF
24729c ELSE
24730c IF (LLAB) THEN
24731c IF (IT.GT.1) THEN
24732c IF (IXSQEL.EQ.0) THEN
24733cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24734cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24735c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24736c & STOT,ETOT,SIN,EIN,STOT0)
24737c IF (IRATIO.EQ.1) THEN
24738c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24739cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24740cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24741c*!! save cross sections
24742c STOTA = STOT
24743c ETOTA = ETOT
24744c STOTP = STGP
24745c*!!
24746c STOT = STOT/(DBLE(IT)*STGP)
24747c SIN = SIN/(DBLE(IT)*SIGP)
24748c STOT0 = STGP
24749c ETOT = ZERO
24750c EIN = ZERO
24751c ENDIF
24752c ELSE
24753c WRITE(LOUT,*)
24754c & ' XSTABL: qel. xs. not implemented for nuclei'
24755c STOP
24756c ENDIF
24757c ELSE
24758c ETOT = ZERO
24759c EIN = ZERO
24760c STOT0= ZERO
24761c IF (IXSQEL.EQ.0) THEN
24762c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24763c ELSE
24764c SIN = ZERO
24765c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24766c ENDIF
24767c ENDIF
24768c ELSE
24769c IF (IT.GT.1) THEN
24770c IF (IXSQEL.EQ.0) THEN
24771c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24772c & STOT,ETOT,SIN,EIN,STOT0)
24773c IF (IRATIO.EQ.1) THEN
24774c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24775c*!! save cross sections
24776c STOTA = STOT
24777c ETOTA = ETOT
24778c STOTP = STGP
24779c*!!
24780c STOT = STOT/(DBLE(IT)*STGP)
24781c SIN = SIN/(DBLE(IT)*SIGP)
24782c STOT0 = STGP
24783c ETOT = ZERO
24784c EIN = ZERO
24785c ENDIF
24786c ELSE
24787c WRITE(LOUT,*)
24788c & ' XSTABL: qel. xs. not implemented for nuclei'
24789c STOP
24790c ENDIF
24791c ELSE
24792c ETOT = ZERO
24793c EIN = ZERO
24794c STOT0= ZERO
24795c IF (IXSQEL.EQ.0) THEN
24796c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24797c ELSE
24798c SIN = ZERO
24799c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24800c ENDIF
24801c ENDIF
24802c ENDIF
24803cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24804cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24805cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24806c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24807c ENDIF
24808 2 CONTINUE
24809 1 CONTINUE
24810
24811 RETURN
24812 END
24813
24814*$ CREATE DT_TESTXS.FOR
24815*COPY DT_TESTXS
24816*
24817*===testxs=============================================================*
24818*
24819 SUBROUTINE DT_TESTXS
24820
24821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24822 SAVE
24823
24824 DIMENSION XSTOT(26,2),XSELA(26,2)
24825
24826 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24827 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24828 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24829 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24830 DUMECM = 0.0D0
24831 PLABL = 0.01D0
24832 PLABH = 10000.0D0
24833 NBINS = 120
24834 APLABL = LOG10(PLABL)
24835 APLABH = LOG10(PLABH)
24836 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24837 DO 1 I=1,NBINS+1
24838 ADP = APLABL+DBLE(I-1)*ADPLAB
24839 P = 10.0D0**ADP
24840 DO 2 J=1,26
24841 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24842 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24843 2 CONTINUE
24844 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24845 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24846 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24847 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24848 1 CONTINUE
24849 1000 FORMAT(F8.3,26F9.3)
24850
24851 RETURN
24852 END
24853************************************************************************
24854* *
24855* DTUNUC 2.0: library routines *
24856* processed by S. Roesler, 6.5.95 *
24857* *
24858************************************************************************
24859*
24860* 1) Handling of parton momenta
24861* SUBROUTINE MASHEL
24862* SUBROUTINE DFERMI
24863*
24864* 2) Handling of parton flavors and particle indices
24865* INTEGER FUNCTION IPDG2B
24866* INTEGER FUNCTION IB2PDG
24867* INTEGER FUNCTION IQUARK
24868* INTEGER FUNCTION IBJQUA
24869* INTEGER FUNCTION ICIHAD
24870* INTEGER FUNCTION IPDGHA
24871* INTEGER FUNCTION MCHAD
24872* SUBROUTINE FLAHAD
24873*
24874* 3) Energy-momentum and quantum number conservation check routines
24875* SUBROUTINE EMC1
24876* SUBROUTINE EMC2
24877* SUBROUTINE EVTEMC
24878* SUBROUTINE EVTFLC
24879* SUBROUTINE EVTCHG
24880*
24881* 4) Transformations
24882* SUBROUTINE LTINI
24883* SUBROUTINE LTRANS
24884* SUBROUTINE LTNUC
24885* SUBROUTINE DALTRA
24886* SUBROUTINE DTRAFO
24887* SUBROUTINE STTRAN
24888* SUBROUTINE MYTRAN
24889* SUBROUTINE LT2LAO
24890* SUBROUTINE LT2LAB
24891*
24892* 5) Sampling from distributions
24893* INTEGER FUNCTION NPOISS
24894* DOUBLE PRECISION FUNCTION SAMPXB
24895* DOUBLE PRECISION FUNCTION SAMPEX
24896* DOUBLE PRECISION FUNCTION SAMSQX
24897* DOUBLE PRECISION FUNCTION BETREJ
24898* DOUBLE PRECISION FUNCTION DGAMRN
24899* DOUBLE PRECISION FUNCTION DBETAR
24900* SUBROUTINE RANNOR
24901* SUBROUTINE DPOLI
24902* SUBROUTINE DSFECF
24903* SUBROUTINE RACO
24904*
24905* 6) Special functions, algorithms and service routines
24906* DOUBLE PRECISION FUNCTION YLAMB
24907* SUBROUTINE SORT
24908* SUBROUTINE SORT1
24909* SUBROUTINE DT_XTIME
24910*
24911* 7) Random number generator package
24912* DOUBLE PRECISION FUNCTION DT_RNDM
24913* SUBROUTINE DT_RNDMST
24914* SUBROUTINE DT_RNDMIN
24915* SUBROUTINE DT_RNDMOU
24916* SUBROUTINE DT_RNDMTE
24917*
24918************************************************************************
24919* *
24920* 1) Handling of parton momenta *
24921* *
24922************************************************************************
24923*$ CREATE DT_MASHEL.FOR
24924*COPY DT_MASHEL
24925*
24926*===mashel=============================================================*
24927*
24928 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24929
24930************************************************************************
24931* *
24932* rescaling of momenta of two partons to put both *
24933* on mass shell *
24934* *
24935* input: PA1,PA2 input momentum vectors *
24936* XM1,2 desired masses of particles afterwards *
24937* P1,P2 changed momentum vectors *
24938* *
24939* The original version is written by R. Engel. *
24940* This version dated 12.12.94 is modified by S. Roesler. *
24941************************************************************************
24942
24943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24944 SAVE
24945
24946 PARAMETER ( LINP = 10 ,
24947 & LOUT = 6 ,
24948 & LDAT = 9 )
24949
24950 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24951
24952 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24953
24954 IREJ = 0
24955
24956* Lorentz transformation into system CMS
24957 PX = PA1(1)+PA2(1)
24958 PY = PA1(2)+PA2(2)
24959 PZ = PA1(3)+PA2(3)
24960 EE = PA1(4)+PA2(4)
24961 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24962 XMS = (EE-XPTOT)*(EE+XPTOT)
24963 IF(XMS.LT.(XM1+XM2)**2) THEN
24964C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24965 GOTO 9999
24966 ENDIF
24967 XMS = SQRT(XMS)
24968 BGX = PX/XMS
24969 BGY = PY/XMS
24970 BGZ = PZ/XMS
24971 GAM = EE/XMS
24972 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24973 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24974* rotation angles
24975 COD = P1(3)/PTOT1
24976C SID = SQRT((ONE-COD)*(ONE+COD))
24977 PPT = SQRT(P1(1)**2+P1(2)**2)
24978 SID = PPT/PTOT1
24979 COF = ONE
24980 SIF = ZERO
24981 IF(PTOT1*SID.GT.TINY10) THEN
24982 COF = P1(1)/(SID*PTOT1)
24983 SIF = P1(2)/(SID*PTOT1)
24984 ANORF = SQRT(COF*COF+SIF*SIF)
24985 COF = COF/ANORF
24986 SIF = SIF/ANORF
24987 ENDIF
24988* new CM momentum and energies (for masses XM1,XM2)
24989 XM12 = SIGN(XM1**2,XM1)
24990 XM22 = SIGN(XM2**2,XM2)
24991 SS = XMS**2
24992 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24993 EE1 = SQRT(XM12+PCMP**2)
24994 EE2 = XMS-EE1
24995* back rotation
24996 MODE = 1
24997 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24998 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24999 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25000 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25001 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25002* check consistency
25003 DEL = XMS*0.0001D0
25004 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25005 IDEV = 1
25006 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25007 IDEV = 2
25008 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25009 IDEV = 3
25010 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25011 IDEV = 4
25012 ELSE
25013 IDEV = 0
25014 ENDIF
25015 IF (IDEV.NE.0) THEN
25016 WRITE(LOUT,'(/1X,A,I3)')
25017 & 'MASHEL: inconsistent transformation',IDEV
25018 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25019 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25020 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25021 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25022 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25023 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25024 ENDIF
25025 RETURN
25026
25027 9999 CONTINUE
25028 IREJ = 1
25029 RETURN
25030 END
25031
25032*$ CREATE DT_DFERMI.FOR
25033*COPY DT_DFERMI
25034*
25035*===dfermi=============================================================*
25036*
25037 SUBROUTINE DT_DFERMI(GPART)
25038
25039************************************************************************
25040* Find largest of three random numbers. *
25041************************************************************************
25042
25043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25044 SAVE
25045
25046 DIMENSION G(3)
25047
25048 DO 10 I=1,3
25049 G(I)=DT_RNDM(GPART)
25050 10 CONTINUE
25051 IF (G(3).LT.G(2)) GOTO 40
25052 IF (G(3).LT.G(1)) GOTO 30
25053 GPART = G(3)
25054 20 RETURN
25055 30 GPART = G(1)
25056 GOTO 20
25057 40 IF (G(2).LT.G(1)) GOTO 30
25058 GPART = G(2)
25059 GOTO 20
25060
25061 END
25062
25063************************************************************************
25064* *
25065* 2) Handling of parton flavors and particle indices *
25066* *
25067************************************************************************
25068*$ CREATE IDT_IPDG2B.FOR
25069*COPY IDT_IPDG2B
25070*
25071*===ipdg2b=============================================================*
25072*
25073 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25074
25075************************************************************************
25076* *
25077* conversion of quark numbering scheme *
25078* *
25079* input: PDG parton numbering *
25080* for diquarks: NN number of the constituent quark *
25081* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25082* *
25083* output: BAMJET particle codes *
25084* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25085* 2 d 8 a-d -2 a-d *
25086* 3 s 9 a-s -3 a-s *
25087* 4 c 10 a-c -4 a-c *
25088* *
25089* This is a modified version of ICONV2 written by R. Engel. *
25090* This version dated 13.12.94 is written by S. Roesler. *
25091************************************************************************
25092
25093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25094 SAVE
25095
25096 PARAMETER ( LINP = 10 ,
25097 & LOUT = 6 ,
25098 & LDAT = 9 )
25099
25100 IDA = ABS(ID)
25101* diquarks
25102 IF (IDA.GT.6) THEN
25103 KF = 3
25104 IF (IDA.GE.1000) KF = 4
25105 IDA = IDA/(10**(KF-NN))
25106 IDA = MOD(IDA,10)
25107 ENDIF
25108* exchange up and dn quarks
25109 IF (IDA.EQ.1) THEN
25110 IDA = 2
25111 ELSEIF (IDA.EQ.2) THEN
25112 IDA = 1
25113 ENDIF
25114* antiquarks
25115 IF (ID.LT.0) THEN
25116 IF (MODE.EQ.1) THEN
25117 IDA = IDA+6
25118 ELSE
25119 IDA = -IDA
25120 ENDIF
25121 ENDIF
25122 IDT_IPDG2B = IDA
25123
25124 RETURN
25125 END
25126
25127*$ CREATE IDT_IB2PDG.FOR
25128*COPY IDT_IB2PDG
25129*
25130*===ib2pdg=============================================================*
25131*
25132 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25133
25134************************************************************************
25135* *
25136* conversion of quark numbering scheme *
25137* *
25138* input: BAMJET particle codes *
25139* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25140* 2 d 8 a-d -2 a-d *
25141* 3 s 9 a-s -3 a-s *
25142* 4 c 10 a-c -4 a-c *
25143* *
25144* output: PDG parton numbering *
25145* *
25146* This version dated 13.12.94 is written by S. Roesler. *
25147************************************************************************
25148
25149 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25150 SAVE
25151
25152 PARAMETER ( LINP = 10 ,
25153 & LOUT = 6 ,
25154 & LDAT = 9 )
25155
25156 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25157 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25158 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25159 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25160 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25161
25162 IDA = ID1
25163 IDB = ID2
25164 IF (MODE.EQ.1) THEN
25165 IF (ID1.GT.6) IDA = -(ID1-6)
25166 IF (ID2.GT.6) IDB = -(ID2-6)
25167 ENDIF
25168 IF (ID2.EQ.0) THEN
25169 IDT_IB2PDG = IHKKQ(IDA)
25170 ELSE
25171 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25172 ENDIF
25173
25174 RETURN
25175 END
25176
25177*$ CREATE IDT_IQUARK.FOR
25178*COPY IDT_IQUARK
25179*
25180*===ipdgqu=============================================================*
25181*
25182 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25183
25184************************************************************************
25185* *
25186* quark contents according to PDG conventions *
25187* (random selection in case of quark mixing) *
25188* *
25189* input: IDBAMJ BAMJET particle code *
25190* K 1..3 quark number *
25191* *
25192* output: 1 d (anti --> neg.) *
25193* 2 u *
25194* 3 s *
25195* 4 c *
25196* *
25197* This version written by R. Engel. *
25198************************************************************************
25199
25200 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25201 SAVE
25202
25203 IQ = IDT_IBJQUA(K,IDBAMJ)
25204* quark-antiquark
25205 IF (IQ.GT.6) THEN
25206 IQ = 6-IQ
25207 ENDIF
25208* exchange of up and down
25209 IF (ABS(IQ).EQ.1) THEN
25210 IQ = SIGN(2,IQ)
25211 ELSEIF (ABS(IQ).EQ.2) THEN
25212 IQ = SIGN(1,IQ)
25213 ENDIF
25214 IDT_IQUARK = IQ
25215
25216 RETURN
25217 END
25218
25219*$ CREATE IDT_IBJQUA.FOR
25220*COPY IDT_IBJQUA
25221*
25222*===ibamq==============================================================*
25223*
25224 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25225
25226************************************************************************
25227* *
25228* quark contents according to BAMJET conventions *
25229* (random selection in case of quark mixing) *
25230* *
25231* input: IDBAMJ BAMJET particle code *
25232* K 1..3 quark number *
25233* *
25234* output: 1 u 7 u bar *
25235* 2 d 8 d bar *
25236* 3 s 9 s bar *
25237* 4 c 10 c bar *
25238* *
25239* This version written by R. Engel. *
25240************************************************************************
25241
25242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25243 SAVE
25244
25245 DIMENSION ITAB(3,210)
25246 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25247 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25248 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25249 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25250*sr 10.1.94
25251C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25252 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25253*
25254 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25255*sr 10.1.94
25256C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25257 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25258*sr 10.1.94
25259C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25260 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25261*
25262 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25263 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25264 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25265 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25266 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25267 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25268 & 2, 9, 0, 3, 7, 0, 3, 8, 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 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25273 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25274 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25275 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25276 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25277 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25278 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25279 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25280 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25281 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25282 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25283 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25284 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25285 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25286 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25287 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25288 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25289 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25290 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25291 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25292 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25293 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25294 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25295 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25296 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25297 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25298 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25299 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25300 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25301 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25302 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25303 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25304 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25305 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25306 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25307 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25308 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25309 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25310 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25311 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25312 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25313 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25314 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25315 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25316 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25317 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25318 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25319 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25320 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25321 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25322 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25323 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25324 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25325 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25326 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25327 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25328 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25329 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25330 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25331 DATA IDOLD /0/
25332
25333 ONE = 1.0D0
25334 IF (ITAB(1,IDBAMJ).LE.200) THEN
25335 ID = ITAB(K,IDBAMJ)
25336 ELSE
25337 IF(IDOLD.NE.IDBAMJ) THEN
25338 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25339 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25340 ELSE
25341 IDOLD = 0
25342 ENDIF
25343 ID = ITAB(K,IT)
25344 ENDIF
25345 IDOLD = IDBAMJ
25346 IDT_IBJQUA = ID
25347
25348 RETURN
25349 END
25350
25351*$ CREATE IDT_ICIHAD.FOR
25352*COPY IDT_ICIHAD
25353*
25354*===icihad=============================================================*
25355*
25356 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25357
25358************************************************************************
25359* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25360* This is a completely new version dated 25.10.95. *
25361* Renamed to be not in conflict with the modified PHOJET-version *
25362************************************************************************
25363
25364 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25365 SAVE
25366
25367* hadron index conversion (BAMJET <--> PDG)
25368 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25369 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25370 & IAMCIN(210)
25371
25372 IDT_ICIHAD = 0
25373 KPDG = ABS(MCIND)
25374 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25375 IF (MCIND.LT.0) THEN
25376 JSIGN = 1
25377 ELSE
25378 JSIGN = 2
25379 ENDIF
25380 IF (KPDG.GE.10000) THEN
25381 DO 1 I=1,19
25382 IDT_ICIHAD = IBAM5(JSIGN,I)
25383 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25384 IDT_ICIHAD = 0
25385 1 CONTINUE
25386 ELSEIF (KPDG.GE.1000) THEN
25387 DO 2 I=1,29
25388 IDT_ICIHAD = IBAM4(JSIGN,I)
25389 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25390 IDT_ICIHAD = 0
25391 2 CONTINUE
25392 ELSEIF (KPDG.GE.100) THEN
25393 DO 3 I=1,22
25394 IDT_ICIHAD = IBAM3(JSIGN,I)
25395 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25396 IDT_ICIHAD = 0
25397 3 CONTINUE
25398 ELSEIF (KPDG.GE.10) THEN
25399 DO 4 I=1,7
25400 IDT_ICIHAD = IBAM2(JSIGN,I)
25401 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25402 IDT_ICIHAD = 0
25403 4 CONTINUE
25404 ENDIF
25405 5 CONTINUE
25406
25407 RETURN
25408 END
25409
25410*$ CREATE IDT_IPDGHA.FOR
25411*COPY IDT_IPDGHA
25412*
25413*===ipdgha=============================================================*
25414*
25415 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25416
25417************************************************************************
25418* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25419* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25420* Renamed to be not in conflict with the modified PHOJET-version *
25421************************************************************************
25422
25423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25424 SAVE
25425
25426* hadron index conversion (BAMJET <--> PDG)
25427 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25428 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25429 & IAMCIN(210)
25430
25431 IDT_IPDGHA = IAMCIN(MCIND)
25432
25433 RETURN
25434 END
25435
25436*$ CREATE DT_FLAHAD.FOR
25437*COPY DT_FLAHAD
25438*
25439*===flahad=============================================================*
25440*
25441 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25442
25443************************************************************************
25444* sampling of FLAvor composition for HADrons/photons *
25445* ID BAMJET-id of hadron *
25446* IF1,2,3 flavor content *
25447* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25448* Note: - u,d numbering as in BAMJET *
25449* - ID .le. 30 !! *
25450* This version dated 12.03.96 is written by S. Roesler *
25451************************************************************************
25452
25453 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25454 SAVE
25455
25456* auxiliary common for reggeon exchange (DTUNUC 1.x)
25457 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25458 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25459 & IQTCHR(-6:6),MQUARK(3,39)
25460
25461 DIMENSION JSEL(3,6)
25462 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25463
25464 ONE = 1.0D0
25465 IF (ID.EQ.7) THEN
25466* photon (charge dependent flavour sampling)
25467 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25468 IF (K.LE.4) THEN
25469 IF1 = 2
25470 IF2 = -2
25471 ELSE IF(K.EQ.5) THEN
25472 IF1 = 1
25473 IF2 = -1
25474 ELSE
25475 IF1 = 3
25476 IF2 = -3
25477 ENDIF
25478 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25479 K = IF1
25480 IF1 = IF2
25481 IF2 = K
25482 ENDIF
25483 IF3 = 0
25484 ELSE
25485* hadron
25486 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25487 IF1 = MQUARK(JSEL(1,IX),ID)
25488 IF2 = MQUARK(JSEL(2,IX),ID)
25489 IF3 = MQUARK(JSEL(3,IX),ID)
25490 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25491 IF1 = IF3
25492 IF3 = 0
25493 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25494 IF2 = IF3
25495 IF3 = 0
25496 ENDIF
25497 ENDIF
25498
25499 RETURN
25500 END
25501
25502*$ CREATE IDT_MCHAD.FOR
25503*COPY IDT_MCHAD
25504*
25505*===mchad==============================================================*
25506*
25507 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25508
25509************************************************************************
25510* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25511* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25512* *
25513* Last change 28.12.2006 by S. Roesler. *
25514************************************************************************
25515
25516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25517 SAVE
25518
25519 DIMENSION ITRANS(210)
25520 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25521 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25522 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25523 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25524 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25525 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25526 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25527
25528 IF ( ITDTU .GT. 0 ) THEN
25529 IDT_MCHAD = ITRANS(ITDTU)
25530 ELSE
25531 IDT_MCHAD = -1
25532 END IF
25533
25534 RETURN
25535 END
25536
25537************************************************************************
25538* *
25539* 3) Energy-momentum and quantum number conservation check routines *
25540* *
25541************************************************************************
25542*$ CREATE DT_EMC1.FOR
25543*COPY DT_EMC1
25544*
25545*===emc1===============================================================*
25546*
25547 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25548
25549************************************************************************
25550* This version dated 15.12.94 is written by S. Roesler *
25551************************************************************************
25552
25553 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25554 SAVE
25555
25556 PARAMETER ( LINP = 10 ,
25557 & LOUT = 6 ,
25558 & LDAT = 9 )
25559
25560 PARAMETER (TINY10=1.0D-10)
25561
25562 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25563
25564 IREJ = 0
25565
25566 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25567 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25568
25569 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25570 IF (MODE.EQ.1) THEN
25571 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25572 ELSEIF (MODE.EQ.2) THEN
25573 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25574 ENDIF
25575 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25576 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25577 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25578 ELSEIF (MODE.LT.0) THEN
25579 IF (MODE.EQ.-1) THEN
25580 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25581 ELSEIF (MODE.EQ.-2) THEN
25582 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25583 ENDIF
25584 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25585 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25586 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25587 ENDIF
25588
25589 IF (ABS(MODE).EQ.3) THEN
25590 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25591 IF (IREJ1.NE.0) GOTO 9999
25592 ENDIF
25593 RETURN
25594
25595 9999 CONTINUE
25596 IREJ = 1
25597 RETURN
25598 END
25599
25600*$ CREATE DT_EMC2.FOR
25601*COPY DT_EMC2
25602*
25603*===emc2===============================================================*
25604*
25605 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25606 & MODE,IPOS,IREJ)
25607
25608************************************************************************
25609* MODE = 1 energy-momentum cons. check *
25610* = 2 flavor-cons. check *
25611* = 3 energy-momentum & flavor cons. check *
25612* = 4 energy-momentum & charge cons. check *
25613* = 5 energy-momentum & flavor & charge cons. check *
25614* This version dated 16.01.95 is written by S. Roesler *
25615************************************************************************
25616
25617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25618 SAVE
25619
25620 PARAMETER ( LINP = 10 ,
25621 & LOUT = 6 ,
25622 & LDAT = 9 )
25623
25624 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25625
25626* event history
25627
25628 PARAMETER (NMXHKK=200000)
25629
25630 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25631 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25632 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25633
25634* extended event history
25635 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25636 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25637 & IHIST(2,NMXHKK)
25638
25639 IREJ = 0
25640 IREJ1 = 0
25641 IREJ2 = 0
25642 IREJ3 = 0
25643
25644 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25645 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25646 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25647 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25648 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25649 DO 1 I=1,NHKK
25650 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25651 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25652 & (ISTHKK(I).EQ.IP5)) THEN
25653 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25654 & .OR.(MODE.EQ.5))
25655 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25656 & 2,IDUM,IDUM)
25657 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25658 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25659 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25660 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25661 ENDIF
25662 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25663 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25664 & (ISTHKK(I).EQ.IN5)) THEN
25665 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25666 & .OR.(MODE.EQ.5))
25667 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25668 & 2,IDUM,IDUM)
25669 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25670 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25671 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25672 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25673 ENDIF
25674 1 CONTINUE
25675 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25676 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25677 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25678 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25679 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25680 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25681
25682 RETURN
25683
25684 9999 CONTINUE
25685 IREJ = 1
25686 RETURN
25687 END
25688
25689*$ CREATE DT_EVTEMC.FOR
25690*COPY DT_EVTEMC
25691*
25692*===evtemc=============================================================*
25693*
25694 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25695
25696************************************************************************
25697* This version dated 13.12.94 is written by S. Roesler *
25698************************************************************************
25699
25700 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25701 SAVE
25702
25703 PARAMETER ( LINP = 10 ,
25704 & LOUT = 6 ,
25705 & LDAT = 9 )
25706
25707 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25708 & ZERO=0.0D0)
25709
25710* event history
25711
25712 PARAMETER (NMXHKK=200000)
25713
25714 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25715 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25716 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25717
25718* flags for input different options
25719 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25720 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25721 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25722
25723 IREJ = 0
25724
25725 MODE = IMODE
25726 CHKLEV = TINY10
25727 IF (MODE.EQ.4) THEN
25728 CHKLEV = TINY2
25729 MODE = 3
25730 ELSEIF (MODE.EQ.5) THEN
25731 CHKLEV = TINY1
25732 MODE = 3
25733 ELSEIF (MODE.EQ.-1) THEN
25734 CHKLEV = EIO
25735 MODE = 3
25736 ENDIF
25737
25738 IF (ABS(MODE).EQ.3) THEN
25739 PXDEV = PX
25740 PYDEV = PY
25741 PZDEV = PZ
25742 EDEV = E
25743 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25744 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25745 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25746 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25747 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25748 & ' event ',NEVHKK,
25749 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25750 PX = 0.0D0
25751 PY = 0.0D0
25752 PZ = 0.0D0
25753 E = 0.0D0
25754 GOTO 9999
25755 ENDIF
25756 PX = 0.0D0
25757 PY = 0.0D0
25758 PZ = 0.0D0
25759 E = 0.0D0
25760 RETURN
25761 ENDIF
25762
25763 IF (MODE.EQ.1) THEN
25764 PX = 0.0D0
25765 PY = 0.0D0
25766 PZ = 0.0D0
25767 E = 0.0D0
25768 ENDIF
25769
25770 PX = PX+PXIO
25771 PY = PY+PYIO
25772 PZ = PZ+PZIO
25773 E = E+EIO
25774
25775 RETURN
25776
25777 9999 CONTINUE
25778 IREJ = 1
25779 RETURN
25780 END
25781
25782*$ CREATE DT_EVTFLC.FOR
25783*COPY DT_EVTFLC
25784*
25785*===evtflc=============================================================*
25786*
25787 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25788
25789************************************************************************
25790* Flavor conservation check. *
25791* ID identity of particle *
25792* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25793* = 2 ID for particle/resonance in BAMJET numbering scheme *
25794* = 3 ID for particle/resonance in PDG numbering scheme *
25795* MODE = 1 initialization and add ID *
25796* =-1 initialization and subtract ID *
25797* = 2 add ID *
25798* =-2 subtract ID *
25799* = 3 check flavor cons. *
25800* IPOS flag to give position of call of EVTFLC to output *
25801* unit in case of violation *
25802* This version dated 10.01.95 is written by S. Roesler *
25803************************************************************************
25804
25805 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25806 SAVE
25807
25808 PARAMETER ( LINP = 10 ,
25809 & LOUT = 6 ,
25810 & LDAT = 9 )
25811
25812 PARAMETER (TINY10=1.0D-10)
25813
25814 IREJ = 0
25815
25816 IF (MODE.EQ.3) THEN
25817 IF (IFL.NE.0) THEN
25818 WRITE(LOUT,'(1X,A,I3,A,I3)')
25819 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25820 & ' ! IFL = ',IFL
25821 IFL = 0
25822 GOTO 9999
25823 ENDIF
25824 IFL = 0
25825 RETURN
25826 ENDIF
25827
25828 IF (MODE.EQ.1) IFL = 0
25829 IF (ID.EQ.0) RETURN
25830
25831 IF (ID1.EQ.1) THEN
25832 IDD = ABS(ID)
25833 NQ = 1
25834 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25835 IF (IDD.GE.1000) NQ = 3
25836 DO 1 I=1,NQ
25837 IFBAM = IDT_IPDG2B(ID,I,2)
25838 IF (ABS(IFBAM).EQ.1) THEN
25839 IFBAM = SIGN(2,IFBAM)
25840 ELSEIF (ABS(IFBAM).EQ.2) THEN
25841 IFBAM = SIGN(1,IFBAM)
25842 ENDIF
25843 IF (MODE.GT.0) THEN
25844 IFL = IFL+IFBAM
25845 ELSE
25846 IFL = IFL-IFBAM
25847 ENDIF
25848 1 CONTINUE
25849 RETURN
25850 ENDIF
25851
25852 IDD = ID
25853 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25854 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25855 DO 2 I=1,3
25856 IF (MODE.GT.0) THEN
25857 IFL = IFL+IDT_IQUARK(I,IDD)
25858 ELSE
25859 IFL = IFL-IDT_IQUARK(I,IDD)
25860 ENDIF
25861 2 CONTINUE
25862 ENDIF
25863 RETURN
25864
25865 9999 CONTINUE
25866 IREJ = 1
25867 RETURN
25868 END
25869
25870*$ CREATE DT_EVTCHG.FOR
25871*COPY DT_EVTCHG
25872*
25873*===evtchg=============================================================*
25874*
25875 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25876
25877************************************************************************
25878* Charge conservation check. *
25879* ID identity of particle (PDG-numbering scheme) *
25880* MODE = 1 initialization *
25881* =-2 subtract ID-charge *
25882* = 2 add ID-charge *
25883* = 3 check charge cons. *
25884* IPOS flag to give position of call of EVTCHG to output *
25885* unit in case of violation *
25886* This version dated 10.01.95 is written by S. Roesler *
25887* Last change: s.r. 21.01.01 *
25888************************************************************************
25889
25890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25891 SAVE
25892
25893 PARAMETER ( LINP = 10 ,
25894 & LOUT = 6 ,
25895 & LDAT = 9 )
25896
25897* event history
25898
25899 PARAMETER (NMXHKK=200000)
25900
25901 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25902 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25903 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25904
25905* particle properties (BAMJET index convention)
25906 CHARACTER*8 ANAME
25907 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25908 & IICH(210),IIBAR(210),K1(210),K2(210)
25909
25910 IREJ = 0
25911
25912 IF (MODE.EQ.1) THEN
25913 ICH = 0
25914 IBAR = 0
25915 RETURN
25916 ENDIF
25917
25918 IF (MODE.EQ.3) THEN
25919 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25920 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25921 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25922 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25923 ICH = 0
25924 IBAR = 0
25925 GOTO 9999
25926 ENDIF
25927 ICH = 0
25928 IBAR = 0
25929 RETURN
25930 ENDIF
25931
25932 IF (ID.EQ.0) RETURN
25933
25934 IDD = IDT_ICIHAD(ID)
25935* modification 21.1.01: use intrinsic phojet-functions to determine charge
25936* and baryon number
25937C IF (IDD.GT.0) THEN
25938C IF (MODE.EQ.2) THEN
25939C ICH = ICH+IICH(IDD)
25940C IBAR = IBAR+IIBAR(IDD)
25941C ELSEIF (MODE.EQ.-2) THEN
25942C ICH = ICH-IICH(IDD)
25943C IBAR = IBAR-IIBAR(IDD)
25944C ENDIF
25945C ELSE
25946C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25947C CALL DT_EVTOUT(4)
25948C STOP
25949C ENDIF
25950 IF (MODE.EQ.2) THEN
25951 ICH = ICH+IPHO_CHR3(ID,1)/3
25952 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25953 ELSEIF (MODE.EQ.-2) THEN
25954 ICH = ICH-IPHO_CHR3(ID,1)/3
25955 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25956 ENDIF
25957
25958 RETURN
25959
25960 9999 CONTINUE
25961 IREJ = 1
25962 RETURN
25963 END
25964
25965************************************************************************
25966* *
25967* 4) Transformations *
25968* *
25969************************************************************************
25970*$ CREATE DT_LTINI.FOR
25971*COPY DT_LTINI
25972*
25973*===ltini==============================================================*
25974*
25975 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25976
25977************************************************************************
25978* Initializations of Lorentz-transformations, calculation of Lorentz- *
25979* parameters. *
25980* This version dated 13.11.95 is written by S. Roesler. *
25981************************************************************************
25982
25983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25984 SAVE
25985
25986 PARAMETER ( LINP = 10 ,
25987 & LOUT = 6 ,
25988 & LDAT = 9 )
25989
25990 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25991 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25992
25993* Lorentz-parameters of the current interaction
25994 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25995 & UMO,PPCM,EPROJ,PPROJ
25996
25997* properties of photon/lepton projectiles
25998 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25999
26000* particle properties (BAMJET index convention)
26001 CHARACTER*8 ANAME
26002 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26003 & IICH(210),IIBAR(210),K1(210),K2(210)
26004
26005* nucleon-nucleon event-generator
26006 CHARACTER*8 CMODEL
26007 LOGICAL LPHOIN
26008 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26009
26010 Q2 = VIRT
26011 IDP = IDPR
26012 IF (MCGENE.NE.3) THEN
26013* lepton-projectiles and PHOJET: initialize real photon instead
26014 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26015 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26016 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26017 IDP = 7
26018 Q2 = ZERO
26019 ENDIF
26020 ENDIF
26021 IDT = IDTA
26022 EPN = EPN0
26023 PPN = PPN0
26024 ECM = ECM0
26025 AMP = AAM(IDP)-SQRT(ABS(Q2))
26026 AMT = AAM(IDT)
26027 AMP2 = SIGN(AMP**2,AMP)
26028 AMT2 = AMT**2
26029 IF (ECM0.GT.ZERO) THEN
26030 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26031 IF (AMP2.GT.ZERO) THEN
26032 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26033 ELSE
26034 PPN = SQRT(EPN**2-AMP2)
26035 ENDIF
26036 ELSE
26037 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26038 IF (IDP.EQ.7) EPN = ABS(EPN)
26039 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26040 IF (AMP2.GT.ZERO) THEN
26041 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26042 ELSE
26043 PPN = SQRT(EPN**2-AMP2)
26044 ENDIF
26045 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26046 IF (AMP2.GT.ZERO) THEN
26047 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26048 ELSE
26049 EPN = SQRT(PPN**2+AMP2)
26050 ENDIF
26051 ENDIF
26052 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26053 ENDIF
26054 UMO = ECM
26055 EPROJ = EPN
26056 PPROJ = PPN
26057 IF (AMP2.GT.ZERO) THEN
26058 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26059 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26060 ELSE
26061 ETARG = TINY10
26062 PTARG = TINY10
26063 ENDIF
26064* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26065 IF (IDP.EQ.7) THEN
26066 PGAMM(1) = ZERO
26067 PGAMM(2) = ZERO
26068 AMGAM = AMP
26069 AMGAM2 = AMP2
26070 IF (ECM0.GT.ZERO) THEN
26071 S = ECM0**2
26072 ELSE
26073 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26074 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26075 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26076 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26077 ENDIF
26078 ENDIF
26079 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26080 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26081 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26082 IF (MODE.EQ.1) THEN
26083 PNUCL(1) = ZERO
26084 PNUCL(2) = ZERO
26085 PNUCL(3) = -PGAMM(3)
26086 PNUCL(4) = SQRT(S)-PGAMM(4)
26087 ENDIF
26088 ENDIF
26089 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26090 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26091 PLEPT0(1) = ZERO
26092 PLEPT0(2) = ZERO
26093* neglect lepton masses
26094C AMLPT2 = AAM(IDPR)**2
26095 AMLPT2 = ZERO
26096*
26097 IF (ECM0.GT.ZERO) THEN
26098 S = ECM0**2
26099 ELSE
26100 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26101 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26102 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26103 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26104 ENDIF
26105 ENDIF
26106 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26107 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26108 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26109 PNUCL(1) = ZERO
26110 PNUCL(2) = ZERO
26111 PNUCL(3) = -PLEPT0(3)
26112 PNUCL(4) = SQRT(S)-PLEPT0(4)
26113 ENDIF
26114* Lorentz-parameter for transformation Lab. - projectile rest system
26115 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26116 GALAB = TINY10
26117 BGLAB = TINY10
26118 BLAB = TINY10
26119 ELSE
26120 GALAB = EPROJ/AMP
26121 BGLAB = PPROJ/AMP
26122 BLAB = BGLAB/GALAB
26123 ENDIF
26124* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26125 IF (IDP.EQ.7) THEN
26126 GACMS(1) = TINY10
26127 BGCMS(1) = TINY10
26128 ELSE
26129 GACMS(1) = (ETARG+AMP)/UMO
26130 BGCMS(1) = PTARG/UMO
26131 ENDIF
26132* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26133 GACMS(2) = (EPROJ+AMT)/UMO
26134 BGCMS(2) = PPROJ/UMO
26135 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26136
26137 EPN0 = EPN
26138 PPN0 = PPN
26139 ECM0 = ECM
26140
26141 RETURN
26142 END
26143
26144*$ CREATE DT_LTRANS.FOR
26145*COPY DT_LTRANS
26146*
26147*===ltrans=============================================================*
26148*
26149 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26150
26151************************************************************************
26152* Lorentz-transformations. *
26153* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26154* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26155* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26156* This version dated 01.11.95 is written by S. Roesler. *
26157************************************************************************
26158
26159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26160 SAVE
26161
26162 PARAMETER ( LINP = 10 ,
26163 & LOUT = 6 ,
26164 & LDAT = 9 )
26165
26166 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26167
26168 PARAMETER (SQTINF=1.0D+15)
26169
26170* particle properties (BAMJET index convention)
26171 CHARACTER*8 ANAME
26172 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26173 & IICH(210),IIBAR(210),K1(210),K2(210)
26174
26175 PXO = PXI
26176 PYO = PYI
26177 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26178
26179* check particle mass for consistency (numerical rounding errors)
26180 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26181 AMO2 = (PEO-PO)*(PEO+PO)
26182 AMORQ2 = AAM(ID)**2
26183 AMDIF2 = ABS(AMO2-AMORQ2)
26184 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26185 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26186 PEO = PEO+DELTA
26187 PO1 = PO -DELTA
26188 PXO = PXO*PO1/PO
26189 PYO = PYO*PO1/PO
26190 PZO = PZO*PO1/PO
26191C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26192 ENDIF
26193
26194 RETURN
26195 END
26196
26197*$ CREATE DT_LTNUC.FOR
26198*COPY DT_LTNUC
26199*
26200*===ltnuc==============================================================*
26201*
26202 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26203
26204************************************************************************
26205* Lorentz-transformations. *
26206* PIN longitudnal momentum (input) *
26207* EIN energy (input) *
26208* POUT transformed long. momentum (output) *
26209* EOUT transformed energy (output) *
26210* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26211* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26212* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26213* This version dated 01.11.95 is written by S. Roesler. *
26214************************************************************************
26215
26216 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26217 SAVE
26218
26219 PARAMETER ( LINP = 10 ,
26220 & LOUT = 6 ,
26221 & LDAT = 9 )
26222
26223 PARAMETER (ZERO=0.0D0)
26224
26225* Lorentz-parameters of the current interaction
26226 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26227 & UMO,PPCM,EPROJ,PPROJ
26228
26229 BDUM1 = ZERO
26230 BDUM2 = ZERO
26231 PDUM1 = ZERO
26232 PDUM2 = ZERO
26233 IF (ABS(MODE).EQ.1) THEN
26234 BG = -SIGN(BGLAB,DBLE(MODE))
26235 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26236 & DUM1,DUM2,DUM3,POUT,EOUT)
26237 ELSEIF (ABS(MODE).EQ.2) THEN
26238 BG = SIGN(BGCMS(1),DBLE(MODE))
26239 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26240 & DUM1,DUM2,DUM3,POUT,EOUT)
26241 ELSEIF (ABS(MODE).EQ.3) THEN
26242 BG = -SIGN(BGCMS(2),DBLE(MODE))
26243 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26244 & DUM1,DUM2,DUM3,POUT,EOUT)
26245 ELSE
26246 WRITE(LOUT,1000) MODE
26247 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26248 EOUT = EIN
26249 POUT = PIN
26250 ENDIF
26251
26252 RETURN
26253 END
26254
26255*$ CREATE DT_DALTRA.FOR
26256*COPY DT_DALTRA
26257*
26258*===daltra=============================================================*
26259*
26260 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26261
26262************************************************************************
26263* Arbitrary Lorentz-transformation. *
26264* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26265************************************************************************
26266
26267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26268 SAVE
26269 PARAMETER (ONE=1.0D0)
26270
26271 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26272 PE = EP/(GA+ONE)+EC
26273 PX = PCX+BGX*PE
26274 PY = PCY+BGY*PE
26275 PZ = PCZ+BGZ*PE
26276 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26277 E = GA*EC+EP
26278
26279 RETURN
26280 END
26281
26282*$ CREATE DT_DTRAFO.FOR
26283*COPY DT_DTRAFO
26284*
26285*====dtrafo============================================================*
26286*
26287 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26288 & PL,CXL,CYL,CZL,EL)
26289
26290C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26291
26292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26293 SAVE
26294
26295 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26296 SID = SQRT(1.D0-COD*COD)
26297 PLX = P*SID*COF
26298 PLY = P*SID*SIF
26299 PCMZ = P*COD
26300 PLZ = GAM*PCMZ+BGAM*ECM
26301 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26302 EL = GAM*ECM+BGAM*PCMZ
26303C ROTATION INTO THE ORIGINAL DIRECTION
26304 COZ = PLZ/PL
26305 SIZ = SQRT(1.D0-COZ**2)
26306 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26307
26308 RETURN
26309 END
26310
26311*$ CREATE DT_STTRAN.FOR
26312*COPY DT_STTRAN
26313*
26314*====sttran============================================================*
26315*
26316 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26317
26318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26319 SAVE
26320 DATA ANGLSQ/1.D-30/
26321************************************************************************
26322* VERSION BY J. RANFT *
26323* LEIPZIG *
26324* *
26325* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26326* *
26327* INPUT VARIABLES: *
26328* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26329* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26330* ANGLE OF "SCATTERING" *
26331* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26332* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26333* OF "SCATTERING" *
26334* *
26335* OUTPUT VARIABLES: *
26336* X,Y,Z = NEW DIRECTION COSINES *
26337* *
26338* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26339************************************************************************
26340*
26341*
26342* Changed by A. Ferrari
26343*
26344* IF (ABS(XO)-0.0001D0) 1,1,2
26345* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26346* 3 CONTINUE
26347 A = XO**2 + YO**2
26348 IF ( A .LT. ANGLSQ ) THEN
26349 X=SDE*CFE
26350 Y=SDE*SFE
26351 Z=CDE*ZO
26352 ELSE
26353 XI=SDE*CFE
26354 YI=SDE*SFE
26355 ZI=CDE
26356 A=SQRT(A)
26357 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26358 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26359 Z=A*YI+ZO*ZI
26360 ENDIF
26361
26362 RETURN
26363 END
26364
26365*$ CREATE DT_MYTRAN.FOR
26366*COPY DT_MYTRAN
26367*
26368*===mytran=============================================================*
26369*
26370 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26371
26372************************************************************************
26373* This subroutine rotates the coordinate frame *
26374* a) theta around y *
26375* b) phi around z if IMODE = 1 *
26376* *
26377* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26378* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26379* z' 0 0 1 -sin(th) 0 cos(th) z *
26380* *
26381* and vice versa if IMODE = 0. *
26382* This version dated 5.4.94 is based on the original version DTRAN *
26383* by J. Ranft and is written by S. Roesler. *
26384************************************************************************
26385
26386 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26387 SAVE
26388
26389 PARAMETER ( LINP = 10 ,
26390 & LOUT = 6 ,
26391 & LDAT = 9 )
26392
26393 IF (IMODE.EQ.1) THEN
26394 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26395 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26396 Z=-SDE *XO +CDE *ZO
26397 ELSE
26398 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26399 Y= -SFE*XO+CFE*YO
26400 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26401 ENDIF
26402 RETURN
26403 END
26404
26405*$ CREATE DT_LT2LAO.FOR
26406*COPY DT_LT2LAO
26407*
26408*===lt2lab=============================================================*
26409*
26410 SUBROUTINE DT_LT2LAO
26411
26412************************************************************************
26413* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26414* for final state particles/fragments defined in nucleon-nucleon-cms *
26415* and transforms them back to the lab. *
26416* This version dated 16.11.95 is written by S. Roesler *
26417************************************************************************
26418
26419 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26420 SAVE
26421
26422 PARAMETER ( LINP = 10 ,
26423 & LOUT = 6 ,
26424 & LDAT = 9 )
26425
26426* event history
26427
26428 PARAMETER (NMXHKK=200000)
26429
26430 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26431 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26432 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26433
26434* extended event history
26435 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26436 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26437 & IHIST(2,NMXHKK)
26438
26439 NEND = NHKK
26440 NPOINT(5) = NHKK+1
26441 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26442 DO 1 I=NPOINT(4),NEND
26443C DO 1 I=1,NEND
26444 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26445 & (ISTHKK(I).EQ.1001)) THEN
26446 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26447 NOB = NOBAM(I)
26448 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26449 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26450 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26451 ISTHKK(I) = 3*ISTHKK(I)
26452 NOBAM(NHKK) = NOB
26453 ELSE
26454 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26455 ISTHKK(I) = SIGN(3,ISTHKK(I))
26456 ENDIF
26457 JDAHKK(1,I) = NHKK
26458 ENDIF
26459 1 CONTINUE
26460
26461 RETURN
26462 END
26463
26464*$ CREATE DT_LT2LAB.FOR
26465*COPY DT_LT2LAB
26466*
26467*===lt2lab=============================================================*
26468*
26469 SUBROUTINE DT_LT2LAB
26470
26471************************************************************************
26472* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26473* for final state particles/fragments defined in nucleon-nucleon-cms *
26474* and transforms them to the lab. *
26475* This version dated 07.01.96 is written by S. Roesler *
26476************************************************************************
26477
26478 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26479 SAVE
26480
26481 PARAMETER ( LINP = 10 ,
26482 & LOUT = 6 ,
26483 & LDAT = 9 )
26484
26485* event history
26486
26487 PARAMETER (NMXHKK=200000)
26488
26489 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26490 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26491 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26492
26493* extended event history
26494 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26495 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26496 & IHIST(2,NMXHKK)
26497
26498 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26499 DO 1 I=NPOINT(4),NHKK
26500 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26501 & (ISTHKK(I).EQ.1001)) THEN
26502 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26503 PHKK(3,I) = PZ
26504 PHKK(4,I) = PE
26505 ENDIF
26506 1 CONTINUE
26507
26508 RETURN
26509 END
26510
26511************************************************************************
26512* *
26513* 5) Sampling from distributions *
26514* *
26515************************************************************************
26516*$ CREATE IDT_NPOISS.FOR
26517*COPY IDT_NPOISS
26518*
26519*===npoiss=============================================================*
26520*
26521 INTEGER FUNCTION IDT_NPOISS(AVN)
26522
26523************************************************************************
26524* Sample according to Poisson distribution with Poisson parameter AVN. *
26525* The original version written by J. Ranft. *
26526* This version dated 11.1.95 is written by S. Roesler. *
26527************************************************************************
26528
26529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26530 SAVE
26531
26532 PARAMETER ( LINP = 10 ,
26533 & LOUT = 6 ,
26534 & LDAT = 9 )
26535
26536 EXPAVN = EXP(-AVN)
26537 K = 1
26538 A = 1.0D0
26539
26540 10 CONTINUE
26541 A = DT_RNDM(A)*A
26542 IF (A.GE.EXPAVN) THEN
26543 K = K+1
26544 GOTO 10
26545 ENDIF
26546 IDT_NPOISS = K-1
26547
26548 RETURN
26549 END
26550
26551*$ CREATE DT_SAMPXB.FOR
26552*COPY DT_SAMPXB
26553*
26554*===sampxb=============================================================*
26555*
26556 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26557
26558************************************************************************
26559* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26560* Processed by S. Roesler, 6.5.95 *
26561************************************************************************
26562
26563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26564 SAVE
26565 PARAMETER (TWO=2.0D0)
26566
26567 A1 = LOG(X1+SQRT(X1**2+B**2))
26568 A2 = LOG(X2+SQRT(X2**2+B**2))
26569 AN = A2-A1
26570 A = AN*DT_RNDM(A1)+A1
26571 BB = EXP(A)
26572 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26573
26574 RETURN
26575 END
26576
26577*$ CREATE DT_SAMPEX.FOR
26578*COPY DT_SAMPEX
26579*
26580*===sampex=============================================================*
26581*
26582 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26583
26584************************************************************************
26585* Sampling from f(x)=1./x between x1 and x2. *
26586* Processed by S. Roesler, 6.5.95 *
26587************************************************************************
26588
26589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26590 SAVE
26591 PARAMETER (ONE=1.0D0)
26592
26593 R = DT_RNDM(X1)
26594 AL1 = LOG(X1)
26595 AL2 = LOG(X2)
26596 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26597
26598 RETURN
26599 END
26600
26601*$ CREATE DT_SAMSQX.FOR
26602*COPY DT_SAMSQX
26603*
26604*===samsqx=============================================================*
26605*
26606 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26607
26608************************************************************************
26609* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26610* Processed by S. Roesler, 6.5.95 *
26611************************************************************************
26612
26613 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26614 SAVE
26615 PARAMETER (ONE=1.0D0)
26616
26617 R = DT_RNDM(X1)
26618 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26619
26620 RETURN
26621 END
26622
26623*$ CREATE DT_SAMPLW.FOR
26624*COPY DT_SAMPLW
26625*
26626*===samplw=============================================================*
26627*
26628 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26629
26630************************************************************************
26631* Sampling from f(x)=1/x^b between x_min and x_max. *
26632* S. Roesler, 18.4.98 *
26633************************************************************************
26634
26635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26636 SAVE
26637 PARAMETER (ONE=1.0D0)
26638
26639 R = DT_RNDM(B)
26640 IF (B.EQ.ONE) THEN
26641 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26642 ELSE
26643 ONEMB = ONE-B
26644 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26645 ENDIF
26646
26647 RETURN
26648 END
26649
26650*$ CREATE DT_BETREJ.FOR
26651*COPY DT_BETREJ
26652*
26653*===betrej=============================================================*
26654*
26655 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26656
26657 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26658 SAVE
26659
26660 PARAMETER ( LINP = 10 ,
26661 & LOUT = 6 ,
26662 & LDAT = 9 )
26663
26664 PARAMETER (ONE=1.0D0)
26665
26666 IF (XMIN.GE.XMAX)THEN
26667 WRITE (LOUT,500) XMIN,XMAX
26668 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26669 STOP
26670 ENDIF
26671
26672 10 CONTINUE
26673 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26674 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26675 YY = BETMAX*DT_RNDM(XX)
26676 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26677 IF (YY.GT.BETXX) GOTO 10
26678 DT_BETREJ = XX
26679
26680 RETURN
26681 END
26682
26683*$ CREATE DT_DGAMRN.FOR
26684*COPY DT_DGAMRN
26685*
26686*===dgamrn=============================================================*
26687*
26688 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26689
26690************************************************************************
26691* Sampling from Gamma-distribution. *
26692* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26693* Processed by S. Roesler, 6.5.95 *
26694************************************************************************
26695
26696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26697 SAVE
26698 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26699
26700 NCOU = 0
26701 N = INT(ETA)
26702 F = ETA-DBLE(N)
26703 IF (F.EQ.ZERO) GOTO 20
26704 10 R = DT_RNDM(F)
26705 NCOU = NCOU+1
26706 IF (NCOU.GE.11) GOTO 20
26707 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26708 YYY = LOG(DT_RNDM(R)+TINY9)/F
26709 IF (ABS(YYY).GT.50.0D0) GOTO 20
26710 Y = EXP(YYY)
26711 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26712 GOTO 40
26713 20 Y = 0.0D0
26714 GOTO 50
26715 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26716 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26717 40 IF (N.EQ.0) GOTO 70
26718 50 Z = 1.0D0
26719 DO 60 I = 1,N
26720 60 Z = Z*DT_RNDM(Z)
26721 Y = Y-LOG(Z+TINY9)
26722 70 DT_DGAMRN = Y/ALAM
26723
26724 RETURN
26725 END
26726
26727*$ CREATE DT_DBETAR.FOR
26728*COPY DT_DBETAR
26729*
26730*===dbetar=============================================================*
26731*
26732 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26733
26734************************************************************************
26735* Sampling from Beta -distribution between 0.0 and 1.0 *
26736* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26737* Processed by S. Roesler, 6.5.95 *
26738************************************************************************
26739
26740 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26741 SAVE
26742
26743 Y = DT_DGAMRN(1.0D0,GAM)
26744 Z = DT_DGAMRN(1.0D0,ETA)
26745 DT_DBETAR = Y/(Y+Z)
26746
26747 RETURN
26748 END
26749
26750*$ CREATE DT_RANNOR.FOR
26751*COPY DT_RANNOR
26752*
26753*===rannor=============================================================*
26754*
26755 SUBROUTINE DT_RANNOR(X,Y)
26756
26757************************************************************************
26758* Sampling from Gaussian distribution. *
26759* Processed by S. Roesler, 6.5.95 *
26760************************************************************************
26761
26762 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26763 SAVE
26764 PARAMETER (TINY10=1.0D-10)
26765
26766 CALL DT_DSFECF(SFE,CFE)
26767 V = MAX(TINY10,DT_RNDM(X))
26768 A = SQRT(-2.D0*LOG(V))
26769 X = A*SFE
26770 Y = A*CFE
26771
26772 RETURN
26773 END
26774
26775*$ CREATE DT_DPOLI.FOR
26776*COPY DT_DPOLI
26777*
26778*===dpoli==============================================================*
26779*
26780 SUBROUTINE DT_DPOLI(CS,SI)
26781
26782 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26783 SAVE
26784
26785 U = DT_RNDM(CS)
26786 CS = DT_RNDM(U)
26787 IF (U.LT.0.5D0) CS=-CS
26788 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26789
26790 RETURN
26791 END
26792
26793*$ CREATE DT_DSFECF.FOR
26794*COPY DT_DSFECF
26795*
26796*===dsfecf=============================================================*
26797*
26798 SUBROUTINE DT_DSFECF(SFE,CFE)
26799
26800 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26801 SAVE
26802 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26803
26804 1 CONTINUE
26805 X = DT_RNDM(SFE)
26806 Y = DT_RNDM(X)
26807 XX = X*X
26808 YY = Y*Y
26809 XY = XX+YY
26810 IF (XY.GT.ONE) GOTO 1
26811 CFE = (XX-YY)/XY
26812 SFE = TWO*X*Y/XY
26813 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26814 RETURN
26815 END
26816
26817*$ CREATE DT_RACO.FOR
26818*COPY DT_RACO
26819*
26820*===raco===============================================================*
26821*
26822 SUBROUTINE DT_RACO(WX,WY,WZ)
26823
26824************************************************************************
26825* Direction cosines of random uniform (isotropic) direction in three *
26826* dimensional space *
26827* Processed by S. Roesler, 20.11.95 *
26828************************************************************************
26829
26830 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26831 SAVE
26832 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26833
26834 10 CONTINUE
26835 X = TWO*DT_RNDM(WX)-ONE
26836 Y = DT_RNDM(X)
26837 X2 = X*X
26838 Y2 = Y*Y
26839 IF (X2+Y2.GT.ONE) GOTO 10
26840
26841 CFE = (X2-Y2)/(X2+Y2)
26842 SFE = TWO*X*Y/(X2+Y2)
26843* z = 1/2 [ 1 + cos (theta) ]
26844 Z = DT_RNDM(X)
26845* 1/2 sin (theta)
26846 WZ = SQRT(Z*(ONE-Z))
26847 WX = TWO*WZ*CFE
26848 WY = TWO*WZ*SFE
26849 WZ = TWO*Z-ONE
26850
26851 RETURN
26852 END
26853
26854************************************************************************
26855* *
26856* 6) Special functions, algorithms and service routines *
26857* *
26858************************************************************************
26859*$ CREATE DT_YLAMB.FOR
26860*COPY DT_YLAMB
26861*
26862*===ylamb==============================================================*
26863*
26864 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26865
26866************************************************************************
26867* *
26868* auxiliary function for three particle decay mode *
26869* (standard LAMBDA**(1/2) function) *
26870* *
26871* Adopted from an original version written by R. Engel. *
26872* This version dated 12.12.94 is written by S. Roesler. *
26873************************************************************************
26874
26875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26876 SAVE
26877
26878 YZ = Y-Z
26879 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26880 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26881 DT_YLAMB = SQRT(XLAM)
26882
26883 RETURN
26884 END
26885
26886*$ CREATE DT_SORT.FOR
26887*COPY DT_SORT
26888*
26889*===sort1==============================================================*
26890*
26891 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26892
26893************************************************************************
26894* This subroutine sorts entries in A in increasing/decreasing order *
26895* of A(3,i). *
26896* MODE = 1 increasing in A(3,i=1..N) *
26897* = 2 decreasing in A(3,i=1..N) *
26898* This version dated 21.04.95 is revised by S. Roesler *
26899************************************************************************
26900
26901 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26902 SAVE
26903
26904 DIMENSION A(3,N)
26905
26906 M = I1
26907 10 CONTINUE
26908 M = I1-1
26909 IF (M.LE.0) RETURN
26910 L = 0
26911 DO 20 I=I0,M
26912 J = I+1
26913 IF (MODE.EQ.1) THEN
26914 IF (A(3,I).LE.A(3,J)) GOTO 20
26915 ELSE
26916 IF (A(3,I).GE.A(3,J)) GOTO 20
26917 ENDIF
26918 B = A(3,I)
26919 C = A(1,I)
26920 D = A(2,I)
26921 A(3,I) = A(3,J)
26922 A(2,I) = A(2,J)
26923 A(1,I) = A(1,J)
26924 A(3,J) = B
26925 A(1,J) = C
26926 A(2,J) = D
26927 L = 1
26928 20 CONTINUE
26929 IF (L.EQ.1) GOTO 10
26930
26931 RETURN
26932 END
26933
26934*$ CREATE DT_SORT1.FOR
26935*COPY DT_SORT1
26936*
26937*===sort1==============================================================*
26938*
26939 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26940
26941************************************************************************
26942* This subroutine sorts entries in A in increasing/decreasing order *
26943* of A(i). *
26944* MODE = 1 increasing in A(i=1..N) *
26945* = 2 decreasing in A(i=1..N) *
26946* This version dated 21.04.95 is revised by S. Roesler *
26947************************************************************************
26948
26949 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26950 SAVE
26951
26952 DIMENSION A(N),IDX(N)
26953
26954 M = I1
26955 10 CONTINUE
26956 M = I1-1
26957 IF (M.LE.0) RETURN
26958 L = 0
26959 DO 20 I=I0,M
26960 J = I+1
26961 IF (MODE.EQ.1) THEN
26962 IF (A(I).LE.A(J)) GOTO 20
26963 ELSE
26964 IF (A(I).GE.A(J)) GOTO 20
26965 ENDIF
26966 B = A(I)
26967 A(I) = A(J)
26968 A(J) = B
26969 IX = IDX(I)
26970 IDX(I) = IDX(J)
26971 IDX(J) = IX
26972 L = 1
26973 20 CONTINUE
26974 IF (L.EQ.1) GOTO 10
26975
26976 RETURN
26977 END
26978
26979*$ CREATE DT_XTIME.FOR
26980*COPY DT_XTIME
26981*
26982*===xtime==============================================================*
26983*
26984 SUBROUTINE DT_XTIME
26985
26986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26987 SAVE
26988
26989 PARAMETER ( LINP = 10 ,
26990 & LOUT = 6 ,
26991 & LDAT = 9 )
26992
26993 CHARACTER DAT*9,TIM*11
26994
26995 DAT = ' '
26996 TIM = ' '
26997C CALL GETDAT(IYEAR,IMONTH,IDAY)
26998C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26999
27000C CALL DATE(DAT)
27001C CALL TIME(TIM)
27002C WRITE(LOUT,1000) DAT,TIM
27003 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27004
27005 RETURN
27006 END
27007
27008************************************************************************
27009* *
27010* 7) Random number generator package *
27011* *
27012* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27013* SERVICE ROUTINES. *
27014* THE ALGORITHM IS FROM *
27015* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27016* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27017* IMPLEMENTATION BY K. HAHN DEC. 88, *
27018* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27019* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27020* THE PERIOD IS ABOUT 2**144, *
27021* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27022* THE PACKAGE CONTAINS *
27023* FUNCTION DT_RNDM(I) : GENERATOR *
27024* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27025* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27026* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27027* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27028*--- *
27029* FUNCTION DT_RNDM(I) *
27030* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27031* I - DUMMY VARIABLE, NOT USED *
27032* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27033* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27034* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27035* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27036* 12,34,56 ARE THE STANDARD VALUES *
27037* NB1 MUST BE IN 1..168 *
27038* 78 IS THE STANDARD VALUE *
27039* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27040* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27041* AS AFTER THE LAST DT_RNDMOU CALL ) *
27042* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27043* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27044* TAKES SEED FROM GENERATOR *
27045* U(97),C,CD,CM,I,J - SEED VALUES *
27046* SUBROUTINE DT_RNDMTE(IO) *
27047* TEST OF THE GENERATOR *
27048* IO - DEFINES OUTPUT *
27049* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27050* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27051* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27052* SAME STATUS *
27053* AS BEFORE CALL OF DT_RNDMTE *
27054************************************************************************
27055*$ CREATE DT_RNDM.FOR
27056*COPY DT_RNDM
27057*
27058*===rndm===============================================================*
27059*
27060c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27061c$$$
27062c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27063c$$$ SAVE
27064c$$$
27065c$$$* counter of calls to random number generator
27066c$$$* uncomment if needed
27067c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27068c$$$C LOGICAL LFIRST
27069c$$$C DATA LFIRST /.TRUE./
27070c$$$
27071c$$$* counter of calls to random number generator
27072c$$$* uncomment if needed
27073c$$$C IF (LFIRST) THEN
27074c$$$C IRNCT0 = 0
27075c$$$C IRNCT1 = 0
27076c$$$C LFIRST = .FALSE.
27077c$$$C ENDIF
27078c$$$
27079c$$$ DT_RNDM = FLRNDM(VDUMMY)
27080c$$$* counter of calls to random number generator
27081c$$$* uncomment if needed
27082c$$$C IRNCT1 = IRNCT1+1
27083c$$$
27084c$$$ RETURN
27085c$$$ END
27086c$$$
27087c$$$*$ CREATE DT_RNDMST.FOR
27088c$$$*COPY DT_RNDMST
27089c$$$*
27090c$$$*===rndmst=============================================================*
27091c$$$*
27092c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27093c$$$
27094c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27095c$$$ SAVE
27096c$$$
27097c$$$* random number generator
27098c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27099c$$$
27100c$$$ MA1 = NA1
27101c$$$ MA2 = NA2
27102c$$$ MA3 = NA3
27103c$$$ MB1 = NB1
27104c$$$ I = 97
27105c$$$ J = 33
27106c$$$ DO 20 II2 = 1,97
27107c$$$ S = 0
27108c$$$ T = 0.5D0
27109c$$$ DO 10 II1 = 1,24
27110c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27111c$$$ MA1 = MA2
27112c$$$ MA2 = MA3
27113c$$$ MA3 = MAT
27114c$$$ MB1 = MOD(53*MB1+1,169)
27115c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27116c$$$ 10 T = 0.5D0*T
27117c$$$ 20 U(II2) = S
27118c$$$ C = 362436.0D0/16777216.0D0
27119c$$$ CD = 7654321.0D0/16777216.0D0
27120c$$$ CM = 16777213.0D0/16777216.0D0
27121c$$$ RETURN
27122c$$$ END
27123c$$$
27124c$$$*$ CREATE DT_RNDMIN.FOR
27125c$$$*COPY DT_RNDMIN
27126c$$$*
27127c$$$*===rndmin=============================================================*
27128c$$$*
27129c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27130c$$$
27131c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27132c$$$ SAVE
27133c$$$
27134c$$$* random number generator
27135c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27136c$$$
27137c$$$ DIMENSION UIN(97)
27138c$$$
27139c$$$ DO 10 KKK = 1,97
27140c$$$ 10 U(KKK) = UIN(KKK)
27141c$$$ C = CIN
27142c$$$ CD = CDIN
27143c$$$ CM = CMIN
27144c$$$ I = IIN
27145c$$$ J = JIN
27146c$$$
27147c$$$ RETURN
27148c$$$ END
27149c$$$
27150c$$$*$ CREATE DT_RNDMOU.FOR
27151c$$$*COPY DT_RNDMOU
27152c$$$*
27153c$$$*===rndmou=============================================================*
27154c$$$*
27155c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27156c$$$
27157c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27158c$$$ SAVE
27159c$$$
27160c$$$* random number generator
27161c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27162c$$$
27163c$$$ DIMENSION UOUT(97)
27164c$$$
27165c$$$ DO 10 KKK = 1,97
27166c$$$ 10 UOUT(KKK) = U(KKK)
27167c$$$ COUT = C
27168c$$$ CDOUT = CD
27169c$$$ CMOUT = CM
27170c$$$ IOUT = I
27171c$$$ JOUT = J
27172c$$$
27173c$$$ RETURN
27174c$$$ END
27175c$$$
27176c$$$*$ CREATE DT_RNDMTE.FOR
27177c$$$*COPY DT_RNDMTE
27178c$$$*
27179c$$$*===rndmte=============================================================*
27180c$$$*
27181c$$$ SUBROUTINE DT_RNDMTE(IO)
27182c$$$
27183c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27184c$$$ SAVE
27185c$$$
27186c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27187c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27188c$$$ +8354498.D0, 10633180.D0/
27189c$$$
27190c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27191c$$$ CALL DT_RNDMST(12,34,56,78)
27192c$$$ DO 10 II1 = 1,20000
27193c$$$ 10 XX = DT_RNDM(XX)
27194c$$$ SD = 0.0D0
27195c$$$ DO 20 II2 = 1,6
27196c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27197c$$$ D(II2) = X(II2)-U(II2)
27198c$$$ 20 SD = SD+D(II2)
27199c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27200c$$$**sr 24.01.95
27201c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27202c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27203c$$$C WRITE(6,1000)
27204c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27205c$$$ & ' passed')
27206c$$$ ENDIF
27207c$$$**
27208c$$$ RETURN
27209c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27210c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27211c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27212c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27213c$$$ END
27214*
27215*$ CREATE PHO_RNDM.FOR
27216*COPY PHO_RNDM
27217*
27218*===pho_rndm===========================================================*
27219*
27220 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27221
27222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27223 SAVE
27224
27225 PHO_RNDM = DT_RNDM(DUMMY)
27226
27227 RETURN
27228 END
27229
27230*$ CREATE PYR.FOR
27231*COPY PYR
27232*
27233*===pyr================================================================*
27234*
27235 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27236
27237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27238 SAVE
27239
27240 DUMMY = DBLE(IDUMMY)
27241 PYR = DT_RNDM(DUMMY)
27242
27243 RETURN
27244 END
27245*$ CREATE DT_TITLE.FOR
27246*COPY DT_TITLE
27247*
27248*===title==============================================================*
27249*
27250 SUBROUTINE DT_TITLE
27251
27252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27253 SAVE
27254
27255 PARAMETER ( LINP = 10 ,
27256 & LOUT = 6 ,
27257 & LDAT = 9 )
27258
27259 CHARACTER*6 CVERSI
27260 CHARACTER*11 CCHANG
27261 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27262
27263 CALL DT_XTIME
27264 WRITE(LOUT,1000) CVERSI,CCHANG
27265 1000 FORMAT(1X,'+-------------------------------------------------',
27266 & '----------------------+',/,
27267 & 1X,'|',71X,'|',/,
27268 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27269 & 1X,'|',71X,'|',/,
27270 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27271 & 1X,'|',71X,'|',/,
27272 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27273 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27274 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27275C & 1X,'|',71X,'|',/,
27276C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27277C & 17X,'|',/,
27278 & 1X,'|',71X,'|',/,
27279 & 1X,'+-------------------------------------------------',
27280 & '----------------------+',/,
27281 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27282 & 'Stefan.Roesler@cern.ch |',/,
27283 & 1X,'+-------------------------------------------------',
27284 & '----------------------+',/)
27285
27286 RETURN
27287 END
27288
27289*$ CREATE DT_EVTINI.FOR
27290*COPY DT_EVTINI
27291*
27292*===evtini=============================================================*
27293*
27294 SUBROUTINE DT_EVTINI
27295
27296************************************************************************
27297* Initialization of DTEVT1. *
27298* This version dated 15.01.94 is written by S. Roesler *
27299************************************************************************
27300
27301 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27302 SAVE
27303
27304 PARAMETER ( LINP = 10 ,
27305 & LOUT = 6 ,
27306 & LDAT = 9 )
27307
27308* event history
27309
27310 PARAMETER (NMXHKK=200000)
27311
27312 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27313 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27314 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27315
27316* extended event history
27317 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27318 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27319 & IHIST(2,NMXHKK)
27320
27321* event flag
27322 COMMON /DTEVNO/ NEVENT,ICASCA
27323
27324 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27325
27326* emulsion treatment
27327 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27328 & NCOMPO,IEMUL
27329
27330* initialization of DTEVT1/DTEVT2
27331 NEND = NHKK
27332 IF (NEVENT.EQ.1) NEND = NMXHKK
27333 NHKK = 0
27334 NEVHKK = NEVENT
27335 DO 1 I=1,NEND
27336 ISTHKK(I) = 0
27337 IDHKK(I) = 0
27338 JMOHKK(1,I) = 0
27339 JMOHKK(2,I) = 0
27340 JDAHKK(1,I) = 0
27341 JDAHKK(2,I) = 0
27342 IDRES(I) = 0
27343 IDXRES(I) = 0
27344 NOBAM(I) = 0
27345 IDCH(I) = 0
27346 IHIST(1,I) = 0
27347 IHIST(2,I) = 0
27348 DO 2 J=1,4
27349 PHKK(J,I) = 0.0D0
27350 VHKK(J,I) = 0.0D0
27351 WHKK(J,I) = 0.0D0
27352 2 CONTINUE
27353 PHKK(5,I) = 0.0D0
27354 1 CONTINUE
27355 DO 3 I=1,10
27356 NPOINT(I) = 0
27357 3 CONTINUE
27358 CALL DT_CHASTA(-1)
27359
27360C* initialization of DTLTRA
27361C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27362
27363 RETURN
27364 END
27365
27366*$ CREATE DT_STATIS.FOR
27367*COPY DT_STATIS
27368*
27369*===statis=============================================================*
27370*
27371 SUBROUTINE DT_STATIS(MODE)
27372
27373************************************************************************
27374* Initialization and output of run-statistics. *
27375* MODE = 1 initialization *
27376* = 2 output *
27377* This version dated 23.01.94 is written by S. Roesler *
27378************************************************************************
27379
27380 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27381 SAVE
27382
27383 PARAMETER ( LINP = 10 ,
27384 & LOUT = 6 ,
27385 & LDAT = 9 )
27386
27387 PARAMETER (TINY3=1.0D-3)
27388
27389* statistics
27390 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27391 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27392 & ICEVTG(8,0:30)
27393
27394* rejection counter
27395 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27396 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27397 & IREXCI(3),IRDIFF(2),IRINC
27398
27399* central particle production, impact parameter biasing
27400 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27401
27402* various options for treatment of partons (DTUNUC 1.x)
27403* (chain recombination, Cronin,..)
27404 LOGICAL LCO2CR,LINTPT
27405 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27406 & LCO2CR,LINTPT
27407
27408* nucleon-nucleon event-generator
27409 CHARACTER*8 CMODEL
27410 LOGICAL LPHOIN
27411 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27412
27413* flags for particle decays
27414 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27415 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27416 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27417
27418* diquark-breaking mechanism
27419 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27420
27421 DIMENSION PP(4),PT(4)
27422
27423 GOTO (1,2) MODE
27424
27425* initialization
27426 1 CONTINUE
27427
27428* initialize statistics counter
27429 ICREQU = 0
27430 ICSAMP = 0
27431 ICCPRO = 0
27432 ICDPR = 0
27433 ICDTA = 0
27434 ICRJSS = 0
27435 ICVV2S = 0
27436 DO 10 I=1,9
27437 ICRES(I) = 0
27438 ICCHAI(1,I) = 0
27439 ICCHAI(2,I) = 0
27440 10 CONTINUE
27441* initialize rejection counter
27442 IRPT = 0
27443 IRHHA = 0
27444 LOMRES = 0
27445 LOBRES = 0
27446 IRFRAG = 0
27447 IREVT = 0
27448 IRRES(1) = 0
27449 IRRES(2) = 0
27450 IRCHKI(1) = 0
27451 IRCHKI(2) = 0
27452 IRCRON(1) = 0
27453 IRCRON(2) = 0
27454 IRCRON(3) = 0
27455 IRDIFF(1) = 0
27456 IRDIFF(2) = 0
27457 IRINC = 0
27458 DO 11 I=1,5
27459 ICDIFF(I) = 0
27460 11 CONTINUE
27461 DO 12 I=1,8
27462 DO 13 J=0,30
27463 ICEVTG(I,J) = 0
27464 13 CONTINUE
27465 12 CONTINUE
27466
27467 RETURN
27468
27469* output
27470 2 CONTINUE
27471
27472* statistics counter
27473 WRITE(LOUT,1000)
27474 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27475 & 28X,'---------------------')
004932dd 27476 IF (ICREQU.GT.0) THEN
7b076c76 27477 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27478 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27479 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27480 & 'event',11X,F9.1)
004932dd 27481 ENDIF
7b076c76 27482 IF (ICDIFF(1).NE.0) THEN
27483 WRITE(LOUT,1009) ICDIFF
27484 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27485 & 'low mass high mass',/,24X,'single diffraction',
27486 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27487 ENDIF
004932dd 27488 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
7b076c76 27489 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27490 & DBLE(ICSAMP)/DBLE(ICCPRO)
27491 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27492 & ' of sampled Glauber-events per event',9X,F9.1,/,
27493 & 2X,'fraction of production cross section',21X,F10.6)
27494 ENDIF
004932dd 27495 IF (ICSAMP.GT.0) THEN
7b076c76 27496 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27497 & DBLE(ICDTA)/DBLE(ICSAMP)
27498 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27499 & ' nucleons after x-sampling',2(4X,F6.2))
004932dd 27500 ENDIF
7b076c76 27501
27502 IF (MCGENE.EQ.1) THEN
004932dd 27503 IF (ICSAMP.GT.0) THEN
7b076c76 27504 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27505 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27506 & ' event',3X,F9.1)
27507 IF (ISICHA.EQ.1) THEN
27508 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27509 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27510 & 'of single chains per event',13X,F9.1)
27511 ENDIF
004932dd 27512 ENDIF
27513 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
7b076c76 27514 WRITE(LOUT,1006)
27515 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27516 & 23X,'mean number of chains mean number of chains',/,
27517 & 23X,'sampled hadronized having mass of a reso.')
27518 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27519 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27520 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27521 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27522 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27523 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27524 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27525 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27526 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27527 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27531 WRITE(LOUT,1008)
27532 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27533 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27534 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27535 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27536 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27537 & DBLE(IRHHA)/DBLE(ICREQU),
27538 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27539 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27540 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27541 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27542 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27543 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27544 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27545 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27546 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27547 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27548 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27549 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27550 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27551 & F7.2,/,1X,'Total no. of rej.',
27552 & ' in chain-systems treatment (GETCSY)',/,43X,
27553 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27554 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27555 & 1X,'Total no. of rej. in DPM-treatment of one event',
27556 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27557 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27558 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27559 & 'IREXCI(3) = ',I5,/)
004932dd 27560 ENDIF
7b076c76 27561 ELSEIF (MCGENE.EQ.2) THEN
27562 WRITE(LOUT,1010) ELOJET
27563 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27564 & F4.1,' GeV')
27565 WRITE(LOUT,1011)
27566 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27567 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27568 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27569 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27570 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27571 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27572 & ((ICEVTG(I,J),I=1,8),J=3,7),
27573 & ((ICEVTG(I,J),I=1,8),J=19,21),
27574 & (ICEVTG(I,8),I=1,8),
27575 & ((ICEVTG(I,J),I=1,8),J=22,24),
27576 & (ICEVTG(I,9),I=1,8),
27577 & ((ICEVTG(I,J),I=1,8),J=25,28),
27578 & ((ICEVTG(I,J),I=1,8),J=10,18)
27579 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27580 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27581 & ' no-dif.',8I8,/,
27582 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27583 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27584 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27585 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27586 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27587 & ' hi-lo ',8I8,/,
27588 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27589 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27590 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27591 WRITE(LOUT,1013)
27592 1013 FORMAT(/,1X,'2. chain system statistics -',
27593 & ' mean numbers per evt:',/,30X,'---------------------',
27594 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
004932dd 27595 IF (ICSAMP.GT.0) THEN
7b076c76 27596 WRITE(LOUT,1014)
27597 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27598 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27599 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27600 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27601 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27602 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27603 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27604 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27605 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27606 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27607 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27608 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27609 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
004932dd 27610 ENDIF
7b076c76 27611 WRITE(LOUT,1015)
27612 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
004932dd 27613 IF (ICSAMP.GT.0) THEN
7b076c76 27614 WRITE(LOUT,1016)
27615 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27616 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27617 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27618 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27619 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27620 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27621 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27622 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27623 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27624 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27625 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27626 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27627 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
004932dd 27628 ENDIF
7b076c76 27629
27630 ENDIF
27631 CALL DT_CHASTA(1)
27632
27633 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27634 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27635 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27636 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27637 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27638 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27639 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27640 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27641 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27642 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27643 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27644 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27645 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27646 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27647 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27648 & DBRKA(3,1),DBRKA(3,2),
27649 & DBRKA(3,3),DBRKA(3,4)
27650 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27651 & DBRKR(3,1),DBRKR(3,2),
27652 & DBRKR(3,3),DBRKR(3,4)
27653 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27654 & DBRKA(3,5),DBRKA(3,6),
27655 & DBRKA(3,7),DBRKA(3,8)
27656 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27657 & DBRKR(3,5),DBRKR(3,6),
27658 & DBRKR(3,7),DBRKR(3,8)
27659 ENDIF
27660
27661 FAC = 1.0D0
27662 IF (MCGENE.EQ.2) THEN
27663
27664C CALL PHO_PHIST(-2,SIGMAX)
27665 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27666
27667 ENDIF
27668
27669 CALL DT_XTIME
27670
27671 RETURN
27672 END
27673
27674*$ CREATE DT_EVTOUT.FOR
27675*COPY DT_EVTOUT
27676*
27677*===evtout=============================================================*
27678*
27679 SUBROUTINE DT_EVTOUT(MODE)
27680
27681************************************************************************
27682* MODE = 1 plot content of complete DTEVT1 to out. unit *
27683* 3 plot entries of extended DTEVT1 (DTEVT2) *
27684* 4 plot entries of DTEVT1 and DTEVT2 *
27685* This version dated 11.12.94 is written by S. Roesler *
27686************************************************************************
27687
27688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27689 SAVE
27690
27691 PARAMETER ( LINP = 10 ,
27692 & LOUT = 6 ,
27693 & LDAT = 9 )
27694
27695* event history
27696
27697 PARAMETER (NMXHKK=200000)
27698
27699 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27700 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27701 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27702
27703 DIMENSION IRANGE(NMXHKK)
27704
27705 IF (MODE.EQ.2) RETURN
27706
27707 CALL DT_EVTPLO(IRANGE,MODE)
27708
27709 RETURN
27710 END
27711
27712*$ CREATE DT_EVTPLO.FOR
27713*COPY DT_EVTPLO
27714*
27715*===evtplo=============================================================*
27716*
27717 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27718
27719************************************************************************
27720* MODE = 1 plot content of complete DTEVT1 to out. unit *
27721* 2 plot entries of DTEVT1 given by IRANGE *
27722* 3 plot entries of extended DTEVT1 (DTEVT2) *
27723* 4 plot entries of DTEVT1 and DTEVT2 *
27724* 5 plot rejection counter *
27725* This version dated 11.12.94 is written by S. Roesler *
27726************************************************************************
27727
27728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27729 SAVE
27730
27731 PARAMETER ( LINP = 10 ,
27732 & LOUT = 6 ,
27733 & LDAT = 9 )
27734
27735 CHARACTER*16 CHAU
27736
27737* event history
27738
27739 PARAMETER (NMXHKK=200000)
27740
27741 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27742 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27743 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27744
27745* extended event history
27746 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27747 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27748 & IHIST(2,NMXHKK)
27749
27750* rejection counter
27751 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27752 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27753 & IREXCI(3),IRDIFF(2),IRINC
27754
27755 DIMENSION IRANGE(NMXHKK)
27756
27757 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27758 WRITE(LOUT,1000)
27759 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27760 & 15X,' --------------------------',/,/,
27761 & ' ST ID M1 M2 D1 D2 PX PY',
27762 & ' PZ E M',/)
27763 DO 1 I=1,NHKK
27764 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27765 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27766 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27767 & PHKK(5,I)
27768C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27769C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27770C & PHKK(3,I),PHKK(4,I)
27771C WRITE(LOUT,'(4E15.4)')
27772C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27773 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27774 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27775 1 CONTINUE
27776 WRITE(LOUT,*)
27777C DO 4 I=1,NHKK
27778C WRITE(LOUT,1006) I,ISTHKK(I),
27779C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27780C & WHKK(2,I),WHKK(3,I)
27781C1006 FORMAT(1X,I4,I6,6E10.3)
27782C 4 CONTINUE
27783 ENDIF
27784
27785 IF (MODE.EQ.2) THEN
27786 WRITE(LOUT,1000)
27787 NC = 0
27788 2 CONTINUE
27789 NC = NC+1
27790 IF (IRANGE(NC).EQ.-100) GOTO 9999
27791 I = IRANGE(NC)
27792 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27793 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27794 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27795 & PHKK(5,I)
27796 GOTO 2
27797 ENDIF
27798
27799 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27800 WRITE(LOUT,1002)
27801 1002 FORMAT(/,1X,'EVTPLO:',14X,
27802 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27803 & 15X,' -----------------------------------',/,/,
27804 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27805 & ' NOBAM IDCH M',/)
27806 DO 3 I=1,NHKK
27807C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27808 KF = IDHKK(I)
27809 IDCHK = KF/10000
27810 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27811 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27812
27813 CALL PYNAME(KF,CHAU)
27814
27815 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27816 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27817 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27818 & PHKK(5,I),CHAU
27819 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27820C ENDIF
27821 3 CONTINUE
27822 ENDIF
27823
27824 IF (MODE.EQ.5) THEN
27825 WRITE(LOUT,1004)
27826 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27827 & 15X,' --------------------------',/)
27828 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27829 & IRSEA,IRCRON
27830 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27831 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27832 & 1X,'IREMC = ',10I5,/,
27833 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27834 ENDIF
27835
27836 9999 RETURN
27837 END
27838
27839*$ CREATE DT_EVTPUT.FOR
27840*COPY DT_EVTPUT
27841*
27842*===evtput=============================================================*
27843*
27844 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27845
27846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27847 SAVE
27848
27849 PARAMETER ( LINP = 10 ,
27850 & LOUT = 6 ,
27851 & LDAT = 9 )
27852
27853 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27854 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27855
27856* event history
27857
27858 PARAMETER (NMXHKK=200000)
27859
27860 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27861 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27862 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27863
27864* extended event history
27865 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27866 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27867 & IHIST(2,NMXHKK)
27868
27869* Lorentz-parameters of the current interaction
27870 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27871 & UMO,PPCM,EPROJ,PPROJ
27872
27873* particle properties (BAMJET index convention)
27874 CHARACTER*8 ANAME
27875 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27876 & IICH(210),IIBAR(210),K1(210),K2(210)
27877
27878C IF (MODE.GT.100) THEN
27879C WRITE(LOUT,'(1X,A,I5,A,I5)')
27880C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27881C NHKK = NHKK-MODE+100
27882C RETURN
27883C ENDIF
27884 MO1 = M1
27885 MO2 = M2
27886 NHKK = NHKK+1
27887
27888 IF (NHKK.GT.NMXHKK) THEN
27889 WRITE(LOUT,1000) NHKK
27890 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27891 & '! program execution stopped..')
27892 STOP
27893 ENDIF
27894 IF (M1.LT.0) MO1 = NHKK+M1
27895 IF (M2.LT.0) MO2 = NHKK+M2
27896 ISTHKK(NHKK) = IST
27897 IDHKK(NHKK) = ID
27898 JMOHKK(1,NHKK) = MO1
27899 JMOHKK(2,NHKK) = MO2
27900 JDAHKK(1,NHKK) = 0
27901 JDAHKK(2,NHKK) = 0
27902 IDRES(NHKK) = IDR
27903 IDXRES(NHKK) = IDXR
27904 IDCH(NHKK) = IDC
27905** here we need to do something..
27906 IF (ID.EQ.88888) THEN
27907 IDMO1 = ABS(IDHKK(MO1))
27908 IDMO2 = ABS(IDHKK(MO2))
27909 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27910 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27911 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27912 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27913 ELSE
27914 NOBAM(NHKK) = 0
27915 ENDIF
27916 IDBAM(NHKK) = IDT_ICIHAD(ID)
27917 IF (MO1.GT.0) THEN
27918 IF (JDAHKK(1,MO1).NE.0) THEN
27919 JDAHKK(2,MO1) = NHKK
27920 ELSE
27921 JDAHKK(1,MO1) = NHKK
27922 ENDIF
27923 ENDIF
27924 IF (MO2.GT.0) THEN
27925 IF (JDAHKK(1,MO2).NE.0) THEN
27926 JDAHKK(2,MO2) = NHKK
27927 ELSE
27928 JDAHKK(1,MO2) = NHKK
27929 ENDIF
27930 ENDIF
27931C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27932C PTOT = SQRT(PX**2+PY**2+PZ**2)
27933C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27934C AMRQ = AAM(IDBAM(NHKK))
27935C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27936C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27937C & (PTOT.GT.ZERO)) THEN
27938C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27939CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27940C E = E+DELTA
27941C PTOT1 = PTOT-DELTA
27942C PX = PX*PTOT1/PTOT
27943C PY = PY*PTOT1/PTOT
27944C PZ = PZ*PTOT1/PTOT
27945C ENDIF
27946C ENDIF
27947 PHKK(1,NHKK) = PX
27948 PHKK(2,NHKK) = PY
27949 PHKK(3,NHKK) = PZ
27950 PHKK(4,NHKK) = E
27951 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27952 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27953 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27954 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27955 ELSE
27956 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27957C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27958C & WRITE(LOUT,'(1X,A,G10.3)')
27959C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27960 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27961 ENDIF
27962 IDCHK = ID/10000
27963 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27964* special treatment for chains:
27965* z coordinate of chain in Lab = pos. of target nucleon
27966* time of chain-creation in Lab = time of passage of projectile
27967* nucleus at pos. of taget nucleus
27968C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27969C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27970 VHKK(1,NHKK) = VHKK(1,MO2)
27971 VHKK(2,NHKK) = VHKK(2,MO2)
27972 VHKK(3,NHKK) = VHKK(3,MO2)
27973 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27974C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27975C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27976 WHKK(1,NHKK) = WHKK(1,MO1)
27977 WHKK(2,NHKK) = WHKK(2,MO1)
27978 WHKK(3,NHKK) = WHKK(3,MO1)
27979 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27980 ELSE
27981 IF (MO1.GT.0) THEN
27982 DO 1 I=1,4
27983 VHKK(I,NHKK) = VHKK(I,MO1)
27984 WHKK(I,NHKK) = WHKK(I,MO1)
27985 1 CONTINUE
27986 ELSE
27987 DO 2 I=1,4
27988 VHKK(I,NHKK) = ZERO
27989 WHKK(I,NHKK) = ZERO
27990 2 CONTINUE
27991 ENDIF
27992 ENDIF
27993
27994 RETURN
27995 END
27996
27997*$ CREATE DT_CHASTA.FOR
27998*COPY DT_CHASTA
27999*
28000*===chasta=============================================================*
28001*
28002 SUBROUTINE DT_CHASTA(MODE)
28003
28004************************************************************************
28005* This subroutine performs CHAin STAtistics and checks sequence of *
28006* partons in dtevt1 and sorts them with projectile partons coming *
28007* first if necessary. *
28008* *
28009* This version dated 8.5.00 is written by S. Roesler. *
28010************************************************************************
28011
28012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28013 SAVE
28014
28015 PARAMETER ( LINP = 10 ,
28016 & LOUT = 6 ,
28017 & LDAT = 9 )
28018
28019 CHARACTER*5 CCHTYP
28020
28021* event history
28022
28023 PARAMETER (NMXHKK=200000)
28024
28025 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28026 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28027 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28028
28029* extended event history
28030 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28031 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28032 & IHIST(2,NMXHKK)
28033
28034* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28035 PARAMETER (MAXCHN=10000)
28036 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28037
28038 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28039 & CCHTYP(9),ICHSTA(10),ITOT(10)
28040 DATA ICHCFG /1800*0/
28041 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28042 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28043 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28044 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28045 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28046 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28047 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28048 & 'ad aq',' d ad','ad d ',' g g '/
28049*
28050* initialization
28051*
28052 IF (MODE.EQ.-1) THEN
28053 NCHAIN = 0
28054*
28055* loop over DTEVT1 and analyse chain configurations
28056*
28057 ELSEIF (MODE.EQ.0) THEN
28058 DO 21 IDX=NPOINT(3),NHKK
28059 IDCHK = IDHKK(IDX)/10000
28060 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28061 & (IDHKK(IDX).NE.80000).AND.
28062 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28063 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28064 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28065 & ' at entry ',IDX
28066 GOTO 21
28067 ENDIF
28068*
28069 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28070 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28071 IMO1 = IST1/10
28072 IMO1 = IST1-10*IMO1
28073 IMO2 = IST2/10
28074 IMO2 = IST2-10*IMO2
28075* swop parton entries if necessary since we need projectile partons
28076* to come first in the common
28077 IF (IMO1.GT.IMO2) THEN
28078 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28079 DO 22 K=1,NPTN/2
28080 I0 = JMOHKK(1,IDX)-1+K
28081 I1 = JMOHKK(2,IDX)+1-K
28082 ITMP = ISTHKK(I0)
28083 ISTHKK(I0) = ISTHKK(I1)
28084 ISTHKK(I1) = ITMP
28085 ITMP = IDHKK(I0)
28086 IDHKK(I0) = IDHKK(I1)
28087 IDHKK(I1) = ITMP
28088 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28089 & JDAHKK(1,JMOHKK(1,I0)) = I1
28090 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28091 & JDAHKK(2,JMOHKK(1,I0)) = I1
28092 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28093 & JDAHKK(1,JMOHKK(2,I0)) = I1
28094 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28095 & JDAHKK(2,JMOHKK(2,I0)) = I1
28096 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28097 & JDAHKK(1,JMOHKK(1,I1)) = I0
28098 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28099 & JDAHKK(2,JMOHKK(1,I1)) = I0
28100 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28101 & JDAHKK(1,JMOHKK(2,I1)) = I0
28102 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28103 & JDAHKK(2,JMOHKK(2,I1)) = I0
28104 ITMP = JMOHKK(1,I0)
28105 JMOHKK(1,I0) = JMOHKK(1,I1)
28106 JMOHKK(1,I1) = ITMP
28107 ITMP = JMOHKK(2,I0)
28108 JMOHKK(2,I0) = JMOHKK(2,I1)
28109 JMOHKK(2,I1) = ITMP
28110 ITMP = JDAHKK(1,I0)
28111 JDAHKK(1,I0) = JDAHKK(1,I1)
28112 JDAHKK(1,I1) = ITMP
28113 ITMP = JDAHKK(2,I0)
28114 JDAHKK(2,I0) = JDAHKK(2,I1)
28115 JDAHKK(2,I1) = ITMP
28116 DO 23 J=1,4
28117 RTMP1 = PHKK(J,I0)
28118 RTMP2 = VHKK(J,I0)
28119 RTMP3 = WHKK(J,I0)
28120 PHKK(J,I0) = PHKK(J,I1)
28121 VHKK(J,I0) = VHKK(J,I1)
28122 WHKK(J,I0) = WHKK(J,I1)
28123 PHKK(J,I1) = RTMP1
28124 VHKK(J,I1) = RTMP2
28125 WHKK(J,I1) = RTMP3
28126 23 CONTINUE
28127 RTMP1 = PHKK(5,I0)
28128 PHKK(5,I0) = PHKK(5,I1)
28129 PHKK(5,I1) = RTMP1
28130 ITMP = IDRES(I0)
28131 IDRES(I0) = IDRES(I1)
28132 IDRES(I1) = ITMP
28133 ITMP = IDXRES(I0)
28134 IDXRES(I0) = IDXRES(I1)
28135 IDXRES(I1) = ITMP
28136 ITMP = NOBAM(I0)
28137 NOBAM(I0) = NOBAM(I1)
28138 NOBAM(I1) = ITMP
28139 ITMP = IDBAM(I0)
28140 IDBAM(I0) = IDBAM(I1)
28141 IDBAM(I1) = ITMP
28142 ITMP = IDCH(I0)
28143 IDCH(I0) = IDCH(I1)
28144 IDCH(I1) = ITMP
28145 ITMP = IHIST(1,I0)
28146 IHIST(1,I0) = IHIST(1,I1)
28147 IHIST(1,I1) = ITMP
28148 ITMP = IHIST(2,I0)
28149 IHIST(2,I0) = IHIST(2,I1)
28150 IHIST(2,I1) = ITMP
28151 22 CONTINUE
28152 ENDIF
28153 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28154 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28155*
28156* parton 1 (projectile side)
28157 IF (IST1.EQ.21) THEN
28158 IDX1 = 1
28159 ELSEIF (IST1.EQ.22) THEN
28160 IDX1 = 2
28161 ELSEIF (IST1.EQ.31) THEN
28162 IDX1 = 3
28163 ELSEIF (IST1.EQ.32) THEN
28164 IDX1 = 4
28165 ELSEIF (IST1.EQ.41) THEN
28166 IDX1 = 5
28167 ELSEIF (IST1.EQ.42) THEN
28168 IDX1 = 6
28169 ELSEIF (IST1.EQ.51) THEN
28170 IDX1 = 7
28171 ELSEIF (IST1.EQ.52) THEN
28172 IDX1 = 8
28173 ELSEIF (IST1.EQ.61) THEN
28174 IDX1 = 9
28175 ELSEIF (IST1.EQ.62) THEN
28176 IDX1 = 10
28177 ELSE
28178c WRITE(LOUT,*)
28179c & ' CHASTA: unknown parton status flag (',
28180c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28181 GOTO 21
28182 ENDIF
28183 ID = IDHKK(JMOHKK(1,IDX))
28184 IF (ABS(ID).LE.4) THEN
28185 IF (ID.GT.0) THEN
28186 ITYP1 = 1
28187 ELSE
28188 ITYP1 = 2
28189 ENDIF
28190 ELSEIF (ABS(ID).GE.1000) THEN
28191 IF (ID.GT.0) THEN
28192 ITYP1 = 3
28193 ELSE
28194 ITYP1 = 4
28195 ENDIF
28196 ELSEIF (ID.EQ.21) THEN
28197 ITYP1 = 5
28198 ELSE
28199 WRITE(LOUT,*)
28200 & ' CHASTA: inconsistent parton identity (',
28201 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28202 GOTO 21
28203 ENDIF
28204*
28205* parton 2 (target side)
28206 IF (IST2.EQ.21) THEN
28207 IDX2 = 1
28208 ELSEIF (IST2.EQ.22) THEN
28209 IDX2 = 2
28210 ELSEIF (IST2.EQ.31) THEN
28211 IDX2 = 3
28212 ELSEIF (IST2.EQ.32) THEN
28213 IDX2 = 4
28214 ELSEIF (IST2.EQ.41) THEN
28215 IDX2 = 5
28216 ELSEIF (IST2.EQ.42) THEN
28217 IDX2 = 6
28218 ELSEIF (IST2.EQ.51) THEN
28219 IDX2 = 7
28220 ELSEIF (IST2.EQ.52) THEN
28221 IDX2 = 8
28222 ELSEIF (IST2.EQ.61) THEN
28223 IDX2 = 9
28224 ELSEIF (IST2.EQ.62) THEN
28225 IDX2 = 10
28226 ELSE
28227c WRITE(LOUT,*)
28228c & ' CHASTA: unknown parton status flag (',
28229c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28230 GOTO 21
28231 ENDIF
28232 ID = IDHKK(JMOHKK(2,IDX))
28233 IF (ABS(ID).LE.4) THEN
28234 IF (ID.GT.0) THEN
28235 ITYP2 = 1
28236 ELSE
28237 ITYP2 = 2
28238 ENDIF
28239 ELSEIF (ABS(ID).GE.1000) THEN
28240 IF (ID.GT.0) THEN
28241 ITYP2 = 3
28242 ELSE
28243 ITYP2 = 4
28244 ENDIF
28245 ELSEIF (ID.EQ.21) THEN
28246 ITYP2 = 5
28247 ELSE
28248 WRITE(LOUT,*)
28249 & ' CHASTA: inconsistent parton identity (',
28250 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28251 GOTO 21
28252 ENDIF
28253*
28254* fill counter
28255 ITYPE = ICHTYP(ITYP1,ITYP2)
28256 IF (ITYPE.NE.0) THEN
28257 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28258 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28259 ICHCFG(IDX1,IDX2,ITYPE,2) =
28260 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28261
28262 NCHAIN = NCHAIN+1
28263 IF (NCHAIN.GT.MAXCHN) THEN
28264 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28265 & NCHAIN,MAXCHN
28266 STOP
28267 ENDIF
28268 IDXCHN(1,NCHAIN) = IDX
28269 IDXCHN(2,NCHAIN) = ITYPE
28270 ELSE
28271 WRITE(LOUT,*)
28272 & ' CHASTA: inconsistent chain at entry ',IDX
28273 GOTO 21
28274 ENDIF
28275 ENDIF
28276 21 CONTINUE
28277*
28278* write statistics to output unit
28279*
28280 ELSEIF (MODE.EQ.1) THEN
28281 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28282 DO 31 I=1,10
28283 WRITE(LOUT,'(/,2A)')
28284 & ' -----------------------------------------',
28285 & '------------------------------------'
28286 WRITE(LOUT,'(2A)')
28287 & ' p\\t 21 22 31 32 41',
28288 & ' 42 51 52 61 62'
28289 WRITE(LOUT,'(2A)')
28290 & ' -----------------------------------------',
28291 & '------------------------------------'
28292 DO 32 J=1,10
28293 ITOT(J) = 0
28294 DO 33 K=1,9
28295 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28296 33 CONTINUE
28297 32 CONTINUE
28298 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28299 DO 34 K=1,9
28300 ISUM = 0
28301 DO 35 J=1,10
28302 ISUM = ISUM+ICHCFG(I,J,K,1)
28303 35 CONTINUE
28304 IF (ISUM.GT.0)
28305 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28306 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28307 34 CONTINUE
28308C WRITE(LOUT,'(2A)')
28309C & ' -----------------------------------------',
28310C & '-------------------------------'
28311 31 CONTINUE
28312*
28313 ELSE
28314 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28315 STOP
28316 ENDIF
28317
28318 RETURN
28319 END
28320*$ CREATE PHO_PHIST.FOR
28321*COPY PHO_PHIST
28322*
28323*===pohist=============================================================*
28324*
28325 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28326
28327 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28328 SAVE
28329
28330 PARAMETER ( LINP = 10 ,
28331 & LOUT = 6 ,
28332 & LDAT = 9 )
28333
28334 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28335
28336* Glauber formalism: cross sections
28337 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28338 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28339 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28340 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28341 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28342 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28343 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28344 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28345 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28346 & BSLOPE,NEBINI,NQBINI
28347
28348 ILAB = 0
28349 IF (IMODE.EQ.10) THEN
28350 IMODE = 1
28351 ILAB = 1
28352 ENDIF
28353 IF (ABS(IMODE).LT.1000) THEN
28354* PHOJET-statistics
28355C CALL POHISX(IMODE,WEIGHT)
28356 IF (IMODE.EQ.-1) THEN
28357 MODE = 1
28358 XSTOT(1,1,1) = WEIGHT
28359 ENDIF
28360 IF (IMODE.EQ. 1) MODE = 2
28361 IF (IMODE.EQ.-2) MODE = 3
28362 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28363C IF (MODE.EQ.3) WRITE(LOUT,*)
28364C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28365 CALL DT_HISTOG(MODE)
28366 CALL DT_USRHIS(MODE)
28367 ELSE
28368* DTUNUC-statistics
28369 MODE = IMODE/1000
28370C IF (MODE.EQ.3) WRITE(LOUT,*)
28371C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28372 CALL DT_HISTOG(MODE)
28373 CALL DT_USRHIS(MODE)
28374 ENDIF
28375
28376 RETURN
28377 END
28378
28379*$ CREATE DT_SWPPHO.FOR
28380*COPY DT_SWPPHO
28381*
28382*===swppho=============================================================*
28383*
28384 SUBROUTINE DT_SWPPHO(ILAB)
28385
28386 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28387 SAVE
28388
28389 PARAMETER ( LINP = 10 ,
28390 & LOUT = 6 ,
28391 & LDAT = 9 )
28392
28393 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28394
28395 LOGICAL LSTART
28396
28397* event history
28398
28399 PARAMETER (NMXHKK=200000)
28400
28401 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28402 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28403 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28404
28405* extended event history
28406 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28407 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28408 & IHIST(2,NMXHKK)
28409
28410* flags for input different options
28411 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28412 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28413 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28414
28415* properties of photon/lepton projectiles
28416 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28417
28418**PHOJET105a
28419C PARAMETER (NMXHEP=2000)
28420C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28421C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28422C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28423C COMMON /PLASAV/ PLAB
28424**PHOJET110
28425C standard particle data interface
28426 INTEGER NMXHEP
28427
28428 PARAMETER (NMXHEP=4000)
28429
28430 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28431 DOUBLE PRECISION PHEP,VHEP
28432 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28433 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28434 & VHEP(4,NMXHEP)
28435C extension to standard particle data interface (PHOJET specific)
28436 INTEGER IMPART,IPHIST,ICOLOR
28437 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28438
28439C global event kinematics and particle IDs
28440 INTEGER IFPAP,IFPAB
28441 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28442 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28443**
28444 DATA ICOUNT/0/
28445
28446 DATA LSTART /.TRUE./
28447
28448C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28449 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28450 UMO = ECM
28451 ELA = ZERO
28452 PLA = ZERO
28453 IDP = IDT_ICIHAD(IFPAP(1))
28454 IDT = IDT_ICIHAD(IFPAP(2))
28455 VIRT = PVIRT(1)
28456 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28457 PLAB = PLA
28458 LSTART = .FALSE.
28459 ENDIF
28460
28461 NHKK = 0
28462 ICOUNT = ICOUNT+1
28463C NEVHKK = NEVHEP
28464 NEVHKK = ICOUNT
28465 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28466 DO 1 I=3,NHEP
28467 IF (ISTHEP(I).EQ.1) THEN
28468 NHKK = NHKK+1
28469 ISTHKK(NHKK) = 1
28470 IDHKK(NHKK) = IDHEP(I)
28471 JMOHKK(1,NHKK) = 0
28472 JMOHKK(2,NHKK) = 0
28473 JDAHKK(1,NHKK) = 0
28474 JDAHKK(2,NHKK) = 0
28475 DO 2 K=1,4
28476 PHKK(K,NHKK) = PHEP(K,I)
28477 VHKK(K,NHKK) = ZERO
28478 WHKK(K,NHKK) = ZERO
28479 2 CONTINUE
28480 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28481 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28482 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28483 PHKK(5,NHKK) = PHEP(5,I)
28484 IDRES(NHKK) = 0
28485 IDXRES(NHKK) = 0
28486 NOBAM(NHKK) = 0
28487 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28488 IDCH(NHKK) = 0
28489 ENDIF
28490 1 CONTINUE
28491
28492 RETURN
28493 END
28494
28495*$ CREATE DT_HISTOG.FOR
28496*COPY DT_HISTOG
28497*
28498*===histog=============================================================*
28499*
28500 SUBROUTINE DT_HISTOG(MODE)
28501
28502************************************************************************
28503* This version dated 25.03.96 is written by S. Roesler *
28504************************************************************************
28505
28506 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28507 SAVE
28508
28509 PARAMETER ( LINP = 10 ,
28510 & LOUT = 6 ,
28511 & LDAT = 9 )
28512
28513 LOGICAL LFSP,LRNL
28514
28515* event history
28516
28517 PARAMETER (NMXHKK=200000)
28518
28519 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28520 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28521 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28522
28523* extended event history
28524 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28525 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28526 & IHIST(2,NMXHKK)
28527
28528* event flag used for histograms
28529 COMMON /DTNORM/ ICEVT,IEVHKK
28530
28531* flags for activated histograms
28532 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28533
28534 IEVHKK = NEVHKK
28535 GOTO (1,2,3) MODE
28536
28537*------------------------------------------------------------------
28538* initialization
28539 1 CONTINUE
28540 ICEVT = 0
28541 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28542 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28543
28544 RETURN
28545*------------------------------------------------------------------
28546* filling of histogram with event-record
28547 2 CONTINUE
28548 ICEVT = ICEVT+1
28549
28550 DO 20 I=1,NHKK
28551 CALL DT_SWPFSP(I,LFSP,LRNL)
28552 IF (LFSP) THEN
28553 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28554 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28555 ENDIF
28556 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28557 20 CONTINUE
28558 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28559
28560 RETURN
28561*------------------------------------------------------------------
28562* output
28563 3 CONTINUE
28564 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28565 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28566
28567 RETURN
28568 END
28569
28570*$ CREATE DT_SWPFSP.FOR
28571*COPY DT_SWPFSP
28572*
28573*===swpfsp=============================================================*
28574*
28575 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28576
28577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28578 SAVE
28579 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28580 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28581 & PI =TWOPI/TWO,
28582 & BOG =TWOPI/360.0D0)
28583
28584* event history
28585
28586 PARAMETER (NMXHKK=200000)
28587
28588 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28589 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28590 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28591
28592* extended event history
28593 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28594 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28595 & IHIST(2,NMXHKK)
28596
28597* particle properties (BAMJET index convention)
28598 CHARACTER*8 ANAME
28599 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28600 & IICH(210),IIBAR(210),K1(210),K2(210)
28601
28602* Lorentz-parameters of the current interaction
28603 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28604 & UMO,PPCM,EPROJ,PPROJ
28605
28606* flags for input different options
28607 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28608 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28609 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28610
28611* INCLUDE '(DIMPAR)'
28612* Taken from FLUKA
28613 PARAMETER ( MXXRGN =20000 )
28614 PARAMETER ( MXXMDF = 710 )
28615 PARAMETER ( MXXMDE = 702 )
28616 PARAMETER ( MFSTCK =40000 )
28617 PARAMETER ( MESTCK = 100 )
28618 PARAMETER ( MOSTCK = 2000 )
28619 PARAMETER ( MXPRSN = 100 )
28620 PARAMETER ( MXPDPM = 800 )
28621 PARAMETER ( MXPSCS =30000 )
28622 PARAMETER ( MXGLWN = 300 )
28623 PARAMETER ( MXOUTU = 50 )
28624 PARAMETER ( NALLWP = 64 )
28625 PARAMETER ( NELEMX = 80 )
28626 PARAMETER ( MPDPDX = 18 )
28627 PARAMETER ( MXHTTR = 260 )
28628 PARAMETER ( MXSEAX = 20 )
28629 PARAMETER ( MXHTNC = MXSEAX + 1 )
28630 PARAMETER ( ICOMAX = 2400 )
28631 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28632 PARAMETER ( NSTBIS = 304 )
28633 PARAMETER ( NQSTIS = 46 )
28634 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28635 PARAMETER ( MXPABL = 120 )
28636 PARAMETER ( IDMAXP = 450 )
28637 PARAMETER ( IDMXDC = 2000 )
28638 PARAMETER ( MXMCIN = 410 )
28639 PARAMETER ( IHYPMX = 4 )
28640 PARAMETER ( MKBMX1 = 11 )
28641 PARAMETER ( MKBMX2 = 11 )
28642 PARAMETER ( MXIRRD = 2500 )
28643 PARAMETER ( MXTRDC = 1500 )
28644 PARAMETER ( NKTL = 17 )
28645 PARAMETER ( NBLNMX = 40000000 )
28646
28647* INCLUDE '(PAREVT)'
28648* Taken from FLUKA
28649 PARAMETER ( FRDIFF = 0.2D+00 )
28650 PARAMETER ( ETHSEA = 1.0D+00 )
28651*
28652 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28653 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28654 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28655 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28656 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28657 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28658 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28659 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28660 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28661 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28662
28663* temporary storage for one final state particle
28664 LOGICAL LFRAG,LGREY,LBLACK
28665 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28666 & SINTHE,COSTHE,THETA,THECMS,
28667 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28668 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28669 & LFRAG,LGREY,LBLACK
28670
28671 LOGICAL LFSP,LRNL
28672
28673 LFSP = .FALSE.
28674 LRNL = .FALSE.
28675 ISTRNL = 1000
28676 MULDEF = 1
28677 IF (LEVPRT) ISTRNL = 1001
28678
28679 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28680 IST = ISTHKK(IDX)
28681 IDPDG = IDHKK(IDX)
28682 LFRAG = .FALSE.
28683 IF (IDHKK(IDX).LT.80000) THEN
28684 IDBJT = IDBAM(IDX)
28685 IBARY = IIBAR(IDBJT)
28686 ICHAR = IICH(IDBJT)
28687 AMASS = AAM(IDBJT)
28688 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28689 IDBJT = 0
28690 IBARY = IDRES(IDX)
28691 ICHAR = IDXRES(IDX)
28692 AMASS = PHKK(5,IDX)
28693 INUT = IBARY-ICHAR
28694 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28695 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28696 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28697 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28698 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28699 ELSE
28700 GOTO 9999
28701 ENDIF
28702 PE = PHKK(4,IDX)
28703 PX = PHKK(1,IDX)
28704 PY = PHKK(2,IDX)
28705 PZ = PHKK(3,IDX)
28706 PT2 = PX**2+PY**2
28707 PT = SQRT(PT2)
28708 PTOT = SQRT(PT2+PZ**2)
28709 SINTHE = PT/MAX(PTOT,TINY14)
28710 COSTHE = PZ/MAX(PTOT,TINY14)
28711 IF (COSTHE.GT.ONE) THEN
28712 THETA = ZERO
28713 ELSEIF (COSTHE.LT.-ONE) THEN
28714 THETA = TWOPI/2.0D0
28715 ELSE
28716 THETA = ACOS(COSTHE)
28717 ENDIF
28718 EKIN = PE-AMASS
28719**sr 15.4.96 new E_t-definition
28720 IF (IBARY.GT.0) THEN
28721 ET = EKIN*SINTHE
28722 ELSEIF (IBARY.LT.0) THEN
28723 ET = (EKIN+TWO*AMASS)*SINTHE
28724 ELSE
28725 ET = PE*SINTHE
28726 ENDIF
28727**
28728 XLAB = PZ/MAX(PPROJ,TINY14)
28729C XLAB = PE/MAX(EPROJ,TINY14)
28730 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28731 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28732 PPLUS = PE+PZ
28733 PMINUS = PE-PZ
28734 IF (PMINUS.GT.TINY14) THEN
28735 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28736 ELSE
28737 YY = 100.0D0
28738 ENDIF
28739 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28740 ETA = -LOG(TAN(THETA/TWO))
28741 ELSE
28742 ETA = 100.0D0
28743 ENDIF
28744 IF (IFRAME.EQ.1) THEN
28745 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28746 PPLUS = EECMS+PZCMS
28747 PMINUS = EECMS-PZCMS
28748 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28749 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28750 ELSE
28751 YYCMS = 100.0D0
28752 ENDIF
28753 PTOTCM = SQRT(PT2+PZCMS**2)
28754 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28755 IF (COSTH.GT.ONE) THEN
28756 THECMS = ZERO
28757 ELSEIF (COSTH.LT.-ONE) THEN
28758 THECMS = TWOPI/2.0D0
28759 ELSE
28760 THECMS = ACOS(COSTH)
28761 ENDIF
28762 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28763 ETACMS = -LOG(TAN(THECMS/TWO))
28764 ELSE
28765 ETACMS = 100.0D0
28766 ENDIF
28767 XF = PZCMS/MAX(PPCM,TINY14)
28768 THECMS = THECMS/BOG
28769 ELSE
28770 PZCMS = PZ
28771 EECMS = PE
28772 YYCMS = YY
28773 ETACMS = ETA
28774 XF = XLAB
28775 THECMS = THETA/BOG
28776 ENDIF
28777 THETA = THETA/BOG
28778
28779* set flag for "grey/black"
28780 LGREY = .FALSE.
28781 LBLACK = .FALSE.
28782 EK = EKIN
28783 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28784 IF (MULDEF.EQ.1) THEN
28785* EMU01-Def.
28786 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28787 & (EK.LE.375.0D-3) ).OR.
28788 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28789 & (EK.LE. 56.0D-3) ).OR.
28790 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28791 & (EK.LE. 56.0D-3) ).OR.
28792 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28793 & (EK.LE.198.0D-3) ).OR.
28794 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28795 & (EK.LE.198.0D-3) ).OR.
28796 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28797 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28798 & (IDBJT.NE.16).AND.
28799 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28800 & LGREY = .TRUE.
28801 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28802 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28803 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28804 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28805 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28806 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28807 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28808 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28809 & LBLACK = .TRUE.
28810 ELSE
28811* common Def.
28812 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28813 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28814 ENDIF
28815 LFSP = .TRUE.
28816 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28817 IST = ISTHKK(IDX)
28818 IDPDG = IDHKK(IDX)
28819 LFRAG = .TRUE.
28820 IDBJT = 0
28821 IBARY = IDRES(IDX)
28822 ICHAR = IDXRES(IDX)
28823 AMASS = PHKK(5,IDX)
28824 PE = PHKK(4,IDX)
28825 PX = PHKK(1,IDX)
28826 PY = PHKK(2,IDX)
28827 PZ = PHKK(3,IDX)
28828 PT2 = PX**2+PY**2
28829 PT = SQRT(PT2)
28830 PTOT = SQRT(PT2+PZ**2)
28831 SINTHE = PT/MAX(PTOT,TINY14)
28832 COSTHE = PZ/MAX(PTOT,TINY14)
28833 IF (COSTHE.GT.ONE) THEN
28834 THETA = ZERO
28835 ELSEIF (COSTHE.LT.-ONE) THEN
28836 THETA = TWOPI/2.0D0
28837 ELSE
28838 THETA = ACOS(COSTHE)
28839 ENDIF
28840 EKIN = PE-AMASS
28841**sr 15.4.96 new E_t-definition
28842C ET = PE*SINTHE
28843 ET = EKIN*SINTHE
28844**
28845 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28846 ETA = -LOG(TAN(THETA/TWO))
28847 ELSE
28848 ETA = 100.0D0
28849 ENDIF
28850 THETA = THETA/BOG
28851 LRNL = .TRUE.
28852 ENDIF
28853
28854 9999 CONTINUE
28855 RETURN
28856 END
28857
28858*$ CREATE DT_HIMULT.FOR
28859*COPY DT_HIMULT
28860*
28861*===himult=============================================================*
28862*
28863 SUBROUTINE DT_HIMULT(MODE)
28864
28865************************************************************************
28866* Tables of average energies/multiplicities. *
28867* This version dated 30.08.2000 is written by S. Roesler *
28868************************************************************************
28869
28870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28871 SAVE
28872
28873 PARAMETER ( LINP = 10 ,
28874 & LOUT = 6 ,
28875 & LDAT = 9 )
28876
28877 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28878
28879 PARAMETER (SWMEXP=1.7D0)
28880
28881 CHARACTER*8 ANAMEH(4)
28882
28883* particle properties (BAMJET index convention)
28884 CHARACTER*8 ANAME
28885 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28886 & IICH(210),IIBAR(210),K1(210),K2(210)
28887
28888* temporary storage for one final state particle
28889 LOGICAL LFRAG,LGREY,LBLACK
28890 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28891 & SINTHE,COSTHE,THETA,THECMS,
28892 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28893 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28894 & LFRAG,LGREY,LBLACK
28895
28896* event flag used for histograms
28897 COMMON /DTNORM/ ICEVT,IEVHKK
28898
28899* Lorentz-parameters of the current interaction
28900 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28901 & UMO,PPCM,EPROJ,PPROJ
28902
28903 PARAMETER (NOPART=210)
28904 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28905 & AVPT(4,NOPART),IAVPT(4,NOPART)
28906 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28907
28908 GOTO (1,2,3) MODE
28909
28910*------------------------------------------------------------------
28911* initialization
28912 1 CONTINUE
28913 DO 10 I=1,NOPART
28914 DO 11 J=1,4
28915 AVMULT(J,I) = ZERO
28916 AVE(J,I) = ZERO
28917 AVSWM(J,I) = ZERO
28918 AVPT(J,I) = ZERO
28919 IAVPT(J,I) = 0
28920 11 CONTINUE
28921 10 CONTINUE
28922
28923 RETURN
28924
28925*------------------------------------------------------------------
28926* filling of histogram with event-record
28927 2 CONTINUE
28928 IF (PE.LT.0.0D0) THEN
28929 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28930 RETURN
28931 ENDIF
28932 IF (.NOT.LFRAG) THEN
28933 IVEL = 2
28934 IF (LGREY) IVEL = 3
28935 IF (LBLACK) IVEL = 4
28936 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28937 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28938 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28939 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28940 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28941 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28942 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28943 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28944 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28945 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28946 IF (IDBJT.LT.116) THEN
28947* total energy, multiplicity
28948 AVE(1,30) = AVE(1,30) +PE
28949 AVE(IVEL,30) = AVE(IVEL,30)+PE
28950 AVPT(1,30) = AVPT(1,30) +PT
28951 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28952 IAVPT(1,30) = IAVPT(1,30) +1
28953 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28954 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28955 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28956 AVMULT(1,30) = AVMULT(1,30) +ONE
28957 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28958* charged energy, multiplicity
28959 IF (ICHAR.LT.0) THEN
28960 AVE(1,26) = AVE(1,26) +PE
28961 AVE(IVEL,26) = AVE(IVEL,26)+PE
28962 AVPT(1,26) = AVPT(1,26) +PT
28963 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28964 IAVPT(1,26) = IAVPT(1,26) +1
28965 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28966 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28967 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28968 AVMULT(1,26) = AVMULT(1,26) +ONE
28969 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28970 ENDIF
28971 IF (ICHAR.NE.0) THEN
28972 AVE(1,27) = AVE(1,27) +PE
28973 AVE(IVEL,27) = AVE(IVEL,27)+PE
28974 AVPT(1,27) = AVPT(1,27) +PT
28975 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28976 IAVPT(1,27) = IAVPT(1,27) +1
28977 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28978 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28979 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28980 AVMULT(1,27) = AVMULT(1,27) +ONE
28981 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28982 ENDIF
28983 ENDIF
28984 ENDIF
28985
28986 RETURN
28987
28988*------------------------------------------------------------------
28989* output
28990 3 CONTINUE
28991 WRITE(LOUT,3000)
28992 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28993 & 29X,'---------------------',/)
28994 IF (MULDEF.EQ.1) THEN
28995 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28996 ELSE
28997 BETGRE = 0.7D0
28998 BETBLC = 0.23D0
28999 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29000 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29001 & ,F4.2,' black: beta < ',F4.2,/)
29002 ENDIF
29003 WRITE(LOUT,3003) SWMEXP
29004 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29005 & 13X,'| total fast',
29006C & ' grey black K f(',F3.1,')',/,1X,
29007 & ' grey black <pt> f(',F3.1,')',/,1X,
29008 & '------------+--------------',
29009 & '-------------------------------------------------')
29010 DO 30 I=1,NOPART
29011 DO 31 J=1,4
29012 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29013 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29014 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29015 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29016 31 CONTINUE
29017 IF (I.LE.115) THEN
29018 WRITE(LOUT,3004) ANAME(I),I,
29019 & AVMULT(1,I),AVMULT(2,I),
29020 & AVMULT(3,I),AVMULT(4,I),
29021C & AVE(1,I),AVSWM(1,I)
29022 & AVPT(1,I),AVSWM(1,I)
29023 ELSEIF (I.LE.119) THEN
29024 WRITE(LOUT,3004) ANAMEH(I-115),I,
29025 & AVMULT(1,I),AVMULT(2,I),
29026 & AVMULT(3,I),AVMULT(4,I),
29027C & AVE(1,I),AVSWM(1,I)
29028 & AVPT(1,I),AVSWM(1,I)
29029 ENDIF
29030 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29031 30 CONTINUE
29032**temporary
29033C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29034C & AVMULT(3,27)+AVMULT(4,27)
29035**
29036
29037 RETURN
29038 END
29039
29040*$ CREATE DT_HISTAT.FOR
29041*COPY DT_HISTAT
29042*
29043*===histat=============================================================*
29044*
29045 SUBROUTINE DT_HISTAT(IDX,MODE)
29046
29047************************************************************************
29048* This version dated 26.02.96 is written by S. Roesler *
29049* *
29050* Last change 27.12.2006 by S. Roesler. *
29051************************************************************************
29052
29053 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29054 SAVE
29055
29056 PARAMETER ( LINP = 10 ,
29057 & LOUT = 6 ,
29058 & LDAT = 9 )
29059
29060 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29061 PARAMETER (NDIM=199)
29062
29063* event history
29064
29065 PARAMETER (NMXHKK=200000)
29066
29067 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29068 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29069 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29070
29071* extended event history
29072 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29073 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29074 & IHIST(2,NMXHKK)
29075
29076* particle properties (BAMJET index convention)
29077 CHARACTER*8 ANAME
29078 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29079 & IICH(210),IIBAR(210),K1(210),K2(210)
29080
29081 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29082
29083* Glauber formalism: cross sections
29084 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29085 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29086 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29087 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29088 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29089 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29090 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29091 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29092 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29093 & BSLOPE,NEBINI,NQBINI
29094
29095* emulsion treatment
29096 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29097 & NCOMPO,IEMUL
29098
29099* properties of interacting particles
29100 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29101
29102* rejection counter
29103 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29104 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29105 & IREXCI(3),IRDIFF(2),IRINC
29106
29107* statistics: residual nuclei
29108 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29109 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29110 & NINCST(2,4),NINCEV(2),
29111 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29112 & NRESPB(2),NRESCH(2),NRESEV(4),
29113 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29114 & NEVAFI(2,2)
29115
29116* parameter for intranuclear cascade
29117 LOGICAL LPAULI
29118 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29119
29120* INCLUDE '(DIMPAR)'
29121* Taken from FLUKA
29122 PARAMETER ( MXXRGN =20000 )
29123 PARAMETER ( MXXMDF = 710 )
29124 PARAMETER ( MXXMDE = 702 )
29125 PARAMETER ( MFSTCK =40000 )
29126 PARAMETER ( MESTCK = 100 )
29127 PARAMETER ( MOSTCK = 2000 )
29128 PARAMETER ( MXPRSN = 100 )
29129 PARAMETER ( MXPDPM = 800 )
29130 PARAMETER ( MXPSCS =30000 )
29131 PARAMETER ( MXGLWN = 300 )
29132 PARAMETER ( MXOUTU = 50 )
29133 PARAMETER ( NALLWP = 64 )
29134 PARAMETER ( NELEMX = 80 )
29135 PARAMETER ( MPDPDX = 18 )
29136 PARAMETER ( MXHTTR = 260 )
29137 PARAMETER ( MXSEAX = 20 )
29138 PARAMETER ( MXHTNC = MXSEAX + 1 )
29139 PARAMETER ( ICOMAX = 2400 )
29140 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29141 PARAMETER ( NSTBIS = 304 )
29142 PARAMETER ( NQSTIS = 46 )
29143 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29144 PARAMETER ( MXPABL = 120 )
29145 PARAMETER ( IDMAXP = 450 )
29146 PARAMETER ( IDMXDC = 2000 )
29147 PARAMETER ( MXMCIN = 410 )
29148 PARAMETER ( IHYPMX = 4 )
29149 PARAMETER ( MKBMX1 = 11 )
29150 PARAMETER ( MKBMX2 = 11 )
29151 PARAMETER ( MXIRRD = 2500 )
29152 PARAMETER ( MXTRDC = 1500 )
29153 PARAMETER ( NKTL = 17 )
29154 PARAMETER ( NBLNMX = 40000000 )
29155
29156* INCLUDE '(PAREVT)'
29157* Taken from FLUKA
29158 PARAMETER ( FRDIFF = 0.2D+00 )
29159 PARAMETER ( ETHSEA = 1.0D+00 )
29160*
29161 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29162 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29163 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29164 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29165 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29166 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29167 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29168 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29169 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29170 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29171
29172* INCLUDE '(FRBKCM)'
29173* Taken from FLUKA
29174* Maximum number of fragments to be emitted:
29175 PARAMETER ( MXFFBK = 6 )
29176 PARAMETER ( MXZFBK = 10 )
29177 PARAMETER ( MXNFBK = 12 )
29178 PARAMETER ( MXAFBK = 16 )
29179 PARAMETER ( MXASST = 25 )
29180 PARAMETER ( NXAFBK = MXAFBK + 1 )
29181 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29182 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29183 PARAMETER ( MXPSST = 700 )
29184* Maximum number of pre-computed break-up combinations
29185 PARAMETER ( MXPPFB = 42500 )
29186* Maximum number of break-up combinations, including special
29187* run-time ones:
29188 PARAMETER ( MXPSFB = 43000 )
29189* Base for J multiplicity encoding:
29190 PARAMETER ( IBFRBK = 73 )
29191* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29192* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29193* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29194* --> Ibfrbk^(Jpwfbx+1) < 2100000000
29195 PARAMETER ( JPWFBX = 4 )
29196 LOGICAL LFRMBK, LNCMSS
29197 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29198 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29199 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29200 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29201 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29202 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29203 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29204 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29205 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29206 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29207
29208* INCLUDE '(EVAFLG)'
29209* Taken from FLUKA
29210 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29211 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29212 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29213 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29214 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29215 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29216 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29217 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29218 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29219 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29220 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29221 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29222
29223* temporary storage for one final state particle
29224 LOGICAL LFRAG,LGREY,LBLACK
29225 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29226 & SINTHE,COSTHE,THETA,THECMS,
29227 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29228 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29229 & LFRAG,LGREY,LBLACK
29230
29231* event flag used for histograms
29232 COMMON /DTNORM/ ICEVT,IEVHKK
29233
29234* statistics: double-Pomeron exchange
29235 COMMON /DTFLG2/ INTFLG,IPOPO
29236
29237 DIMENSION EMUSAM(NCOMPX)
29238
29239 CHARACTER*13 CMSG(3)
29240 DATA CMSG /'not requested','not requested','not requested'/
29241
29242 GOTO (1,2,3,4,5) MODE
29243
29244*------------------------------------------------------------------
29245* initialization
29246 1 CONTINUE
29247* emulsion treatment
29248 IF (NCOMPO.GT.0) THEN
29249 DO 10 I=1,NCOMPX
29250 EMUSAM(I) = ZERO
29251 10 CONTINUE
29252 ENDIF
29253* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29254 NINCGE = 0
29255 DO 11 I=1,2
29256 EXCDPM(I) = ZERO
29257 EXCDPM(I+2) = ZERO
29258 EXCEVA(I) = ZERO
29259 NINCWO(I) = 0
29260 NINCEV(I) = 0
29261 NRESTO(I) = 0
29262 NRESPR(I) = 0
29263 NRESNU(I) = 0
29264 NRESBA(I) = 0
29265 NRESPB(I) = 0
29266 NRESCH(I) = 0
29267 NRESEV(I) = 0
29268 NRESEV(I+2) = 0
29269 NEVAGA(I) = 0
29270 NEVAHT(I) = 0
29271 NEVAFI(1,I) = 0
29272 NEVAFI(2,I) = 0
29273 DO 12 J=1,6
29274 IF (J.LE.2) NINCHR(I,J) = 0
29275 IF (J.LE.3) NINCCO(I,J) = 0
29276 IF (J.LE.4) NINCST(I,J) = 0
29277 NEVA(I,J) = 0
29278 12 CONTINUE
29279 DO 13 J=1,210
29280 NEVAHY(1,I,J) = 0
29281 NEVAHY(2,I,J) = 0
29282 13 CONTINUE
29283 11 CONTINUE
29284 MAXGEN = 0
29285**dble Po statistics.
29286 KPOPO = 0
29287
29288 RETURN
29289*------------------------------------------------------------------
29290* filling of histogram with event-record
29291 2 CONTINUE
29292 IF (IST.EQ.-1) THEN
29293 IF (.NOT.LFRAG) THEN
29294 IF (IDPDG.EQ.2212) THEN
29295 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29296 ELSEIF (IDPDG.EQ.2112) THEN
29297 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29298 ELSEIF (IDPDG.EQ.22) THEN
29299 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29300 ELSEIF (IDPDG.EQ.80000) THEN
29301 IF (IDBJT.EQ.116) THEN
29302 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29303 ELSEIF (IDBJT.EQ.117) THEN
29304 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29305 ELSEIF (IDBJT.EQ.118) THEN
29306 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29307 ELSEIF (IDBJT.EQ.119) THEN
29308 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29309 ENDIF
29310 ENDIF
29311 ELSE
29312* heavy fragments (here: fission products only)
29313 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29314 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29315 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29316 ENDIF
29317 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29318 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29319 ENDIF
29320
29321 RETURN
29322*------------------------------------------------------------------
29323* output
29324 3 CONTINUE
29325
29326**dble Po statistics.
29327C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29328C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29329C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29330
29331* emulsion treatment
29332 IF (NCOMPO.GT.0) THEN
29333 WRITE(LOUT,3000)
29334 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29335 & 22X,'----------------------------',/,/,19X,
29336 & 'mass charge fraction',/,39X,
29337 & 'input treated',/)
29338 DO 30 I=1,NCOMPO
29339 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29340 & EMUSAM(I)/DBLE(ICEVT)
29341 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29342 30 CONTINUE
29343 ENDIF
29344
29345* i.n.c. statistics: output
29346 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29347 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29348 & 22X,'---------------------------------',/,/,1X,
29349 & 'no. of events for normalization: (accepted final events,',
29350 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29351 & /,1X,'no. of rejected events due to intranuclear',
29352 & ' cascade',15X,I6,/)
29353 ICEV = MAX(ICEVT,1)
29354 ICEV1 = ICEV
29355 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29356 WRITE(LOUT,3002)
29357 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29358 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29359 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29360 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29361 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29362 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29363 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29364 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29365 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29366 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29367 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29368 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29369 & /,1X,'maximum no. of generations treated (maximum allowed:'
29370 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29371 & ' interactions in proj./ target (mean per evt1)',
29372 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29373 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29374 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29375 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29376 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29377 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29378 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29379 & 'evaporation',/,22X,'-----------------------------',
29380 & '------------',/,/,1X,'no. of events for normal.: ',
29381 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29382 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29383 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29384
29385 WRITE(LOUT,3004)
29386 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29387 ICEV = MAX(NRESEV(2),1)
29388 WRITE(LOUT,3005)
29389 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29390 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29391 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29392 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29393 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29394 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29395 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29396 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29397 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29398 & 'proj. / target',/,/,8X,'total number of particles',15X,
29399 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29400 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29401 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29402 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29403 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29404
29405* evaporation / fission / fragmentation statistics: output
29406 ICEV = MAX(NRESEV(2),1)
29407 ICEV1 = MAX(NRESEV(4),1)
29408 NTEVA1 =
29409 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29410 NTEVA2 =
29411 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29412 IF (LEVPRT) THEN
29413
29414 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29415
29416 IF (LFRMBK) CMSG(2) = 'requested '
29417 IF (LDEEXG) CMSG(3) = 'requested '
29418 WRITE(LOUT,3006)
29419 & CMSG,
29420 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29421 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29422 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29423 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29424 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29425 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29426 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29427 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29428 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29429 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29430 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29431 & 'deexcitation:',2X,A13,/,/,
29432 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29433 & 'proj. / target',/,/,8X,'total number of evap. particles',
29434 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29435 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29436 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29437 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29438 & 'heavy fragments',25X,2F9.3,/)
29439
29440 IF (IEVFSS.EQ.1) THEN
29441
29442 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29443 & NEVAFI(2,1),NEVAFI(2,2),
29444 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29445 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29446 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29447 & 12X,'out of which fission occured',8X,2I9,/,
29448 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29449 ENDIF
29450
29451C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29452
29453C WRITE(LOUT,3008)
29454C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29455C & ' proj. / target',/)
29456C DO 31 I=1,210
29457C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29458C WRITE(LOUT,3009) I,
29459C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29460C3009 FORMAT(38X,I3,3X,2E12.3)
29461C ENDIF
29462C 31 CONTINUE
29463C WRITE(LOUT,3010)
29464C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29465C & ' proj. / target',/)
29466C DO 32 I=1,210
29467C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29468C WRITE(LOUT,3011) I,
29469C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29470C3011 FORMAT(38X,I3,3X,2E12.3)
29471C ENDIF
29472C 32 CONTINUE
29473C WRITE(LOUT,*)
29474C ENDIF
29475 ELSE
29476 WRITE(LOUT,3012)
29477 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29478 & 'Evaporation: not requested',/)
29479 ENDIF
29480
29481 RETURN
29482*------------------------------------------------------------------
29483* filling of histogram with event-record
29484 4 CONTINUE
29485* emulsion treatment
29486 IF (NCOMPO.GT.0) THEN
29487 DO 40 I=1,NCOMPO
29488 IF (IT.EQ.IEMUMA(I)) THEN
29489 EMUSAM(I) = EMUSAM(I)+ONE
29490 ENDIF
29491 40 CONTINUE
29492 ENDIF
29493 NINCGE = NINCGE+MAXGEN
29494 MAXGEN = 0
29495**dble Po statistics.
29496 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29497
29498 RETURN
29499*------------------------------------------------------------------
29500* filling of histogram with event-record
29501 5 CONTINUE
29502 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29503 IB = IIBAR(IDBAM(IDX))
29504 IC = IICH(IDBAM(IDX))
29505 J = ISTHKK(IDX)-14
29506 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29507 NINCST(J,1) = NINCST(J,1)+1
29508 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29509 NINCST(J,2) = NINCST(J,2)+1
29510 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29511 NINCST(J,3) = NINCST(J,3)+1
29512 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29513 NINCST(J,4) = NINCST(J,4)+1
29514 ENDIF
29515 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29516 NINCWO(1) = NINCWO(1)+1
29517 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29518 NINCWO(2) = NINCWO(2)+1
29519 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29520 IB = IDRES(IDX)
29521 IC = IDXRES(IDX)
29522 IF (IC.GT.0) THEN
29523 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29524 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29525 ENDIF
29526 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29527 ENDIF
29528
29529 RETURN
29530 END
29531*$ CREATE DT_NEWHGR.FOR
29532*COPY DT_NEWHGR
29533*
29534*===newhgr=============================================================*
29535*
29536 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29537
29538************************************************************************
29539* *
29540* Histogram initialization. *
29541* *
29542* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29543* XLIM3 bin size *
29544* IBIN > 0 number of bins in equidistant lin. binning *
29545* = -1 reset histograms *
29546* < -1 |IBIN| number of bins in equidistant log. *
29547* binning or log. binning in user def. struc. *
29548* XLIMB(*) user defined bin structure *
29549* *
29550* The bin structure is sensitive to *
29551* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29552* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29553* XLIMB, IBIN if XLIM3 < 0 *
29554* *
29555* *
29556* output: IREFN histogram index *
29557* (= -1 for inconsistent histogr. request) *
29558* *
29559* This subroutine is based on a original version by R. Engel. *
29560* This version dated 22.4.95 is written by S. Roesler. *
29561************************************************************************
29562
29563 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29564 SAVE
29565
29566 PARAMETER ( LINP = 10 ,
29567 & LOUT = 6 ,
29568 & LDAT = 9 )
29569
29570 LOGICAL LSTART
29571
29572 PARAMETER (ZERO = 0.0D0,
29573 & TINY = 1.0D-10)
29574
29575 DIMENSION XLIMB(*)
29576
29577* histograms
29578
29579 PARAMETER (NHIS=150, NDIM=250)
29580
29581 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29582 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29583
29584* auxiliary common for histograms
29585 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29586
29587 DATA LSTART /.TRUE./
29588
29589* reset histogram counter
29590 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29591 IHISL = 0
29592 IF (IBIN.EQ.-1) RETURN
29593 LSTART = .FALSE.
29594 ENDIF
29595
29596 IHIS = IHISL+1
29597* check for maximum number of allowed histograms
29598 IF (IHIS.GT.NHIS) THEN
29599 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29600 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29601 & I4,') exceeds array size (',I4,')',/,21X,
29602 & 'histogram',I3,' skipped!')
29603 GOTO 9999
29604 ENDIF
29605
29606 IREFN = IHIS
29607 IBINS(IHIS) = ABS(IBIN)
29608* check requested number of bins
29609 IF (IBINS(IHIS).GE.NDIM) THEN
29610 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29611 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29612 & I3,') exceeds array size (',I3,')',/,21X,
29613 & 'and will be reset to ',I3)
29614 IBINS(IHIS) = NDIM
29615 ENDIF
29616 IF (IBINS(IHIS).EQ.0) THEN
29617 WRITE(LOUT,1001) IBIN,IHIS
29618 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29619 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29620 GOTO 9999
29621 ENDIF
29622
29623* initialize arrays
29624 DO 1 I=1,NDIM
29625 DO 2 K=1,3
29626 HIST(K,IHIS,I) = ZERO
29627 HIST(K+3,IHIS,I) = ZERO
29628 TMPHIS(K,IHIS,I) = ZERO
29629 2 CONTINUE
29630 HIST(7,IHIS,I) = ZERO
29631 1 CONTINUE
29632 DENTRY(1,IHIS)= ZERO
29633 DENTRY(2,IHIS)= ZERO
29634 OVERF(IHIS) = ZERO
29635 UNDERF(IHIS) = ZERO
29636 TMPUFL(IHIS) = ZERO
29637 TMPOFL(IHIS) = ZERO
29638
29639* bin str. sensitive to lower edge, bin size, and numb. of bins
29640 IF (XLIM3.GT.ZERO) THEN
29641 DO 3 K=1,IBINS(IHIS)+1
29642 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29643 3 CONTINUE
29644 ISWI(IHIS) = 1
29645* bin str. sensitive to lower/upper edge and numb. of bins
29646 ELSEIF (XLIM3.EQ.ZERO) THEN
29647* linear binning
29648 IF (IBIN.GT.0) THEN
29649 XLOW = XLIM1
29650 XHI = XLIM2
29651 IF (XLIM2.LE.XLIM1) THEN
29652 WRITE(LOUT,1002) XLIM1,XLIM2
29653 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29654 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29655 GOTO 9999
29656 ENDIF
29657 ISWI(IHIS) = 1
29658 ELSEIF (IBIN.LT.-1) THEN
29659* logarithmic binning
29660 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29661 WRITE(LOUT,1004) XLIM1,XLIM2
29662 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29663 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29664 GOTO 9999
29665 ENDIF
29666 IF (XLIM2.LE.XLIM1) THEN
29667 WRITE(LOUT,1005) XLIM1,XLIM2
29668 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29669 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29670 GOTO 9999
29671 ENDIF
29672 XLOW = LOG10(XLIM1)
29673 XHI = LOG10(XLIM2)
29674 ISWI(IHIS) = 3
29675 ENDIF
29676 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29677 DO 4 K=1,IBINS(IHIS)+1
29678 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29679 4 CONTINUE
29680 ELSE
29681* user defined bin structure
29682 DO 5 K=1,IBINS(IHIS)+1
29683 IF (IBIN.GT.0) THEN
29684 HIST(1,IHIS,K) = XLIMB(K)
29685 ISWI(IHIS) = 2
29686 ELSEIF (IBIN.LT.-1) THEN
29687 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29688 ISWI(IHIS) = 4
29689 ENDIF
29690 5 CONTINUE
29691 ENDIF
29692
29693* histogram accepted
29694 IHISL = IHIS
29695
29696 RETURN
29697
29698 9999 CONTINUE
29699 IREFN = -1
29700 RETURN
29701 END
29702
29703*$ CREATE DT_FILHGR.FOR
29704*COPY DT_FILHGR
29705*
29706*===filhgr=============================================================*
29707*
29708 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29709
29710************************************************************************
29711* *
29712* Scoring for histogram IHIS. *
29713* *
29714* This subroutine is based on a original version by R. Engel. *
29715* This version dated 23.4.95 is written by S. Roesler. *
29716************************************************************************
29717
29718 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29719 SAVE
29720
29721 PARAMETER ( LINP = 10 ,
29722 & LOUT = 6 ,
29723 & LDAT = 9 )
29724
29725 PARAMETER (ZERO = 0.0D0,
29726 & ONE = 1.0D0,
29727 & TINY = 1.0D-10)
29728
29729* histograms
29730
29731 PARAMETER (NHIS=150, NDIM=250)
29732
29733 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29734 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29735
29736* auxiliary common for histograms
29737 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29738
29739 DATA NCEVT /1/
29740
29741 X = XI
29742 Y = YI
29743
29744* dump content of temorary arrays into histograms
29745 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29746 CALL DT_EVTHIS(IDUM)
29747 NCEVT = NEVT
29748 ENDIF
29749
29750* check histogram index
29751 IF (IHIS.EQ.-1) RETURN
29752 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29753C WRITE(LOUT,1000) IHIS,IHISL
29754 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29755 & ' out of range (1..',I3,')')
29756 RETURN
29757 ENDIF
29758
29759 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29760* bin structure not explicitly given
29761 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29762 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29763 IF (X.LT.HIST(1,IHIS,1)) THEN
29764 I1 = 0
29765 ELSE
29766 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29767 ENDIF
29768
29769 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29770* user defined bin structure
29771 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29772 IF (X.LT.HIST(1,IHIS,1)) THEN
29773 I1 = 0
29774 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29775 I1 = IBINS(IHIS)+1
29776 ELSE
29777* binary sort algorithm
29778 KMIN = 0
29779 KMAX = IBINS(IHIS)+1
29780 1 CONTINUE
29781 IF ((KMAX-KMIN).EQ.1) GOTO 2
29782 KK = (KMAX+KMIN)/2
29783 IF (X.LE.HIST(1,IHIS,KK)) THEN
29784 KMAX=KK
29785 ELSE
29786 KMIN=KK
29787 ENDIF
29788 GOTO 1
29789 2 CONTINUE
29790 I1 = KMIN
29791 ENDIF
29792
29793 ELSE
29794 WRITE(LOUT,1001)
29795 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29796 RETURN
29797 ENDIF
29798
29799* scoring
29800 IF (I1.LE.0) THEN
29801 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29802 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29803 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29804 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29805 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29806 ELSE
29807 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29808 ENDIF
29809 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29810 ELSE
29811 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29812 ENDIF
29813
29814 RETURN
29815 END
29816
29817*$ CREATE DT_EVTHIS.FOR
29818*COPY DT_EVTHIS
29819*
29820*===evthis=============================================================*
29821*
29822 SUBROUTINE DT_EVTHIS(NEVT)
29823
29824************************************************************************
29825* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29826* is called after each event and for the last event before any call *
29827* to OUTHGR. *
29828* NEVT number of events dumped, this is only needed to *
29829* get the normalization after the last event *
29830* This version dated 23.4.95 is written by S. Roesler. *
29831************************************************************************
29832
29833 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29834 SAVE
29835
29836 PARAMETER ( LINP = 10 ,
29837 & LOUT = 6 ,
29838 & LDAT = 9 )
29839
29840 LOGICAL LNOETY
29841
29842 PARAMETER (ZERO = 0.0D0,
29843 & ONE = 1.0D0,
29844 & TINY = 1.0D-10)
29845
29846* histograms
29847
29848 PARAMETER (NHIS=150, NDIM=250)
29849
29850 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29851 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29852
29853* auxiliary common for histograms
29854 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29855
29856 DATA NCEVT /0/
29857
29858 NCEVT = NCEVT+1
29859 NEVT = NCEVT
29860
29861 DO 1 I=1,IHISL
29862 LNOETY = .TRUE.
29863 DO 2 J=1,IBINS(I)
29864 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29865 LNOETY = .FALSE.
29866 HIST(2,I,J) = HIST(2,I,J)+ONE
29867 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29868 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29869 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29870 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29871 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29872 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29873 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29874 TMPHIS(1,I,J) = ZERO
29875 TMPHIS(2,I,J) = ZERO
29876 TMPHIS(3,I,J) = ZERO
29877 ENDIF
29878 2 CONTINUE
29879 IF (LNOETY) THEN
29880 IF (TMPUFL(I).GT.ZERO) THEN
29881 UNDERF(I) = UNDERF(I)+ONE
29882 TMPUFL(I) = ZERO
29883 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29884 OVERF(I) = OVERF(I)+ONE
29885 TMPOFL(I) = ZERO
29886 ENDIF
29887 ELSE
29888 DENTRY(1,I) = DENTRY(1,I)+ONE
29889 ENDIF
29890 1 CONTINUE
29891
29892 RETURN
29893 END
29894
29895*$ CREATE DT_OUTHGR.FOR
29896*COPY DT_OUTHGR
29897*
29898*===outhgr=============================================================*
29899*
29900 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29901 & ILOGY,INORM,NMODE)
29902
29903************************************************************************
29904* *
29905* Plot histogram(s) to standard output unit *
29906* *
29907* I1..6 indices of histograms to be plotted *
29908* CHEAD,IHEAD header string,integer *
29909* NEVTS number of events *
29910* FAC scaling factor *
29911* ILOGY = 1 logarithmic y-axis *
29912* INORM normalization *
29913* = 0 no further normalization (FAC is obsolete) *
29914* = 1 per event and bin width *
29915* = 2 per entry and bin width *
29916* = 3 per bin entry *
29917* = 4 per event and "bin width" x1^2...x2^2 *
29918* = 5 per event and "log. bin width" ln x1..ln x2 *
29919* = 6 per event *
29920* MODE = 0 no output but normalization applied *
29921* = 1 all valid histograms separately (small frame) *
29922* all valid histograms separately (small frame) *
29923* = -1 and tables as histograms *
29924* = 2 all valid histograms (one plot, wide frame) *
29925* all valid histograms (one plot, wide frame) *
29926* = -2 and tables as histograms *
29927* *
29928* *
29929* Note: All histograms to be plotted with one call to this *
29930* subroutine and |MODE|=2 must have the same bin structure! *
29931* There is no test included ensuring this fact. *
29932* *
29933* This version dated 23.4.95 is written by S. Roesler. *
29934************************************************************************
29935
29936 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29937 SAVE
29938
29939 PARAMETER ( LINP = 10 ,
29940 & LOUT = 6 ,
29941 & LDAT = 9 )
29942
29943 CHARACTER*72 CHEAD
29944
29945 PARAMETER (ZERO = 0.0D0,
29946 & IZERO = 0,
29947 & ONE = 1.0D0,
29948 & TWO = 2.0D0,
29949 & OHALF = 0.5D0,
29950 & EPS = 1.0D-5,
29951 & TINY = 1.0D-8,
29952 & SMALL = -1.0D8,
29953 & RLARGE = 1.0D8 )
29954
29955* histograms
29956
29957 PARAMETER (NHIS=150, NDIM=250)
29958
29959 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29960 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29961
29962 PARAMETER (NDIM2 = 2*NDIM)
29963 DIMENSION XX(NDIM2),YY(NDIM2)
29964
29965 PARAMETER (NHISTO = 6)
29966 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29967 & IDX(NHISTO)
29968
29969 CHARACTER*43 CNORM(0:8)
29970 DATA CNORM /'no further normalization ',
29971 & 'per event and bin width ',
29972 & 'per entry1 and bin width ',
29973 & 'per bin entry ',
29974 & 'per event and "bin width" x1^2...x2^2 ',
29975 & 'per event and "log. bin width" ln x1..ln x2',
29976 & 'per event ',
29977 & 'per bin entry1 ',
29978 & 'per entry2 and bin width '/
29979
29980 IDX1(1) = I1
29981 IDX1(2) = I2
29982 IDX1(3) = I3
29983 IDX1(4) = I4
29984 IDX1(5) = I5
29985 IDX1(6) = I6
29986
29987 MODE = NMODE
29988
29989* initialization if "wide frame" is requested
29990 IF (ABS(MODE).EQ.2) THEN
29991 DO 1 I=1,NHISTO
29992 DO 2 J=1,NDIM
29993 XX1(J,I) = ZERO
29994 YY1(J,I) = ZERO
29995 2 CONTINUE
29996 1 CONTINUE
29997 ENDIF
29998
29999* plot header
30000 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30001
30002* check histogram indices
30003 NHI = 0
30004 DO 3 I=1,NHISTO
30005 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30006 IF (ISWI(IDX1(I)).NE.0) THEN
30007 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30008 WRITE(LOUT,1000)
30009 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30010 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30011 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30012 & ' overflows: ',F10.0)
30013 ELSE
30014 NHI = NHI+1
30015 IDX(NHI) = IDX1(I)
30016 ENDIF
30017 ENDIF
30018 ENDIF
30019 3 CONTINUE
30020 IF (NHI.EQ.0) THEN
30021 WRITE(LOUT,1001)
30022 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30023 RETURN
30024 ENDIF
30025
30026* check normalization request
30027 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30028 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30029 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30030 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30031 WRITE(LOUT,1002) NEVTS,INORM,FAC
30032 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30033 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30034 & 'FAC = ',E11.4)
30035 RETURN
30036 ENDIF
30037
30038 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30039
30040* apply normalization
30041 DO 4 N=1,NHI
30042
30043 I = IDX(N)
30044
30045 IF (ISWI(I).EQ.1) THEN
30046 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30047 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30048 & ' to',2X,E10.4,',',2X,I3,' bins')
30049 ELSEIF (ISWI(I).EQ.2) THEN
30050 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30051 WRITE(LOUT,1007)
30052 1007 FORMAT(1X,'user defined bin structure')
30053 ELSEIF (ISWI(I).EQ.3) THEN
30054 WRITE(LOUT,1004)
30055 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30056 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30057 & ' to',2X,E10.4,',',2X,I3,' bins')
30058 ELSEIF (ISWI(I).EQ.4) THEN
30059 WRITE(LOUT,1004)
30060 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30061 WRITE(LOUT,1007)
30062 ELSE
30063 WRITE(LOUT,1008) ISWI(I)
30064 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30065 ENDIF
30066 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30067 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30068 & ' overfl.:',F8.0)
30069 WRITE(LOUT,1009) CNORM(INORM)
30070 1009 FORMAT(1X,'normalization: ',A,/)
30071
30072 DO 5 K=1,IBINS(I)
30073 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30074 YMEAN = FAC*YMEAN
30075 YERR = FAC*YERR
30076 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30077 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30078 1006 FORMAT(1X,5E11.3)
30079* small frame
30080 II = 2*K
30081 XX(II-1) = HIST(1,I,K)
30082 XX(II) = HIST(1,I,K+1)
30083 YY(II-1) = YMEAN
30084 YY(II) = YMEAN
30085* wide frame
30086 XX1(K,N) = XMEAN
30087 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30088 & XX1(K,N) = LOG10(XMEAN)
30089 YY1(K,N) = YMEAN
30090 5 CONTINUE
30091
30092* plot small frame
30093 IF (ABS(MODE).EQ.1) THEN
30094 IBIN2 = 2*IBINS(I)
30095 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30096 IF(ILOGY.EQ.1) THEN
30097 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30098 ELSE
30099 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30100 ENDIF
30101 ENDIF
30102
30103 4 CONTINUE
30104
30105* plot wide frame
30106 IF (ABS(MODE).EQ.2) THEN
30107 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30108 NSIZE = NDIM*NHISTO
30109 DXLOW = HIST(1,IDX(1),1)
30110 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30111 YLOW = RLARGE
30112 YHI = SMALL
30113 DO 6 I=1,NHISTO
30114 DO 7 J=1,NDIM
30115 IF (YY1(J,I).LT.YLOW) THEN
30116 IF (ILOGY.EQ.1) THEN
30117 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30118 ELSE
30119 YLOW = YY1(J,I)
30120 ENDIF
30121 ENDIF
30122 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30123 7 CONTINUE
30124 6 CONTINUE
30125 DY = (YHI-YLOW)/DBLE(NDIM)
30126 IF (DY.LE.ZERO) THEN
30127 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30128 & 'OUTHGR: warning! zero bin width for histograms ',
30129 & IDX,': ',YLOW,YHI
30130 RETURN
30131 ENDIF
30132 IF (ILOGY.EQ.1) THEN
30133 YLOW = LOG10(YLOW)
30134 DY = (LOG10(YHI)-YLOW)/100.0D0
30135 DO 8 I=1,NHISTO
30136 DO 9 J=1,NDIM
30137 IF (YY1(J,I).LE.ZERO) THEN
30138 YY1(J,I) = YLOW
30139 ELSE
30140 YY1(J,I) = LOG10(YY1(J,I))
30141 ENDIF
30142 9 CONTINUE
30143 8 CONTINUE
30144 ENDIF
30145 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30146 ENDIF
30147
30148 RETURN
30149 END
30150
30151*$ CREATE DT_GETBIN.FOR
30152*COPY DT_GETBIN
30153*
30154*===getbin=============================================================*
30155*
30156 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30157 & XMEAN,YMEAN,YERR)
30158
30159************************************************************************
30160* This version dated 23.4.95 is written by S. Roesler. *
30161************************************************************************
30162
30163 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30164 SAVE
30165
30166 PARAMETER ( LINP = 10 ,
30167 & LOUT = 6 ,
30168 & LDAT = 9 )
30169
30170 PARAMETER (ZERO = 0.0D0,
30171 & ONE = 1.0D0,
30172 & TINY35 = 1.0D-35)
30173
30174* histograms
30175
30176 PARAMETER (NHIS=150, NDIM=250)
30177
30178 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30179 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30180
30181 XLOW = HIST(1,IHIS,IBIN)
30182 XHI = HIST(1,IHIS,IBIN+1)
30183 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30184 XLOW = 10**XLOW
30185 XHI = 10**XHI
30186 ENDIF
30187 IF (NORM.EQ.2) THEN
30188 DX = XHI-XLOW
30189 NEVT = INT(DENTRY(1,IHIS))
30190 ELSEIF (NORM.EQ.3) THEN
30191 DX = ONE
30192 NEVT = INT(HIST(2,IHIS,IBIN))
30193 ELSEIF (NORM.EQ.4) THEN
30194 DX = XHI**2-XLOW**2
30195 NEVT = KEVT
30196 ELSEIF (NORM.EQ.5) THEN
30197 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30198 NEVT = KEVT
30199 ELSEIF (NORM.EQ.6) THEN
30200 DX = ONE
30201 NEVT = KEVT
30202 ELSEIF (NORM.EQ.7) THEN
30203 DX = ONE
30204 NEVT = INT(HIST(7,IHIS,IBIN))
30205 ELSEIF (NORM.EQ.8) THEN
30206 DX = XHI-XLOW
30207 NEVT = INT(DENTRY(2,IHIS))
30208 ELSE
30209 DX = ABS(XHI-XLOW)
30210 NEVT = KEVT
30211 ENDIF
30212 IF (ABS(DX).LT.TINY35) DX = ONE
30213 NEVT = MAX(NEVT,1)
30214 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30215 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30216 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30217 YSUM = HIST(5,IHIS,IBIN)
30218 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30219C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30220 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30221 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30222
30223 RETURN
30224 END
30225
30226*$ CREATE DT_JOIHIS.FOR
30227*COPY DT_JOIHIS
30228*
30229*===joihis=============================================================*
30230*
30231 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30232
30233************************************************************************
30234* *
30235* Operation on histograms. *
30236* *
30237* input: IH1,IH2 histogram indices to be joined *
30238* COPER character defining the requested operation, *
30239* i.e. '+', '-', '*', '/' *
30240* FAC1,FAC2 factors for joining, i.e. *
30241* FAC1*histo1 COPER FAC2*histo2 *
30242* *
30243* This version dated 23.4.95 is written by S. Roesler. *
30244************************************************************************
30245
30246 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30247 SAVE
30248
30249 PARAMETER ( LINP = 10 ,
30250 & LOUT = 6 ,
30251 & LDAT = 9 )
30252
30253 CHARACTER COPER*1
30254
30255 PARAMETER (ZERO = 0.0D0,
30256 & ONE = 1.0D0,
30257 & OHALF = 0.5D0,
30258 & TINY8 = 1.0D-8,
30259 & SMALL = -1.0D8,
30260 & RLARGE = 1.0D8 )
30261
30262* histograms
30263
30264 PARAMETER (NHIS=150, NDIM=250)
30265
30266 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30267 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30268
30269 PARAMETER (NDIM2 = 2*NDIM)
30270 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30271
30272 CHARACTER*43 CNORM(0:6)
30273 DATA CNORM /'no further normalization ',
30274 & 'per event and bin width ',
30275 & 'per entry and bin width ',
30276 & 'per bin entry ',
30277 & 'per event and "bin width" x1^2...x2^2 ',
30278 & 'per event and "log. bin width" ln x1..ln x2',
30279 & 'per event '/
30280
30281* check histogram indices
30282 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30283 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30284 WRITE(LOUT,1000) IH1,IH2,IHISL
30285 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30286 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30287 GOTO 9999
30288 ENDIF
30289
30290* check bin structure of histograms to be joined
30291 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30292 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30293 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30294 & ' and ',I3,' failed',/,21X,
30295 & 'due to different numbers of bins (',I3,',',I3,')')
30296 GOTO 9999
30297 ENDIF
30298 DO 1 K=1,IBINS(IH1)+1
30299 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30300 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30301 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30302 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30303 & 'X1,X2 = ',2E11.4)
30304 GOTO 9999
30305 ENDIF
30306 1 CONTINUE
30307
30308 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30309 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30310 & 'operation ',A,/,11X,'and factors ',2E11.4)
30311 WRITE(LOUT,1004) CNORM(NORM)
30312 1004 FORMAT(1X,'normalization: ',A,/)
30313
30314 DO 2 K=1,IBINS(IH1)
30315 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30316 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30317 XLOW = XLOW1
30318 XHI = XHI1
30319 XMEAN = OHALF*(XMEAN1+XMEAN2)
30320 IF (COPER.EQ.'+') THEN
30321 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30322 ELSEIF (COPER.EQ.'*') THEN
30323 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30324 ELSEIF (COPER.EQ.'/') THEN
30325 IF (YMEAN2.EQ.ZERO) THEN
30326 YMEAN = ZERO
30327 ELSE
30328 IF (FAC2.EQ.ZERO) FAC2 = ONE
30329 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30330 ENDIF
30331 ELSE
30332 GOTO 9998
30333 ENDIF
30334 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30335 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30336 1006 FORMAT(1X,5E11.3)
30337* small frame
30338 II = 2*K
30339 XX(II-1) = HIST(1,IH1,K)
30340 XX(II) = HIST(1,IH1,K+1)
30341 YY(II-1) = YMEAN
30342 YY(II) = YMEAN
30343* wide frame
30344 XX1(K) = XMEAN
30345 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30346 YY1(K) = YMEAN
30347 2 CONTINUE
30348
30349* plot small frame
30350 IF (ABS(MODE).EQ.1) THEN
30351 IBIN2 = 2*IBINS(IH1)
30352 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30353 IF(ILOGY.EQ.1) THEN
30354 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30355 ELSE
30356 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30357 ENDIF
30358 ENDIF
30359
30360* plot wide frame
30361 IF (ABS(MODE).EQ.2) THEN
30362 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30363 NSIZE = NDIM
30364 DXLOW = HIST(1,IH1,1)
30365 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30366 YLOW = RLARGE
30367 YHI = SMALL
30368 DO 3 I=1,NDIM
30369 IF (YY1(I).LT.YLOW) THEN
30370 IF (ILOGY.EQ.1) THEN
30371 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30372 ELSE
30373 YLOW = YY1(I)
30374 ENDIF
30375 ENDIF
30376 IF (YY1(I).GT.YHI) YHI = YY1(I)
30377 3 CONTINUE
30378 DY = (YHI-YLOW)/DBLE(NDIM)
30379 IF (DY.LE.ZERO) THEN
30380 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30381 & 'JOIHIS: warning! zero bin width for histograms ',
30382 & IH1,IH2,': ',YLOW,YHI
30383 RETURN
30384 ENDIF
30385 IF (ILOGY.EQ.1) THEN
30386 YLOW = LOG10(YLOW)
30387 DY = (LOG10(YHI)-YLOW)/100.0D0
30388 DO 4 I=1,NDIM
30389 IF (YY1(I).LE.ZERO) THEN
30390 YY1(I) = YLOW
30391 ELSE
30392 YY1(I) = LOG10(YY1(I))
30393 ENDIF
30394 4 CONTINUE
30395 ENDIF
30396 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30397 ENDIF
30398
30399 RETURN
30400
30401 9998 CONTINUE
30402 WRITE(LOUT,1005) COPER
30403 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30404
30405 9999 CONTINUE
30406 RETURN
30407 END
30408
30409*$ CREATE DT_XGRAPH.FOR
30410*COPY DT_XGRAPH
30411*
30412*===qgraph=============================================================*
30413*
30414 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30415C***********************************************************************
30416C
30417C calculate quasi graphic picture with 25 lines and 79 columns
30418C ranges will be chosen automatically
30419C
30420C input N dimension of input fields
30421C IARG number of curves (fields) to plot
30422C X field of X
30423C Y1 field of Y1
30424C Y2 field of Y2
30425C
30426C This subroutine is written by R. Engel.
30427C***********************************************************************
30428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30429 SAVE
30430
30431 PARAMETER ( LINP = 10 ,
30432 & LOUT = 6 ,
30433 & LDAT = 9 )
30434
30435C
30436 DIMENSION X(N),Y1(N),Y2(N)
30437 PARAMETER (EPS=1.D-30)
30438 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30439 CHARACTER SYMB(5)
30440 CHARACTER COL(0:149,0:49)
30441C
30442 DATA SYMB /'0','e','z','#','x'/
30443C
30444 ISPALT=IBREIT-10
30445C
30446C*** automatic range fitting
30447C
30448 XMAX=X(1)
30449 XMIN=X(1)
30450 DO 600 I=1,N
30451 XMAX=MAX(X(I),XMAX)
30452 XMIN=MIN(X(I),XMIN)
30453 600 CONTINUE
30454 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30455C
30456 ITEST=0
30457 DO 1100 K=0,IZEIL-1
30458 ITEST=ITEST+1
30459 IF (ITEST.EQ.IYRAST) THEN
30460 DO 1010 L=1,ISPALT-1
30461 COL(L,K)='-'
304621010 CONTINUE
30463 COL(ISPALT,K)='+'
30464 ITEST=0
30465 DO 1020 L=0,ISPALT-1,IXRAST
30466 COL(L,K)='+'
304671020 CONTINUE
30468 ELSE
30469 DO 1030 L=1,ISPALT-1
30470 COL(L,K)=' '
304711030 CONTINUE
30472 DO 1040 L=0,ISPALT-1,IXRAST
30473 COL(L,K)='|'
304741040 CONTINUE
30475 COL(ISPALT,K)='|'
30476 ENDIF
304771100 CONTINUE
30478C
30479C*** plot curve Y1
30480C
30481 YMAX=Y1(1)
30482 YMIN=Y1(1)
30483 DO 500 I=1,N
30484 YMAX=MAX(Y1(I),YMAX)
30485 YMIN=MIN(Y1(I),YMIN)
30486500 CONTINUE
30487 IF(IARG.GT.1) THEN
30488 DO 550 I=1,N
30489 YMAX=MAX(Y2(I),YMAX)
30490 YMIN=MIN(Y2(I),YMIN)
30491550 CONTINUE
30492 ENDIF
30493 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30494 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30495 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30496 IF(YZOOM.LT.EPS) THEN
30497 WRITE(LOUT,'(1X,A)')
30498 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30499 RETURN
30500 ENDIF
30501C
30502C*** plot curve Y1
30503C
30504 ILAST=-1
30505 LLAST=-1
30506 DO 1200 K=1,N
30507 L=NINT((X(K)-XMIN)/XZOOM)
30508 I=NINT((YMAX-Y1(K))/YZOOM)
30509 IF(ILAST.GE.0) THEN
30510 LD = L-LLAST
30511 ID = I-ILAST
30512 DO 55 II=0,LD,SIGN(1,LD)
30513 DO 66 KK=0,ID,SIGN(1,ID)
30514 COL(II+LLAST,KK+ILAST)=SYMB(1)
30515 66 CONTINUE
30516 55 CONTINUE
30517 ELSE
30518 COL(L,I)=SYMB(1)
30519 ENDIF
30520 ILAST = I
30521 LLAST = L
305221200 CONTINUE
30523C
30524 IF(IARG.GT.1) THEN
30525C
30526C*** plot curve Y2
30527C
30528 DO 1250 K=1,N
30529 L=NINT((X(K)-XMIN)/XZOOM)
30530 I=NINT((YMAX-Y2(K))/YZOOM)
30531 COL(L,I)=SYMB(2)
305321250 CONTINUE
30533 ENDIF
30534C
30535C*** write it
30536C
30537 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30538C
30539C*** write range of X
30540C
30541 XZOOM = (XMAX-XMIN)/DBLE(7)
30542 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30543C
30544 DO 1300 K=0,IZEIL-1
30545 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30546 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30547 110 FORMAT(1X,1PE9.2,70A1)
305481300 CONTINUE
30549C
30550C*** write range of X
30551C
30552 XZOOM = (XMAX-XMIN)/DBLE(7)
30553 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30554 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30555 120 FORMAT(6X,7(1PE10.3))
30556 END
30557
30558*$ CREATE DT_XGLOGY.FOR
30559*COPY DT_XGLOGY
30560*
30561*===qglogy=============================================================*
30562*
30563 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30564C***********************************************************************
30565C
30566C calculate quasi graphic picture with 25 lines and 79 columns
30567C logarithmic y axis
30568C ranges will be chosen automatically
30569C
30570C input N dimension of input fields
30571C IARG number of curves (fields) to plot
30572C X field of X
30573C Y1 field of Y1
30574C Y2 field of Y2
30575C
30576C This subroutine is written by R. Engel.
30577C***********************************************************************
30578C
30579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30580 SAVE
30581
30582 PARAMETER ( LINP = 10 ,
30583 & LOUT = 6 ,
30584 & LDAT = 9 )
30585
30586 DIMENSION X(N),Y1(N),Y2(N)
30587 PARAMETER (EPS=1.D-30)
30588 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30589 CHARACTER SYMB(5)
30590 CHARACTER COL(0:149,0:49)
30591 PARAMETER (DEPS = 1.D-10)
30592C
30593 DATA SYMB /'0','e','z','#','x'/
30594C
30595 ISPALT=IBREIT-10
30596C
30597C*** automatic range fitting
30598C
30599 XMAX=X(1)
30600 XMIN=X(1)
30601 DO 600 I=1,N
30602 XMAX=MAX(X(I),XMAX)
30603 XMIN=MIN(X(I),XMIN)
30604 600 CONTINUE
30605 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30606C
30607 ITEST=0
30608 DO 1100 K=0,IZEIL-1
30609 ITEST=ITEST+1
30610 IF (ITEST.EQ.IYRAST) THEN
30611 DO 1010 L=1,ISPALT-1
30612 COL(L,K)='-'
306131010 CONTINUE
30614 COL(ISPALT,K)='+'
30615 ITEST=0
30616 DO 1020 L=0,ISPALT-1,IXRAST
30617 COL(L,K)='+'
306181020 CONTINUE
30619 ELSE
30620 DO 1030 L=1,ISPALT-1
30621 COL(L,K)=' '
306221030 CONTINUE
30623 DO 1040 L=0,ISPALT-1,IXRAST
30624 COL(L,K)='|'
306251040 CONTINUE
30626 COL(ISPALT,K)='|'
30627 ENDIF
306281100 CONTINUE
30629C
30630C*** plot curve Y1
30631C
30632 YMAX=Y1(1)
30633 YMIN=MAX(Y1(1),EPS)
30634 DO 500 I=1,N
30635 YMAX =MAX(Y1(I),YMAX)
30636 IF(Y1(I).GT.EPS) THEN
30637 IF(YMIN.EQ.EPS) THEN
30638 YMIN = Y1(I)/10.D0
30639 ELSE
30640 YMIN = MIN(Y1(I),YMIN)
30641 ENDIF
30642 ENDIF
30643500 CONTINUE
30644 IF(IARG.GT.1) THEN
30645 DO 550 I=1,N
30646 YMAX=MAX(Y2(I),YMAX)
30647 IF(Y2(I).GT.EPS) THEN
30648 IF(YMIN.EQ.EPS) THEN
30649 YMIN = Y2(I)
30650 ELSE
30651 YMIN = MIN(Y2(I),YMIN)
30652 ENDIF
30653 ENDIF
30654550 CONTINUE
30655 ENDIF
30656C
30657 DO 560 I=1,N
30658 Y1(I) = MAX(Y1(I),YMIN)
30659 560 CONTINUE
30660 IF(IARG.GT.1) THEN
30661 DO 570 I=1,N
30662 Y2(I) = MAX(Y2(I),YMIN)
30663 570 CONTINUE
30664 ENDIF
30665C
30666 IF(YMAX.LE.YMIN) THEN
30667 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30668 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30669 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30670 RETURN
30671 ENDIF
30672C
30673 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30674 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30675 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30676 IF(YZOOM.LT.EPS) THEN
30677 WRITE(LOUT,'(1X,A)')
30678 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30679 RETURN
30680 ENDIF
30681C
30682C*** plot curve Y1
30683C
30684 ILAST=-1
30685 LLAST=-1
30686 DO 1200 K=1,N
30687 L=NINT((X(K)-XMIN)/XZOOM)
30688 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30689 IF(ILAST.GE.0) THEN
30690 LD = L-LLAST
30691 ID = I-ILAST
30692 DO 55 II=0,LD,SIGN(1,LD)
30693 DO 66 KK=0,ID,SIGN(1,ID)
30694 COL(II+LLAST,KK+ILAST)=SYMB(1)
30695 66 CONTINUE
30696 55 CONTINUE
30697 ELSE
30698 COL(L,I)=SYMB(1)
30699 ENDIF
30700 ILAST = I
30701 LLAST = L
307021200 CONTINUE
30703C
30704 IF(IARG.GT.1) THEN
30705C
30706C*** plot curve Y2
30707C
30708 DO 1250 K=1,N
30709 L=NINT((X(K)-XMIN)/XZOOM)
30710 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30711 COL(L,I)=SYMB(2)
307121250 CONTINUE
30713 ENDIF
30714C
30715C*** write it
30716C
30717 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30718 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30719C
30720C*** write range of X
30721C
30722 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30723 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30724C
30725 DO 1300 K=0,IZEIL-1
30726 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30727 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30728 110 FORMAT(1X,1PE9.2,70A1)
307291300 CONTINUE
30730C
30731C*** write range of X
30732C
30733 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30734 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30735 120 FORMAT(6X,7(1PE10.3))
30736C
30737 END
30738
30739*$ CREATE DT_SRPLOT.FOR
30740*COPY DT_SRPLOT
30741*
30742*===plot===============================================================*
30743*
30744 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30745
30746 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30747 SAVE
30748
30749 PARAMETER ( LINP = 10 ,
30750 & LOUT = 6 ,
30751 & LDAT = 9 )
30752
30753*
30754* initial version
30755* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30756* This is a subroutine of fluka to plot Y across the page
30757* as a function of X down the page. Up to 37 curves can be
30758* plotted in the same picture with different plotting characters.
30759* Output of first 10 overprinted characters addad by FB 88
30760* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30761*
30762* Input Variables:
30763* X = array containing the values of X
30764* Y = array containing the values of Y
30765* N = number of values in X and in Y
30766* can exceed the fixed number of lines
30767* M = number of different curves X,Y are containing
30768* MM = number of points in each curve i.e. N=M*MM
30769* XO = smallest value of X to be plotted
30770* DX = increment of X between subsequent lines
30771* YO = smallest value of Y to be plotted
30772* DY = increment of Y between subsequent character spaces
30773*
30774* other variables used inside:
30775* XX = numbers along the X-coordinate axis
30776* YY = numbers along the Y-coordinate axis
30777* LL = ten lines temporary storage for the plot
30778* L = character set used to plot different curves
30779* LOV = memorizes overprinted symbols
30780* the first 10 overprinted symbols are printed on
30781* the end of the line to avoid ambiguities
30782* (added by FB as considered quite helpful)
30783*
30784*********************************************************************
30785*
30786 DIMENSION XX(61),YY(61),LL(101,10)
30787 DIMENSION X(N),Y(N),L(40),LOV(40,10)
004932dd 30788 INTEGER*4 LL, L, LOV
7b076c76 30789 DATA L/
30790 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30791 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30792 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30793 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30794*
30795*
30796 MN=51
30797 DO 10 I=1,MN
30798 AI=I-1
30799 10 XX(I)=XO+AI*DX
30800 DO 20 I=1,11
30801 AI=I-1
30802 20 YY(I)=YO+10.0D0*AI*DY
30803 WRITE(LOUT, 500) (YY(I),I=1,11)
30804 MMN=MN-1
30805*
30806*
30807 DO 90 JJ=1,MMN,10
30808 JJJ=JJ-1
30809 DO 30 I=1,101
30810 DO 30 J=1,10
30811 30 LL(I,J)=L(40)
30812 DO 40 I=1,101
30813 40 LL(I,1)=L(39)
30814 DO 50 I=1,101,10
30815 DO 50 J=1,10
30816 50 LL(I,J)=L(38)
30817 DO 60 I=1,40
30818 DO 60 J=1,10
30819 60 LOV(I,J)=L(40)
30820*
30821*
30822 DO 70 I=1,M
30823 DO 70 J=1,MM
30824 II=J+(I-1)*MM
30825 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30826 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30827 AIX=AIX-DBLE(JJJ)
30828* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30829 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30830 + . AIY .LT. 102.D0) THEN
30831 IX=INT(AIX)
30832 IY=INT(AIY)
30833 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30834 + THEN
30835 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30836 + =LL(IY,IX)
30837 LL(IY,IX)=L(I)
30838 ENDIF
30839 ENDIF
30840 70 CONTINUE
30841*
30842*
30843 DO 80 I=1,10
30844 II=I+JJJ
30845 III=II+1
30846 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30847 & (LOV(J,I),J=1,10)
30848 80 CONTINUE
30849 90 CONTINUE
30850*
30851*
30852 WRITE(LOUT, 520)
30853 WRITE(LOUT, 500) (YY(I),I=1,11)
30854 RETURN
30855*
30856 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30857 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30858 520 FORMAT(20X,10('1---------'),'1')
30859 END
30860*$ CREATE DT_DEFSET.FOR
30861*COPY DT_DEFSET
30862*
30863*===defset=============================================================*
30864*
30865 BLOCK DATA DT_DEFSET
30866
30867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30868 SAVE
30869
30870* flags for input different options
30871 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30872 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30873 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30874
30875 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30876
30877* emulsion treatment
30878 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30879 & NCOMPO,IEMUL
30880
30881* / DTFLG1 /
30882 DATA IFRAG / 2, 1 /
30883 DATA IRESCO / 1 /
30884 DATA IMSHL / 1 /
30885 DATA IRESRJ / 0 /
30886 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30887 DATA LEMCCK / .FALSE. /
30888 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30889 & .TRUE.,.TRUE.,.TRUE./
30890 DATA LSEADI / .TRUE. /
30891 DATA LEVAPO / .TRUE. /
30892 DATA IFRAME / 1 /
30893 DATA ITRSPT / 0 /
30894
30895* / DTCOMP /
30896 DATA EMUFRA / NCOMPX*0.0D0 /
30897 DATA IEMUMA / NCOMPX*1 /
30898 DATA IEMUCH / NCOMPX*1 /
30899 DATA NCOMPO / 0 /
30900 DATA IEMUL / 0 /
30901
30902 END
30903
30904*$ CREATE DT_HADPRP.FOR
30905*COPY DT_HADPRP
30906*
30907*===hadprp=============================================================*
30908*
30909 BLOCK DATA DT_HADPRP
30910
30911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30912 SAVE
30913
30914* auxiliary common for reggeon exchange (DTUNUC 1.x)
30915 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30916 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30917 & IQTCHR(-6:6),MQUARK(3,39)
30918
30919* hadron index conversion (BAMJET <--> PDG)
30920 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30921 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30922 & IAMCIN(210)
30923
30924* names of hadrons used in input-cards
30925 CHARACTER*8 BTYPE
30926 COMMON /DTPAIN/ BTYPE(30)
30927
30928* / DTQUAR /
30929*----------------------------------------------------------------------*
30930* *
30931* Quark content of particles: *
30932* index quark el. charge bar. charge isospin isospin3 *
30933* 1 = u 2/3 1/3 1/2 1/2 *
30934* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30935* 2 = d -1/3 1/3 1/2 -1/2 *
30936* -2 = dbar 1/3 -1/3 1/2 1/2 *
30937* 3 = s -1/3 1/3 0 0 *
30938* -3 = sbar 1/3 -1/3 0 0 *
30939* 4 = c 2/3 1/3 0 0 *
30940* -4 = cbar -2/3 -1/3 0 0 *
30941* 5 = b -1/3 1/3 0 0 *
30942* -5 = bbar 1/3 -1/3 0 0 *
30943* 6 = t 2/3 1/3 0 0 *
30944* -6 = tbar -2/3 -1/3 0 0 *
30945* *
30946* Mquark = particle quark composition (Paprop numbering) *
30947* Iqechr = electric charge ( in 1/3 unit ) *
30948* Iqbchr = baryonic charge ( in 1/3 unit ) *
30949* Iqichr = isospin ( in 1/2 unit ), z component *
30950* Iqschr = strangeness *
30951* Iqcchr = charm *
30952* Iquchr = beauty *
30953* Iqtchr = ...... *
30954* *
30955*----------------------------------------------------------------------*
30956 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30957 DATA IQBCHR / 6*-1, 0, 6*1 /
30958 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30959 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30960 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30961 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30962 DATA IQTCHR / -1, 11*0, 1 /
30963 DATA MQUARK /
30964 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30965 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30966 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30967 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30968 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30969 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30970 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30971 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30972
30973* / DTHAIC /
30974* (renamed) (HAdron InDex COnversion)
30975* translation table version filled up by r.e. 25.01.94 *
30976 DATA IAMCIN /
30977 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30978 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30979 &3222,3212,111,311,-311, 0,0,0,0,0,
30980 &221,213,113,-213,223, 323,313,-323,-313,10323,
30981 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30982 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30983 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30984 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30985 &5*99999, 5*99999,
30986 &4*99999,331, 333,3322,3312,-3222,-3212,
30987 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30988 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30989 &-431,441,423,413,-413, -423,433,-433,20443,443,
30990 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30991 &4212,4112,3*99999, 3*99999,-4122,-4232,
30992 &-4132,-4222,-4212,-4112,99999, 5*99999,
30993 &5*99999, 5*99999,
30994 &10*99999,
30995 &5*99999 , 20211,20111,-20211,99999,20321,
30996 &-20321,20311,-20311,7*99999 ,
30997 &7*99999,12212,12112,99999/
30998
30999* / DTHAIC /
31000* (HAdron InDex COnversion)
31001 DATA (IPDG2(1,K),K=1,7)
31002 & / -11, -12, -13, -15, -16, -14, 0/
31003 DATA (IBAM2(1,K),K=1,7)
31004 & / 4, 6, 10, 131, 134, 136, 0/
31005 DATA (IPDG2(2,K),K=1,7)
31006 & / 11, 12, 22, 13, 15, 16, 14/
31007 DATA (IBAM2(2,K),K=1,7)
31008 & / 3, 5, 7, 11, 132, 133, 135/
31009 DATA (IPDG3(1,K),K=1,22)
31010 & / -211, -321, -311, -213, -323, -313, -411, -421,
31011 & -431, -413, -423, -433, 0, 0, 0, 0,
31012 & 0, 0, 0, 0, 0, 0/
31013 DATA (IBAM3(1,K),K=1,22)
31014 & / 14, 16, 25, 34, 38, 39, 118, 119,
31015 & 121, 125, 126, 128, 0, 0, 0, 0,
31016 & 0, 0, 0, 0, 0, 0/
31017 DATA (IPDG3(2,K),K=1,22)
31018 & / 130, 211, 321, 310, 111, 311, 221, 213,
31019 & 113, 223, 323, 313, 331, 333, 421, 411,
31020 & 431, 441, 423, 413, 433, 443/
31021 DATA (IBAM3(2,K),K=1,22)
31022 & / 12, 13, 15, 19, 23, 24, 31, 32,
31023 & 33, 35, 36, 37, 95, 96, 116, 117,
31024 & 120, 122, 123, 124, 127, 130/
31025 DATA (IPDG4(1,K),K=1,29)
31026 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31027 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31028 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31029 & -4212, -4112, 0, 0, 0/
31030 DATA (IBAM4(1,K),K=1,29)
31031 & / 2, 9, 18, 67, 68, 69, 70, 75,
31032 & 76, 99, 100, 101, 102, 103, 110, 111,
31033 & 112, 113, 114, 115, 149, 150, 151, 152,
31034 & 153, 154, 0, 0, 0/
31035 DATA (IPDG4(2,K),K=1,29)
31036 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31037 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31038 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31039 & 4232, 4132, 4222, 4212, 4112/
31040 DATA (IBAM4(2,K),K=1,29)
31041 & / 1, 8, 17, 20, 21, 22, 48, 49,
31042 & 50, 51, 52, 53, 54, 55, 56, 97,
31043 & 98, 104, 105, 106, 107, 108, 109, 137,
31044 & 138, 139, 140, 141, 142/
31045 DATA (IPDG5(1,K),K=1,19)
31046 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31047 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31048 & 0, 0, 0/
31049 DATA (IBAM5(1,K),K=1,19)
31050 & / 42, 43, 46, 47, 71, 72, 73, 74,
31051 & 188, 191, 193, 0, 0, 0, 0, 0,
31052 & 0, 0, 0/
31053 DATA (IPDG5(2,K),K=1,19)
31054 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31055 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31056 & 20311, 12212, 12112/
31057 DATA (IBAM5(2,K),K=1,19)
31058 & / 40, 41, 44, 45, 57, 58, 59, 60,
31059 & 63, 64, 65, 66, 129, 186, 187, 190,
31060 & 192, 208, 209/
31061
31062* / DTPAIN /
31063* internal particle names
31064 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31065 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31066 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31067 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31068 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31069 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31070 &'BLANK ' /
31071
31072 END
31073
31074*$ CREATE DT_BLKD46.FOR
31075*COPY DT_BLKD46
31076*
31077*===blkd46=============================================================*
31078*
31079 BLOCK DATA DT_BLKD46
31080
31081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31082 SAVE
31083
31084 PARAMETER ( AMELCT = 0.51099906 D-03 )
31085 PARAMETER ( AMMUON = 0.105658389 D+00 )
31086
31087* particle properties (BAMJET index convention)
31088 CHARACTER*8 ANAME
31089 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31090 & IICH(210),IIBAR(210),K1(210),K2(210)
31091
31092* / DTPART /
31093* Particle masses Engel version JETSET compatible
31094C DATA (AAM(K),K=1,85) /
31095C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31096C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31097C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31098C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31099C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31100C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31101C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31102C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31103C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31104C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31105C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31106C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31107C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31108C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31109C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31110C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31111C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31112C DATA (AAM(K),K=86,183) /
31113C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31114C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31115C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31116C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31117C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31118C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31119C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31120C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31121C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31122C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31123C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31124C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31125C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31126C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31127C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31128C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31129C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31130C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31131C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31132C & .1250D+01, .1250D+01, .1250D+01 /
31133C DATA (AAM ( I ), I = 184,210 ) /
31134C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31135C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31136C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31137C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31138C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31139C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31140C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31141C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31142C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31143* sr 25.1.06: particle masses adjusted to Pythia
31144 DATA (AAM(K),K=1,85) /
31145 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31146 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31147 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31148 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31149 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31150 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31151 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31152 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31153 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31154 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31155 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31156 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31157 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31158 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31159 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31160 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31161 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31162 DATA (AAM(K),K=86,183) /
31163 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31164 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31165 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31166 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31167 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31168 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31169 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31170 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31171 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31172 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31173 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31174 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31175 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31176 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31177 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31178 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31179 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31180 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31181 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31182 & .1250D+01, .1250D+01, .1250D+01 /
31183 DATA (AAM ( I ), I = 184,210 ) /
31184 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31185 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31186 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31187 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31188 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31189 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31190 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31191 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31192 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31193* Particle mean lives
31194 DATA (TAU(K),K=1,183) /
31195 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31196 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31197 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31198 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31199 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31200 & 70*.0000D+00,
31201 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31202 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31203 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31204 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31205 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31206 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31207 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31208 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31209 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31210 & 40*.0000D+00,
31211 & .0000D+00, .0000D+00, .0000D+00 /
31212 DATA ( TAU ( I ), I = 184,210 ) /
31213 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31214 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31215 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31216 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31217 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31218 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31219 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31220 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31221 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31222* Resonance width Gamma in GeV
31223 DATA (GA(K),K= 1,85) /
31224 & 30*.0000D+00,
31225 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31226 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31227 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31228 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31229 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31230 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31231 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31232 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31233 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31234 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31235 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31236 DATA (GA(K),K= 86,183) /
31237 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31238 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31239 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31240 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31241 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31242 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31243 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31244 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31245 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31246 & 50*.0000D+00,
31247 & .3000D+00, .3000D+00, .3000D+00 /
31248 DATA ( GA ( I ), I = 184,210 ) /
31249 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31250 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31251 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31252 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31253 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31254 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31255 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31256 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31257 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31258* Particle names
31259* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31260* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31261* designation N*@@ means N*@1(@2)
31262 DATA (ANAME(K),K=1,85) /
31263 & 'P ','AP ','E- ','E+ ','NUE ',
31264 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31265 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31266 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31267 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31268 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31269 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31270 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31271 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31272 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31273 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31274 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31275 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31276 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31277 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31278 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31279 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31280 DATA (ANAME(K),K=86,183) /
31281 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31282 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31283 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31284 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31285 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31286 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31287 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31288 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31289 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31290 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31291 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31292 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31293 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31294 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31295 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31296 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31297 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31298 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31299 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31300 & 'RO ','R+ ','R- ' /
31301 DATA ( ANAME ( I ), I = 184,210 ) /
31302 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31303 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31304 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31305 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31306 &'N*+14 ','N*014 ','BLANK '/
31307* Charge of particles and resonances
31308 DATA (IICH ( I ), I = 1,210 ) /
31309 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31310 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31311 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31312 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31313 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31314 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31315 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31316 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31317 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31318 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31319 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31320 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31321 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31322 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31323* Particle baryonic charges
31324 DATA (IIBAR ( I ), I = 1,210 ) /
31325 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31326 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31327 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31328 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31329 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31330 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31331 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31332 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31333 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31334 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31335 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31336 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31337 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31338 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31339* First number of decay channels used for resonances
31340* and decaying particles
31341 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31342 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31343 & 2*330, 46, 51, 52, 54, 55, 58,
31344* 50
31345 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31346 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31347 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31348* 85
31349 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31350 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31351 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31352 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31353 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31354 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31355 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31356 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31357 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31358 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31359 & 590, 596, 602 /
31360* Last number of decay channels used for resonances
31361* and decaying particles
31362 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31363 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31364 & 2* 330, 50, 51, 53, 54, 57,
31365* 50
31366 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31367 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31368 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31369* 85
31370 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31371 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31372 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31373 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31374 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31375 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31376 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31377 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31378 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31379 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31380 & 589, 595, 601, 602 /
31381
31382 END
31383
31384*$ CREATE DT_BLKD47.FOR
31385*COPY DT_BLKD47
31386*
31387*===blkd47=============================================================*
31388*
31389 BLOCK DATA DT_BLKD47
31390
31391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31392 SAVE
31393
31394* HADRIN: decay channel information
31395 PARAMETER (IDMAX9=602)
31396 CHARACTER*8 ZKNAME
31397 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31398
31399* Name of decay channel
31400* Designation N*@ means N*@1(1236)
31401* @1=# means ++, @1 = = means --
31402* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31403 DATA (ZKNAME(K),K= 1, 85) /
31404 & 'P ','AP ','E- ','E+ ','NUE ',
31405 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31406 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31407 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31408 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31409 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31410 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31411 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31412 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31413 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31414 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31415 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31416 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31417 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31418 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31419 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31420 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31421 DATA (ZKNAME(K),K= 86,170) /
31422 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31423 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31424 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31425 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31426 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31427 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31428 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31429 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31430 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31431 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31432 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31433 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31434 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31435 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31436 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31437 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31438 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31439 DATA (ZKNAME(K),K=171,255) /
31440 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31441 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31442 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31443 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31444 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31445 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31446 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31447 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31448 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31449 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31450 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31451 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31452 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31453 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31454 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31455 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31456 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31457 DATA (ZKNAME(K),K=256,340) /
31458 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31459 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31460 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31461 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31462 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31463 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31464 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31465 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31466 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31467 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31468 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31469 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31470 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31471 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31472 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31473 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31474 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31475 DATA (ZKNAME(K),K=341,425) /
31476 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31477 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31478 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31479 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31480 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31481 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31482 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31483 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31484 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31485 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31486 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31487 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31488 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31489 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31490 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31491 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31492 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31493 DATA (ZKNAME(K),K=426,510) /
31494 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31495 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31496 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31497 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31498 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31499 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31500 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31501 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31502 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31503 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31504 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31505 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31506 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31507 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31508 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31509 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31510 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31511 DATA (ZKNAME(K),K=511,540) /
31512 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31513 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31514 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31515 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31516 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31517 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31518 DATA (ZKNAME(I),I=541,602)/
31519 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31520 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31521 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31522 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31523 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31524 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31525 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31526 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31527 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31528* Weight of decay channel
31529 DATA (WT(K),K= 1, 85) /
31530 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31531 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31532 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31533 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31534 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31535 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31536 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31537 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31538 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31539 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31540 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31541 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31542 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31543 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31544 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31545 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31546 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31547 DATA (WT(K),K= 86,170) /
31548 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31549 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31550 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31551 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31552 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31553 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31554 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31555 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31556 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31557 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31558 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31559 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31560 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31561 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31562 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31563 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31564 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31565 DATA (WT(K),K=171,255) /
31566 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31567 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31568 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31569 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31570 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31571 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31572 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31573 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31574 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31575 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31576 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31577 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31578 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31579 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31580 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31581 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31582 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31583 DATA (WT(K),K=256,340) /
31584 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31585 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31586 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31587 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31588 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31589 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31590 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31591 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31592 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31593 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31594 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31595 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31596 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31597 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31598 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31599 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31600 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31601 DATA (WT(K),K=341,425) /
31602 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31603 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31604 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31605 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31606 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31607 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31608 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31609 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31610 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31611 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31612 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31613 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31614 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31615 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31616 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31617 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31618 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31619 DATA (WT(K),K=426,510) /
31620 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31621 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31622 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31623 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31624 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31625 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31626 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31627 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31628 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31629 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31630 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31631 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31632 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31633 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31634 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31635 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31636 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31637 DATA (WT(K),K=511,540) /
31638 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31639 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31640 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31641 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31642 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31643 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31644C
31645 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31646 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31647 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31648 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31649 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31650 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31651 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31652* Particle numbers in decay channel
31653 DATA (NZK(K,1),K= 1,170) /
31654 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31655 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31656 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31657 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31658 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31659 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31660 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31661 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31662 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31663 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31664 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31665 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31666 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31667 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31668 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31669 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31670 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31671 DATA (NZK(K,1),K=171,340) /
31672 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31673 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31674 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31675 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31676 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31677 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31678 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31679 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31680 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31681 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31682 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31683 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31684 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31685 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31686 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31687 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31688 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31689 DATA (NZK(K,1),K=341,510) /
31690 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31691 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31692 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31693 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31694 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31695 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31696 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31697 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31698 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31699 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31700 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31701 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31702 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31703 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31704 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31705 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31706 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31707 DATA (NZK(K,1),K=511,540) /
31708 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31709 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31710 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31711 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31712 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31713 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31714 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31715 & 55, 8, 1, 8, 8, 54, 55, 210/
31716 DATA (NZK(K,2),K= 1,170) /
31717 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31718 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31719 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31720 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31721 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31722 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31723 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31724 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31725 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31726 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31727 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31728 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31729 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31730 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31731 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31732 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31733 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31734 DATA (NZK(K,2),K=171,340) /
31735 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31736 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31737 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31738 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31739 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31740 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31741 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31742 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31743 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31744 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31745 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31746 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31747 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31748 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31749 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31750 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31751 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31752 DATA (NZK(K,2),K=341,510) /
31753 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31754 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31755 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31756 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31757 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31758 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31759 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31760 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31761 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31762 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31763 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31764 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31765 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31766 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31767 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31768 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31769 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31770 DATA (NZK(K,2),K=511,540) /
31771 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31772 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31773 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31774 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31775 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31776 & 14, 14, 23, 14, 16, 25,
31777 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31778 & 23, 13, 14, 23, 0 /
31779 DATA (NZK(K,3),K= 1,170) /
31780 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31781 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31782 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31783 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31784 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31785 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31786 & 110*0 /
31787 DATA (NZK(K,3),K=171,340) /
31788 & 80*0,
31789 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31790 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31791 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31792 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31793 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31794 & 30*0,
31795 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31796 DATA (NZK(K,3),K=341,510) /
31797 & 30*0,
31798 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31799 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31800 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31801 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31802 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31803 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31804 & 80*0 /
31805 DATA (NZK(K,3),K=511,540) /
31806 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31807 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31808 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31809 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31810 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31811
31812 END
31813
31814*$ CREATE DT_XHOINI.FOR
31815*COPY DT_XHOINI
31816*
31817*====phoini============================================================*
31818*
31819 SUBROUTINE DT_XHOINI
31820C SUBROUTINE DT_PHOINI
31821
31822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31823 SAVE
31824
31825 PARAMETER ( LINP = 10 ,
31826 & LOUT = 6 ,
31827 & LDAT = 9 )
31828
31829 RETURN
31830 END
31831
31832*$ CREATE DT_XVENTB.FOR
31833*COPY DT_XVENTB
31834*
31835*====eventb============================================================*
31836*
31837 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31838C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31839
31840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31841 SAVE
31842
31843 PARAMETER ( LINP = 10 ,
31844 & LOUT = 6 ,
31845 & LDAT = 9 )
31846
31847 WRITE(LOUT,1000)
31848 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31849 STOP
31850
31851 END
31852
31853*$ CREATE DT_XVENT.FOR
31854*COPY DT_XVENT
31855*
31856*===event==============================================================*
31857*
31858 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31859C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31860
31861 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31862 SAVE
31863
31864 DIMENSION PP(4),PT(4)
31865
31866 RETURN
31867 END
31868
31869*$ CREATE DT_XOHISX.FOR
31870*COPY DT_XOHISX
31871*
31872*===pohisx=============================================================*
31873*
31874 SUBROUTINE DT_XOHISX(I,X)
31875C SUBROUTINE POHISX(I,X)
31876
31877 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31878 SAVE
31879
31880 RETURN
31881 END
31882
31883*$ CREATE PHO_LHIST.FOR
31884*COPY PHO_LHIST
31885*
31886*===poluhi=============================================================*
31887*
31888 SUBROUTINE PHO_LHIST(I,X)
31889
31890**
31891
31892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31893 SAVE
31894
31895 RETURN
31896 END
31897
31898*$ CREATE PDFSET.FOR
31899*COPY PDFSET
31900*
31901C**********************************************************************
31902C
31903C dummy subroutines, remove to link PDFLIB
31904C
31905C**********************************************************************
31906 SUBROUTINE PDFSET(PARAM,VALUE)
31907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31908 DIMENSION PARAM(20),VALUE(20)
31909 CHARACTER*20 PARAM
31910 END
31911
31912*$ CREATE STRUCTM.FOR
31913*COPY STRUCTM
31914*
31915 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31917 END
31918
31919*$ CREATE STRUCTP.FOR
31920*COPY STRUCTP
31921*
31922 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31923 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31924 END
31925
31926*$ CREATE DT_DIQBRK.FOR
31927*COPY DT_DIQBRK
31928*
31929*===diqbrk=============================================================*
31930*
31931 SUBROUTINE DT_XIQBRK
31932C SUBROUTINE DT_DIQBRK
31933
31934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31935 SAVE
31936
31937 STOP 'diquark-breaking not implemeted !'
31938
31939 RETURN
31940 END
31941*$ CREATE DT_ELHAIN.FOR
31942*COPY DT_ELHAIN
31943*
31944*===elhain=============================================================*
31945*
31946 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31947
31948************************************************************************
31949* Elastic hadron-hadron scattering. *
31950* This is a revised version of the original. *
31951* This version dated 03.04.98 is written by S. Roesler *
31952************************************************************************
31953
31954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31955 SAVE
31956
31957 PARAMETER ( LINP = 10 ,
31958 & LOUT = 6 ,
31959 & LDAT = 9 )
31960
31961 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31962 & TINY10=1.0D-10)
31963
31964 PARAMETER (ENNTHR = 3.5D0)
31965 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31966 & BLOWB=0.05D0,BHIB=0.2D0,
31967 & BLOWM=0.1D0, BHIM=2.0D0)
31968
31969* particle properties (BAMJET index convention)
31970 CHARACTER*8 ANAME
31971 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31972 & IICH(210),IIBAR(210),K1(210),K2(210)
31973
31974* final state from HADRIN interaction
31975 PARAMETER (MAXFIN=10)
31976 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31977 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31978
31979C DATA TSLOPE /10.0D0/
31980
31981 IREJ = 0
31982
31983 1 CONTINUE
31984
31985 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31986 EKIN = ELAB-AAM(IP)
31987* kinematical quantities in cms of the hadrons
31988 AMP2 = AAM(IP)**2
31989 AMT2 = AAM(IT)**2
31990 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31991 ECM = SQRT(S)
31992 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31993 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31994
31995* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31996 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31997 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31998* TSAMCS treats pp and np only, therefore change pn into np and
31999* nn into pp
32000 IF (IT.EQ.1) THEN
32001 KPROJ = IP
32002 ELSE
32003 KPROJ = 8
32004 IF (IP.EQ.8) KPROJ = 1
32005 ENDIF
32006 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32007 T = TWO*PCM**2*(CTCMS-ONE)
32008
32009* very crude treatment otherwise: sample t from exponential dist.
32010 ELSE
32011* momentum transfer t
32012 TMAX = TWO*TWO*PCM**2
32013 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32014 IF (IIBAR(IP).NE.0) THEN
32015 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32016 ELSE
32017 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32018 ENDIF
32019 FMAX = EXP(-TSLOPE*TMAX)-ONE
32020 R = DT_RNDM(RR)
32021 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32022 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32023 ENDIF
32024
32025* target hadron in Lab after scattering
32026 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32027 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32028 IF (PLRH(2).LE.TINY10) THEN
32029C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32030 GOTO 1
32031 ENDIF
32032* projectile hadron in Lab after scattering
32033 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32034 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32035* scattering angle of projectile in Lab
32036 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32037 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32038 CALL DT_DSFECF(SPLABP,CPLABP)
32039* direction cosines of projectile in Lab
32040 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32041 & CXRH(1),CYRH(1),CZRH(1))
32042* scattering angle of target in Lab
32043 PLLABT = PLAB-CTLABP*PLRH(1)
32044 CTLABT = PLLABT/PLRH(2)
32045 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32046* direction cosines of target in Lab
32047 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32048 & CXRH(2),CYRH(2),CZRH(2))
32049* fill /HNFSPA/
32050 IRH = 2
32051 ITRH(1) = IP
32052 ITRH(2) = IT
32053
32054 RETURN
32055 END
32056
32057*$ CREATE DT_TSAMCS.FOR
32058*COPY DT_TSAMCS
32059*
32060*===tsamcs=============================================================*
32061*
32062 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32063
32064************************************************************************
32065* Sampling of cos(theta) for nucleon-proton scattering according to *
32066* hetkfa2/bertini parametrization. *
32067* This is a revised version of the original (HJM 24/10/88) *
32068* This version dated 28.10.95 is written by S. Roesler *
32069************************************************************************
32070
32071 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32072 SAVE
32073
32074 PARAMETER ( LINP = 10 ,
32075 & LOUT = 6 ,
32076 & LDAT = 9 )
32077
32078 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32079 & TINY10=1.0D-10)
32080
32081 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32082 DIMENSION PDCI(60),PDCH(55)
32083
32084 DATA (DCLIN(I),I=1,80) /
32085 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32086 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32087 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32088 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32089 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32090 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32091 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32092 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32093 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32094 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32095 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32096 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32097 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32098 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32099 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32100 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32101 DATA (DCLIN(I),I=81,160) /
32102 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32103 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32104 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32105 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32106 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32107 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32108 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32109 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32110 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32111 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32112 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32113 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32114 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32115 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32116 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32117 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32118 DATA (DCLIN(I),I=161,195) /
32119 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32120 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32121 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32122 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32123 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32124 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32125 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32126
32127 DATA PDCI /
32128 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32129 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32130 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32131 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32132 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32133 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32134 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32135 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32136 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32137 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32138 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32139 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32140
32141 DATA PDCH /
32142 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32143 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32144 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32145 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32146 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32147 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32148 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32149 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32150 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32151 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32152 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32153
32154 DATA (DCHN(I),I=1,90) /
32155 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32156 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32157 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32158 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32159 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32160 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32161 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32162 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32163 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32164 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32165 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32166 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32167 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32168 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32169 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32170 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32171 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32172 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32173 DATA (DCHN(I),I=91,143) /
32174 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32175 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32176 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32177 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32178 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32179 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32180 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32181 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32182 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32183 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32184 & 6.488D-02, 6.485D-02, 6.480D-02/
32185
32186 DATA DCHNA /
32187 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32188 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32189 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32190 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32191 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32192 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32193 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32194 & 1.000D+00/
32195
32196 DATA DCHNB /
32197 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32198 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32199 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32200 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32201 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32202 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32203 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32204 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32205 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32206 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32207 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32208 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32209
32210 CST = ONE
32211 IF (EKIN.GT.3.5D0) RETURN
32212C
32213 IF(KPROJ.EQ.8) GOTO 101
32214 IF(KPROJ.EQ.1) GOTO 102
32215C* INVALID REACTION
32216 WRITE(LOUT,'(A,I5/A)')
32217 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32218 & ' COS(THETA) = 1D0 RETURNED'
32219 RETURN
32220C-------------------------------- NP ELASTIC SCATTERING----------
32221101 CONTINUE
32222 IF (EKIN.GT.0.740D0)GOTO 1000
32223 IF (EKIN.LT.0.300D0)THEN
32224C EKIN .LT. 300 MEV
32225 IDAT=1
32226 ELSE
32227C 300 MEV < EKIN < 740 MEV
32228 IDAT=6
32229 END IF
32230C
32231 ENER=EKIN
32232 IE=INT(ABS(ENER/0.020D0))
32233 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32234C FORWARD/BACKWARD DECISION
32235 K=IDAT+5*IE
32236 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32237 IF (DT_RNDM(CST).LT.BWFW)THEN
32238 VALUE2=-1D0
32239 K=K+1
32240 ELSE
32241 VALUE2=1D0
32242 K=K+3
32243 END IF
32244C
32245 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32246 RND=DT_RNDM(COEF)
32247C
32248 IF(RND.LT.COEF)THEN
32249 CST=DT_RNDM(RND)
32250 CST=CST*VALUE2
32251 ELSE
32252 R1=DT_RNDM(CST)
32253 R2=DT_RNDM(R1)
32254 R3=DT_RNDM(R2)
32255 R4=DT_RNDM(R3)
32256C
32257 IF(VALUE2.GT.0.0)THEN
32258 CST=MAX(R1,R2,R3,R4)
32259 GOTO 1500
32260 ELSE
32261 R5=DT_RNDM(R4)
32262C
32263 IF (IDAT.EQ.1)THEN
32264 CST=-MAX(R1,R2,R3,R4,R5)
32265 ELSE
32266 R6=DT_RNDM(R5)
32267 R7=DT_RNDM(R6)
32268 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32269 END IF
32270C
32271 END IF
32272C
32273 END IF
32274C
32275 GOTO 1500
32276C
32277C******** EKIN .GT. 0.74 GEV
32278C
322791000 ENER=EKIN - 0.66D0
32280C IE=ABS(ENER/0.02)
32281 IE=INT(ENER/0.02D0)
32282 EMEV=EKIN*1D3
32283C
32284 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32285 K=IE
32286 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32287 RND=DT_RNDM(BWFW)
32288C FORWARD NEUTRON
32289 IF (RND.GE.BWFW)THEN
32290 DO 1200 K=10,36,9
32291 IF (DCHNA(K).GT.EMEV) THEN
32292 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32293 UNIV=DT_RNDM(UNIVE)
32294 DO 1100 I=1,8
32295 II=K+I
32296 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32297C
32298 IF (P.GT.UNIV)THEN
32299 UNIV=DT_RNDM(UNIVE)
32300 FLTI=DBLE(I)-UNIV
32301 GOTO(290,290,290,290,330,340,350,360) I
32302 END IF
32303 1100 CONTINUE
32304 END IF
32305 1200 CONTINUE
32306C
32307 ELSE
32308C BACKWARD NEUTRON
32309 DO 1400 K=13,60,12
32310 IF (DCHNB(K).GT.EMEV) THEN
32311 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32312 UNIV=DT_RNDM(UNIVE)
32313 DO 1300 I=1,11
32314 II=K+I
32315 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32316C
32317 IF (P.GT.UNIV)THEN
32318 UNIV=DT_RNDM(P)
32319 FLTI=DBLE(I)-UNIV
32320 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32321 END IF
32322 1300 CONTINUE
32323 END IF
32324 1400 CONTINUE
32325 END IF
32326C
32327120 CST=1.0D-2*FLTI-1.0D0
32328 GOTO 1500
32329140 CST=2.0D-2*UNIV-0.98D0
32330 GOTO 1500
32331150 CST=4.0D-2*UNIV-0.96D0
32332 GOTO 1500
32333160 CST=6.0D-2*FLTI-1.16D0
32334 GOTO 1500
32335180 CST=8.0D-2*UNIV-0.80D0
32336 GOTO 1500
32337190 CST=1.0D-1*UNIV-0.72D0
32338 GOTO 1500
32339200 CST=1.2D-1*UNIV-0.62D0
32340 GOTO 1500
32341210 CST=2.0D-1*UNIV-0.50D0
32342 GOTO 1500
32343220 CST=3.0D-1*(UNIV-1.0D0)
32344 GOTO 1500
32345C
32346290 CST=1.0D0-2.5d-2*FLTI
32347 GOTO 1500
32348330 CST=0.85D0+0.5D-1*UNIV
32349 GOTO 1500
32350340 CST=0.70D0+1.5D-1*UNIV
32351 GOTO 1500
32352350 CST=0.50D0+2.0D-1*UNIV
32353 GOTO 1500
32354360 CST=0.50D0*UNIV
32355C
323561500 RETURN
32357C
32358C----------------------------------- PP ELASTIC SCATTERING -------
32359C
32360 102 CONTINUE
32361 EMEV=EKIN*1D3
32362C
32363 IF (EKIN.LE.0.500D0) THEN
32364 RND=DT_RNDM(EMEV)
32365 CST=2.0D0*RND-1.0D0
32366 RETURN
32367C
32368 ELSEIF (EKIN.LT.1.0D0) THEN
32369 DO 2200 K=13,60,12
32370 IF (PDCI(K).GT.EMEV) THEN
32371 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32372 UNIV=DT_RNDM(UNIVE)
32373 SUM=0
32374 DO 2100 I=1,11
32375 II=K+I
32376 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32377C
32378 IF (UNIV.LT.SUM)THEN
32379 UNIV=DT_RNDM(SUM)
32380 FLTI=DBLE(I)-UNIV
32381 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32382 END IF
32383 2100 CONTINUE
32384 END IF
32385 2200 CONTINUE
32386 ELSE
32387 DO 2400 K=12,55,11
32388 IF (PDCH(K).GT.EMEV) THEN
32389 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32390 UNIV=DT_RNDM(UNIVE)
32391 SUM=0.0D0
32392 DO 2300 I=1,10
32393 II=K+I
32394 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32395C
32396 IF (UNIV.LT.SUM)THEN
32397 UNIV=DT_RNDM(SUM)
32398 FLTI=UNIV+DBLE(I)
32399 GOTO(50,55,60,60,65,65,65,65,70,70) I
32400 END IF
32401 2300 CONTINUE
32402 END IF
32403 2400 CONTINUE
32404 END IF
32405C
3240650 CST=0.4D0*UNIV
32407 GOTO 2500
3240855 CST=0.2D0*FLTI
32409 GOTO 2500
3241060 CST=0.3D0+0.1D0*FLTI
32411 GOTO 2500
3241265 CST=0.6D0+0.04D0*FLTI
32413 GOTO 2500
3241470 CST=0.78D0+0.02D0*FLTI
32415C
324162500 CONTINUE
32417 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32418C
32419 RETURN
32420 END
32421
32422*$ CREATE DT_DHADRI.FOR
32423*COPY DT_DHADRI
32424*
32425*===dhadri=============================================================*
32426*
32427 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32428
32429 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32430 SAVE
32431
32432 PARAMETER ( LINP = 10 ,
32433 & LOUT = 6 ,
32434 & LDAT = 9 )
32435
32436C
32437C-----------------------------
32438C*** INPUT VARIABLES LIST:
32439C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32440C*** GEV/C LABORATORY MOMENTUM REGION
32441C*** N - PROJECTILE HADRON INDEX
32442C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32443C*** ELAB - LABORATORY ENERGY OF N (GEV)
32444C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32445C*** ITTA - TARGET NUCLEON INDEX
32446C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32447C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32448C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32449C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32450C*** RESPECT., UNITS (GEV/C AND GEV)
32451C----------------------------
32452
32453 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32454
32455 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32456
32457 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32458 & NRK(2,268),NURE(30,2)
32459
32460* particle properties (BAMJET index convention),
32461* (dublicate of DTPART for HADRIN)
32462 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32463 & K1H(110),K2H(110)
32464
32465 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32466
32467 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32468 & ITS(149),IS
32469
32470 COMMON /HNDRUN/ RUNTES,EFTES
32471
32472* particle properties (BAMJET index convention)
32473 CHARACTER*8 ANAME
32474 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32475 & IICH(210),IIBAR(210),K1(210),K2(210)
32476
32477* final state from HADRIN interaction
32478 PARAMETER (MAXFIN=10)
32479 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32480 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32481
32482 DIMENSION ITPRF(110)
32483 DATA NNN/0/
32484 DATA UMODA/0./
32485 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32486 LOWP=0
32487 IF (N.LE.0.OR.N.GE.111)N=1
32488 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32489 GOTO 280
32490* WRITE (6,1000)
32491* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32492* STOP
32493*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32494* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32495 ENDIF
32496 IATMPT=0
32497 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32498C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32499C STOP
32500 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32501 + ALLOWED REGION, PLAB=',1E15.5)
32502
32503 20 CONTINUE
32504 UMODAT=N*1.11111D0+ITTA*2.19291D0
32505 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32506 UMODA=UMODAT
32507 30 IATMPT=0
32508 LOWP=LOWP+1
32509 40 CONTINUE
32510 IMACH=0
32511 REDU=2.0D0
32512 IF (LOWP.GT.20) THEN
32513C WRITE(LOUT,*) ' jump 1'
32514 GO TO 280
32515 ENDIF
32516 NNN=N
32517 IF (NNN.EQ.N) GO TO 50
32518 RUNTES=0.0D0
32519 EFTES=0.0D0
32520 50 CONTINUE
32521 IS=1
32522 IRH=0
32523 IST=1
32524 NSTAB=23
32525 IRE=NURE(N,1)
32526 IF(ITTA.GT.1) IRE=NURE(N,2)
32527C
32528C-----------------------------
32529C*** IE,AMT,ECM,SI DETERMINATION
32530C----------------------------
32531 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32532 IANTH=-1
32533**sr
32534C IF (AMH(1).NE.0.93828D0) IANTH=1
32535 IF (AMH(1).NE.0.9383D0) IANTH=1
32536**
32537 IF (IANTH.GE.0) SI=1.0D0
32538 ECMMH=ECM
32539C
32540C-----------------------------
32541C ENERGY INDEX
32542C IRE CHARACTERIZES THE REACTION
32543C IE IS THE ENERGY INDEX
32544C----------------------------
32545 IF (SI.LT.1.D-6) THEN
32546C WRITE(LOUT,*) ' jump 2'
32547 GO TO 280
32548 ENDIF
32549 IF (N.LE.NSTAB) GO TO 60
32550 RUNTES=RUNTES+1.0D0
32551 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32552 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32553 IF(IBARH(N).EQ.1) N=8
32554 IF(IBARH(N).EQ.-1) N=9
32555 60 CONTINUE
32556 IMACH=IMACH+1
32557**sr 19.2.97: loop for direct channel suppression
32558C IF (IMACH.GT.10) THEN
32559 IF (IMACH.GT.1000) THEN
32560**
32561C WRITE(LOUT,*) ' jump 3'
32562 GO TO 280
32563 ENDIF
32564 ECM =ECMMH
32565 AMN2=AMN**2
32566 AMT2=AMT**2
32567 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32568 IF(ECMN.LE.AMN) ECMN=AMN
32569 PCMN=SQRT(ECMN**2-AMN2)
32570 GAM=(ELAB+AMT)/ECM
32571 BGAM=PLAB/ECM
32572 IF (IANTH.GE.0) ECM=2.1D0
32573C
32574C-----------------------------
32575C*** RANDOM CHOICE OF REACTION CHANNEL
32576C----------------------------
32577 IST=0
32578 VV=DT_RNDM(AMN2)
32579 VV=VV-1.D-17
32580C
32581C-----------------------------
32582C*** PLACE REDUCED VERSION
32583C----------------------------
32584 IIEI=IEII(IRE)
32585 IDWK=IEII(IRE+1)-IIEI
32586 IIWK=IRII(IRE)
32587 IIKI=IKII(IRE)
32588C
32589C-----------------------------
32590C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32591C----------------------------
32592 HECM=ECM
32593 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32594 IF (HUMO.LT.ECM) ECM=HUMO
32595C
32596C-----------------------------
32597C*** INTERPOLATION PREPARATION
32598C----------------------------
32599 ECMO=UMO(IE)
32600 ECM1=UMO(IE-1)
32601 DECM=ECMO-ECM1
32602 DEC=ECMO-ECM
32603C
32604C-----------------------------
32605C*** RANDOM LOOP
32606C----------------------------
32607 IK=0
32608 WKK=0.0D0
32609 WICOR=0.0D0
32610 70 IK=IK+1
32611 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32612 WOK=WK(IWK)
32613 WDK=WOK-WK(IWK-1)
32614C
32615C-----------------------------
32616C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32617C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32618C CONTRIBUTE
32619C----------------------------
32620 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32621 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32622 IF (WICO.EQ.WICOR) GO TO 70
32623 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32624 WICOR=WICO
32625C
32626C-----------------------------
32627C*** INTERPOLATION IN CHANNEL WEIGHTS
32628C----------------------------
32629 EKLIM=-THRESH(IIKI+IK)
32630 IELIM=IDT_IEFUND(EKLIM,IRE)
32631 DELIM=UMO(IELIM)+EKLIM
32632 *+1.D-16
32633 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32634 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32635 80 DECC=DELIM
32636 GO TO 100
32637 90 DECC=DECM
32638 100 CONTINUE
32639 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32640C
32641C-----------------------------
32642C*** RANDOM CHOICE
32643C----------------------------
32644C
32645 IF (VV.GT.WKK) GO TO 70
32646C
32647C***IK IS THE REACTION CHANNEL
32648C----------------------------
32649 INRK=IKII(IRE)+IK
32650 ECM=HECM
32651 I1001 =0
32652C
32653 110 CONTINUE
32654 IT1=NRK(1,INRK)
32655 AM1=DT_DAMG(IT1)
32656 IT2=NRK(2,INRK)
32657 AM2=DT_DAMG(IT2)
32658 AMS=AM1+AM2
32659 I1001=I1001+1
32660 IF (I1001.GT.50) GO TO 60
32661C
32662 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32663 IT11=IT1
32664 IT22=IT2
32665 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32666 AM11=AM1
32667 AM22=AM2
32668 IF (IT2.GT.0) GO TO 120
32669**sr 19.2.97: supress direct channel for pp-collisions
32670 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32671 RR = DT_RNDM(AM11)
32672 IF (RR.LE.0.75D0) GOTO 60
32673 ENDIF
32674**
32675C
32676C-----------------------------
32677C INCLUSION OF DIRECT RESONANCES
32678C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32679C------------------------
32680 KZ1=K1H(IT1)
32681 IST=IST+1
32682 IECO=0
32683 ECO=ECM
32684 GAM=(ELAB+AMT)/ECO
32685 BGAM=PLAB/ECO
32686 CXS(1)=CX
32687 CYS(1)=CY
32688 CZS(1)=CZ
32689 GO TO 170
32690 120 CONTINUE
32691 WW=DT_RNDM(ECO)
32692 IF(WW.LT. 0.5D0) GO TO 130
32693 IT1=IT22
32694 IT2=IT11
32695 AM1=AM22
32696 AM2=AM11
32697 130 CONTINUE
32698C
32699C-----------------------------
32700C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32701 IBN=IBARH(N)
32702 IB1=IBARH(IT1)
32703 IT11=IT1
32704 IT22=IT2
32705 AM11=AM1
32706 AM22=AM2
32707 IF(IB1.EQ.IBN) GO TO 140
32708 IT1=IT22
32709 IT2=IT11
32710 AM1=AM22
32711 AM2=AM11
32712 140 CONTINUE
32713C-----------------------------
32714C***IT1,IT2 ARE THE CREATED PARTICLES
32715C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32716C------------------------
32717 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32718 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32719 IST=IST+1
32720 ITS(IST)=IT1
32721 AMM(IST)=AM1
32722C
32723C-----------------------------
32724C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32725C----------------------------
32726 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32727 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32728 IST=IST+1
32729 ITS(IST)=IT2
32730 AMM(IST)=AM2
32731 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32732 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32733 150 CONTINUE
32734C
32735C-----------------------------
32736C***TEST STABLE OR UNSTABLE
32737C----------------------------
32738 IF(ITS(IST).GT.NSTAB) GO TO 160
32739 IRH=IRH+1
32740C
32741C-----------------------------
32742C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32743C----------------------------
32744C* IF (REDU.LT.0.D0) GO TO 1009
32745 ITRH(IRH)=ITS(IST)
32746 PLRH(IRH)=PLS(IST)
32747 CXRH(IRH)=CXS(IST)
32748 CYRH(IRH)=CYS(IST)
32749 CZRH(IRH)=CZS(IST)
32750 ELRH(IRH)=ELS(IST)
32751 IST=IST-1
32752 IF(IST.GE.1) GO TO 150
32753 GO TO 260
32754 160 CONTINUE
32755C
32756C RANDOM CHOICE OF DECAY CHANNELS
32757C----------------------------
32758C
32759 IT=ITS(IST)
32760 ECO=AMM(IST)
32761 GAM=ELS(IST)/ECO
32762 BGAM=PLS(IST)/ECO
32763 IECO=0
32764 KZ1=K1H(IT)
32765 170 CONTINUE
32766 IECO=IECO+1
32767 VV=DT_RNDM(GAM)
32768 VV=VV-1.D-17
32769 IIK=KZ1-1
32770 180 IIK=IIK+1
32771 IF (VV.GT.WTI(IIK)) GO TO 180
32772C
32773C IIK IS THE DECAY CHANNEL
32774C----------------------------
32775 IT1=NZKI(IIK,1)
32776 I310=0
32777 190 CONTINUE
32778 I310=I310+1
32779 AM1=DT_DAMG(IT1)
32780 IT2=NZKI(IIK,2)
32781 AM2=DT_DAMG(IT2)
32782 IF (IT2-1.LT.0) GO TO 240
32783 IT3=NZKI(IIK,3)
32784 AM3=DT_DAMG(IT3)
32785 AMS=AM1+AM2+AM3
32786C
32787C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32788C----------------------------
32789 IF (IECO.LE.10) GO TO 200
32790 IATMPT=IATMPT+1
32791 IF(IATMPT.GT.3) THEN
32792C WRITE(LOUT,*) ' jump 4'
32793 GO TO 280
32794 ENDIF
32795 GO TO 40
32796 200 CONTINUE
32797 IF (I310.GT.50) GO TO 170
32798 IF (AMS.GT.ECO) GO TO 190
32799C
32800C FOR THE DECAY CHANNEL
32801C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32802C----------------------------
32803 IF (REDU.LT.0.D0) GO TO 30
32804 ITWTHC=0
32805 REDU=2.0D0
32806 IF(IT3.EQ.0) GO TO 220
32807 210 CONTINUE
32808 ITWTH=1
32809 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32810 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32811 GO TO 230
32812 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32813 &COD2,COF2,SIF2,AM1,AM2)
32814 ITWTH=-1
32815 IT3=0
32816 230 CONTINUE
32817 ITWTHC=ITWTHC+1
32818 IF (REDU.GT.0.D0) GO TO 240
32819 REDU=2.0D0
32820 IF (ITWTHC.GT.100) GO TO 30
32821 IF (ITWTH) 220,220,210
32822 240 CONTINUE
32823 ITS(IST )=IT1
32824 IF (IT2-1.LT.0) GO TO 250
32825 ITS(IST+1) =IT2
32826 ITS(IST+2)=IT3
32827 RX=CXS(IST)
32828 RY=CYS(IST)
32829 RZ=CZS(IST)
32830 AMM(IST)=AM1
32831 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32832 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32833 IST=IST+1
32834 AMM(IST)=AM2
32835 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32836 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32837 IF (IT3.LE.0) GO TO 250
32838 IST=IST+1
32839 AMM(IST)=AM3
32840 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32841 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32842 250 CONTINUE
32843 GO TO 150
32844 260 CONTINUE
32845 270 CONTINUE
32846 RETURN
32847 280 CONTINUE
32848C
32849C----------------------------
32850C
32851C ZERO CROSS SECTION CASE
32852C----------------------------
32853C
32854 IRH=1
32855 ITRH(1)=N
32856 CXRH(1)=CX
32857 CYRH(1)=CY
32858 CZRH(1)=CZ
32859 ELRH(1)=ELAB
32860 PLRH(1)=PLAB
32861 RETURN
32862 END
32863
32864*$ CREATE DT_RUNTT.FOR
32865*COPY DT_RUNTT
32866*
32867*===runtt==============================================================*
32868*
32869 BLOCK DATA DT_RUNTT
32870
32871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32872 SAVE
32873
32874 COMMON /HNDRUN/ RUNTES,EFTES
32875
32876 DATA RUNTES,EFTES /100.D0,100.D0/
32877
32878 END
32879
32880*$ CREATE DT_NONAME.FOR
32881*COPY DT_NONAME
32882*
32883*===noname=============================================================*
32884*
32885 BLOCK DATA DT_NONAME
32886
32887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32888 SAVE
32889
32890* slope parameters for HADRIN interactions
32891 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32892
32893 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32894
32895C DATAS DATAS DATAS DATAS DATAS
32896C****** *********
32897 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32898 & 207, 224, 241, 252, 268 /
32899 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32900 & 220, 241, 262, 279, 296 /
32901 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32902 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32903
32904C
32905C MASSES FOR THE SLOPE B(M) IN GEV
32906C SLOPE B(M) FOR AN MESONIC SYSTEM
32907C SLOPE B(M) FOR A BARYONIC SYSTEM
32908
32909*
32910 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32911 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32912 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32913 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32914 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32915 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32916 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32917 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32918 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32919 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32920 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32921 & 14.2D0, 13.4D0, 12.6D0,
32922 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32923 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32924*
32925 END
32926
32927*$ CREATE DT_DAMG.FOR
32928*COPY DT_DAMG
32929*
32930*===damg===============================================================*
32931*
32932 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32933
32934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32935 SAVE
32936
32937* particle properties (BAMJET index convention),
32938* (dublicate of DTPART for HADRIN)
32939 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32940 & K1H(110),K2H(110)
32941
32942 DIMENSION GASUNI(14)
32943 DATA GASUNI/
32944 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32945 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32946 DATA GAUNO/2.352D0/
32947 DATA GAUNON/2.4D0/
32948 DATA IO/14/
32949 DATA NSTAB/23/
32950
32951 I=1
32952 IF (IT.LE.0) GO TO 30
32953 IF (IT.LE.NSTAB) GO TO 20
32954 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32955 VV=DT_RNDM(DGAUNI)
32956 VV=VV*2.0D0-1.0D0+1.D-16
32957 10 CONTINUE
32958 VO=GASUNI(I)
32959 I=I+1
32960 V1=GASUNI(I)
32961 IF (VV.GT.V1) GO TO 10
32962 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32963 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32964 DAM=GAH(IT)*UNIGA/GAUNO
32965 AAM=AMH(IT)+DAM
32966 DT_DAMG=AAM
32967 RETURN
32968 20 CONTINUE
32969 DT_DAMG=AMH(IT)
32970 RETURN
32971 30 CONTINUE
32972 DT_DAMG=0.0D0
32973 RETURN
32974 END
32975
32976*$ CREATE DT_DCALUM.FOR
32977*COPY DT_DCALUM
32978*
32979*===dcalum=============================================================*
32980*
32981 SUBROUTINE DT_DCALUM(N,ITTA)
32982
32983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32984 SAVE
32985
32986C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32987
32988* particle properties (BAMJET index convention),
32989* (dublicate of DTPART for HADRIN)
32990 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32991 & K1H(110),K2H(110)
32992
32993 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32994
32995 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32996
32997 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32998 & NRK(2,268),NURE(30,2)
32999
33000 IRE=NURE(N,ITTA/8+1)
33001 IEO=IEII(IRE)+1
33002 IEE=IEII(IRE +1)
33003 AM1=AMH(N )
33004 AM12=AM1**2
33005 AM2=AMH(ITTA)
33006 AM22=AM2**2
33007 DO 10 IE=IEO,IEE
33008 PLAB2=PLABF(IE)**2
33009 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33010 UMO(IE)=ELAB
33011 10 CONTINUE
33012 IKO=IKII(IRE)+1
33013 IKE=IKII(IRE +1)
33014 UMOO=UMO(IEO)
33015 DO 30 IK=IKO,IKE
33016 IF(NRK(2,IK).GT.0) GO TO 30
33017 IKI=NRK(1,IK)
33018 AMSS=5.0D0
33019 K11=K1H(IKI)
33020 K22=K2H(IKI)
33021 DO 20 IK1=K11,K22
33022 IN=NZKI(IK1,1)
33023 AMS=AMH(IN)
33024 IN=NZKI(IK1,2)
33025 IF(IN.GT.0)AMS=AMS+AMH(IN)
33026 IN=NZKI(IK1,3)
33027 IF(IN.GT.0) AMS=AMS+AMH(IN)
33028 IF (AMS.LT.AMSS) AMSS=AMS
33029 20 CONTINUE
33030 IF(UMOO.LT.AMSS) UMOO=AMSS
33031 THRESH(IK)=UMOO
33032 30 CONTINUE
33033 RETURN
33034 END
33035
33036*$ CREATE DT_DCHANH.FOR
33037*COPY DT_DCHANH
33038*
33039*===dchanh=============================================================*
33040*
33041 SUBROUTINE DT_DCHANH
33042
33043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33044 SAVE
33045
33046 PARAMETER ( LINP = 10 ,
33047 & LOUT = 6 ,
33048 & LDAT = 9 )
33049
33050* particle properties (BAMJET index convention),
33051* (dublicate of DTPART for HADRIN)
33052 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33053 & K1H(110),K2H(110)
33054
33055 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33056
33057 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33058
33059 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33060 & NRK(2,268),NURE(30,2)
33061
33062 DIMENSION HWT(460),HWK(40),SI(5184)
33063 EQUIVALENCE (WK(1),SI(1))
33064C--------------------
33065C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33066C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33067C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33068C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33069C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33070C--------------------------
33071 IREG=16
33072 DO 90 IRE=1,IREG
33073 IWKO=IRII(IRE)
33074 IEE=IEII(IRE+1)-IEII(IRE)
33075 IKE=IKII(IRE+1)-IKII(IRE)
33076 IEO=IEII(IRE)+1
33077 IIKA=IKII(IRE)
33078* modifications to suppress elestic scattering 24/07/91
33079 DO 80 IE=1,IEE
33080 SIS=1.D-14
33081 SINORC=0.0D0
33082 DO 10 IK=1,IKE
33083 IWK=IWKO+IEE*(IK-1)+IE
33084 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33085 SIS=SIS+SI(IWK)*SINORC
33086 10 CONTINUE
33087 SIIN(IEO+IE-1)=SIS
33088 SIO=0.D0
33089 IF (SIS.GE.1.D-12) GO TO 20
33090 SIS=1.D0
33091 SIO=1.D0
33092 20 CONTINUE
33093 SINORC=0.0D0
33094 DO 30 IK=1,IKE
33095 IWK=IWKO+IEE*(IK-1)+IE
33096 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33097 SIO=SIO+SI(IWK)*SINORC/SIS
33098 HWK(IK)=SIO
33099 30 CONTINUE
33100 DO 40 IK=1,IKE
33101 IWK=IWKO+IEE*(IK-1)+IE
33102 40 WK(IWK)=HWK(IK)
33103 IIKI=IKII(IRE)
33104 DO 70 IK=1,IKE
33105 AM111=0.D0
33106 INRK1=NRK(1,IIKI+IK)
33107 IF (INRK1.GT.0) AM111=AMH(INRK1)
33108 AM222=0.D0
33109 INRK2=NRK(2,IIKI+IK)
33110 IF (INRK2.GT.0) AM222=AMH(INRK2)
33111 THRESH(IIKI+IK)=AM111 +AM222
33112 IF (INRK2-1.GE.0) GO TO 60
33113 INRKK=K1H(INRK1)
33114 AMSS=5.D0
33115 INRKO=K2H(INRK1)
33116 DO 50 INRK1=INRKK,INRKO
33117 INZK1=NZKI(INRK1,1)
33118 INZK2=NZKI(INRK1,2)
33119 INZK3=NZKI(INRK1,3)
33120 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33121 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33122 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33123C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33124 1000 FORMAT (4I10)
33125 AMS=AMH(INZK1)+AMH(INZK2)
33126 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33127 IF (AMSS.GT.AMS) AMSS=AMS
33128 50 CONTINUE
33129 AMS=AMSS
33130 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33131 THRESH(IIKI+IK)=AMS
33132 60 CONTINUE
33133 70 CONTINUE
33134 80 CONTINUE
33135 90 CONTINUE
33136 DO 100 J=1,460
33137 100 HWT(J)=0.D0
33138 DO 120 I=1,110
33139 IK1=K1H(I)
33140 IK2=K2H(I)
33141 HV=0.D0
33142 IF (IK2.GT.460)IK2=460
33143 IF (IK1.LE.0)IK1=1
33144 DO 110 J=IK1,IK2
33145 HV=HV+WTI(J)
33146 HWT(J)=HV
33147 JI=J
33148 110 CONTINUE
33149 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33150 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33151 120 CONTINUE
33152 DO 130 J=1,460
33153 130 WTI(J)=HWT(J)
33154 RETURN
33155 END
33156
33157*$ CREATE DT_DHADDE.FOR
33158*COPY DT_DHADDE
33159*
33160*===dhadde=============================================================*
33161*
33162 SUBROUTINE DT_DHADDE
33163
33164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33165 SAVE
33166
33167* particle properties (BAMJET index convention)
33168 CHARACTER*8 ANAME
33169 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33170 & IICH(210),IIBAR(210),K1(210),K2(210)
33171
33172* HADRIN: decay channel information
33173 PARAMETER (IDMAX9=602)
33174 CHARACTER*8 ZKNAME
33175 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33176
33177* particle properties (BAMJET index convention),
33178* (dublicate of DTPART for HADRIN)
33179 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33180 & K1H(110),K2H(110)
33181
33182 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33183
33184* decay channel information for HADRIN
33185 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33186 & K1Z(16),K2Z(16),WTZ(153),II22,
33187 & NZK1(153),NZK2(153),NZK3(153)
33188
33189 DATA IRETUR/0/
33190
33191 IRETUR=IRETUR+1
33192 AMH(31)=0.48D0
33193 IF (IRETUR.GT.1) RETURN
33194 DO 10 I=1,94
33195 AMH(I) = AAM(I)
33196 GAH(I) = GA(I)
33197 TAUH(I) = TAU(I)
33198 ICHH(I) = IICH(I)
33199 IBARH(I) = IIBAR(I)
33200 K1H(I) = K1(I)
33201 K2H(I) = K2(I)
33202 10 CONTINUE
33203**sr
33204C AMH(1)=0.93828D0
33205 AMH(1)=0.9383D0
33206**
33207 AMH(2)=AMH(1)
33208 DO 20 I=26,30
33209 K1H(I)=452
33210 K2H(I)=452
33211 20 CONTINUE
33212 DO 30 I=1,307
33213 WTI(I) = WT(I)
33214 NZKI(I,1) = NZK(I,1)
33215 NZKI(I,2) = NZK(I,2)
33216 NZKI(I,3) = NZK(I,3)
33217 30 CONTINUE
33218 DO 40 I=1,16
33219 L=I+94
33220 AMH(L)=AMZ(I)
33221 GAH( L)=GAZ(I)
33222 TAUH( L)=TAUZ(I)
33223 ICHH( L)=ICHZ(I)
33224 IBARH( L)=IBARZ(I)
33225 K1H( L)=K1Z(I)
33226 K2H( L)=K2Z(I)
33227 40 CONTINUE
33228 DO 50 I=1,153
33229 L=I+307
33230 WTI(L) = WTZ(I)
33231 NZKI(L,3) = NZK3(I)
33232 NZKI(L,2) = NZK2(I)
33233 NZKI(L,1) = NZK1(I)
33234 50 CONTINUE
33235 RETURN
33236 END
33237
33238*$ CREATE IDT_IEFUND.FOR
33239*COPY IDT_IEFUND
33240*
33241*===iefund=============================================================*
33242*
33243 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33244
33245 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33246 SAVE
33247
33248C*****IEFUN CALCULATES A MOMENTUM INDEX
33249
33250 PARAMETER ( LINP = 10 ,
33251 & LOUT = 6 ,
33252 & LDAT = 9 )
33253
33254 COMMON /HNDRUN/ RUNTES,EFTES
33255
33256 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33257
33258 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33259 & NRK(2,268),NURE(30,2)
33260
33261 IPLA=IEII(IRE)+1
33262 *+1
33263 IPLE=IEII(IRE+1)
33264 IF (PL.LT.0.) GO TO 30
33265 DO 10 I=IPLA,IPLE
33266 J=I-IPLA+1
33267 IF (PL.LE.PLABF(I)) GO TO 60
33268 10 CONTINUE
33269 I=IPLE
33270 IF ( EFTES.GT.40.D0) GO TO 20
33271 EFTES=EFTES+1.0D0
33272 WRITE(LOUT,1000)PL,J
33273 20 CONTINUE
33274 GO TO 70
33275 30 CONTINUE
33276 DO 40 I=IPLA,IPLE
33277 J=I-IPLA+1
33278 IF (-PL.LE.UMO(I)) GO TO 60
33279 40 CONTINUE
33280 I=IPLE
33281 IF ( EFTES.GT.40.D0) GO TO 50
33282 EFTES=EFTES+1.0D0
33283 WRITE(LOUT,1000)PL,I
33284 50 CONTINUE
33285 60 CONTINUE
33286 70 CONTINUE
33287 IDT_IEFUND=I
33288 RETURN
33289 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33290 +7H IEFUN=,I5)
33291 END
33292
33293*$ CREATE DT_DSIGIN.FOR
33294*COPY DT_DSIGIN
33295*
33296*===dsigin=============================================================*
33297*
33298 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33299
33300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33301 SAVE
33302
33303* particle properties (BAMJET index convention),
33304* (dublicate of DTPART for HADRIN)
33305 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33306 & K1H(110),K2H(110)
33307
33308 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33309
33310 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33311 & NRK(2,268),NURE(30,2)
33312
33313 IE=IDT_IEFUND(PLAB,IRE)
33314 IF (IE.LE.IEII(IRE)) IE=IE+1
33315 AMT=AMH(ITAR)
33316 AMN=AMH(N)
33317 AMN2=AMN*AMN
33318 AMT2=AMT*AMT
33319 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33320C*** INTERPOLATION PREPARATION
33321 ECMO=UMO(IE)
33322 ECM1=UMO(IE-1)
33323 DECM=ECMO-ECM1
33324 DEC=ECMO-ECM
33325 IIKI=IKII(IRE)+1
33326 EKLIM=-THRESH(IIKI)
33327 WOK=SIIN(IE)
33328 WDK=WOK-SIIN(IE-1)
33329 IF (ECM.GT.ECMO) WDK=0.0D0
33330C*** INTERPOLATION IN CHANNEL WEIGHTS
33331 IELIM=IDT_IEFUND(EKLIM,IRE)
33332 DELIM=UMO(IELIM)+EKLIM
33333 *+1.D-16
33334 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33335 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33336 10 DECC=DELIM
33337 GO TO 30
33338 20 DECC=DECM
33339 30 CONTINUE
33340 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33341 IF (WKK.LT.0.0D0) WKK=0.0D0
33342 SI=WKK+1.D-12
33343 IF (-EKLIM.GT.ECM) SI=1.D-14
33344 RETURN
33345 END
33346
33347*$ CREATE DT_DTCHOI.FOR
33348*COPY DT_DTCHOI
33349*
33350*===dtchoi=============================================================*
33351*
33352 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33353
33354 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33355 SAVE
33356
33357C ****************************
33358C TCHOIC CALCULATES A RANDOM VALUE
33359C FOR THE FOUR-MOMENTUM-TRANSFER T
33360C ****************************
33361
33362* particle properties (BAMJET index convention),
33363* (dublicate of DTPART for HADRIN)
33364 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33365 & K1H(110),K2H(110)
33366
33367* slope parameters for HADRIN interactions
33368 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33369
33370 AMA=AM1
33371 AMB=AM2
33372 IF (I.GT.30.AND.II.GT.30) GO TO 20
33373 III=II
33374 AM3=AM2
33375 IF (I.LE.30) GO TO 10
33376 III=I
33377 AM3=AM1
33378 10 CONTINUE
33379 GO TO 30
33380 20 CONTINUE
33381 III=II
33382 AM3=AM2
33383 IF (AMA.LE.AMB) GO TO 30
33384 III=I
33385 AM3=AM1
33386 30 CONTINUE
33387 IB=IBARH(III)
33388 AMA=AM3
33389 K=INT((AMA-0.75D0)/0.05D0)
33390 IF (K-2.LT.0) K=1
33391 IF (K-26.GE.0) K=25
33392 IF (IB)50,40,50
33393 40 BM=BBM(K)
33394 GO TO 60
33395 50 BM=BBB(K)
33396 60 CONTINUE
33397C NORMALIZATION
33398 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33399 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33400 VB=DT_RNDM(TMIN)
33401**sr test
33402C IF (VB.LT.0.2D0) BM=BM*0.1
33403C **0.5
33404 BM = BM*5.05D0
33405**
33406 TMI=BM*TMIN
33407 TMA=BM*TMAX
33408 ETMA=0.D0
33409 IF (ABS(TMA).GT.120.D0) GO TO 70
33410 ETMA=EXP(TMA)
33411 70 CONTINUE
33412 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33413C*** RANDOM CHOICE OF THE T - VALUE
33414 R=DT_RNDM(TMI)
33415 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33416 RETURN
33417 END
33418
33419*$ CREATE DT_DTWOPA.FOR
33420*COPY DT_DTWOPA
33421*
33422*===dtwopa=============================================================*
33423*
33424 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33425 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33426
33427 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33428 SAVE
33429
33430C ******************************************************
33431C QUASI TWO PARTICLE PRODUCTION
33432C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33433C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33434C IN THE CM - SYSTEM
33435C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33436C SPHERICAL COORDINATES
33437C ******************************************************
33438
33439* particle properties (BAMJET index convention),
33440* (dublicate of DTPART for HADRIN)
33441 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33442 & K1H(110),K2H(110)
33443
33444 AMA=AM1
33445 AMB=AM2
33446 AMA2=AMA*AMA
33447 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33448 E2=UMOO - E1
33449 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33450 AMTE=(E1-AMA)*(E1+AMA)
33451 AMTE=AMTE+1.D-18
33452 P1=SQRT(AMTE)
33453 P2=P1
33454C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33455C DETERMINATION OF THE ANGLES
33456C COS(THETA1)=COD1 COS(THETA2)=COD2
33457C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33458C COS(PHI1)=COF1 COS(PHI2)=COF2
33459C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33460 CALL DT_DSFECF(COF1,SIF1)
33461 COF2=-COF1
33462 SIF2=-SIF1
33463C CALCULATION OF THETA1
33464 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33465 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33466 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33467 COD2=-COD1
33468 RETURN
33469 END
33470
33471*$ CREATE DT_ZK.FOR
33472*COPY DT_ZK
33473*
33474*===zk=================================================================*
33475*
33476 BLOCK DATA DT_ZK
33477
33478 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33479 SAVE
33480
33481* decay channel information for HADRIN
33482 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33483 & K1Z(16),K2Z(16),WTZ(153),II22,
33484 & NZK1(153),NZK2(153),NZK3(153)
33485
33486* decay channel information for HADRIN
33487 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33488 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33489
33490* Particle masses in GeV *
33491 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33492 & 2*1.7D0, 3*0.D0/
33493* Resonance width Gamma in GeV *
33494 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33495* Mean life time in seconds *
33496 DATA TAUZ / 16*0.D0 /
33497* Charge of particles and resonances *
33498 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33499* Baryonic charge *
33500 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33501* First number of decay channels used for resonances *
33502* and decaying particles *
33503 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33504 & 3*460/
33505* Last number of decay channels used for resonances *
33506* and decaying particles *
33507 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33508 & 3*460/
33509* Weight of decay channel *
33510 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33511 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33512 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33513 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33514 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33515 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33516 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33517 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33518 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33519 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33520 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33521 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33522 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33523 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33524 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33525 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33526 & .05D0, .65D0, 9*1.D0 /
33527* Particle numbers in decay channel *
33528 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33529 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33530 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33531 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33532 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33533 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33534 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33535 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33536 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33537 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33538 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33539 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33540 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33541 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33542 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33543 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33544 & 1, 8, 1, 8, 1, 9*0 /
33545 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33546 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33547 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33548 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33549 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33550 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33551* Particle names *
33552 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33553 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33554 & 3*'BLANK' /
33555* Name of decay channel *
33556 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33557 & 'ANNPI0','APPPI0','ANPPI-'/
33558 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33559 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33560 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33561 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33562 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33563 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33564 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33565 & 'OMOMOM',
33566 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33567 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33568 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33569 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33570 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33571 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33572 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33573 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33574 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33575 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33576 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33577 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33578 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33579 & 9*'BLANK'/
33580*= end*block.zk *
33581 END
33582
33583*$ CREATE DT_BLKD43.FOR
33584*COPY DT_BLKD43
33585*
33586*===blkd43=============================================================*
33587*
33588 BLOCK DATA DT_BLKD43
33589
33590 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33591 SAVE
33592
33593*
33594*=== reac =============================================================*
33595*
33596*----------------------------------------------------------------------*
33597* *
33598* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33599* Infn - Milan *
33600* *
33601* Last change on 10-dec-91 by Alfredo Ferrari *
33602* *
33603* This is the original common reac of Hadrin *
33604* *
33605*----------------------------------------------------------------------*
33606*
33607
33608 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33609 & NRK(2,268),NURE(30,2)
33610
33611 DIMENSION
33612 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33613 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33614 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33615 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33616 & SPIKP5(187), SPIKP6(289),
33617 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33618 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33619 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33620 & SANPEL(84) , SPIKPF(273),
33621 & SPKP15(187), SPKP16(272),
33622 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33623 & NURELN(60)
33624*
33625 DIMENSION NRKLIN(532)
33626 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33627 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33628 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33629 EQUIVALENCE ( UMO(263), UMOK0(1))
33630 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33631 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33632 EQUIVALENCE ( PLABF(263), PLAK0(1))
33633 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33634 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33635 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33636 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33637 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33638 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33639 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33640 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33641 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33642 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33643 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33644 EQUIVALENCE ( WK(4913), SPKP16(1))
33645 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33646 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33647 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33648 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33649 EQUIVALENCE (NURE(1,1), NURELN(1))
33650*
33651**** pi- p data *
33652**** pi+ n data *
33653 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33654 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33655 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33656 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33657 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33658 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33659 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33660 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33661 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33662 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33663 DATA PLAKC /
33664 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33665 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33666 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33667 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33668 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33669 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33670 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33671 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33672 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33673 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33674 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33675 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33676 DATA PLAK0 /
33677 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33678 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33679 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33680 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33681 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33682 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33683* pp pn np nn *
33684 DATA PLAP /
33685 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33687 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33688 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33689 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33690 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33691* app apn anp ann *
33692 DATA PLAN /
33693 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33694 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33695 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33696 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33697 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33698 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33699 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33700 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33701 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33702 DATA SIIN / 296*0.D0 /
33703 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33704 & 1.557D0,1.615D0,1.6435D0,
33705 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33706 & 2.286D0,2.366D0,2.482D0,2.56D0,
33707 & 2.735D0,2.90D0,
33708 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33709 & 1.496D0,1.527D0,1.557D0,
33710 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33711 & 2.071D0,2.159D0,2.286D0,2.366D0,
33712 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33713 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33714 & 1.496D0,1.527D0,1.557D0,
33715 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33716 & 2.071D0,2.159D0,2.286D0,2.366D0,
33717 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33718 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33719 & 1.557D0,1.615D0,1.6435D0,
33720 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33721 & 2.286D0,2.366D0,2.482D0,2.56D0,
33722 & 2.735D0, 2.90D0/
33723 DATA UMOKC/ 1.44D0,
33724 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33725 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33726 & 3.1D0,1.44D0,
33727 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33728 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33729 & 3.1D0,1.44D0,
33730 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33731 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33732 & 3.1D0,1.44D0,
33733 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33734 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33735 & 3.1D0/
33736 DATA UMOK0/ 1.44D0,
33737 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33738 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33739 & 3.1D0,1.44D0,
33740 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33741 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33742 & 3.1D0/
33743* pp pn np nn *
33744 DATA UMOP/
33745 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746 & 3.D0,3.1D0,3.2D0,
33747 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33748 & 3.D0,3.1D0,3.2D0,
33749 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33750 & 3.D0,3.1D0,3.2D0/
33751* app apn anp ann *
33752 DATA UMON /
33753 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33754 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33755 & 3.D0,3.1D0,3.2D0,
33756 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33757 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33758 & 3.D0,3.1D0,3.2D0,
33759 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33760 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33761 & 3.D0,3.1D0,3.2D0/
33762**** reaction channel state particles *
33763 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33764 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33765 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33766 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33767 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33768 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33769 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33770 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33771 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33772 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33773 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33774 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33775 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33776 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33777 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33778 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33779 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33780 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33781* *
33782* k0 p k0 n ak0 p ak/ n *
33783* *
33784 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33785 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33786 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33787 & 53, 47, 1, 103, 0, 93, 0/
33788* pp pn np nn *
33789 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33790 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33791 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33792 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33793* app apn anp ann *
33794 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33795 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33796 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33797 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33798 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33799 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33800 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33801**** channel cross section *
33802 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33803 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33804 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33805 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33806 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33807 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33808 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33809 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33810 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33811 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33812 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33813 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33814 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33815 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33816 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33817 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33818 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33819 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33820 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33821 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33822**** pi+ n data *
33823 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33824 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33825 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33826 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33827 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33828 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33829 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33830 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33831 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33832 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33833 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33834 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33835 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33836 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33837 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33838 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33839 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33840 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33841 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33842 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33843*
33844 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33845 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33846 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33847 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33848 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33849 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33850 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33851 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33852 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33853 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33854 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33855 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33856 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33857 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33858 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33859 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33860 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33861 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33862 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33863 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33864**** pi- p data *
33865 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33866 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33867 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33868 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33869 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33870 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33871 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33872 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33873 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33874 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33875 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33876 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33877 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33878 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33879 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33880 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33881 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33882 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33883 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33884*
33885 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33886 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33887 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33888 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33889 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33890 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33891 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33892 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33893 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33894 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33895 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33896 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33897 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33898 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33899 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33900 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33901 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33902 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33903 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33904 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33905**** pi- n data *
33906 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33907 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33908 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33909 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33910 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33911 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33912 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33913 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33914 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33915 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33916 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33917 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33918 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33919 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33920 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33921 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33922 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33923 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33924 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33925 & 3.3D0, 5.4D0, 7.D0 /
33926**** k+ p data *
33927 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33928 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33929 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33930 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33931 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33932 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33933 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33934 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33935 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33936 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33937 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33938 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33939 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33940**** k+ n data *
33941 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33942 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33943 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33944 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33945 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33946 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33947 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33948 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33949 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33950 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33951 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33952 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33953 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33954 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33955 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33956 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33957 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33958 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33959 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33960**** k- p data *
33961 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33962 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33963 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33964 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33965 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33966 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33967 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33968 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33969 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33970 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33971 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33972 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33973 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33974 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33975 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33976 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33977 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33978 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33979 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33980 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33981 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33982 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33983 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33984 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33985 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33986 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33987 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33988 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33989 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33990 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33991 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33992 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33993 & 10*0.D0/
33994***** k- n data *
33995 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33996 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33997 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33998 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33999 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34000 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34001 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34002 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34003 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34004 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34005 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34006 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34007 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34008 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34009 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34010 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34011 & .39D0, .22D0, .07D0, 0.D0,
34012 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34013 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34014 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34015 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34016 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34017 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34018 & 5.10D0, 5.44D0, 5.3D0,
34019 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34020***** p p data *
34021 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34022 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34023 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34024 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34025 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34026 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34027 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34028 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34029 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34030 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34031 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34032 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34033 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34034 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34035 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34036***** p n data *
34037 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34038 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34039 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34040 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34041 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34042 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34043 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34044 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34045 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34046 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34047 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34048 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34049 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34050 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34051 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34052 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34053 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34054 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34055* nn - data *
34056* *
34057 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34058 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34059 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34060 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34061 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34062 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34063 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34064 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34065 & 11.D0, 5.5D0, 3.5D0,
34066 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34067 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34068 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34069 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34070 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34071 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34072**************** ap - p - data *
34073 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34074 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34075 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34076 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34077 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34078 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34079 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34080 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34081 & 1.55D0, 1.3D0, .95D0, .75D0,
34082 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34083 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34084 & .01D0, .008D0, .006D0, .005D0/
34085 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34086 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34087 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34088 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34089 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34090 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34091 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34092 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34093 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34094 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34095 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34096 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34097 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34098 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34099 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34100 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34101 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34102 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34103 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34104 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34105**************** ap - n - data *
34106 DATA SAPNEL/
34107 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34108 & 50.D0, 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,
34110 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34111 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34112 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34113 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34114 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34115 & .01D0, .008D0, .006D0, .005D0 /
34116 DATA SPIKPZ/ 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* *
34131* *
34132**************** an - p - data *
34133* *
34134 DATA SANPEL/
34135 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34136 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34137 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34138 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34139 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34140 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34141 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34142 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34143 & .01D0, .008D0, .006D0, .005D0 /
34144 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34145 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34146 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34147 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34148 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34149 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34150 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34151 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34152 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34153 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34154 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34155 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34156 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34157 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34158**** ko - n - data *
34159 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34160 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34161 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34162 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34163 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34164 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34165 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34166 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34167 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34168 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34169 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34170 & 4.85D0, 4.9D0,
34171 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34172 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34173 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34174 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34175 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34176**** ako - p - data *
34177 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34178 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34179 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34180 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34181 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34182 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34183 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34184 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34185 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34186 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34187 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34188 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34189 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34190 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34191 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34192 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34193 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34194 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34195 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34196 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34197 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34198 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34199 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34200*= end*block.blkdt3 *
34201 END
34202*$ CREATE DT_QEL_POL.FOR
34203*COPY DT_QEL_POL
34204*
34205*===qel_pol============================================================*
34206*
34207 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34208
34209 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34210 SAVE
34211
34212 CALL DT_MASS_INI
34213 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34214
34215 RETURN
34216 END
34217
34218*$ CREATE DT_GEN_QEL.FOR
34219*COPY DT_GEN_QEL
34220C==================================================================
34221C Generation of a Quasi-Elastic neutrino scattering
34222C==================================================================
34223*
34224*===gen_qel============================================================*
34225*
34226 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34227
34228C...Generate a quasi-elastic neutrino/antineutrino
34229C. Interaction on a nuclear target
34230C. INPUT : LTYP = neutrino type (1,...,6)
34231C. ENU (GeV) = neutrino energy
34232C----------------------------------------------------
34233
34234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34235 SAVE
34236
34237 PARAMETER ( LINP = 10 ,
34238 & LOUT = 6 ,
34239 & LDAT = 9 )
34240 PARAMETER (MAXLND=4000)
34241 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34242
34243* nuclear potential
34244 LOGICAL LFERMI
34245 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34246 & EBINDP(2),EBINDN(2),EPOT(2,210),
34247 & ETACOU(2),ICOUL,LFERMI
34248
34249* steering flags for qel neutrino scattering modules
34250 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34251**sr - removed (not needed)
34252C COMMON /CBAD/ LBAD, NBAD
34253C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34254**
34255
34256 DIMENSION PI(3),PO(3)
34257CJR+
34258 DATA ININU/0/
34259CJR-
34260C REAL*8 DBETA(3)
34261C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34262 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34263 DATA AMN /0.93827231D0, 0.93956563D0/
34264 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34265 DATA INIPRI/0/
34266
34267C DATA PFERMI/0.22D0/
34268CGB+...Binding Energy
34269 DATA EBIND/0.008D0/
34270CGB-...
34271
34272 ININU=ININU+1
34273 IF(ININU.EQ.1)NDSIG=0
34274 LBAD = 0
34275 enu0=enu
34276c write(*,*) enu0
34277C...Lepton mass
34278 AML = AML0(LTYP) ! massa leptoni
34279 AML2 = AML**2 ! massa leptoni **2
34280C...Particle labels (LUND)
34281 N = 5
34282 K(1,1) = 21
34283 K(2,1) = 21
34284 K(3,1) = 21
34285 K(3,3) = 1
34286 K(4,1) = 1
34287 K(4,3) = 1
34288 K(5,1) = 1
34289 K(5,3) = 2
34290 K0 = (LTYP-1)/2 ! 2
34291 K1 = LTYP/2 ! 2
34292 KA = 12 + 2*K0 ! 16
34293 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34294 K(1,2) = IS*KA
34295 K(4,2) = IS*(KA-1)
34296 K(3,2) = IS*24
34297 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34298 IF (LNU .EQ. 2) THEN
34299 K(2,2) = 2212
34300 K(5,2) = 2112
34301 AMI = AMN(1)
34302 AMF = AMN(2)
34303CJR+
34304 PFERMI=PFERMN(2)
34305CJR-
34306 ELSE
34307 K(2,2) = 2112
34308 K(5,2) = 2212
34309 AMI = AMN(2)
34310 AMF = AMN(1)
34311CJR+
34312 PFERMI=PFERMP(2)
34313CJR-
34314 ENDIF
34315 AMI2 = AMI**2
34316 AMF2 = AMF**2
34317
34318 DO IGB=1,5
34319 P(3,IGB) = 0.
34320 P(4,IGB) = 0.
34321 P(5,IGB) = 0.
34322 END DO
34323
34324 NTRY = 0
34325CGB+...
34326 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34327 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34328CGB-...
34329
34330 100 CONTINUE
34331
34332C...4-momentum initial lepton
34333 P(1,5) = 0. ! massa
34334 P(1,4) = ENU0 ! energia
34335 P(1,1) = 0. ! px
34336 P(1,2) = 0. ! py
34337 P(1,3) = ENU0 ! pz
34338
34339C PF = PFERMI*PYR(0)**(1./3.)
34340c write(23,*) PYR(0)
34341c write(*,*) 'Pfermi=',PF
34342c PF = 0.
34343 NTRY=NTRY+1
34344C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34345 IF (NTRY .GT. 500) THEN
34346 LBAD = 1
34347 WRITE (LOUT,1001) NBAD, ENU
34348 RETURN
34349 ENDIF
34350C CT = -1. + 2.*PYR(0)
34351c CT = -1.
34352C ST = SQRT(1.-CT*CT)
34353C F = 2.*3.1415926*PYR(0)
34354c F = 0.
34355
34356C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34357C P(2,1) = PF*ST*COS(F) ! px
34358C P(2,2) = PF*ST*SIN(F) ! py
34359C P(2,3) = PF*CT ! pz
34360C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34361 P(2,1) = P21
34362 P(2,2) = P22
34363 P(2,3) = P23
34364 P(2,4) = P24
34365 P(2,5) = P25
34366 beta1=-p(2,1)/p(2,4)
34367 beta2=-p(2,2)/p(2,4)
34368 beta3=-p(2,3)/p(2,4)
34369 N=2
34370C WRITE(6,*)' before transforming into target rest frame'
34371
34372 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34373
34374C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34375 N=5
34376
34377 phi11=atan(p(1,2)/p(1,3))
34378 pi(1)=p(1,1)
34379 pi(2)=p(1,2)
34380 pi(3)=p(1,3)
34381
34382 CALL DT_TESTROT(PI,Po,PHI11,1)
34383 DO ll=1,3
34384 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34385 END DO
34386c WRITE(*,*) po
34387 p(1,1)=po(1)
34388 p(1,2)=po(2)
34389 p(1,3)=po(3)
34390 phi12=atan(p(1,1)/p(1,3))
34391
34392 pi(1)=p(1,1)
34393 pi(2)=p(1,2)
34394 pi(3)=p(1,3)
34395 CALL DT_TESTROT(Pi,Po,PHI12,2)
34396 DO ll=1,3
34397 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34398 END DO
34399c WRITE(*,*) po
34400 p(1,1)=po(1)
34401 p(1,2)=po(2)
34402 p(1,3)=po(3)
34403
34404 enu=p(1,4)
34405
34406C...Kinematical limits in Q**2
34407c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34408 S = P(2,5)**2 + 2.*ENU*P(2,5)
34409 SQS = SQRT(S) ! E centro massa
34410 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34411 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34412 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34413 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34414 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34415 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34416 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34417
34418C...Generate Q**2
34419 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34420 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34421 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34422 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34423 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34424 NDSIG=NDSIG+1
34425C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34426C &Q2,Q2min,Q2MAX,DSIGEV
34427
34428C...c.m. frame. Neutrino along z axis
34429 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34430 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34431 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34432 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34433c WRITE(*,*)
34434c WRITE(*,*)
34435C WRITE(*,*) 'Input values laboratory frame'
34436 N=2
34437
34438 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34439
34440 N=5
34441c STHETA = ULANGL(P(1,3),P(1,1))
34442c write(*,*) 'stheta' ,stheta
34443c stheta=0.
34444c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34445c WRITE(*,*)
34446c WRITE(*,*)
34447C WRITE(*,*) 'Output values cm frame'
34448C...Kinematic in c.m. frame
34449 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34450 STSTAR = SQRT(1.-CTSTAR**2)
34451 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34452 P(4,5) = AML ! massa leptone
34453 P(4,4) = ELF ! e leptone
34454 P(4,3) = PLF*CTSTAR ! px
34455 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34456 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34457
34458 P(5,5) = AMF ! barione
34459 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34460 P(5,3) = -P(4,3) ! px
34461 P(5,1) = -P(4,1) ! py
34462 P(5,2) = -P(4,2) ! pz
34463
34464 P(3,5) = -Q2
34465 P(3,1) = P(1,1)-P(4,1)
34466 P(3,2) = P(1,2)-P(4,2)
34467 P(3,3) = P(1,3)-P(4,3)
34468 P(3,4) = P(1,4)-P(4,4)
34469
34470C...Transform back to laboratory frame
34471C WRITE(*,*) 'before going back to nucl rest frame'
34472c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34473 N=5
34474
34475 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34476
34477C WRITE(*,*) 'Now back in nucl rest frame'
34478 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34479
34480c********************************************
34481
34482 DO kw=1,5
34483 pi(1)=p(kw,1)
34484 pi(2)=p(kw,2)
34485 pi(3)=p(kw,3)
34486 CALL DT_TESTROT(Pi,Po,PHI12,3)
34487 DO ll=1,3
34488 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34489 END DO
34490 p(kw,1)=po(1)
34491 p(kw,2)=po(2)
34492 p(kw,3)=po(3)
34493 END DO
34494c********************************************
34495
34496 DO kw=1,5
34497 pi(1)=p(kw,1)
34498 pi(2)=p(kw,2)
34499 pi(3)=p(kw,3)
34500 CALL DT_TESTROT(Pi,Po,PHI11,4)
34501 DO ll=1,3
34502 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34503 END DO
34504 p(kw,1)=po(1)
34505 p(kw,2)=po(2)
34506 p(kw,3)=po(3)
34507 END DO
34508
34509c********************************************
34510
34511C WRITE(*,*) 'Now back in lab frame'
34512
34513 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34514
34515CGB+...
34516C...test (on final momentum of nucleon) if Fermi-blocking
34517C...is operating
34518 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34519 & - P(5,5)
34520 IF (ENUCL.LT. EFMAX) THEN
34521 IF(INIPRI.LT.10)THEN
34522 INIPRI=INIPRI+1
34523C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34524C...the interaction is not possible due to Pauli-Blocking and
34525C...it must be resampled
34526 ENDIF
34527 GOTO 100
34528 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34529 IF(INIPRI.LT.10)THEN
34530 INIPRI=INIPRI+1
34531C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34532 ENDIF
34533C Reject (J:R) here all these events
34534C are otherwise rejected in dpmjet
34535 GOTO 100
34536C...the interaction is possible, but the nucleon remains inside
34537C...the nucleus. The nucleus is therefore left excited.
34538C...We treat this case as a nucleon with 0 kinetic energy.
34539C P(5,5) = AMF
34540C P(5,4) = AMF
34541C P(5,1) = 0.
34542C P(5,2) = 0.
34543C P(5,3) = 0.
34544 ELSE IF (ENUCL.GE.ENWELL) THEN
34545C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34546C...the interaction is possible, the nucleon can exit the nucleus
34547C...but the nuclear well depth must be subtracted. The nucleus could be
34548C...left in an excited state.
34549 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34550C P(5,4) = ENUCL-ENWELL + AMF
34551 Pnucl = SQRT(P(5,4)**2-AMF**2)
34552C...The 3-momentum is scaled assuming that the direction remains
34553C...unaffected
34554 P(5,1) = P(5,1) * Pnucl/Pstart
34555 P(5,2) = P(5,2) * Pnucl/Pstart
34556 P(5,3) = P(5,3) * Pnucl/Pstart
34557C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34558 ENDIF
34559CGB-...
34560 DSIGSU=DSIGSU+DSIGEV
34561
34562 GA=P(4,4)/P(4,5)
34563 BGX=P(4,1)/P(4,5)
34564 BGY=P(4,2)/P(4,5)
34565 BGZ=P(4,3)/P(4,5)
34566*
34567 DBETB(1)=BGX/GA
34568 DBETB(2)=BGY/GA
34569 DBETB(3)=BGZ/GA
34570 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34571
34572 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34573
34574 ENDIF
34575c
34576C PRINT*,' FINE EVENTO '
34577 enu=enu0
34578 RETURN
34579
34580 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34581 END
34582
34583*$ CREATE DT_MASS_INI.FOR
34584*COPY DT_MASS_INI
34585C====================================================================
34586C. Masses
34587C====================================================================
34588*
34589*===mass_ini===========================================================*
34590*
34591 SUBROUTINE DT_MASS_INI
34592C...Initialize the kinematics for the quasi-elastic cross section
34593
34594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34595 SAVE
34596
34597* particle masses used in qel neutrino scattering modules
34598 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34599 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34600 & EMPROTSQ,EMNEUTSQ,EMNSQ
34601
34602 EML(1) = 0.51100D-03 ! e-
34603 EML(2) = EML(1) ! e+
34604 EML(3) = 0.105659D0 ! mu-
34605 EML(4) = EML(3) ! mu+
34606 EML(5) = 1.7777D0 ! tau-
34607 EML(6) = EML(5) ! tau+
34608 EMPROT = 0.93827231D0 ! p
34609 EMNEUT = 0.93956563D0 ! n
34610 EMPROTSQ = EMPROT**2
34611 EMNEUTSQ = EMNEUT**2
34612 EMN = (EMPROT + EMNEUT)/2.
34613 EMNSQ = EMN**2
34614 DO J=1,3
34615 J0 = 2*(J-1)
34616 EMN1(J0+1) = EMNEUT
34617 EMN1(J0+2) = EMPROT
34618 EMN2(J0+1) = EMPROT
34619 EMN2(J0+2) = EMNEUT
34620 ENDDO
34621 DO J=1,6
34622 EMLSQ(J) = EML(J)**2
34623 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34624 ENDDO
34625 RETURN
34626 END
34627
34628*$ CREATE DT_DSQEL_Q2.FOR
34629*COPY DT_DSQEL_Q2
34630*
34631*===dsqel_q2===========================================================*
34632*
34633 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34634
34635C...differential cross section for Quasi-Elastic scattering
34636C. nu + N -> l + N'
34637C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34638C.
34639C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34640C. ENU (GeV) = Neutrino energy
34641C. Q2 (GeV**2) = (Transfer momentum)**2
34642C.
34643C. OUTPUT : DSQEL_Q2 = differential cross section :
34644C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34645C------------------------------------------------------------------
34646
34647 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34648 SAVE
34649
34650* particle masses used in qel neutrino scattering modules
34651 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34652 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34653 & EMPROTSQ,EMNEUTSQ,EMNSQ
34654**sr - removed (not needed)
34655C COMMON /CAXIAL/ FA0, AXIAL2
34656**
34657
34658 DIMENSION SS(6)
34659 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34660 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34661 DATA AXIAL2 /1.03D0/ ! to be checked
34662
34663 FA0=-1.253D0
34664 CSI = 3.71D0 ! ???
34665 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34666 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34667 X = Q2/(EMN*EMN) ! emn=massa barione
34668 XA = X/4.D0
34669 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34670 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34671 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34672 FFA = FA*FA
34673 FFV1 = FV1*FV1
34674 FFV2 = FV2*FV2
34675 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34676 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34677 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34678 AA = (XA+0.25D0*RM)*(A1 + A2)
34679 BB = -X*FA*(FV1 + FV2)
34680 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34681 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34682 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34683 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34684
34685 RETURN
34686 END
34687
34688*$ CREATE DT_PREPOLA.FOR
34689*COPY DT_PREPOLA
34690*
34691*===prepola============================================================*
34692*
34693 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34694
34695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34696 SAVE
34697c
34698c By G. Battistoni and E. Scapparone (sept. 1997)
34699c According to:
34700c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34701c
34702c
34703 PARAMETER (MAXLND=4000)
34704 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34705
34706 COMMON /QNPOL/ POLARX(4),PMODUL
34707
34708* particle masses used in qel neutrino scattering modules
34709 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34710 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34711 & EMPROTSQ,EMNEUTSQ,EMNSQ
34712
34713* steering flags for qel neutrino scattering modules
34714 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34715**sr - removed (not needed)
34716C COMMON /CAXIAL/ FA0, AXIAL2
34717C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34718C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34719**
34720 REAL*8 POL(4,4),BB2(3)
34721 DIMENSION SS(6)
34722C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34723 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34724**sr uncommented since common block CAXIAL is now commented
34725 DATA AXIAL2 /1.03D0/ ! to be checked
34726**
34727
34728 RML=P(4,5)
34729 RMM=0.93960D+00
34730 FM2 = RMM**2
34731 MPI = 0.135D+00
34732 OLDQ2=Q2
34733 FA0=-1.253D+00
34734 CSI = 3.71D+00 !
34735 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34736 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34737 X = Q2/(EMN*EMN) ! emn=massa barione
34738 XA = X/4.D0
34739 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34740 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34741 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34742 FFA = FA*FA
34743 FFV1 = FV1*FV1
34744 FFV2 = FV2*FV2
34745 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34746 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34747 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34748 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34749 AA = (XA+0.25D+00*RM)*(A1 + A2)
34750 BB = -X*FA*(FV1 + FV2)
34751 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34752 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34753
34754 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34755 OMEGA2=4.D+00*CC
34756 OMEGA3=2.D+00*FA*(FV1+FV2)
34757 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34758 1 (Q2/FM2))*FP**2)
34759 OMEGA5=OMEGA2
34760 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34761 WW1=2.D+00*OMEGA1*EMN**2
34762 WW2=2.D+00*OMEGA2*EMN**2
34763 WW3=2.D+00*OMEGA3*EMN**2
34764 WW4=2.D+00*OMEGA4*EMN**2
34765 WW5=2.D+00*OMEGA5*EMN**2
34766
34767 DO I=1,3
34768 BB2(I)=-P(4,I)/P(4,4)
34769 END DO
34770c WRITE(*,*)
34771c WRITE(*,*)
34772c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34773 N=5
34774
34775 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34776
34777* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34778c WRITE(*,*)
34779c WRITE(*,*)
34780c WRITE(*,*) 'Prepola: now in lepton rest frame'
34781 EE=ENU
34782 QM2=Q2+RML**2
34783 U=Q2/(2.*RMM)
34784 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34785 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34786 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34787
34788 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34789 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34790
34791 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34792
34793 DO I=1,3
34794 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34795 POLARX(I)=POL(4,I)
34796 END DO
34797
34798 PMODUL=0.D0
34799 DO I=1,3
34800 PMODUL=PMODUL+POL(4,I)**2
34801 END DO
34802
34803 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34804 IF(NEUDEC.EQ.1) THEN
34805 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34806 + ETL,PXL,PYL,PZL,
34807 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34808c
34809c Tau has decayed in muon
34810c
34811 ENDIF
34812 IF(NEUDEC.EQ.2) THEN
34813 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34814 + ETL,PXL,PYL,PZL,
34815 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34816c
34817c Tau has decayed in electron
34818c
34819 ENDIF
34820 K(4,1)=15
34821 K(4,4) = 6
34822 K(4,5) = 8
34823 N=N+3
34824c
34825c fill common for muon(electron)
34826c
34827 P(6,1)=PXL
34828 P(6,2)=PYL
34829 P(6,3)=PZL
34830 P(6,4)=ETL
34831 K(6,1)=1
34832 IF(JTYP.EQ.5) THEN
34833 IF(NEUDEC.EQ.1) THEN
34834 P(6,5)=EML(JTYP-2)
34835 K(6,2)=13
34836 ELSEIF(NEUDEC.EQ.2) THEN
34837 P(6,5)=EML(JTYP-4)
34838 K(6,2)=11
34839 ENDIF
34840 ELSEIF(JTYP.EQ.6) THEN
34841 IF(NEUDEC.EQ.1) THEN
34842 K(6,2)=-13
34843 ELSEIF(NEUDEC.EQ.2) THEN
34844 K(6,2)=-11
34845 ENDIF
34846 END IF
34847 K(6,3)=4
34848 K(6,4)=0
34849 K(6,5)=0
34850c
34851c fill common for tau_(anti)neutrino
34852c
34853 P(7,1)=PXB
34854 P(7,2)=PYB
34855 P(7,3)=PZB
34856 P(7,4)=ETB
34857 P(7,5)=0.
34858 K(7,1)=1
34859 IF(JTYP.EQ.5) THEN
34860 K(7,2)=16
34861 ELSEIF(JTYP.EQ.6) THEN
34862 K(7,2)=-16
34863 END IF
34864 K(7,3)=4
34865 K(7,4)=0
34866 K(7,5)=0
34867c
34868c Fill common for muon(electron)_(anti)neutrino
34869c
34870 P(8,1)=PXN
34871 P(8,2)=PYN
34872 P(8,3)=PZN
34873 P(8,4)=ETN
34874 P(8,5)=0.
34875 K(8,1)=1
34876 IF(JTYP.EQ.5) THEN
34877 IF(NEUDEC.EQ.1) THEN
34878 K(8,2)=-14
34879 ELSEIF(NEUDEC.EQ.2) THEN
34880 K(8,2)=-12
34881 ENDIF
34882 ELSEIF(JTYP.EQ.6) THEN
34883 IF(NEUDEC.EQ.1) THEN
34884 K(8,2)=14
34885 ELSEIF(NEUDEC.EQ.2) THEN
34886 K(8,2)=12
34887 ENDIF
34888 END IF
34889 K(8,3)=4
34890 K(8,4)=0
34891 K(8,5)=0
34892 ENDIF
34893c WRITE(*,*)
34894c WRITE(*,*)
34895
34896c IF(PMODUL.GE.1.D+00) THEN
34897c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34898c write(*,*) pmodul
34899c DO I=1,3
34900c POL(4,I)=POL(4,I)/PMODUL
34901c POLARX(I)=POL(4,I)
34902c END DO
34903c PMODUL=0.
34904c DO I=1,3
34905c PMODUL=PMODUL+POL(4,I)**2
34906c END DO
34907c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34908c
34909c ENDIF
34910
34911c WRITE(*,*) 'PMODUL = ',PMODUL
34912
34913c WRITE(*,*)
34914c WRITE(*,*)
34915c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34916
34917 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34918
34919 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34920 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34921 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34922 DO NDC =6,8
34923 V(NDC,1) = XDC
34924 V(NDC,2) = YDC
34925 V(NDC,3) = ZDC
34926 END DO
34927
34928 RETURN
34929 END
34930
34931*$ CREATE DT_TESTROT.FOR
34932*COPY DT_TESTROT
34933*
34934*===testrot============================================================*
34935*
34936 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34937
34938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34939 SAVE
34940
34941 DIMENSION ROT(3,3),PI(3),PO(3)
34942
34943 IF (MODE.EQ.1) THEN
34944 ROT(1,1) = 1.D0
34945 ROT(1,2) = 0.D0
34946 ROT(1,3) = 0.D0
34947 ROT(2,1) = 0.D0
34948 ROT(2,2) = COS(PHI)
34949 ROT(2,3) = -SIN(PHI)
34950 ROT(3,1) = 0.D0
34951 ROT(3,2) = SIN(PHI)
34952 ROT(3,3) = COS(PHI)
34953 ELSEIF (MODE.EQ.2) THEN
34954 ROT(1,1) = 0.D0
34955 ROT(1,2) = 1.D0
34956 ROT(1,3) = 0.D0
34957 ROT(2,1) = COS(PHI)
34958 ROT(2,2) = 0.D0
34959 ROT(2,3) = -SIN(PHI)
34960 ROT(3,1) = SIN(PHI)
34961 ROT(3,2) = 0.D0
34962 ROT(3,3) = COS(PHI)
34963 ELSEIF (MODE.EQ.3) THEN
34964 ROT(1,1) = 0.D0
34965 ROT(2,1) = 1.D0
34966 ROT(3,1) = 0.D0
34967 ROT(1,2) = COS(PHI)
34968 ROT(2,2) = 0.D0
34969 ROT(3,2) = -SIN(PHI)
34970 ROT(1,3) = SIN(PHI)
34971 ROT(2,3) = 0.D0
34972 ROT(3,3) = COS(PHI)
34973 ELSEIF (MODE.EQ.4) THEN
34974 ROT(1,1) = 1.D0
34975 ROT(2,1) = 0.D0
34976 ROT(3,1) = 0.D0
34977 ROT(1,2) = 0.D0
34978 ROT(2,2) = COS(PHI)
34979 ROT(3,2) = -SIN(PHI)
34980 ROT(1,3) = 0.D0
34981 ROT(2,3) = SIN(PHI)
34982 ROT(3,3) = COS(PHI)
34983 ELSE
34984 STOP ' TESTROT: mode not supported!'
34985 ENDIF
34986 DO 1 J=1,3
34987 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34988 1 CONTINUE
34989
34990 RETURN
34991 END
34992
34993*$ CREATE DT_LEPDCYP.FOR
34994*COPY DT_LEPDCYP
34995*
34996*===lepdcyp============================================================*
34997*
34998 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34999 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35000C
35001C-----------------------------------------------------------------
35002C
35003C Author :- G. Battistoni 10-NOV-1995
35004C
35005C=================================================================
35006C
35007C Purpose : performs decay of polarized lepton in
35008C its rest frame: a => b + l + anti-nu
35009C (Example: mu- => nu-mu + e- + anti-nu-e)
35010C Polarization is assumed along Z-axis
35011C WARNING:
35012C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35013C OF NEGLIGIBLE MASS
35014C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35015C IN THIS VERSION
35016C
35017C Method : modifies phase space distribution obtained
35018C by routine EXPLOD using a rejection against the
35019C matrix element for unpolarized lepton decay
35020C
35021C Inputs : Mass of a : AMA
35022C Mass of l : AML
35023C Polar. of a: POL
35024C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35025C POL = -1)
35026C
35027C Outputs : kinematic variables in the rest frame of decaying lepton
35028C ETL,PXL,PYL,PZL 4-moment of l
35029C ETB,PXB,PYB,PZB 4-moment of b
35030C ETN,PXN,PYN,PZN 4-moment of anti-nu
35031C
35032C============================================================
35033C +
35034C Declarations.
35035C -
35036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35037 SAVE
35038
35039 PARAMETER ( LINP = 10 ,
35040 & LOUT = 6 ,
35041 & LDAT = 9 )
35042
35043 PARAMETER ( KALGNM = 2 )
35044 PARAMETER ( ANGLGB = 5.0D-16 )
35045 PARAMETER ( ANGLSQ = 2.5D-31 )
35046 PARAMETER ( AXCSSV = 0.2D+16 )
35047 PARAMETER ( ANDRFL = 1.0D-38 )
35048 PARAMETER ( AVRFLW = 1.0D+38 )
35049 PARAMETER ( AINFNT = 1.0D+30 )
35050 PARAMETER ( AZRZRZ = 1.0D-30 )
35051 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35052 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35053 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35054 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35055 PARAMETER ( CSNNRM = 2.0D-15 )
35056 PARAMETER ( DMXTRN = 1.0D+08 )
35057 PARAMETER ( ZERZER = 0.D+00 )
35058 PARAMETER ( ONEONE = 1.D+00 )
35059 PARAMETER ( TWOTWO = 2.D+00 )
35060 PARAMETER ( THRTHR = 3.D+00 )
35061 PARAMETER ( FOUFOU = 4.D+00 )
35062 PARAMETER ( FIVFIV = 5.D+00 )
35063 PARAMETER ( SIXSIX = 6.D+00 )
35064 PARAMETER ( SEVSEV = 7.D+00 )
35065 PARAMETER ( EIGEIG = 8.D+00 )
35066 PARAMETER ( ANINEN = 9.D+00 )
35067 PARAMETER ( TENTEN = 10.D+00 )
35068 PARAMETER ( HLFHLF = 0.5D+00 )
35069 PARAMETER ( ONETHI = ONEONE / THRTHR )
35070 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35071 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35072 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35073 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35074 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35075 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35076 PARAMETER ( AMELGR = 9.1093897 D-28 )
35077 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35078 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35079 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35080 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35081 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35082 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35083 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35084 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35085 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35086 PARAMETER ( PLABRC = 0.197327053 D+00 )
35087 PARAMETER ( AMELCT = 0.51099906 D-03 )
35088 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35089 PARAMETER ( AMMUON = 0.105658389 D+00 )
35090 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35091 PARAMETER ( GEVMEV = 1.0 D+03 )
35092 PARAMETER ( EMVGEV = 1.0 D-03 )
35093 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35094 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35095 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35096C +
35097C variables for EXPLOD
35098C -
35099 PARAMETER ( KPMX = 10 )
35100 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35101 & PZEXPL (KPMX), ETEXPL (KPMX)
35102C +
35103C test variables
35104C -
35105**sr - removed (not needed)
35106C COMMON /GBATNU/ ELERAT,NTRY
35107**
35108C +
35109C Initializes test variables
35110C -
35111 NTRY = 0
35112 ELERAT = 0.D+00
35113C +
35114C Maximum value for matrix element
35115C -
35116 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35117 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35118C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35119C Inputs for EXPLOD
35120C part. no. 1 is l (e- in mu- decay)
35121C part. no. 2 is b (nu-mu in mu- decay)
35122C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35123C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35124 NPEXPL = 3
35125 ETOTEX = AMA
35126 AMEXPL(1) = AML
35127 AMEXPL(2) = 0.D+00
35128 AMEXPL(3) = 0.D+00
35129C +
35130C phase space distribution
35131C -
35132 100 CONTINUE
35133 NTRY = NTRY + 1
35134
35135 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35136 & PYEXPL, PZEXPL )
35137
35138C +
35139C Calculates matrix element:
35140C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35141C Here CTH is the cosine of the angle between anti-nu and Z axis
35142C -
35143 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35144 & PZEXPL(3)**2 )
35145 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35146 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35147 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35148 ELEMAT = 16.D+00 * PROD1 * PROD2
35149 IF(ELEMAT.GT.ELEMAX) THEN
35150 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35151 STOP
35152 ENDIF
35153C +
35154C Here performs the rejection
35155C -
35156 TEST = DT_RNDM(ETOTEX) * ELEMAX
35157 IF ( TEST .GT. ELEMAT ) GO TO 100
35158C +
35159C final assignment of variables
35160C -
35161 ELERAT = ELEMAT/ELEMAX
35162 ETL = ETEXPL(1)
35163 PXL = PXEXPL(1)
35164 PYL = PYEXPL(1)
35165 PZL = PZEXPL(1)
35166 ETB = ETEXPL(2)
35167 PXB = PXEXPL(2)
35168 PYB = PYEXPL(2)
35169 PZB = PZEXPL(2)
35170 ETN = ETEXPL(3)
35171 PXN = PXEXPL(3)
35172 PYN = PYEXPL(3)
35173 PZN = PZEXPL(3)
35174 999 RETURN
35175 END
35176
35177*$ CREATE DT_GEN_DELTA.FOR
35178*COPY DT_GEN_DELTA
35179C==================================================================
35180C. Generation of Delta resonance events
35181C==================================================================
35182*
35183*===gen_delta==========================================================*
35184*
35185 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35186
35187 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35188 SAVE
35189
35190 PARAMETER ( LINP = 10 ,
35191 & LOUT = 6 ,
35192 & LDAT = 9 )
35193
35194C...Generate a Delta-production neutrino/antineutrino
35195C. CC-interaction on a nucleon
35196C
35197C. INPUT ENU (GeV) = Neutrino Energy
35198C. LLEP = neutrino type
35199C. LTARG = nucleon target type 1=p, 2=n.
35200C. JINT = 1:CC, 2::NC
35201C.
35202C. OUTPUT PPL(4) 4-monentum of final lepton
35203C----------------------------------------------------
35204 PARAMETER (MAXLND=4000)
35205 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35206
35207**sr - removed (not needed)
35208C COMMON /CBAD/ LBAD, NBAD
35209**
35210
35211 DIMENSION PI(3),PO(3)
35212C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35213 DIMENSION AML0(6),AMN(2)
35214 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35215 DATA AMN /0.93827231, 0.93956563/
35216 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35217
35218c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35219 LBAD = 0
35220C...Final lepton mass
35221 IF (JINT.EQ.1) THEN
35222 AML = AML0(LLEP)
35223 ELSE
35224 AML = 0.
35225 ENDIF
35226 AML2 = AML**2
35227
35228C...Particle labels (LUND)
35229 N = 5
35230 K(1,1) = 21
35231 K(2,1) = 21
35232 K(3,1) = 21
35233 K(4,1) = 1
35234 K(3,3) = 1
35235 K(4,3) = 1
35236 IF (LTARG .EQ. 1) THEN
35237 K(2,2) = 2212
35238 ELSE
35239 K(2,2) = 2112
35240 ENDIF
35241 K0 = (LLEP-1)/2
35242 K1 = LLEP/2
35243 KA = 12 + 2*K0
35244 IS = -1 + 2*LLEP - 4*K1
35245 LNU = 2 - LLEP + 2*K1
35246 K(1,2) = IS*KA
35247 K(5,1) = 1
35248 K(5,3) = 2
35249 IF (JINT .EQ. 1) THEN ! CC interactions
35250 K(3,2) = IS*24
35251 K(4,2) = IS*(KA-1)
35252 IF(LNU.EQ.1) THEN
35253 IF (LTARG .EQ. 1) THEN
35254 K(5,2) = 2224
35255 ELSE
35256 K(5,2) = 2214
35257 ENDIF
35258 ELSE
35259 IF (LTARG .EQ. 1) THEN
35260 K(5,2) = 2114
35261 ELSE
35262 K(5,2) = 1114
35263 ENDIF
35264 ENDIF
35265 ELSE
35266 K(3,2) = 23 ! NC (Z0) interactions
35267 K(4,2) = K(1,2)
35268**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35269* Delta0 for neutron (LTARG=2)
35270C IF (LTARG .EQ. 1) THEN
35271C K(5,2) = 2114
35272C ELSE
35273C K(5,2) = 2214
35274C ENDIF
35275 IF (LTARG .EQ. 1) THEN
35276 K(5,2) = 2214
35277 ELSE
35278 K(5,2) = 2114
35279 ENDIF
35280**
35281 ENDIF
35282
35283C...4-momentum initial lepton
35284 P(1,5) = 0.
35285 P(1,4) = ENU
35286 P(1,1) = 0.
35287 P(1,2) = 0.
35288 P(1,3) = ENU
35289C...4-momentum initial nucleon
35290 P(2,5) = AMN(LTARG)
35291C P(2,4) = P(2,5)
35292C P(2,1) = 0.
35293C P(2,2) = 0.
35294C P(2,3) = 0.
35295 P(2,1) = P21
35296 P(2,2) = P22
35297 P(2,3) = P23
35298 P(2,4) = P24
35299 P(2,5) = P25
35300 N=2
35301 beta1=-p(2,1)/p(2,4)
35302 beta2=-p(2,2)/p(2,4)
35303 beta3=-p(2,3)/p(2,4)
35304 N=2
35305
35306 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35307
35308C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35309
35310 phi11=atan(p(1,2)/p(1,3))
35311 pi(1)=p(1,1)
35312 pi(2)=p(1,2)
35313 pi(3)=p(1,3)
35314
35315 CALL DT_TESTROT(PI,Po,PHI11,1)
35316 DO ll=1,3
35317 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35318 END DO
35319 p(1,1)=po(1)
35320 p(1,2)=po(2)
35321 p(1,3)=po(3)
35322 phi12=atan(p(1,1)/p(1,3))
35323
35324 pi(1)=p(1,1)
35325 pi(2)=p(1,2)
35326 pi(3)=p(1,3)
35327 CALL DT_TESTROT(Pi,Po,PHI12,2)
35328 DO ll=1,3
35329 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35330 END DO
35331 p(1,1)=po(1)
35332 p(1,2)=po(2)
35333 p(1,3)=po(3)
35334
35335 ENUU=P(1,4)
35336
35337C...Generate the Mass of the Delta
35338 NTRY = 0
35339100 R = PYR(0)
35340 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35341 NTRY = NTRY + 1
35342 IF (NTRY .GT. 1000) THEN
35343 LBAD = 1
35344 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35345 RETURN
35346 ENDIF
35347 IF (AMD .LT. AMDMIN) GOTO 100
35348 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35349 IF (ENUU .LT. ET) GOTO 100
35350
35351C...Kinematical limits in Q**2
35352 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35353 SQS = SQRT(S)
35354 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35355 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35356 PLF = SQRT(ELF**2 - AML2)
35357 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35358 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35359 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35360
35361 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35362200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35363 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35364 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35365
35366C...Generate the kinematics of the final particles
35367 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35368 GAM = EISTAR/AMN(LTARG)
35369 BET = PSTAR/EISTAR
35370 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35371 EL = GAM*(ELF + BET*PLF*CTSTAR)
35372 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35373 PL = SQRT(EL**2 - AML2)
35374 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35375 PHI = 6.28319*PYR(0)
35376 P(4,1) = PLT*COS(PHI)
35377 P(4,2) = PLT*SIN(PHI)
35378 P(4,3) = PLZ
35379 P(4,4) = EL
35380 P(4,5) = AML
35381
35382C...4-momentum of Delta
35383 P(5,1) = -P(4,1)
35384 P(5,2) = -P(4,2)
35385 P(5,3) = ENUU-P(4,3)
35386 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35387 P(5,5) = AMD
35388
35389C...4-momentum of intermediate boson
35390 P(3,5) = -Q2
35391 P(3,4) = P(1,4)-P(4,4)
35392 P(3,1) = P(1,1)-P(4,1)
35393 P(3,2) = P(1,2)-P(4,2)
35394 P(3,3) = P(1,3)-P(4,3)
35395 N=5
35396
35397 DO kw=1,5
35398 pi(1)=p(kw,1)
35399 pi(2)=p(kw,2)
35400 pi(3)=p(kw,3)
35401 CALL DT_TESTROT(Pi,Po,PHI12,3)
35402 DO ll=1,3
35403 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35404 END DO
35405 p(kw,1)=po(1)
35406 p(kw,2)=po(2)
35407 p(kw,3)=po(3)
35408 END DO
35409
35410c********************************************
35411
35412 DO kw=1,5
35413 pi(1)=p(kw,1)
35414 pi(2)=p(kw,2)
35415 pi(3)=p(kw,3)
35416 CALL DT_TESTROT(Pi,Po,PHI11,4)
35417 DO ll=1,3
35418 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35419 END DO
35420 p(kw,1)=po(1)
35421 p(kw,2)=po(2)
35422 p(kw,3)=po(3)
35423 END DO
35424c********************************************
35425C transform back into Lab.
35426
35427 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35428
35429C WRITE(6,*)' Lab fram ( fermi incl.) '
35430 N=5
35431 CALL PYEXEC
35432
35433 RETURN
354341001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35435 END
35436
35437*$ CREATE DT_DSIGMA_DELTA.FOR
35438*COPY DT_DSIGMA_DELTA
35439*
35440*===dsigma_delta=======================================================*
35441*
35442 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35443
35444 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35445 SAVE
35446
35447C...Reaction nu + N -> lepton + Delta
35448C. returns the cross section
35449C. dsigma/dt
35450C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35451C. QQ = t (always negative) GeV**2
35452C. S = (c.m energy)**2 GeV**2
35453C. OUTPUT = 10**-38 cm+2/GeV**2
35454C-----------------------------------------------------
35455 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35456 DATA MN /0.938/
35457 DATA PI /3.1415926/
35458
35459 GF = (1.1664 * 1.97)
35460 GF2 = GF*GF
35461 MN2 = MN*MN
35462 MN4 = MN2*MN2
35463 MD2 = MD*MD
35464 MD4 = MD2*MD2
35465 AML2 = AML*AML
35466 AML4 = AML2*AML2
35467 VQ = (MN2 - MD2 - QQ)/2.
35468 VPI = (MN2 + MD2 - QQ)/2.
35469 VK = (S + QQ - MN2 - AML2)/2.
35470 PIK = (S - MN2)/2.
35471 QK = (AML2 - QQ)/2.
35472 PIQ = (QQ + MN2 - MD2)/2.
35473 Q = SQRT(-QQ)
35474 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35475 C3 = SQRT(3.)*C3V/MN
35476 C4 = -C3/MD ! attenzione al segno
35477 C5A = 1.18/(1.-QQ/0.4225)**2
35478 C32 = C3**2
35479 C42 = C4**2
35480 C5A2 = C5A**2
35481
35482 IF (LNU .EQ. 1) THEN
35483 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35484 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35485 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35486 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35487 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35488 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35489 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35490 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35491 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35492 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35493 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35494 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35495 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35496 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35497 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35498 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35499 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35500 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35501 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35502 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35503 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35504 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35505 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35506 ELSE
35507 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35508 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35509 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35510 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35511 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35512 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35513 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35514 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35515 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35516 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35517 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35518 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35519 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35520 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35521 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35522 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35523 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35524 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35525 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35526 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35527 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35528 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35529 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35530 ENDIF
35531 ANS1=32.*ANS2
35532 ANS=ANS1/(3.*MD2)
35533 P1CM = (S-MN2)/(2.*SQRT(S))
35534 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35535
35536 RETURN
35537 END
35538
35539*$ CREATE DT_QGAUS.FOR
35540*COPY DT_QGAUS
35541*
35542*===qgaus==============================================================*
35543*
35544 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35545
35546 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35547 SAVE
35548
35549 DIMENSION X(5),W(5)
35550 DATA X/.1488743389D0,.4333953941D0,
35551 & .6794095682D0,.8650633666D0,.9739065285D0
35552 */
35553 DATA W/.2955242247D0,.2692667193D0,
35554 & .2190863625D0,.1494513491D0,.0666713443D0
35555 */
35556 XM=0.5D0*(B+A)
35557 XR=0.5D0*(B-A)
35558 SS=0
35559 DO 11 J=1,5
35560 DX=XR*X(J)
35561 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35562 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3556311 CONTINUE
35564 SS=XR*SS
35565
35566 RETURN
35567 END
35568*$ CREATE DT_DIQBRK.FOR
35569*COPY DT_DIQBRK
35570*
35571*===diqbrk=============================================================*
35572*
35573 SUBROUTINE DT_DIQBRK
35574
35575 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35576 SAVE
35577
35578* event history
35579
35580 PARAMETER (NMXHKK=200000)
35581
35582 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35583 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35584 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35585
35586* extended event history
35587 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35588 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35589 & IHIST(2,NMXHKK)
35590
35591* event flag
35592 COMMON /DTEVNO/ NEVENT,ICASCA
35593
35594C IF(DT_RNDM(VV).LE.0.5D0)THEN
35595C CALL GSQBS1(NHKK)
35596C CALL GSQBS2(NHKK)
35597C CALL USQBS1(NHKK)
35598C CALL USQBS2(NHKK)
35599C CALL GSABS1(NHKK)
35600C CALL GSABS2(NHKK)
35601C CALL USABS1(NHKK)
35602C CALL USABS2(NHKK)
35603C ELSE
35604C CALL GSQBS2(NHKK)
35605C CALL GSQBS1(NHKK)
35606C CALL USQBS2(NHKK)
35607C CALL USQBS1(NHKK)
35608C CALL GSABS2(NHKK)
35609C CALL GSABS1(NHKK)
35610C CALL USABS2(NHKK)
35611C CALL USABS1(NHKK)
35612C ENDIF
35613
35614 IF(DT_RNDM(VV).LE.0.5D0) THEN
35615 CALL DT_DBREAK(1)
35616 CALL DT_DBREAK(2)
35617 CALL DT_DBREAK(3)
35618 CALL DT_DBREAK(4)
35619 CALL DT_DBREAK(5)
35620 CALL DT_DBREAK(6)
35621 CALL DT_DBREAK(7)
35622 CALL DT_DBREAK(8)
35623 ELSE
35624 CALL DT_DBREAK(2)
35625 CALL DT_DBREAK(1)
35626 CALL DT_DBREAK(4)
35627 CALL DT_DBREAK(3)
35628 CALL DT_DBREAK(6)
35629 CALL DT_DBREAK(5)
35630 CALL DT_DBREAK(8)
35631 CALL DT_DBREAK(7)
35632 ENDIF
35633
35634 RETURN
35635 END
35636
35637*$ CREATE MUSQBS2.FOR
35638*COPY MUSQBS2
35639C
35640C
35641C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35642 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35643 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35644C
35645C USQBS-2 diagram (split target diquark)
35646C
35647 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35648 SAVE
35649
35650 PARAMETER ( LINP = 10 ,
35651 & LOUT = 6 ,
35652 & LDAT = 9 )
35653
35654* event history
35655
35656 PARAMETER (NMXHKK=200000)
35657
35658 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35659 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35660 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35661
35662* extended event history
35663 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35664 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35665 & IHIST(2,NMXHKK)
35666
35667* Lorentz-parameters of the current interaction
35668 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35669 & UMO,PPCM,EPROJ,PPROJ
35670
35671* diquark-breaking mechanism
35672 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35673
35674C
35675 PARAMETER (NTMHKK= 300)
35676 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35677 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35678 +(4,NTMHKK)
35679*KEEP,XSEADI.
35680 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35681 +SSMIMQ,VVMTHR
35682*KEEP,DPRIN.
35683 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35684 COMMON /EVFLAG/ NUMEV
35685C
35686C USQBS-2 diagram (split target diquark)
35687C
35688C
35689C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35690C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35691C
35692C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35693C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35694C
35695C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35696C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35697C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35698C
35699C
35700C Put new chains into COMMON /HKKTMP/
35701C
35702 IIGLU1=NC1T-NC1P-1
35703 IIGLU2=NC2T-NC2P-1
35704 IGCOUN=0
35705C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35706 CVQ=1.D0
35707 IREJ=0
35708 IF(IPIP.EQ.2)THEN
35709C IF(NUMEV.EQ.-324)THEN
35710C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35711C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35712C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35713C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35714 ENDIF
35715C
35716C
35717C
35718C determine x-values of NC1T diquark
35719 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35720 XVQP=PHKK(4,NC1P)*2.D0/UMO
35721C
35722C determine x-values of sea quark pair
35723C
35724 IPCO=1
35725 ICOU=0
35726 2234 CONTINUE
35727 ICOU=ICOU+1
35728 IF(ICOU.GE.500)THEN
35729 IREJ=1
35730 IF(ISQ.EQ.3)IREJ=3
35731 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35732 IPCO=0
35733 RETURN
35734 ENDIF
35735 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35736 * UMO, XDIQT,XVQP
35737 XSQ=0.D0
35738 XSAQ=0.D0
35739**NEW
35740C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35741 IF (IPIP.EQ.1) THEN
35742 XQMAX = XDIQT/2.0D0
35743 XAQMAX = 2.D0*XVQP/3.0D0
35744 ELSE
35745 XQMAX = 2.D0*XVQP/3.0D0
35746 XAQMAX = XDIQT/2.0D0
35747 ENDIF
35748 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35749 ISAQ = 6+ISQ
35750C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35751**
35752 IF(IPCO.GE.3)
35753 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35754 IF(IREJ.GE.1)THEN
35755 IF(IPCO.GE.3)
35756 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35757 IPCO=0
35758 RETURN
35759 ENDIF
35760 IF(IPIP.EQ.1)THEN
35761 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35762 ELSEIF(IPIP.EQ.2)THEN
35763 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35764 ENDIF
35765 IF(IPCO.GE.3)THEN
35766 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35767 & XDIQT,XVQP,XSQ,XSAQ
35768 ENDIF
35769C
35770C subtract xsq,xsaq from NC1T diquark and NC1P quark
35771C
35772C XSQ=0.D0
35773 IF(IPIP.EQ.1)THEN
35774 XDIQT=XDIQT-XSQ
35775 XVQP =XVQP -XSAQ
35776 ELSEIF(IPIP.EQ.2)THEN
35777 XDIQT=XDIQT-XSAQ
35778 XVQP =XVQP -XSQ
35779 ENDIF
35780 IF(IPCO.GE.3)
35781 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35782C
35783C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35784C
35785 XVTHRO=CVQ/UMO
35786 IVTHR=0
35787 3466 CONTINUE
35788 IF(IVTHR.EQ.10)THEN
35789 IREJ=1
35790 IF(ISQ.EQ.3)IREJ=3
35791 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35792 IPCO=0
35793 RETURN
35794 ENDIF
35795 IVTHR=IVTHR+1
35796 XVTHR=XVTHRO/(201-IVTHR)
35797 UNOPRV=UNON
35798 380 CONTINUE
35799 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35800 IREJ=1
35801 IF(ISQ.EQ.3)IREJ=3
35802 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35803 * XVTHR
35804 IPCO=0
35805 RETURN
35806 ENDIF
35807 IF(DT_RNDM(V).LT.0.5D0)THEN
35808 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35809 XVTQII=XDIQT-XVTQI
35810 ELSE
35811 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35812 XVTQI=XDIQT-XVTQII
35813 ENDIF
35814 IF(IPCO.GE.3)THEN
35815 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35816 ENDIF
35817C
35818C Prepare 4 momenta of new chains and chain ends
35819C
35820C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35821C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35822C +(4,NTMHKK)
35823C
35824C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35825C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35826C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35827C
35828C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35829C * IP1,IP21,IP22,IPP1,IPP2)
35830C
35831 IF(IPIP.EQ.1)THEN
35832 XSQ1=XSQ
35833 XSAQ1=XSAQ
35834 ISQ1=ISQ
35835 ISAQ1=ISAQ
35836 ELSEIF(IPIP.EQ.2)THEN
35837 XSQ1=XSAQ
35838 XSAQ1=XSQ
35839 ISQ1=ISAQ
35840 ISAQ1=ISQ
35841 ENDIF
35842 IDHKT(1) =IPP1
35843 ISTHKT(1) =951
35844 JMOHKT(1,1)=NC2P
35845 JMOHKT(2,1)=0
35846 JDAHKT(1,1)=3+IIGLU1
35847 JDAHKT(2,1)=0
35848C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35849 PHKT(1,1) =PHKK(1,NC2P)
35850 PHKT(2,1) =PHKK(2,NC2P)
35851 PHKT(3,1) =PHKK(3,NC2P)
35852 PHKT(4,1) =PHKK(4,NC2P)
35853C PHKT(5,1) =PHKK(5,NC2P)
35854 XMIST =(PHKT(4,1)**2-
35855 * PHKT(3,1)**2-PHKT(2,1)**2-
35856 *PHKT(1,1)**2)
35857 IF(XMIST.GT.0.D0)THEN
35858 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35859 *PHKT(1,1)**2)
35860 ELSE
35861C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35862 PHKT(5,1)=0.D0
35863 ENDIF
35864 VHKT(1,1) =VHKK(1,NC2P)
35865 VHKT(2,1) =VHKK(2,NC2P)
35866 VHKT(3,1) =VHKK(3,NC2P)
35867 VHKT(4,1) =VHKK(4,NC2P)
35868 WHKT(1,1) =WHKK(1,NC2P)
35869 WHKT(2,1) =WHKK(2,NC2P)
35870 WHKT(3,1) =WHKK(3,NC2P)
35871 WHKT(4,1) =WHKK(4,NC2P)
35872C Add here IIGLU1 gluons to this chaina
35873 PG1=0.D0
35874 PG2=0.D0
35875 PG3=0.D0
35876 PG4=0.D0
35877 IF(IIGLU1.GE.1)THEN
35878 JJG=NC1P
35879 DO 61 IIG=2,2+IIGLU1-1
35880 KKG=JJG+IIG-1
35881 IDHKT(IIG) =IDHKK(KKG)
35882 ISTHKT(IIG) =921
35883 JMOHKT(1,IIG)=KKG
35884 JMOHKT(2,IIG)=0
35885 JDAHKT(1,IIG)=3+IIGLU1
35886 JDAHKT(2,IIG)=0
35887 PHKT(1,IIG)=PHKK(1,KKG)
35888 PG1=PG1+ PHKT(1,IIG)
35889 PHKT(2,IIG)=PHKK(2,KKG)
35890 PG2=PG2+ PHKT(2,IIG)
35891 PHKT(3,IIG)=PHKK(3,KKG)
35892 PG3=PG3+ PHKT(3,IIG)
35893 PHKT(4,IIG)=PHKK(4,KKG)
35894 PG4=PG4+ PHKT(4,IIG)
35895 PHKT(5,IIG)=PHKK(5,KKG)
35896 VHKT(1,IIG) =VHKK(1,KKG)
35897 VHKT(2,IIG) =VHKK(2,KKG)
35898 VHKT(3,IIG) =VHKK(3,KKG)
35899 VHKT(4,IIG) =VHKK(4,KKG)
35900 WHKT(1,IIG) =WHKK(1,KKG)
35901 WHKT(2,IIG) =WHKK(2,KKG)
35902 WHKT(3,IIG) =WHKK(3,KKG)
35903 WHKT(4,IIG) =WHKK(4,KKG)
35904 61 CONTINUE
35905 ENDIF
35906 IDHKT(2+IIGLU1) =IP21
35907 ISTHKT(2+IIGLU1) =952
35908 JMOHKT(1,2+IIGLU1)=NC1T
35909 JMOHKT(2,2+IIGLU1)=0
35910 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35911 JDAHKT(2,2+IIGLU1)=0
35912 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35913 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35914 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35915 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35916C PHKT(5,2) =PHKK(5,NC1T)
35917 XMIST =(PHKT(4,2+IIGLU1)**2-
35918 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35919 *PHKT(1,2+IIGLU1)**2)
35920 IF(XMIST.GT.0.D0)THEN
35921 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35922 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35923 *PHKT(1,2+IIGLU1)**2)
35924 ELSE
35925C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35926 PHKT(5,5+IIGLU1)=0.D0
35927 ENDIF
35928 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35929 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35930 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35931 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35932 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35933 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35934 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35935 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35936 IDHKT(3+IIGLU1) =88888
35937 ISTHKT(3+IIGLU1) =95
35938 JMOHKT(1,3+IIGLU1)=1
35939 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35940 JDAHKT(1,3+IIGLU1)=0
35941 JDAHKT(2,3+IIGLU1)=0
35942 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35943 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35944 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35945 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35946 XMIST
35947 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35948 * -PHKT(3,3+IIGLU1)**2)
35949 IF(XMIST.GT.0.D0)THEN
35950 PHKT(5,3+IIGLU1)
35951 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35952 * -PHKT(3,3+IIGLU1)**2)
35953 ELSE
35954C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35955 PHKT(5,5+IIGLU1)=0.D0
35956 ENDIF
35957 IF(IPIP.GE.2)THEN
35958C IF(NUMEV.EQ.-324)THEN
35959C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35960C * JDAHKT(1,1),
35961C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35962 DO 71 IIG=2,2+IIGLU1-1
35963C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35964C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35965C * JDAHKT(1,IIG),
35966C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35967 71 CONTINUE
35968C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35969C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35970C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35971C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35972C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35973C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35974 ENDIF
35975 CHAMAL=CHAM1
35976 IF(IPIP.EQ.1)THEN
35977 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35978 ELSEIF(IPIP.EQ.2)THEN
35979 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35980 ENDIF
35981 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35982C IREJ=1
35983 IPCO=0
35984C RETURN
35985C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35986 GO TO 3466
35987 ENDIF
35988 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35989 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35990 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35991 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35992 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35993 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35994 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35995 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35996 IF(IPIP.EQ.1)THEN
35997 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35998 ELSEIF(IPIP.EQ.2)THEN
35999 IDHKT(4+IIGLU1) =ISAQ1
36000 ENDIF
36001 ISTHKT(4+IIGLU1) =951
36002 JMOHKT(1,4+IIGLU1)=NC1P
36003 JMOHKT(2,4+IIGLU1)=0
36004 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36005 JDAHKT(2,4+IIGLU1)=0
36006C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36007 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36008 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36009 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36010 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36011C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36012 XMIST =(PHKT(4,4+IIGLU1)**2-
36013 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36014 *PHKT(1,4+IIGLU1)**2)
36015 IF(XMIST.GT.0.D0)THEN
36016 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36017 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36018 *PHKT(1,4+IIGLU1)**2)
36019 ELSE
36020C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36021 PHKT(5,4+IIGLU1)=0.D0
36022 ENDIF
36023 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36024 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36025 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36026 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36027 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36028 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36029 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36030 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36031 IDHKT(5+IIGLU1) =IP22
36032 ISTHKT(5+IIGLU1) =952
36033 JMOHKT(1,5+IIGLU1)=NC1T
36034 JMOHKT(2,5+IIGLU1)=0
36035 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36036 JDAHKT(2,5+IIGLU1)=0
36037 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36038 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36039 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36040 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36041C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36042 XMIST =(PHKT(4,5+IIGLU1)**2-
36043 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36044 *PHKT(1,5+IIGLU1)**2)
36045 IF(XMIST.GT.0.D0)THEN
36046 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36047 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36048 *PHKT(1,5+IIGLU1)**2)
36049 ELSE
36050C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36051 PHKT(5,5+IIGLU1)=0.D0
36052 ENDIF
36053 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36054 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36055 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36056 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36057 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36058 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36059 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36060 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36061 IDHKT(6+IIGLU1) =88888
36062 ISTHKT(6+IIGLU1) =95
36063 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36064 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36065 JDAHKT(1,6+IIGLU1)=0
36066 JDAHKT(2,6+IIGLU1)=0
36067 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36068 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36069 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36070 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36071 XMIST
36072 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36073 * -PHKT(3,6+IIGLU1)**2)
36074 IF(XMIST.GT.0.D0)THEN
36075 PHKT(5,6+IIGLU1)
36076 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36077 * -PHKT(3,6+IIGLU1)**2)
36078 ELSE
36079C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36080 PHKT(5,5+IIGLU1)=0.D0
36081 ENDIF
36082C IF(IPIP.GE.2)THEN
36083C IF(NUMEV.EQ.-324)THEN
36084C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36085C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36086C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36087C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36088C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36089C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36090C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36091C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36092C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36093C ENDIF
36094 CHAMAL=CHAM1
36095 IF(IPIP.EQ.1)THEN
36096 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36097 ELSEIF(IPIP.EQ.2)THEN
36098 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36099 ENDIF
36100 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36101C IREJ=1
36102 IPCO=0
36103C RETURN
36104C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36105C * CHAMAL,PHKT(5,6+IIGLU1)
36106 GO TO 3466
36107 ENDIF
36108 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36109 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36110 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36111 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36112 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36113 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36114 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36115 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36116C IDHKT(7) =1000*IPP1+100*ISQ+1
36117 IDHKT(7+IIGLU1) =IP1
36118 ISTHKT(7+IIGLU1) =951
36119 JMOHKT(1,7+IIGLU1)=NC1P
36120 JMOHKT(2,7+IIGLU1)=0
36121**NEW
36122C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36123 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36124**
36125 JDAHKT(2,7+IIGLU1)=0
36126 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36127 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36128 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36129 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36130C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36131 XMIST =(PHKT(4,7+IIGLU1)**2-
36132 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36133 *PHKT(1,7+IIGLU1)**2)
36134 IF(XMIST.GT.0.D0)THEN
36135 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36136 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36137 *PHKT(1,7+IIGLU1)**2)
36138 ELSE
36139C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36140 PHKT(5,7+IIGLU1)=0.D0
36141 ENDIF
36142 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36143 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36144 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36145 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36146 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36147 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36148 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36149 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36150C Insert here the IIGLU2 gluons
36151 PG1=0.D0
36152 PG2=0.D0
36153 PG3=0.D0
36154 PG4=0.D0
36155 IF(IIGLU2.GE.1)THEN
36156 JJG=NC2P
36157 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36158 KKG=JJG+IIG-7-IIGLU1
36159 IDHKT(IIG) =IDHKK(KKG)
36160 ISTHKT(IIG) =921
36161 JMOHKT(1,IIG)=KKG
36162 JMOHKT(2,IIG)=0
36163 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36164 JDAHKT(2,IIG)=0
36165 PHKT(1,IIG)=PHKK(1,KKG)
36166 PG1=PG1+ PHKT(1,IIG)
36167 PHKT(2,IIG)=PHKK(2,KKG)
36168 PG2=PG2+ PHKT(2,IIG)
36169 PHKT(3,IIG)=PHKK(3,KKG)
36170 PG3=PG3+ PHKT(3,IIG)
36171 PHKT(4,IIG)=PHKK(4,KKG)
36172 PG4=PG4+ PHKT(4,IIG)
36173 PHKT(5,IIG)=PHKK(5,KKG)
36174 VHKT(1,IIG) =VHKK(1,KKG)
36175 VHKT(2,IIG) =VHKK(2,KKG)
36176 VHKT(3,IIG) =VHKK(3,KKG)
36177 VHKT(4,IIG) =VHKK(4,KKG)
36178 WHKT(1,IIG) =WHKK(1,KKG)
36179 WHKT(2,IIG) =WHKK(2,KKG)
36180 WHKT(3,IIG) =WHKK(3,KKG)
36181 WHKT(4,IIG) =WHKK(4,KKG)
36182 81 CONTINUE
36183 ENDIF
36184 IF(IPIP.EQ.1)THEN
36185 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36186 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36187 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36188 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36189 ELSEIF(IPIP.EQ.2)THEN
36190 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36191 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36192 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36193 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36194 ENDIF
36195 ISTHKT(8+IIGLU1+IIGLU2) =952
36196 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36197 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36198 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36199 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36200 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36201 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36202 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36203 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36204 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36205 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36206 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36207 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36208C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36209C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36210 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36211C IREJ=1
36212C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36213C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36214 IPCO=0
36215C RETURN
36216 GO TO 3466
36217 ENDIF
36218C PHKT(5,8) =PHKK(5,NC2T)
36219 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36220 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36221 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36222 IF(XMIST.GT.0.D0)THEN
36223 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36224 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36225 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36226 ELSE
36227C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36228 PHKT(5,5+IIGLU1)=0.D0
36229 ENDIF
36230 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36231 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36232 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36233 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36234 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36235 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36236 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36237 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36238 IDHKT(9+IIGLU1+IIGLU2) =88888
36239 ISTHKT(9+IIGLU1+IIGLU2) =95
36240 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36241 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36242 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36243 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36244**NEW
36245C PHKT(1,9+IIGLU1+IIGLU2)
36246C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36247C PHKT(2,9+IIGLU1+IIGLU2)
36248C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36249C PHKT(3,9+IIGLU1+IIGLU2)
36250C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36251C PHKT(4,9+IIGLU1+IIGLU2)
36252C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36253 PHKT(1,9+IIGLU1+IIGLU2)
36254 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36255 PHKT(2,9+IIGLU1+IIGLU2)
36256 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36257 PHKT(3,9+IIGLU1+IIGLU2)
36258 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36259 PHKT(4,9+IIGLU1+IIGLU2)
36260 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36261**
36262 XMIST
36263 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36264 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36265 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36266 IF(XMIST.GT.0.D0)THEN
36267 PHKT(5,9+IIGLU1+IIGLU2)
36268 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36269 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36270 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36271 ELSE
36272C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36273 PHKT(5,5+IIGLU1)=0.D0
36274 ENDIF
36275 IF(IPIP.GE.2)THEN
36276C IF(NUMEV.EQ.-324)THEN
36277C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36278C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36279C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36280C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36281C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36282C * JDAHKT(1,IIG),
36283C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36284C 91 CONTINUE
36285C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36286C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36287C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36288C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36289C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36290C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36291C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36292C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36293 ENDIF
36294 CHAMAL=CHAB1
36295 IF(IPIP.EQ.1)THEN
36296 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36297 ELSEIF(IPIP.EQ.2)THEN
36298 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36299 ENDIF
36300 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36301C IREJ=1
36302 IPCO=0
36303C RETURN
36304C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36305C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36306 GO TO 3466
36307 ENDIF
36308 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36309 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36310 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36311 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36312 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36313 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36314 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36315 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36316C
36317 IPCO=0
36318 IGCOUN=9+IIGLU1+IIGLU2
36319 RETURN
36320 END
36321
36322*$ CREATE MGSQBS2.FOR
36323*COPY MGSQBS2
36324C
36325C
36326C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36327 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36328 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36329C
36330C GSQBS-2 diagram (split target diquark)
36331C
36332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36333 SAVE
36334
36335 PARAMETER ( LINP = 10 ,
36336 & LOUT = 6 ,
36337 & LDAT = 9 )
36338
36339* event history
36340
36341 PARAMETER (NMXHKK=200000)
36342
36343 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36344 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36345 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36346
36347* extended event history
36348 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36349 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36350 & IHIST(2,NMXHKK)
36351
36352* Lorentz-parameters of the current interaction
36353 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36354 & UMO,PPCM,EPROJ,PPROJ
36355
36356* diquark-breaking mechanism
36357 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36358
36359C
36360 PARAMETER (NTMHKK= 300)
36361 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36362 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36363 +(4,NTMHKK)
36364
36365*KEEP,XSEADI.
36366 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36367 +SSMIMQ,VVMTHR
36368*KEEP,DPRIN.
36369 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36370C
36371C GSQBS-2 diagram (split target diquark)
36372C
36373C
36374C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36375C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36376C
36377C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36378C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36379C
36380C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36381C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36382C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36383C
36384C
36385C
36386C Put new chains into COMMON /HKKTMP/
36387C
36388 IIGLU1=NC1T-NC1P-1
36389 IIGLU2=NC2T-NC2P-1
36390 IGCOUN=0
36391C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36392 CVQ=1.D0
36393 IREJ=0
36394C IF(IPIP.EQ.2)THEN
36395C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36396C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36397C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36398C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36399C ENDIF
36400C
36401C
36402C
36403C determine x-values of NC1T diquark
36404 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36405 XVQP=PHKK(4,NC1P)*2.D0/UMO
36406C
36407C determine x-values of sea quark pair
36408C
36409 IPCO=1
36410 ICOU=0
36411 2234 CONTINUE
36412 ICOU=ICOU+1
36413 IF(ICOU.GE.500)THEN
36414 IREJ=1
36415 IF(ISQ.EQ.3)IREJ=3
36416 IF(IPCO.GE.3)
36417 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36418 IPCO=0
36419 RETURN
36420 ENDIF
36421 IF(IPCO.GE.3)
36422 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36423 * UMO, XDIQT,XVQP
36424 XSQ=0.D0
36425 XSAQ=0.D0
36426**NEW
36427C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36428 IF (IPIP.EQ.1) THEN
36429 XQMAX = XDIQT/2.0D0
36430 XAQMAX = 2.D0*XVQP/3.0D0
36431 ELSE
36432 XQMAX = 2.D0*XVQP/3.0D0
36433 XAQMAX = XDIQT/2.0D0
36434 ENDIF
36435 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36436 ISAQ = 6+ISQ
36437C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36438**
36439 IF(IPCO.GE.3)
36440 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36441 IF(IREJ.GE.1)THEN
36442 IF(IPCO.GE.3)
36443 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36444 IPCO=0
36445 RETURN
36446 ENDIF
36447 IF(IPIP.EQ.1)THEN
36448 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36449 ELSEIF(IPIP.EQ.2)THEN
36450 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36451 ENDIF
36452 IF(IPCO.GE.3)THEN
36453 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36454 & XDIQT,XVQP,XSQ,XSAQ
36455 ENDIF
36456C
36457C subtract xsq,xsaq from NC1T diquark and NC1P quark
36458C
36459C XSQ=0.D0
36460 IF(IPIP.EQ.1)THEN
36461 XDIQT=XDIQT-XSQ
36462 XVQP =XVQP -XSAQ
36463 ELSEIF(IPIP.EQ.2)THEN
36464 XDIQT=XDIQT-XSAQ
36465 XVQP =XVQP -XSQ
36466 ENDIF
36467 IF(IPCO.GE.3)
36468 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36469C
36470C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36471C
36472 XVTHRO=CVQ/UMO
36473 IVTHR=0
36474 3466 CONTINUE
36475 IF(IVTHR.EQ.10)THEN
36476 IREJ=1
36477 IF(ISQ.EQ.3)IREJ=3
36478 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36479 IPCO=0
36480 RETURN
36481 ENDIF
36482 IVTHR=IVTHR+1
36483 XVTHR=XVTHRO/(201-IVTHR)
36484 UNOPRV=UNON
36485 380 CONTINUE
36486 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36487 IREJ=1
36488 IF(ISQ.EQ.3)IREJ=3
36489 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36490 * XVTHR
36491 IPCO=0
36492 RETURN
36493 ENDIF
36494 IF(DT_RNDM(V).LT.0.5D0)THEN
36495 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36496 XVTQII=XDIQT-XVTQI
36497 ELSE
36498 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36499 XVTQI=XDIQT-XVTQII
36500 ENDIF
36501 IF(IPCO.GE.3)THEN
36502 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36503 ENDIF
36504C
36505C Prepare 4 momenta of new chains and chain ends
36506C
36507C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36508C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36509C +(4,NTMHKK)
36510C
36511C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36512C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36513C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36514C
36515C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36516C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36517C
36518 IF(IPIP.EQ.1)THEN
36519 XSQ1=XSQ
36520 XSAQ1=XSAQ
36521 ISQ1=ISQ
36522 ISAQ1=ISAQ
36523 ELSEIF(IPIP.EQ.2)THEN
36524 XSQ1=XSAQ
36525 XSAQ1=XSQ
36526 ISQ1=ISAQ
36527 ISAQ1=ISQ
36528 ENDIF
36529 KK11=IP21
36530C IDHKT(1) =1000*IPP11+100*IPP12+1
36531 KK21=IPP11
36532 KK22=IPP12
36533 XGIVE=0.D0
36534 IF(IPIP.EQ.1)THEN
36535 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36536 ELSEIF(IPIP.EQ.2)THEN
36537 IDHKT(4+IIGLU1) =ISAQ1
36538 ENDIF
36539 ISTHKT(4+IIGLU1) =961
36540 JMOHKT(1,4+IIGLU1)=NC1P
36541 JMOHKT(2,4+IIGLU1)=0
36542 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36543 JDAHKT(2,4+IIGLU1)=0
36544C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36545 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36546 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36547 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36548 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36549C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36550 XXMIST=(PHKT(4,4+IIGLU1)**2-
36551 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36552 *PHKT(1,4+IIGLU1)**2)
36553 IF(XXMIST.GT.0.D0)THEN
36554 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36555 ELSE
36556 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36557 XXMIST=ABS(XXMIST)
36558 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36559 ENDIF
36560 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36561 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36562 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36563 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36564 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36565 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36566 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36567 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36568 IDHKT(5+IIGLU1) =IP22
36569 ISTHKT(5+IIGLU1) =962
36570 JMOHKT(1,5+IIGLU1)=NC1T
36571 JMOHKT(2,5+IIGLU1)=0
36572 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36573 JDAHKT(2,5+IIGLU1)=0
36574 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36575 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36576 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36577 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36578C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36579 XXMIST=(PHKT(4,5+IIGLU1)**2-
36580 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36581 *PHKT(1,5+IIGLU1)**2)
36582 IF(XXMIST.GT.0.D0)THEN
36583 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36584 ELSE
36585 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36586 XXMIST=ABS(XXMIST)
36587 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36588 ENDIF
36589 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36590 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36591 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36592 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36593 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36594 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36595 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36596 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36597 IDHKT(6+IIGLU1) =88888
36598 ISTHKT(6+IIGLU1) =96
36599 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36600 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36601 JDAHKT(1,6+IIGLU1)=0
36602 JDAHKT(2,6+IIGLU1)=0
36603 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36604 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36605 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36606 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36607 PHKT(5,6+IIGLU1)
36608 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36609 * -PHKT(3,6+IIGLU1)**2)
36610 CHAMAL=CHAM1
36611 IF(IPIP.EQ.1)THEN
36612 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36613 ELSEIF(IPIP.EQ.2)THEN
36614 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36615 ENDIF
36616C---------------------------------------------------
36617 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36618 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36619C we drop chain 6 and give the energy to chain 3
36620 IDHKT(6+IIGLU1)=22888
36621 XGIVE=1.D0
36622C WRITE(6,*)' drop chain 6 xgive=1'
36623 GO TO 7788
36624 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36625C we drop chain 6 and give the energy to chain 3
36626C and change KK11 to IDHKT(5)
36627 IDHKT(6+IIGLU1)=22888
36628 XGIVE=1.D0
36629C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36630 KK11=IDHKT(5+IIGLU1)
36631 GO TO 7788
36632 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36633C we drop chain 6 and give the energy to chain 3
36634C and change KK21 to IDHKT(5+IIGLU1)
36635C IDHKT(1) =1000*IPP11+100*IPP12+1
36636 IDHKT(6+IIGLU1)=22888
36637 XGIVE=1.D0
36638C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36639 KK21=IDHKT(5+IIGLU1)
36640 GO TO 7788
36641 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36642C we drop chain 6 and give the energy to chain 3
36643C and change KK22 to IDHKT(5)
36644C IDHKT(1) =1000*IPP11+100*IPP12+1
36645 IDHKT(6+IIGLU1)=22888
36646 XGIVE=1.D0
36647C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36648 KK22=IDHKT(5+IIGLU1)
36649 GO TO 7788
36650 ENDIF
36651C IREJ=1
36652 IPCO=0
36653C RETURN
36654 GO TO 3466
36655 ENDIF
36656 7788 CONTINUE
36657C---------------------------------------------------
36658 IF(IPIP.GE.3)THEN
36659 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36660 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36661 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36662 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36663 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36664 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36665 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36666 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36667 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36668 ENDIF
36669 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36670 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36671 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36672 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36673 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36674 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36675 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36676 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36677C IDHKT(1) =1000*IPP11+100*IPP12+1
36678 IF(IPIP.EQ.1)THEN
36679 IDHKT(1) =1000*KK21+100*KK22+3
36680 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36681 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36682 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36683 ELSEIF(IPIP.EQ.2)THEN
36684 IDHKT(1) =1000*KK21+100*KK22-3
36685 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36686 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36687 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36688 ENDIF
36689 ISTHKT(1) =961
36690 JMOHKT(1,1)=NC2P
36691 JMOHKT(2,1)=0
36692 JDAHKT(1,1)=3+IIGLU1
36693 JDAHKT(2,1)=0
36694C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36695 PHKT(1,1) =PHKK(1,NC2P)
36696 *+XGIVE*PHKT(1,4+IIGLU1)
36697 PHKT(2,1) =PHKK(2,NC2P)
36698 *+XGIVE*PHKT(2,4+IIGLU1)
36699 PHKT(3,1) =PHKK(3,NC2P)
36700 *+XGIVE*PHKT(3,4+IIGLU1)
36701 PHKT(4,1) =PHKK(4,NC2P)
36702 *+XGIVE*PHKT(4,4+IIGLU1)
36703C PHKT(5,1) =PHKK(5,NC2P)
36704 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36705 *PHKT(1,1)**2
36706 IF(XXMIST.GT.0.D0)THEN
36707 PHKT(5,1) =SQRT(XXMIST)
36708 ELSE
36709 WRITE(LOUT,*)'MGSQBS2',XXMIST
36710 XXMIST=ABS(XXMIST)
36711 PHKT(5,1) =SQRT(XXMIST)
36712 ENDIF
36713 VHKT(1,1) =VHKK(1,NC2P)
36714 VHKT(2,1) =VHKK(2,NC2P)
36715 VHKT(3,1) =VHKK(3,NC2P)
36716 VHKT(4,1) =VHKK(4,NC2P)
36717 WHKT(1,1) =WHKK(1,NC2P)
36718 WHKT(2,1) =WHKK(2,NC2P)
36719 WHKT(3,1) =WHKK(3,NC2P)
36720 WHKT(4,1) =WHKK(4,NC2P)
36721C Add here IIGLU1 gluons to this chaina
36722 PG1=0.D0
36723 PG2=0.D0
36724 PG3=0.D0
36725 PG4=0.D0
36726 IF(IIGLU1.GE.1)THEN
36727 JJG=NC1P
36728 DO 61 IIG=2,2+IIGLU1-1
36729 KKG=JJG+IIG-1
36730 IDHKT(IIG) =IDHKK(KKG)
36731 ISTHKT(IIG) =921
36732 JMOHKT(1,IIG)=KKG
36733 JMOHKT(2,IIG)=0
36734 JDAHKT(1,IIG)=3+IIGLU1
36735 JDAHKT(2,IIG)=0
36736 PHKT(1,IIG)=PHKK(1,KKG)
36737 PG1=PG1+ PHKT(1,IIG)
36738 PHKT(2,IIG)=PHKK(2,KKG)
36739 PG2=PG2+ PHKT(2,IIG)
36740 PHKT(3,IIG)=PHKK(3,KKG)
36741 PG3=PG3+ PHKT(3,IIG)
36742 PHKT(4,IIG)=PHKK(4,KKG)
36743 PG4=PG4+ PHKT(4,IIG)
36744 PHKT(5,IIG)=PHKK(5,KKG)
36745 VHKT(1,IIG) =VHKK(1,KKG)
36746 VHKT(2,IIG) =VHKK(2,KKG)
36747 VHKT(3,IIG) =VHKK(3,KKG)
36748 VHKT(4,IIG) =VHKK(4,KKG)
36749 WHKT(1,IIG) =WHKK(1,KKG)
36750 WHKT(2,IIG) =WHKK(2,KKG)
36751 WHKT(3,IIG) =WHKK(3,KKG)
36752 WHKT(4,IIG) =WHKK(4,KKG)
36753 61 CONTINUE
36754 ENDIF
36755C IDHKT(2) =IP21
36756 IDHKT(2+IIGLU1) =KK11
36757 ISTHKT(2+IIGLU1) =962
36758 JMOHKT(1,2+IIGLU1)=NC1T
36759 JMOHKT(2,2+IIGLU1)=0
36760 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36761 JDAHKT(2,2+IIGLU1)=0
36762 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36763C * +0.5D0*PHKK(1,NC2T)
36764 *+XGIVE*PHKT(1,5+IIGLU1)
36765 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36766C *+0.5D0*PHKK(2,NC2T)
36767 *+XGIVE*PHKT(2,5+IIGLU1)
36768 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36769C *+0.5D0*PHKK(3,NC2T)
36770 *+XGIVE*PHKT(3,5+IIGLU1)
36771 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36772C *+0.5D0*PHKK(4,NC2T)
36773 *+XGIVE*PHKT(4,5+IIGLU1)
36774C PHKT(5,2) =PHKK(5,NC1T)
36775 XXMIST=(PHKT(4,2+IIGLU1)**2-
36776 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36777 *PHKT(1,2+IIGLU1)**2)
36778 IF(XXMIST.GT.0.D0)THEN
36779 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36780 ELSE
36781 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36782 XXMIST=ABS(XXMIST)
36783 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36784 ENDIF
36785 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36786 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36787 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36788 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36789 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36790 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36791 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36792 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36793 IDHKT(3+IIGLU1) =88888
36794 ISTHKT(3+IIGLU1) =96
36795 JMOHKT(1,3+IIGLU1)=1
36796 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36797 JDAHKT(1,3+IIGLU1)=0
36798 JDAHKT(2,3+IIGLU1)=0
36799 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36800 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36801 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36802 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36803 PHKT(5,3+IIGLU1)
36804 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36805 * -PHKT(3,3+IIGLU1)**2)
36806 IF(IPIP.EQ.3)THEN
36807 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36808 * JDAHKT(1,1),
36809 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36810 DO 71 IIG=2,2+IIGLU1-1
36811 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36812 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36813 * JDAHKT(1,IIG),
36814 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36815 71 CONTINUE
36816 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36817 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36818 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36819 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36820 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36821 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36822 ENDIF
36823 CHAMAL=CHAB1
36824 IF(IPIP.EQ.1)THEN
36825 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36826 ELSEIF(IPIP.EQ.2)THEN
36827 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36828 ENDIF
36829 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36830C IREJ=1
36831 IPCO=0
36832C RETURN
36833 GO TO 3466
36834 ENDIF
36835 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36836 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36837 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36838 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36839 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36840 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36841 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36842 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36843C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36844 IDHKT(7+IIGLU1) =IP1
36845 ISTHKT(7+IIGLU1) =961
36846 JMOHKT(1,7+IIGLU1)=NC1P
36847 JMOHKT(2,7+IIGLU1)=0
36848 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36849 JDAHKT(2,7+IIGLU1)=0
36850 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36851 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36852 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36853 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36854C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36855 XXMIST=(PHKT(4,7+IIGLU1)**2-
36856 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36857 *PHKT(1,7+IIGLU1)**2)
36858 IF(XXMIST.GT.0.D0)THEN
36859 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36860 ELSE
36861 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36862 XXMIST=ABS(XXMIST)
36863 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36864 ENDIF
36865 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36866 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36867 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36868 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36869 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36870 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36871 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36872 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36873C IDHKT(7) =1000*IPP1+100*ISQ+1
36874C Insert here the IIGLU2 gluons
36875 PG1=0.D0
36876 PG2=0.D0
36877 PG3=0.D0
36878 PG4=0.D0
36879 IF(IIGLU2.GE.1)THEN
36880 JJG=NC2P
36881 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36882 KKG=JJG+IIG-7-IIGLU1
36883 IDHKT(IIG) =IDHKK(KKG)
36884 ISTHKT(IIG) =921
36885 JMOHKT(1,IIG)=KKG
36886 JMOHKT(2,IIG)=0
36887 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36888 JDAHKT(2,IIG)=0
36889 PHKT(1,IIG)=PHKK(1,KKG)
36890 PG1=PG1+ PHKT(1,IIG)
36891 PHKT(2,IIG)=PHKK(2,KKG)
36892 PG2=PG2+ PHKT(2,IIG)
36893 PHKT(3,IIG)=PHKK(3,KKG)
36894 PG3=PG3+ PHKT(3,IIG)
36895 PHKT(4,IIG)=PHKK(4,KKG)
36896 PG4=PG4+ PHKT(4,IIG)
36897 PHKT(5,IIG)=PHKK(5,KKG)
36898 VHKT(1,IIG) =VHKK(1,KKG)
36899 VHKT(2,IIG) =VHKK(2,KKG)
36900 VHKT(3,IIG) =VHKK(3,KKG)
36901 VHKT(4,IIG) =VHKK(4,KKG)
36902 WHKT(1,IIG) =WHKK(1,KKG)
36903 WHKT(2,IIG) =WHKK(2,KKG)
36904 WHKT(3,IIG) =WHKK(3,KKG)
36905 WHKT(4,IIG) =WHKK(4,KKG)
36906 81 CONTINUE
36907 ENDIF
36908 IF(IPIP.EQ.1)THEN
36909 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36910 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36911 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36912 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36913 ELSEIF(IPIP.EQ.2)THEN
36914**NEW
36915C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36916 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36917**
36918 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36919 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36920 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36921 ENDIF
36922 ISTHKT(8+IIGLU1+IIGLU2) =962
36923 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36924 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36925 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36926 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36927C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36928C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36929C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36930C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36931 PHKT(1,8+IIGLU1+IIGLU2) =
36932 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36933 PHKT(2,8+IIGLU1+IIGLU2) =
36934 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36935 PHKT(3,8+IIGLU1+IIGLU2) =
36936 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36937 PHKT(4,8+IIGLU1+IIGLU2) =
36938 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36939C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36940C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36941 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36942C IREJ=1
36943C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36944 IPCO=0
36945C RETURN
36946 GO TO 3466
36947 ENDIF
36948C PHKT(5,8) =PHKK(5,NC2T)
36949 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36950 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36951 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36952 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36953 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36954 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36955 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36956 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36957 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36958 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36959 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36960 IDHKT(9+IIGLU1+IIGLU2) =88888
36961 ISTHKT(9+IIGLU1+IIGLU2) =96
36962 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36963 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36964 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36965 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36966 PHKT(1,9+IIGLU1+IIGLU2)
36967 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36968 PHKT(2,9+IIGLU1+IIGLU2)
36969 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36970 PHKT(3,9+IIGLU1+IIGLU2)
36971 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36972 PHKT(4,9+IIGLU1+IIGLU2)
36973 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36974 PHKT(5,9+IIGLU1+IIGLU2)
36975 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36976 * PHKT(2,9+IIGLU1+IIGLU2)**2
36977 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36978 IF(IPIP.GE.3)THEN
36979 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36980 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36981 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36982 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36983 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36984 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36985 * JDAHKT(1,IIG),
36986 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36987 91 CONTINUE
36988 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36989 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36990 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36991 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36992 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36993 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36994 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36995 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36996 ENDIF
36997 CHAMAL=CHAB1
36998 IF(IPIP.EQ.1)THEN
36999 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37000 ELSEIF(IPIP.EQ.2)THEN
37001 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37002 ENDIF
37003 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37004C IREJ=1
37005 IPCO=0
37006C RETURN
37007 GO TO 3466
37008 ENDIF
37009 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37010 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37011 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37012 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37013 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37014 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37015 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37016 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37017C
37018 IPCO=0
37019 IGCOUN=9+IIGLU1+IIGLU2
37020 RETURN
37021 END
37022
37023*$ CREATE MUSQBS1.FOR
37024*COPY MUSQBS1
37025C
37026C
37027C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37028 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37029 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37030C
37031C USQBS-1 diagram (split projectile diquark)
37032C
37033 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37034 SAVE
37035
37036 PARAMETER ( LINP = 10 ,
37037 & LOUT = 6 ,
37038 & LDAT = 9 )
37039
37040* event history
37041
37042 PARAMETER (NMXHKK=200000)
37043
37044 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37045 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37046 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37047
37048* extended event history
37049 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37050 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37051 & IHIST(2,NMXHKK)
37052
37053* Lorentz-parameters of the current interaction
37054 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37055 & UMO,PPCM,EPROJ,PPROJ
37056
37057* diquark-breaking mechanism
37058 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37059
37060C
37061 PARAMETER (NTMHKK= 300)
37062 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37063 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37064 +(4,NTMHKK)
37065*KEEP,XSEADI.
37066 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37067 +SSMIMQ,VVMTHR
37068*KEEP,DPRIN.
37069 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37070 COMMON /EVFLAG/ NUMEV
37071C
37072C USQBS-1 diagram (split projectile diquark)
37073C
37074C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37075C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37076C
37077C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37078C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37079C
37080C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37081C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37082C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37083C
37084C Put new chains into COMMON /HKKTMP/
37085C
37086 IIGLU1=NC1T-NC1P-1
37087 IIGLU2=NC2T-NC2P-1
37088 IGCOUN=0
37089C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37090 CVQ=1.D0
37091 IREJ=0
37092 IF(IPIP.EQ.3)THEN
37093C IF(NUMEV.EQ.-324)THEN
37094 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37095 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37096 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37097 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37098 ENDIF
37099C
37100C
37101C
37102C determine x-values of NC1P diquark
37103 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37104 XVQT=PHKK(4,NC1T)*2.D0/UMO
37105C
37106C determine x-values of sea quark pair
37107C
37108 IPCO=1
37109 ICOU=0
37110 2234 CONTINUE
37111 ICOU=ICOU+1
37112 IF(ICOU.GE.500)THEN
37113 IREJ=1
37114 IF(ISQ.EQ.3)IREJ=3
37115 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37116 IPCO=0
37117 RETURN
37118 ENDIF
37119 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37120 * UMO, XDIQP,XVQT
37121 XSQ=0.D0
37122 XSAQ=0.D0
37123**NEW
37124C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37125 IF (IPIP.EQ.1) THEN
37126 XQMAX = XDIQP/2.0D0
37127 XAQMAX = 2.D0*XVQT/3.0D0
37128 ELSE
37129 XQMAX = 2.D0*XVQT/3.0D0
37130 XAQMAX = XDIQP/2.0D0
37131 ENDIF
37132 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37133 ISAQ = 6+ISQ
37134C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37135**
37136 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37137 IF(IREJ.GE.1)THEN
37138 IF(IPCO.GE.3)
37139 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37140 IPCO=0
37141 RETURN
37142 ENDIF
37143 IF(IPIP.EQ.1)THEN
37144 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37145 ELSEIF(IPIP.EQ.2)THEN
37146 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37147 ENDIF
37148 IF(IPCO.GE.3)THEN
37149 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37150 & XDIQP,XVQT,XSQ,XSAQ
37151 ENDIF
37152C
37153C subtract xsq,xsaq from NC1P diquark and NC1T quark
37154C
37155C XSQ=0.D0
37156 IF(IPIP.EQ.1)THEN
37157 XDIQP=XDIQP-XSQ
37158 XVQT =XVQT -XSAQ
37159 ELSEIF(IPIP.EQ.2)THEN
37160 XDIQP=XDIQP-XSAQ
37161 XVQT =XVQT -XSQ
37162 ENDIF
37163 IF(IPCO.GE.3)
37164 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37165C
37166C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37167C
37168 XVTHRO=CVQ/UMO
37169 IVTHR=0
37170 3466 CONTINUE
37171 IF(IVTHR.EQ.10)THEN
37172 IREJ=1
37173 IF(ISQ.EQ.3)IREJ=3
37174 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37175 IPCO=0
37176 RETURN
37177 ENDIF
37178 IVTHR=IVTHR+1
37179 XVTHR=XVTHRO/(201-IVTHR)
37180 UNOPRV=UNON
37181 380 CONTINUE
37182 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37183 IREJ=1
37184 IF(ISQ.EQ.3)IREJ=3
37185 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37186 * XVTHR
37187 IPCO=0
37188 RETURN
37189 ENDIF
37190 IF(DT_RNDM(V).LT.0.5D0)THEN
37191 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37192 XVPQII=XDIQP-XVPQI
37193 ELSE
37194 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37195 XVPQI=XDIQP-XVPQII
37196 ENDIF
37197 IF(IPCO.GE.3)THEN
37198 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37199 ENDIF
37200C
37201C Prepare 4 momenta of new chains and chain ends
37202C
37203C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37204C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37205C +(4,NTMHKK)
37206C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37207C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37208C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37209 IF(IPIP.EQ.1)THEN
37210 XSQ1=XSQ
37211 XSAQ1=XSAQ
37212 ISQ1=ISQ
37213 ISAQ1=ISAQ
37214 ELSEIF(IPIP.EQ.2)THEN
37215 XSQ1=XSAQ
37216 XSAQ1=XSQ
37217 ISQ1=ISAQ
37218 ISAQ1=ISQ
37219 ENDIF
37220 IDHKT(1) =IP11
37221 ISTHKT(1) =931
37222 JMOHKT(1,1)=NC1P
37223 JMOHKT(2,1)=0
37224 JDAHKT(1,1)=3+IIGLU1
37225 JDAHKT(2,1)=0
37226C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37227 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37228 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37229 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37230 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37231C PHKT(5,1) =PHKK(5,NC1P)
37232 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37233 *PHKT(1,1)**2)
37234 IF(XMIST.GE.0.D0)THEN
37235 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37236 *PHKT(1,1)**2)
37237 ELSE
37238C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37239 PHKT(5,1)=0.D0
37240 ENDIF
37241 VHKT(1,1) =VHKK(1,NC1P)
37242 VHKT(2,1) =VHKK(2,NC1P)
37243 VHKT(3,1) =VHKK(3,NC1P)
37244 VHKT(4,1) =VHKK(4,NC1P)
37245 WHKT(1,1) =WHKK(1,NC1P)
37246 WHKT(2,1) =WHKK(2,NC1P)
37247 WHKT(3,1) =WHKK(3,NC1P)
37248 WHKT(4,1) =WHKK(4,NC1P)
37249C Add here IIGLU1 gluons to this chaina
37250 PG1=0.D0
37251 PG2=0.D0
37252 PG3=0.D0
37253 PG4=0.D0
37254 IF(IIGLU1.GE.1)THEN
37255 JJG=NC1P
37256 DO 61 IIG=2,2+IIGLU1-1
37257 KKG=JJG+IIG-1
37258 IDHKT(IIG) =IDHKK(KKG)
37259 ISTHKT(IIG) =921
37260 JMOHKT(1,IIG)=KKG
37261 JMOHKT(2,IIG)=0
37262 JDAHKT(1,IIG)=3+IIGLU1
37263 JDAHKT(2,IIG)=0
37264 PHKT(1,IIG)=PHKK(1,KKG)
37265 PG1=PG1+ PHKT(1,IIG)
37266 PHKT(2,IIG)=PHKK(2,KKG)
37267 PG2=PG2+ PHKT(2,IIG)
37268 PHKT(3,IIG)=PHKK(3,KKG)
37269 PG3=PG3+ PHKT(3,IIG)
37270 PHKT(4,IIG)=PHKK(4,KKG)
37271 PG4=PG4+ PHKT(4,IIG)
37272 PHKT(5,IIG)=PHKK(5,KKG)
37273 VHKT(1,IIG) =VHKK(1,KKG)
37274 VHKT(2,IIG) =VHKK(2,KKG)
37275 VHKT(3,IIG) =VHKK(3,KKG)
37276 VHKT(4,IIG) =VHKK(4,KKG)
37277 WHKT(1,IIG) =WHKK(1,KKG)
37278 WHKT(2,IIG) =WHKK(2,KKG)
37279 WHKT(3,IIG) =WHKK(3,KKG)
37280 WHKT(4,IIG) =WHKK(4,KKG)
37281 61 CONTINUE
37282 ENDIF
37283 IDHKT(2+IIGLU1) =IPP2
37284 ISTHKT(2+IIGLU1) =932
37285 JMOHKT(1,2+IIGLU1)=NC2T
37286 JMOHKT(2,2+IIGLU1)=0
37287 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37288 JDAHKT(2,2+IIGLU1)=0
37289 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37290 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37291 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37292 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37293C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37294 XMIST=(PHKT(4,2+IIGLU1)**2-
37295 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37296 *PHKT(1,2+IIGLU1)**2)
37297 IF(XMIST.GT.0.D0)THEN
37298 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37299 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37300 *PHKT(1,2+IIGLU1)**2)
37301 ELSE
37302C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37303 PHKT(5,2+IIGLU1)=0.D0
37304 ENDIF
37305 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37306 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37307 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37308 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37309 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37310 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37311 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37312 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37313 IDHKT(3+IIGLU1) =88888
37314 ISTHKT(3+IIGLU1) =94
37315 JMOHKT(1,3+IIGLU1)=1
37316 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37317 JDAHKT(1,3+IIGLU1)=0
37318 JDAHKT(2,3+IIGLU1)=0
37319 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37320 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37321 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37322 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37323 XMIST
37324 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37325 * -PHKT(3,3+IIGLU1)**2)
37326 IF(XMIST.GE.0.D0)THEN
37327 PHKT(5,3+IIGLU1)
37328 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37329 * -PHKT(3,3+IIGLU1)**2)
37330 ELSE
37331C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37332 PHKT(5,1)=0.D0
37333 ENDIF
37334 IF(IPIP.GE.3)THEN
37335C IF(NUMEV.EQ.-324)THEN
37336 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37337 * JMOHKT(2,1),JDAHKT(1,1),
37338 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37339 DO 71 IIG=2,2+IIGLU1-1
37340 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37341 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37342 * JDAHKT(1,IIG),
37343 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37344 71 CONTINUE
37345 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37346 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37347 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37348 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37349 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37350 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37351 ENDIF
37352 CHAMAL=CHAM1
37353 IF(IPIP.EQ.1)THEN
37354 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37355 ELSEIF(IPIP.EQ.2)THEN
37356 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37357 ENDIF
37358 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37359C IREJ=1
37360 IPCO=0
37361C RETURN
37362C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37363 GO TO 3466
37364 ENDIF
37365 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37366 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37367 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37368 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37369 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37370 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37371 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37372 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37373 IDHKT(4+IIGLU1) =IP12
37374 ISTHKT(4+IIGLU1) =931
37375 JMOHKT(1,4+IIGLU1)=NC1P
37376 JMOHKT(2,4+IIGLU1)=0
37377 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37378 JDAHKT(2,4+IIGLU1)=0
37379C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37380 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37381 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37382 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37383 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37384C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37385 XMIST =(PHKT(4,4+IIGLU1)**2-
37386 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37387 *PHKT(1,4+IIGLU1)**2)
37388 IF(XMIST.GT.0.D0)THEN
37389 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37390 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37391 *PHKT(1,4+IIGLU1)**2)
37392 ELSE
37393C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37394 PHKT(5,4+IIGLU1)=0.D0
37395 ENDIF
37396 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37397 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37398 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37399 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37400 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37401 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37402 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37403 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37404 IF(IPIP.EQ.1)THEN
37405 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37406 ELSEIF(IPIP.EQ.2)THEN
37407 IDHKT(5+IIGLU1) =ISAQ1
37408 ENDIF
37409 ISTHKT(5+IIGLU1) =932
37410 JMOHKT(1,5+IIGLU1)=NC1T
37411 JMOHKT(2,5+IIGLU1)=0
37412 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37413 JDAHKT(2,5+IIGLU1)=0
37414 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37415 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37416 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37417 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37418C IF( PHKT(4,5).EQ.0.D0)THEN
37419C IREJ=1
37420CIPCO=0
37421CRETURN
37422C ENDIF
37423C PHKT(5,5) =PHKK(5,NC1T)
37424 XMIST=(PHKT(4,5+IIGLU1)**2-
37425 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37426 *PHKT(1,5+IIGLU1)**2)
37427 IF(XMIST.GT.0.D0)THEN
37428 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37429 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37430 *PHKT(1,5+IIGLU1)**2)
37431 ELSE
37432C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37433 PHKT(5,5+IIGLU1)=0.D0
37434 ENDIF
37435 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37436 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37437 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37438 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37439 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37440 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37441 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37442 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37443 IDHKT(6+IIGLU1) =88888
37444 ISTHKT(6+IIGLU1) =94
37445 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37446 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37447 JDAHKT(1,6+IIGLU1)=0
37448 JDAHKT(2,6+IIGLU1)=0
37449 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37450 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37451 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37452 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37453 XMIST
37454 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37455 * -PHKT(3,6+IIGLU1)**2)
37456 IF(XMIST.GE.0.D0)THEN
37457 PHKT(5,6+IIGLU1)
37458 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37459 * -PHKT(3,6+IIGLU1)**2)
37460 ELSE
37461C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37462 PHKT(5,1)=0.D0
37463 ENDIF
37464C IF(IPIP.EQ.3)THEN
37465 CHAMAL=CHAM1
37466 IF(IPIP.EQ.1)THEN
37467 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37468 ELSEIF(IPIP.EQ.2)THEN
37469 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37470 ENDIF
37471 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37472C IREJ=1
37473 IPCO=0
37474C RETURN
37475C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37476C & CHAMAL,PHKT(5,6+IIGLU1)
37477 GO TO 3466
37478 ENDIF
37479 IF(IPIP.GE.3)THEN
37480C IF(NUMEV.EQ.-324)THEN
37481 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37482 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37483 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37484 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37485 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37486 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37487 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37488 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37489 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37490 ENDIF
37491 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37492 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37493 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37494 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37495 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37496 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37497 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37498 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37499 IF(IPIP.EQ.1)THEN
37500 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37501 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37502 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37503 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37504 ELSEIF(IPIP.EQ.2)THEN
37505 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37506 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37507 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37508 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37509C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37510 ENDIF
37511 ISTHKT(7+IIGLU1) =931
37512 JMOHKT(1,7+IIGLU1)=NC2P
37513 JMOHKT(2,7+IIGLU1)=0
37514 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37515 JDAHKT(2,7+IIGLU1)=0
37516C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37517 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37518 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37519 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37520 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37521C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37522C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37523 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37524C IREJ=1
37525C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37526 IPCO=0
37527C RETURN
37528 GO TO 3466
37529 ENDIF
37530C PHKT(5,7) =PHKK(5,NC2P)
37531 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37532 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37533 *PHKT(1,7+IIGLU1)**2)
37534 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37535 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37536 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37537 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37538 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37539 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37540 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37541 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37542C Insert here the IIGLU2 gluons
37543 PG1=0.D0
37544 PG2=0.D0
37545 PG3=0.D0
37546 PG4=0.D0
37547 IF(IIGLU2.GE.1)THEN
37548 JJG=NC2P
37549 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37550 KKG=JJG+IIG-7-IIGLU1
37551 IDHKT(IIG) =IDHKK(KKG)
37552 ISTHKT(IIG) =921
37553 JMOHKT(1,IIG)=KKG
37554 JMOHKT(2,IIG)=0
37555 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37556 JDAHKT(2,IIG)=0
37557 PHKT(1,IIG)=PHKK(1,KKG)
37558 PG1=PG1+ PHKT(1,IIG)
37559 PHKT(2,IIG)=PHKK(2,KKG)
37560 PG2=PG2+ PHKT(2,IIG)
37561 PHKT(3,IIG)=PHKK(3,KKG)
37562 PG3=PG3+ PHKT(3,IIG)
37563 PHKT(4,IIG)=PHKK(4,KKG)
37564 PG4=PG4+ PHKT(4,IIG)
37565 PHKT(5,IIG)=PHKK(5,KKG)
37566 VHKT(1,IIG) =VHKK(1,KKG)
37567 VHKT(2,IIG) =VHKK(2,KKG)
37568 VHKT(3,IIG) =VHKK(3,KKG)
37569 VHKT(4,IIG) =VHKK(4,KKG)
37570 WHKT(1,IIG) =WHKK(1,KKG)
37571 WHKT(2,IIG) =WHKK(2,KKG)
37572 WHKT(3,IIG) =WHKK(3,KKG)
37573 WHKT(4,IIG) =WHKK(4,KKG)
37574 81 CONTINUE
37575 ENDIF
37576 IDHKT(8+IIGLU1+IIGLU2) =IP2
37577 ISTHKT(8+IIGLU1+IIGLU2) =932
37578 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37579 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37580 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37581 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37582 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37583 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37584 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37585 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37586C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37587 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37588 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37589 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37590 IF(XMIST.GT.0.D0)THEN
37591 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37592 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37593 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37594 ELSE
37595C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37596 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37597 ENDIF
37598 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37599 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37600 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37601 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37602 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37603 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37604 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37605 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37606 IDHKT(9+IIGLU1+IIGLU2) =88888
37607 ISTHKT(9+IIGLU1+IIGLU2) =94
37608 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37609 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37610 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37611 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37612 PHKT(1,9+IIGLU1+IIGLU2)
37613 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37614 PHKT(2,9+IIGLU1+IIGLU2)
37615 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37616 PHKT(3,9+IIGLU1+IIGLU2)
37617 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37618 PHKT(4,9+IIGLU1+IIGLU2)
37619 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37620 XMIST
37621 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37622 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37623 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37624 IF(XMIST.GE.0.D0)THEN
37625 PHKT(5,9+IIGLU1+IIGLU2)
37626 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37627 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37628 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37629 ELSE
37630C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37631 PHKT(5,1)=0.D0
37632 ENDIF
37633 IF(IPIP.GE.3)THEN
37634C IF(NUMEV.EQ.-324)THEN
37635 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37636 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37637 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37638 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37639 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37640 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37641 * JDAHKT(1,IIG),
37642 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37643 91 CONTINUE
37644 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37645 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37646 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37647 *JDAHKT(1,8+IIGLU1+IIGLU2),
37648 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37649 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37650 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37651 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37652 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37653 ENDIF
37654 CHAMAL=CHAB1
37655 IF(IPIP.EQ.1)THEN
37656 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37657 ELSEIF(IPIP.EQ.2)THEN
37658 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37659 ENDIF
37660 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37661C IREJ=1
37662 IPCO=0
37663C RETURN
37664C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37665C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37666 GO TO 3466
37667 ENDIF
37668 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37669 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37670 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37671 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37672 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37673 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37674 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37675 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37676C
37677 IPCO=0
37678 IGCOUN=9+IIGLU1+IIGLU2
37679 RETURN
37680 END
37681
37682*$ CREATE MGSQBS1.FOR
37683*COPY MGSQBS1
37684C
37685C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37686 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37687 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37688C
37689C GSQBS-1 diagram (split projectile diquark)
37690C
37691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37692 SAVE
37693
37694 PARAMETER ( LINP = 10 ,
37695 & LOUT = 6 ,
37696 & LDAT = 9 )
37697
37698* event history
37699
37700 PARAMETER (NMXHKK=200000)
37701
37702 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37703 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37704 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37705
37706* extended event history
37707 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37708 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37709 & IHIST(2,NMXHKK)
37710
37711* Lorentz-parameters of the current interaction
37712 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37713 & UMO,PPCM,EPROJ,PPROJ
37714
37715* diquark-breaking mechanism
37716 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37717
37718C
37719 PARAMETER (NTMHKK= 300)
37720 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37721 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37722 +(4,NTMHKK)
37723*KEEP,XSEADI.
37724 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37725 +SSMIMQ,VVMTHR
37726*KEEP,DPRIN.
37727 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37728C
37729C GSQBS-1 diagram (split projectile diquark)
37730C
37731C
37732C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37733C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37734C
37735C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37736C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37737C
37738C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37739C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37740C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37741C
37742C Put new chains into COMMON /HKKTMP/
37743C
37744 IIGLU1=NC1T-NC1P-1
37745 IIGLU2=NC2T-NC2P-1
37746 IGCOUN=0
37747C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37748 CVQ=1.D0
37749 NNNC1=IDHKK(NC1)/1000
37750 MMMC1=IDHKK(NC1)-NNNC1*1000
37751 KKKC1=ISTHKK(NC1)
37752 NNNC2=IDHKK(NC2)/1000
37753 MMMC2=IDHKK(NC2)-NNNC2*1000
37754 KKKC2=ISTHKK(NC2)
37755 IREJ=0
37756 IF(IPIP.EQ.3)THEN
37757 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37758 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37759 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37760 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37761 ENDIF
37762C
37763C
37764C
37765C determine x-values of NC1P diquark
37766 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37767 XVQT=PHKK(4,NC1T)*2.D0/UMO
37768C
37769C determine x-values of sea quark pair
37770C
37771 IPCO=1
37772 ICOU=0
37773 2234 CONTINUE
37774 ICOU=ICOU+1
37775 IF(ICOU.GE.500)THEN
37776 IREJ=1
37777 IF(ISQ.EQ.3)IREJ=3
37778 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37779 IPCO=0
37780 RETURN
37781 ENDIF
37782 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37783 * UMO, XDIQP,XVQT
37784 XSQ=0.D0
37785 XSAQ=0.D0
37786**NEW
37787C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37788 IF (IPIP.EQ.1) THEN
37789 XQMAX = XDIQP/2.0D0
37790 XAQMAX = 2.D0*XVQT/3.0D0
37791 ELSE
37792 XQMAX = 2.D0*XVQT/3.0D0
37793 XAQMAX = XDIQP/2.0D0
37794 ENDIF
37795 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37796 ISAQ = 6+ISQ
37797C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37798**
37799 IF(IPCO.GE.3)
37800 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37801 IF(IREJ.GE.1)THEN
37802 IF(IPCO.GE.3)
37803 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37804 IPCO=0
37805 RETURN
37806 ENDIF
37807 IF(IPIP.EQ.1)THEN
37808 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37809 ELSEIF(IPIP.EQ.2)THEN
37810 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37811 ENDIF
37812 IF(IPCO.GE.3)THEN
37813 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37814 & XDIQP,XVQT,XSQ,XSAQ
37815 ENDIF
37816C
37817C subtract xsq,xsaq from NC1P diquark and NC1T quark
37818C
37819C XSQ=0.D0
37820 IF(IPIP.EQ.1)THEN
37821 XDIQP=XDIQP-XSQ
37822**NEW
37823C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37824**
37825 XVQT =XVQT -XSAQ
37826 ELSEIF(IPIP.EQ.2)THEN
37827 XDIQP=XDIQP-XSAQ
37828 XVQT =XVQT -XSQ
37829 ENDIF
37830 IF(IPCO.GE.3)
37831 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37832C
37833C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37834C
37835 XVTHRO=CVQ/UMO
37836 IVTHR=0
37837 3466 CONTINUE
37838 IF(IVTHR.EQ.10)THEN
37839 IREJ=1
37840 IF(ISQ.EQ.3)IREJ=3
37841 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37842 IPCO=0
37843 RETURN
37844 ENDIF
37845 IVTHR=IVTHR+1
37846 XVTHR=XVTHRO/(201-IVTHR)
37847 UNOPRV=UNON
37848 380 CONTINUE
37849 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37850 IREJ=1
37851 IF(ISQ.EQ.3)IREJ=3
37852 IF(IPCO.GE.3)
37853 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37854 * XVTHR
37855 IPCO=0
37856 RETURN
37857 ENDIF
37858 IF(DT_RNDM(V).LT.0.5D0)THEN
37859 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37860 XVPQII=XDIQP-XVPQI
37861 ELSE
37862 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37863 XVPQI=XDIQP-XVPQII
37864 ENDIF
37865 IF(IPCO.GE.3)THEN
37866 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37867 & XVTHR,XDIQP,XVPQI,XVPQII
37868 ENDIF
37869C
37870C Prepare 4 momenta of new chains and chain ends
37871C
37872C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37873C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37874C +(4,NTMHKK)
37875C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37876C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37877C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37878 IF(IPIP.EQ.1)THEN
37879 XSQ1=XSQ
37880 XSAQ1=XSAQ
37881 ISQ1=ISQ
37882 ISAQ1=ISAQ
37883 ELSEIF(IPIP.EQ.2)THEN
37884 XSQ1=XSAQ
37885 XSAQ1=XSQ
37886 ISQ1=ISAQ
37887 ISAQ1=ISQ
37888 ENDIF
37889 KK11=IP11
37890C IDHKT(2) =1000*IPP21+100*IPP22+1
37891 KK21= IPP21
37892 KK22= IPP22
37893 XGIVE=0.D0
37894 IDHKT(4+IIGLU1) =IP12
37895 ISTHKT(4+IIGLU1) =921
37896 JMOHKT(1,4+IIGLU1)=NC1P
37897 JMOHKT(2,4+IIGLU1)=0
37898 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37899 JDAHKT(2,4+IIGLU1)=0
37900**NEW
37901 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37902 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37903**
37904 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37905 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37906 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37907 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37908C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37909 XXMIST=(PHKT(4,4+IIGLU1)**2-
37910 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37911 * PHKT(1,4+IIGLU1)**2)
37912 IF(XXMIST.GT.0.D0)THEN
37913 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37914 ELSE
37915 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37916 XXMIST=ABS(XXMIST)
37917 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37918 ENDIF
37919 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37920 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37921 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37922 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37923 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37924 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37925 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37926 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37927 IF(IPIP.EQ.1)THEN
37928 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37929 ELSEIF(IPIP.EQ.2)THEN
37930 IDHKT(5+IIGLU1) =ISAQ1
37931 ENDIF
37932 ISTHKT(5+IIGLU1) =922
37933 JMOHKT(1,5+IIGLU1)=NC1T
37934 JMOHKT(2,5+IIGLU1)=0
37935 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37936 JDAHKT(2,5+IIGLU1)=0
37937**NEW
37938 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37939 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37940**
37941 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37942 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37943 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37944 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37945C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37946 XMIST=(PHKT(4,5+IIGLU1)**2-
37947 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37948 *PHKT(1,5+IIGLU1)**2)
37949 IF(XMIST.GT.0.D0)THEN
37950 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37951 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37952 *PHKT(1,5+IIGLU1)**2)
37953 ELSE
37954C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37955 PHKT(5,5+IIGLU1)=0.D0
37956 ENDIF
37957 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37958 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37959 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37960 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37961 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37962 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37963 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37964 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37965 IDHKT(6+IIGLU1) =88888
37966C IDHKT(6) =1000*NNNC1+MMMC1
37967 ISTHKT(6+IIGLU1) =93
37968C ISTHKT(6) =KKKC1
37969 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37970 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37971 JDAHKT(1,6+IIGLU1)=0
37972 JDAHKT(2,6+IIGLU1)=0
37973 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37974 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37975 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37976 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37977 PHKT(5,6+IIGLU1)
37978 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37979 * -PHKT(3,6+IIGLU1)**2)
37980 CHAMAL=CHAM1
37981 IF(IPIP.EQ.1)THEN
37982 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37983 ELSEIF(IPIP.EQ.2)THEN
37984 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37985 ENDIF
37986 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37987 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37988C we drop chain 6 and give the energy to chain 3
37989 IDHKT(6+IIGLU1)=33888
37990 XGIVE=1.D0
37991C WRITE(6,*)' drop chain 6 xgive=1'
37992 GO TO 7788
37993 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37994C we drop chain 6 and give the energy to chain 3
37995C and change KK11 to IDHKT(4)
37996 IDHKT(6+IIGLU1)=33888
37997 XGIVE=1.D0
37998C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37999 KK11=IDHKT(4+IIGLU1)
38000 GO TO 7788
38001 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38002C we drop chain 6 and give the energy to chain 3
38003C and change KK21 to IDHKT(4)
38004C IDHKT(2) =1000*IPP21+100*IPP22+1
38005 IDHKT(6+IIGLU1)=33888
38006 XGIVE=1.D0
38007C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38008 KK21=IDHKT(4+IIGLU1)
38009 GO TO 7788
38010 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38011C we drop chain 6 and give the energy to chain 3
38012C and change KK22 to IDHKT(4)
38013C IDHKT(2) =1000*IPP21+100*IPP22+1
38014 IDHKT(6+IIGLU1)=33888
38015 XGIVE=1.D0
38016C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38017 KK22=IDHKT(4+IIGLU1)
38018 GO TO 7788
38019 ENDIF
38020C IREJ=1
38021 IPCO=0
38022C RETURN
38023C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38024 GO TO 3466
38025 ENDIF
38026 7788 CONTINUE
38027 IF(IPIP.GE.3)THEN
38028 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38029 * JMOHKT(1,4+IIGLU1),
38030 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38031 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38032 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38033 * JMOHKT(1,5+IIGLU1),
38034 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38035 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38036 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38037 * JMOHKT(1,6+IIGLU1),
38038 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38039 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38040 ENDIF
38041 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38042 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38043 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38044 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38045 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38046 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38047 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38048 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38049C IDHKT(1) =IP11
38050 IDHKT(1) =KK11
38051 ISTHKT(1) =921
38052 JMOHKT(1,1)=NC1P
38053 JMOHKT(2,1)=0
38054 JDAHKT(1,1)=3+IIGLU1
38055 JDAHKT(2,1)=0
38056 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38057C * +0.5D0*PHKK(1,NC2P)
38058 *+XGIVE*PHKT(1,4+IIGLU1)
38059 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38060C * +0.5D0*PHKK(2,NC2P)
38061 *+XGIVE*PHKT(2,4+IIGLU1)
38062 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38063C * +0.5D0*PHKK(3,NC2P)
38064 *+XGIVE*PHKT(3,4+IIGLU1)
38065 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38066C * +0.5D0*PHKK(4,NC2P)
38067 *+XGIVE*PHKT(4,4+IIGLU1)
38068C PHKT(5,1) =PHKK(5,NC1P)
38069 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38070 *PHKT(1,1)**2)
38071 IF(XMIST.GE.0.D0)THEN
38072 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38073 *PHKT(1,1)**2)
38074 ELSE
38075C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38076 PHKT(5,1)=0.D0
38077 ENDIF
38078 VHKT(1,1) =VHKK(1,NC1P)
38079 VHKT(2,1) =VHKK(2,NC1P)
38080 VHKT(3,1) =VHKK(3,NC1P)
38081 VHKT(4,1) =VHKK(4,NC1P)
38082 WHKT(1,1) =WHKK(1,NC1P)
38083 WHKT(2,1) =WHKK(2,NC1P)
38084 WHKT(3,1) =WHKK(3,NC1P)
38085 WHKT(4,1) =WHKK(4,NC1P)
38086C Add here IIGLU1 gluons to this chaina
38087 PG1=0.D0
38088 PG2=0.D0
38089 PG3=0.D0
38090 PG4=0.D0
38091 IF(IIGLU1.GE.1)THEN
38092 JJG=NC1P
38093 DO 61 IIG=2,2+IIGLU1-1
38094 KKG=JJG+IIG-1
38095 IDHKT(IIG) =IDHKK(KKG)
38096 ISTHKT(IIG) =921
38097 JMOHKT(1,IIG)=KKG
38098 JMOHKT(2,IIG)=0
38099 JDAHKT(1,IIG)=3+IIGLU1
38100 JDAHKT(2,IIG)=0
38101 PHKT(1,IIG)=PHKK(1,KKG)
38102 PG1=PG1+ PHKT(1,IIG)
38103 PHKT(2,IIG)=PHKK(2,KKG)
38104 PG2=PG2+ PHKT(2,IIG)
38105 PHKT(3,IIG)=PHKK(3,KKG)
38106 PG3=PG3+ PHKT(3,IIG)
38107 PHKT(4,IIG)=PHKK(4,KKG)
38108 PG4=PG4+ PHKT(4,IIG)
38109 PHKT(5,IIG)=PHKK(5,KKG)
38110 VHKT(1,IIG) =VHKK(1,KKG)
38111 VHKT(2,IIG) =VHKK(2,KKG)
38112 VHKT(3,IIG) =VHKK(3,KKG)
38113 VHKT(4,IIG) =VHKK(4,KKG)
38114 WHKT(1,IIG) =WHKK(1,KKG)
38115 WHKT(2,IIG) =WHKK(2,KKG)
38116 WHKT(3,IIG) =WHKK(3,KKG)
38117 WHKT(4,IIG) =WHKK(4,KKG)
38118 61 CONTINUE
38119 ENDIF
38120C IDHKT(2) =1000*IPP21+100*IPP22+1
38121 IF(IPIP.EQ.1)THEN
38122 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38123 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38124 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38125 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38126 ELSEIF(IPIP.EQ.2)THEN
38127 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38128 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38129 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38130 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38131 ENDIF
38132 ISTHKT(2+IIGLU1) =922
38133 JMOHKT(1,2+IIGLU1)=NC2T
38134 JMOHKT(2,2+IIGLU1)=0
38135 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38136 JDAHKT(2,2+IIGLU1)=0
38137 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38138 *+XGIVE*PHKT(1,5+IIGLU1)
38139 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38140 *+XGIVE*PHKT(2,5+IIGLU1)
38141 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38142 *+XGIVE*PHKT(3,5+IIGLU1)
38143 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38144 *+XGIVE*PHKT(4,5+IIGLU1)
38145C PHKT(5,2) =PHKK(5,NC2T)
38146 XMIST=(PHKT(4,2+IIGLU1)**2-
38147 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38148 *PHKT(1,2+IIGLU1)**2)
38149 IF(XMIST.GT.0.D0)THEN
38150 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38151 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38152 *PHKT(1,2+IIGLU1)**2)
38153 ELSE
38154C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38155 PHKT(5,2+IIGLU1)=0.D0
38156 ENDIF
38157 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38158 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38159 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38160 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38161 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38162 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38163 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38164 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38165 IDHKT(3+IIGLU1) =88888
38166C IDHKT(3) =1000*NNNC1+MMMC1+10
38167 ISTHKT(3+IIGLU1) =93
38168C ISTHKT(3) =KKKC1
38169 JMOHKT(1,3+IIGLU1)=1
38170 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38171 JDAHKT(1,3+IIGLU1)=0
38172 JDAHKT(2,3+IIGLU1)=0
38173 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38174 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38175 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38176 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38177 PHKT(5,3+IIGLU1)
38178 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38179 * -PHKT(3,3+IIGLU1)**2)
38180 IF(IPIP.GE.3)THEN
38181 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38182 * JDAHKT(1,1),
38183 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38184 DO 71 IIG=2,2+IIGLU1-1
38185 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38186 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38187 * JDAHKT(1,IIG),
38188 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38189 71 CONTINUE
38190 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38191 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38192 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38193 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38194 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38195 * JMOHKT(1,3+IIGLU1),
38196 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38197 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38198 ENDIF
38199 CHAMAL=CHAB1
38200**NEW
38201C IF(IPIP.EQ.1)THEN
38202C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38203C ELSEIF(IPIP.EQ.2)THEN
38204C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38205C ENDIF
38206 IF(IPIP.EQ.1)THEN
38207 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38208 ELSEIF(IPIP.EQ.2)THEN
38209 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38210 ENDIF
38211**
38212 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38213C IREJ=1
38214 IPCO=0
38215C RETURN
38216C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38217 GO TO 3466
38218 ENDIF
38219 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38220 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38221 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38222 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38223 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38224 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38225 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38226 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38227 IF(IPIP.EQ.1)THEN
38228 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38229 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38230 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38231 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38232 ELSEIF(IPIP.EQ.2)THEN
38233 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38234 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38235 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38236 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38237C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38238 ENDIF
38239 ISTHKT(7+IIGLU1) =921
38240 JMOHKT(1,7+IIGLU1)=NC2P
38241 JMOHKT(2,7+IIGLU1)=0
38242 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38243 JDAHKT(2,7+IIGLU1)=0
38244C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38245C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38246C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38247C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38248**NEW
38249 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38250 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38251**
38252 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38253 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38254 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38255 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38256C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38257C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38258 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38259C IREJ=1
38260C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38261 IPCO=0
38262C RETURN
38263 GO TO 3466
38264 ENDIF
38265C PHKT(5,7) =PHKK(5,NC2P)
38266 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38267 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38268 *PHKT(1,7+IIGLU1)**2)
38269 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38270 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38271 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38272 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38273 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38274 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38275 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38276 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38277C Insert here the IIGLU2 gluons
38278 PG1=0.D0
38279 PG2=0.D0
38280 PG3=0.D0
38281 PG4=0.D0
38282 IF(IIGLU2.GE.1)THEN
38283 JJG=NC2P
38284 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38285 KKG=JJG+IIG-7-IIGLU1
38286 IDHKT(IIG) =IDHKK(KKG)
38287 ISTHKT(IIG) =921
38288 JMOHKT(1,IIG)=KKG
38289 JMOHKT(2,IIG)=0
38290 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38291 JDAHKT(2,IIG)=0
38292 PHKT(1,IIG)=PHKK(1,KKG)
38293 PG1=PG1+ PHKT(1,IIG)
38294 PHKT(2,IIG)=PHKK(2,KKG)
38295 PG2=PG2+ PHKT(2,IIG)
38296 PHKT(3,IIG)=PHKK(3,KKG)
38297 PG3=PG3+ PHKT(3,IIG)
38298 PHKT(4,IIG)=PHKK(4,KKG)
38299 PG4=PG4+ PHKT(4,IIG)
38300 PHKT(5,IIG)=PHKK(5,KKG)
38301 VHKT(1,IIG) =VHKK(1,KKG)
38302 VHKT(2,IIG) =VHKK(2,KKG)
38303 VHKT(3,IIG) =VHKK(3,KKG)
38304 VHKT(4,IIG) =VHKK(4,KKG)
38305 WHKT(1,IIG) =WHKK(1,KKG)
38306 WHKT(2,IIG) =WHKK(2,KKG)
38307 WHKT(3,IIG) =WHKK(3,KKG)
38308 WHKT(4,IIG) =WHKK(4,KKG)
38309 81 CONTINUE
38310 ENDIF
38311 IDHKT(8+IIGLU1+IIGLU2) =IP2
38312 ISTHKT(8+IIGLU1+IIGLU2) =922
38313 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38314 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38315 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38316 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38317**NEW
38318 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38319 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38320**
38321 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38322 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38323 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38324 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38325C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38326 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38327 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38328 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38329 IF(XMIST.GT.0.D0)THEN
38330 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38331 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38332 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38333 ELSE
38334C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38335 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38336 ENDIF
38337 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38338 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38339 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38340 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38341 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38342 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38343 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38344 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38345 IDHKT(9+IIGLU1+IIGLU2) =88888
38346C IDHKT(9) =1000*NNNC2+MMMC2+10
38347 ISTHKT(9+IIGLU1+IIGLU2) =93
38348C ISTHKT(9) =KKKC2
38349 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38350 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38351 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38352 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38353 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38354 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38355 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38356 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38357 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38358 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38359 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38360 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38361 PHKT(5,9+IIGLU1+IIGLU2)
38362 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38363 * PHKT(2,9+IIGLU1+IIGLU2)**2
38364 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38365 IF(IPIP.GE.3)THEN
38366 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38367 * JMOHKT(1,7+IIGLU1),
38368 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38369 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38370 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38371 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38372 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38373 * JDAHKT(1,IIG),
38374 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38375 91 CONTINUE
38376 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38377 * IDHKT(8+IIGLU1+IIGLU2),
38378 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38379 * JDAHKT(1,8+IIGLU1+IIGLU2),
38380 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38381 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38382 * IDHKT(9+IIGLU1+IIGLU2),
38383 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38384 * JDAHKT(1,9+IIGLU1+IIGLU2),
38385 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38386 ENDIF
38387 CHAMAL=CHAB1
38388 IF(IPIP.EQ.1)THEN
38389 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38390 ELSEIF(IPIP.EQ.2)THEN
38391 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38392 ENDIF
38393 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38394C IREJ=1
38395 IPCO=0
38396C RETURN
38397C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38398C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38399 GO TO 3466
38400 ENDIF
38401 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38402 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38403 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38404 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38405 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38406 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38407 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38408 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38409C
38410 IGCOUN=9+IIGLU1+IIGLU2
38411 IPCO=0
38412 RETURN
38413 END
38414
38415*$ CREATE HKKHKT.FOR
38416*COPY HKKHKT
38417C
38418C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38419C
38420 SUBROUTINE HKKHKT(I,J)
38421 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38422 SAVE
38423
38424* event history
38425
38426 PARAMETER (NMXHKK=200000)
38427
38428 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38429 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38430 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38431
38432* extended event history
38433 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38434 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38435 & IHIST(2,NMXHKK)
38436
38437 PARAMETER (NTMHKK= 300)
38438 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38439 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38440 +(4,NTMHKK)
38441C
38442 ISTHKK(I) =ISTHKT(J)
38443 IDHKK(I) =IDHKT(J)
38444C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38445 IF(IDHKK(I).EQ.88888)THEN
38446C JMOHKK(1,I)=I-2
38447C JMOHKK(2,I)=I-1
38448 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38449 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38450 ELSE
38451 JMOHKK(1,I)=JMOHKT(1,J)
38452 JMOHKK(2,I)=JMOHKT(2,J)
38453 ENDIF
38454 JDAHKK(1,I)=JDAHKT(1,J)
38455 JDAHKK(2,I)=JDAHKT(2,J)
38456C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38457C JDAHKK(1,I)=I+2
38458C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38459C JDAHKK(1,I)=I+1
38460C ENDIF
38461 IF(JDAHKT(1,J).GT.0)THEN
38462 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38463 ENDIF
38464 PHKK(1,I) =PHKT(1,J)
38465 PHKK(2,I) =PHKT(2,J)
38466 PHKK(3,I) =PHKT(3,J)
38467 PHKK(4,I) =PHKT(4,J)
38468 PHKK(5,I) =PHKT(5,J)
38469 VHKK(1,I) =VHKT(1,J)
38470 VHKK(2,I) =VHKT(2,J)
38471 VHKK(3,I) =VHKT(3,J)
38472 VHKK(4,I) =VHKT(4,J)
38473 WHKK(1,I) =WHKT(1,J)
38474 WHKK(2,I) =WHKT(2,J)
38475 WHKK(3,I) =WHKT(3,J)
38476 WHKK(4,I) =WHKT(4,J)
38477 RETURN
38478 END
38479
38480*$ CREATE DT_DBREAK.FOR
38481*COPY DT_DBREAK
38482*
38483*===dbreak=============================================================*
38484*
38485 SUBROUTINE DT_DBREAK(MODE)
38486
38487************************************************************************
38488* This is the steering subroutine for the different diquark breaking *
38489* mechanisms. *
38490* *
38491* MODE = 1 breaking of projectile diquark in qq-q chain using *
38492* a sea quark (q-qq chain) of the same projectile *
38493* = 2 breaking of target diquark in q-qq chain using *
38494* a sea quark (qq-q chain) of the same target *
38495* = 3 breaking of projectile diquark in qq-q chain using *
38496* a sea quark (q-aq chain) of the same projectile *
38497* = 4 breaking of target diquark in q-qq chain using *
38498* a sea quark (aq-q chain) of the same target *
38499* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38500* a sea anti-quark (aq-aqaq chain) of the same projectile *
38501* = 6 breaking of target anti-diquark in aq-aqaq chain using *
38502* a sea anti-quark (aqaq-aq chain) of the same target *
38503* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38504* a sea anti-quark (aq-q chain) of the same projectile *
38505* = 8 breaking of target anti-diquark in aq-aqaq chain using *
38506* a sea anti-quark (q-aq chain) of the same target *
38507* *
38508* Original version by J. Ranft. *
38509* This version dated 17.5.00 is written by S. Roesler. *
38510************************************************************************
38511
38512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38513 SAVE
38514
38515 PARAMETER ( LINP = 10 ,
38516 & LOUT = 6 ,
38517 & LDAT = 9 )
38518
38519* event history
38520
38521 PARAMETER (NMXHKK=200000)
38522
38523 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38524 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38525 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38526
38527* extended event history
38528 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38529 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38530 & IHIST(2,NMXHKK)
38531
38532* flags for input different options
38533 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38534 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38535 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38536
38537* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38538 PARAMETER (MAXCHN=10000)
38539 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38540
38541* diquark-breaking mechanism
38542 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38543
38544* flags for particle decays
38545 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38546 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38547 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38548
38549*
38550* chain identifiers
38551* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38552* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38553 DIMENSION IDCHN1(8),IDCHN2(8)
38554 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38555 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38556*
38557* parton identifiers
38558* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38559* +-51/52 = unitarity-sea, +-61/62 = gluons )
38560 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38561 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38562 & 31, 31, 31, 31, 31, 31, 31, 31,
38563 & 41, 41, 41, 41, 51, 51, 51, 51/
38564 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38565 & 32, 32, 32, 32, 32, 32, 32, 32,
38566 & 42, 42, 42, 42, 52, 52, 52, 52/
38567 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38568 & 51, 31, 41, 41, 31, 31, 31, 31,
38569 & 0, 41, 51, 51, 51, 51, 51, 51/
38570 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38571 & 32, 52, 42, 42, 32, 32, 32, 32,
38572 & 42, 0, 52, 52, 52, 52, 52, 52/
38573
38574 IF (NCHAIN.LE.0) RETURN
38575 DO 1 I=1,NCHAIN
38576 IDX1 = IDXCHN(1,I)
38577 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38578 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38579 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38580 & .AND.
38581 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38582 & (IS1P.EQ.ISP1P(MODE,3)))
38583 & .AND.
38584 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38585 & (IS1T.EQ.ISP1T(MODE,3)))
38586 & ) THEN
38587 DO 2 J=1,NCHAIN
38588 IDX2 = IDXCHN(1,J)
38589 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38590 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38591 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38592 & .AND.
38593 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38594 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38595 & .AND.
38596 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38597 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38598 & ) THEN
38599* find mother nucleons of the diquark to be splitted and of the
38600* sea-quark and reject this combination if it is not the same
38601 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38602 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38603 IANCES = 1
38604 ELSE
38605 IANCES = 2
38606 ENDIF
38607 IDXMO1 = JMOHKK(IANCES,IDX1)
38608 4 CONTINUE
38609 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38610 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38611 IANC = IANCES
38612 ELSE
38613 IANC = 1
38614 ENDIF
38615 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38616 IDXMO1 = JMOHKK(IANC,IDXMO1)
38617 GOTO 4
38618 ENDIF
38619 IDXMO2 = JMOHKK(IANCES,IDX2)
38620 5 CONTINUE
38621 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38622 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38623 IANC = IANCES
38624 ELSE
38625 IANC = 1
38626 ENDIF
38627 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38628 IDXMO2 = JMOHKK(IANC,IDXMO2)
38629 GOTO 5
38630 ENDIF
38631 IF (IDXMO1.NE.IDXMO2) GOTO 2
38632* quark content of projectile parton
38633 IP1 = IDHKK(JMOHKK(1,IDX1))
38634 IP11 = IP1/1000
38635 IP12 = (IP1-1000*IP11)/100
38636 IP2 = IDHKK(JMOHKK(2,IDX1))
38637 IP21 = IP2/1000
38638 IP22 = (IP2-1000*IP21)/100
38639* quark content of target parton
38640 IT1 = IDHKK(JMOHKK(1,IDX2))
38641 IT11 = IT1/1000
38642 IT12 = (IT1-1000*IT11)/100
38643 IT2 = IDHKK(JMOHKK(2,IDX2))
38644 IT21 = IT2/1000
38645 IT22 = (IT2-1000*IT21)/100
38646* split diquark and form new chains
38647 IF (MODE.EQ.1) THEN
38648 IF (IT1.EQ.4) GOTO 2
38649 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38650 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38651 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38652 ELSEIF (MODE.EQ.2) THEN
38653 IF (IT2.EQ.4) GOTO 2
38654 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38655 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38656 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38657 ELSEIF (MODE.EQ.3) THEN
38658 IF (IT1.EQ.4) GOTO 2
38659 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38660 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38661 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38662 ELSEIF (MODE.EQ.4) THEN
38663 IF (IT2.EQ.4) GOTO 2
38664 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38667 ELSEIF (MODE.EQ.5) THEN
38668 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38671 ELSEIF (MODE.EQ.6) THEN
38672 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38675 ELSEIF (MODE.EQ.7) THEN
38676 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38679 ELSEIF (MODE.EQ.8) THEN
38680 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38681 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38682 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38683 ENDIF
38684 IF (IREJ.GE.1) THEN
38685 if ((ipq.lt.0).or.(ipq.ge.4))
38686 & write(LOUT,*) 'ipq !!!',ipq,mode
38687 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38688* accept or reject new chains corresponding to PDBSEA
38689 ELSE
38690 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38691 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38692 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38693 ELSEIF (IPQ.EQ.3) THEN
38694 ACC = DBRKA(3,MODE)
38695 REJ = DBRKR(3,MODE)
38696 ELSE
38697 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38698 STOP
38699 ENDIF
38700 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38701 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38702 IACC = 1
38703 ELSE
38704 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38705 IACC = 0
38706 ENDIF
38707* new chains have been accepted and are now copied into HKKEVT
38708 IF (IACC.EQ.1) THEN
38709 IF (LEMCCK) THEN
38710 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38711 & PHKK(3,IDX1),PHKK(4,IDX1),
38712 & 1,IDUM1,IDUM2)
38713 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38714 & PHKK(3,IDX2),PHKK(4,IDX2),
38715 & 2,IDUM1,IDUM2)
38716 ENDIF
38717 IDHKK(IDX1) = 99888
38718 IDHKK(IDX2) = 99888
38719 IDXCHN(2,I) = -1
38720 IDXCHN(2,J) = -1
38721 DO 3 K=1,IGCOUN
38722 NHKK = NHKK+1
38723 CALL HKKHKT(NHKK,K)
38724 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38725 PX = -PHKK(1,NHKK)
38726 PY = -PHKK(2,NHKK)
38727 PZ = -PHKK(3,NHKK)
38728 PE = -PHKK(4,NHKK)
38729 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38730 ENDIF
38731 3 CONTINUE
38732 IF (LEMCCK) THEN
38733 CHKLEV = 0.1D0
38734 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38735 & IREJ)
38736 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38737 ENDIF
38738 GOTO 1
38739 ENDIF
38740 ENDIF
38741 ENDIF
38742 2 CONTINUE
38743 ENDIF
38744 1 CONTINUE
38745 RETURN
38746 END
38747
38748*$ CREATE DT_CQPAIR.FOR
38749*COPY DT_CQPAIR
38750*
38751*===cqpair=============================================================*
38752*
38753 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38754
38755************************************************************************
38756* This subroutine Creates a Quark-antiquark PAIR from the sea. *
38757* *
38758* XQMAX maxium energy fraction of quark (input) *
38759* XAQMAX maxium energy fraction of antiquark (input) *
38760* XQ energy fraction of quark (output) *
38761* XAQ energy fraction of antiquark (output) *
38762* IFLV quark flavour (- antiquark flavor) (output) *
38763* *
38764* This version dated 14.5.00 is written by S. Roesler. *
38765************************************************************************
38766
38767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38768 SAVE
38769
38770 PARAMETER ( LINP = 10 ,
38771 & LOUT = 6 ,
38772 & LDAT = 9 )
38773
38774* Lorentz-parameters of the current interaction
38775 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38776 & UMO,PPCM,EPROJ,PPROJ
38777
38778*
38779 IREJ = 0
38780 XQ = 0.0D0
38781 XAQ = 0.0D0
38782*
38783* sample quark flavour
38784*
38785* set seasq here (the one from DTCHAI should be used in the future)
38786 SEASQ = 0.5D0
38787 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38788*
38789* sample energy fractions of sea pair
38790* we first sample the energy fraction of a gluon and then split the gluon
38791*
38792* maximum energy fraction of the gluon forced via input
38793 XGMAXI = XQMAX+XAQMAX
38794* minimum energy fraction of the gluon
38795 XTHR1 = 4.0D0 /UMO**2
38796 XTHR2 = 0.54D0/UMO**1.5D0
38797 XGMIN = MAX(XTHR1,XTHR2)
38798* maximum energy fraction of the gluon
38799 XGMAX = 0.3D0
38800 XGMAX = MIN(XGMAXI,XGMAX)
38801 IF (XGMIN.GE.XGMAX) THEN
38802 IREJ = 1
38803 RETURN
38804 ENDIF
38805*
38806* sample energy fraction of the gluon
38807 NLOOP = 0
38808 1 CONTINUE
38809 NLOOP = NLOOP+1
38810 IF (NLOOP.GE.50) THEN
38811 IREJ = 1
38812 RETURN
38813 ENDIF
38814 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38815 EGLUON = XGLUON*UMO/2.0D0
38816*
38817* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38818 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38819 ZMAX = 1.0D0-ZMIN
38820 RZ = DT_RNDM(ZMAX)
38821 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38822 RQ = DT_RNDM(ZMAX)
38823 IF (RQ.LT.0.5D0) THEN
38824 XQ = XGLUON*XHLP
38825 XAQ = XGLUON-XQ
38826 ELSE
38827 XAQ = XGLUON*XHLP
38828 XQ = XGLUON-XAQ
38829 ENDIF
38830 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38831
38832 RETURN
38833 END