]> 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
Update amanda server for TOF
[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,
031c717a
AM		 3753 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3754 & NCP,NCT
7b076c76 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
5555
5556 1 CONTINUE
5557 ICSAMP = ICSAMP+1
5558 NC = NC+1
5559 IF (MOD(NC,10).EQ.0) THEN
5560 WRITE(LOUT,1000) NEVHKK
5561 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5562 GOTO 9999
5563 ENDIF
5564
5565* initialize DTEVT1/DTEVT2
5566 CALL DT_EVTINI
5567
5568* We need the following only in order to sample nucleon coordinates.
5569* However we don't have parameters (cross sections, slope etc.)
5570* for neutrinos available. Therefore switch projectile to proton
5571* in this case.
5572 IF (MCGENE.EQ.4) THEN
5573 JJPROJ = 1
5574 ELSE
5575 JJPROJ = IJPROJ
5576 ENDIF
5577
5578 10 CONTINUE
5579 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5580* make sure that Glauber-formalism is called each time the interaction
5581* configuration changed
5582 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5583 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5584* sample number of nucleon-nucleon coll. according to Glauber-form.
5585 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5586 NWTSAM = NN
5587 NWASAM = NP
5588 NWBSAM = NT
5589 NEVOLD = NEVHKK
5590 IPOLD = IP
5591 ITOLD = IT
5592 JJPOLD = JJPROJ
5593 EPROLD = EPROJ
4467935f 5594 NCP = 0
5595 NCT = 0
5596
7d5a4d62 5597 DO 8 I=1, IP
ebb0c0e0 5598 NCP = NCP+JSSH(I)
5599* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5600 8 CONTINUE
7d5a4d62 5601 DO 9 I=1, IT
ebb0c0e0 5602 NCT = NCT+JTSH(I)
5603* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5604 9 CONTINUE
7b076c76 5605 ENDIF
5606
5607* force diffractive particle production in h-K interactions
5608 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5609 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5610 NEVOLD = 0
5611 GOTO 10
5612 ENDIF
5613
5614* check number of involved proj. nucl. (NP) if central prod.is requested
5615 IF (ICENTR.GT.0) THEN
5616 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5617 IF (IBACK.GT.0) GOTO 10
5618 ENDIF
5619
5620* get initial nucleon-configuration in projectile and target
5621* rest-system (including Fermi-momenta if requested)
5622 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5623 MODE = 2
5624 IF (EPROJ.LE.EHADTH) MODE = 3
5625 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5626
5627 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5628
5629* activate HADRIN at low energies (implemented for h-N scattering only)
5630 IF (EPROJ.LE.EHADHI) THEN
5631 IF (EHADTH.LT.ZERO) THEN
5632* smooth transition btwn. DPM and HADRIN
5633 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5634 RR = DT_RNDM(FRAC)
5635 IF (RR.GT.FRAC) THEN
5636 IF (IP.EQ.1) THEN
5637 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5638 IF (IREJ1.GT.0) GOTO 1
5639 RETURN
5640 ELSE
5641 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5642 ENDIF
5643 ENDIF
5644 ELSE
5645* fixed threshold for onset of production via HADRIN
5646 IF (EPROJ.LE.EHADTH) THEN
5647 IF (IP.EQ.1) THEN
5648 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5649 IF (IREJ1.GT.0) GOTO 1
5650 RETURN
5651 ELSE
5652 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5653 ENDIF
5654 ENDIF
5655 ENDIF
5656 ENDIF
5657 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5658 & I3,') with target (m=',I3,')',/,11X,
5659 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5660 & 'GeV) cannot be handled')
5661
5662* sampling of momentum-x fractions & flavors of chain ends
5663 CALL DT_SPLPTN(NN)
5664
5665* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5666 CALL DT_NUC2CM
5667
5668* collect momenta of chain ends and put them into DTEVT1
5669 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5670 IF (IREJ1.NE.0) GOTO 1
5671
5672 ENDIF
5673
5674* handle chains including fragmentation (two-chain approximation)
5675 IF (MCGENE.EQ.1) THEN
5676* two-chain approximation
5677 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5678 IF (IREJ1.NE.0) THEN
5679 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5680 GOTO 1
5681 ENDIF
5682 ELSEIF (MCGENE.EQ.2) THEN
5683* multiple-Po exchange including minijets
5684 CALL DT_EVENTB(NCSY,IREJ1)
5685 IF (IREJ1.NE.0) THEN
5686 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5687 GOTO 1
5688 ENDIF
5689 ELSEIF (MCGENE.EQ.3) THEN
5690 STOP ' This version does not contain LEPTO !'
5691
5692 ELSEIF (MCGENE.EQ.4) THEN
5693* quasi-elastic neutrino scattering
5694 CALL DT_EVENTD(IREJ1)
5695 IF (IREJ1.NE.0) THEN
5696 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5697 GOTO 1
5698 ENDIF
5699 ELSE
5700 WRITE(LOUT,1002) MCGENE
5701 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5702 & ' not available - program stopped')
5703 STOP
5704 ENDIF
5705
5706 RETURN
5707
5708 9999 CONTINUE
5709 IREJ = 1
5710 RETURN
5711 END
5712
5713*$ CREATE DT_CHKCEN.FOR
5714*COPY DT_CHKCEN
5715*
5716*===chkcen=============================================================*
5717*
5718 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5719
5720************************************************************************
5721* Check of number of involved projectile nucleons if central production*
5722* is requested. *
5723* Adopted from a part of the old KKEVT routine which was written by *
5724* J. Ranft/H.-J.Moehring. *
5725* This version dated 13.01.95 is written by S. Roesler *
5726************************************************************************
5727
5728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5729 SAVE
5730
5731 PARAMETER ( LINP = 10 ,
5732 & LOUT = 6 ,
5733 & LDAT = 9 )
5734
5735* statistics
5736 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5737 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5738 & ICEVTG(8,0:30)
5739
5740* central particle production, impact parameter biasing
5741 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5742
5743 IBACK = 0
5744
5745* old version
5746 IF (ICENTR.EQ.2) THEN
5747 IF (IP.LT.IT) THEN
5748 IF (IP.LE.8) THEN
5749 IF (NP.LT.IP-1) IBACK = 1
5750 ELSEIF (IP.LE.16) THEN
5751 IF (NP.LT.IP-2) IBACK = 1
5752 ELSEIF (IP.LE.32) THEN
5753 IF (NP.LT.IP-3) IBACK = 1
5754 ELSEIF (IP.GE.33) THEN
5755 IF (NP.LT.IP-5) IBACK = 1
5756 ENDIF
5757 ELSEIF (IP.EQ.IT) THEN
5758 IF (IP.EQ.32) THEN
5759 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5760 ELSE
5761 IF (NP.LT.IP-IP/8) IBACK = 1
5762 ENDIF
5763 ELSEIF (ABS(IP-IT).LT.3) THEN
5764 IF (NP.LT.IP-IP/8) IBACK = 1
5765 ENDIF
5766 ELSE
5767* new version (DPMJET, 5.6.99)
5768 IF (IP.LT.IT) THEN
5769 IF (IP.LE.8) THEN
5770 IF (NP.LT.IP-1) IBACK = 1
5771 ELSEIF (IP.LE.16) THEN
5772 IF (NP.LT.IP-2) IBACK = 1
5773 ELSEIF (IP.LT.32) THEN
5774 IF (NP.LT.IP-3) IBACK = 1
5775 ELSEIF (IP.GE.32) THEN
5776 IF (IT.LE.150) THEN
5777* Example: S-Ag
5778 IF (NP.LT.IP-1) IBACK = 1
5779 ELSE
5780* Example: S-Au
5781 IF (NP.LT.IP) IBACK = 1
5782 ENDIF
5783 ENDIF
5784 ELSEIF (IP.EQ.IT) THEN
5785* Example: S-S
5786 IF (IP.EQ.32) THEN
5787 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5788* Example: Pb-Pb
5789 ELSE
5790 IF (NP.LT.IP-IP/4) IBACK = 1
5791 ENDIF
5792 ELSEIF (ABS(IP-IT).LT.3) THEN
5793 IF (NP.LT.IP-IP/8) IBACK = 1
5794 ENDIF
5795 ENDIF
5796
5797 ICCPRO = ICCPRO+1
5798
5799 RETURN
5800 END
5801
5802*$ CREATE DT_ININUC.FOR
5803*COPY DT_ININUC
5804*
5805*===ininuc=============================================================*
5806*
5807 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5808
5809************************************************************************
5810* Samples initial configuration of nucleons in nucleus with mass NMASS *
5811* including Fermi-momenta (if reqested). *
5812* ID BAMJET-code for hadrons (instead of nuclei) *
5813* NMASS mass number of nucleus (number of nucleons) *
5814* NCH charge of nucleus *
5815* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5816* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5817* IMODE = 1 projectile nucleus *
5818* = 2 target nucleus *
5819* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5820* Adopted from a part of the old KKEVT routine which was written by *
5821* J. Ranft/H.-J.Moehring. *
5822* This version dated 13.01.95 is written by S. Roesler *
5823************************************************************************
5824
5825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5826 SAVE
5827
5828 PARAMETER ( LINP = 10 ,
5829 & LOUT = 6 ,
5830 & LDAT = 9 )
5831
5832 PARAMETER (FM2MM=1.0D-12)
5833
5834 PARAMETER ( MAXNCL = 260,
5835
5836 & MAXVQU = MAXNCL,
5837 & MAXSQU = 20*MAXVQU,
5838 & MAXINT = MAXVQU+MAXSQU)
5839
5840* event history
5841
5842 PARAMETER (NMXHKK=200000)
5843
5844 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5845 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5846 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5847
5848* extended event history
5849 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5850 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5851 & IHIST(2,NMXHKK)
5852
5853* flags for input different options
5854 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5855 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5856 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5857
5858* auxiliary common for chain system storage (DTUNUC 1.x)
5859 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5860
5861* nuclear potential
5862 LOGICAL LFERMI
5863 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5864 & EBINDP(2),EBINDN(2),EPOT(2,210),
5865 & ETACOU(2),ICOUL,LFERMI
5866
5867* properties of photon/lepton projectiles
5868 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5869
5870* particle properties (BAMJET index convention)
5871 CHARACTER*8 ANAME
5872 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5873 & IICH(210),IIBAR(210),K1(210),K2(210)
5874
5875* Glauber formalism: collision properties
5876 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 5877 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5878 & NCP,NCT
7b076c76 5879
5880* flavors of partons (DTUNUC 1.x)
5881 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5882 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5883 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5884 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5885 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5886 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5887 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5888
5889* interface HADRIN-DPM
5890 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5891
5892 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5893
5894* number of neutrons
5895 NNEU = NMASS-NCH
5896* initializations
5897 NP = 0
5898 NN = 0
5899 DO 1 K=1,4
5900 PFTOT(K) = 0.0D0
5901 1 CONTINUE
5902 MODE = IMODE
5903 IF (IMODE.GT.2) MODE = 2
5904**sr 29.5. new NPOINT(1)-definition
5905C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5906**
5907 NHADRI = 0
5908 NC = NHKK
5909
5910* get initial configuration
5911 DO 2 I=1,NMASS
5912 NHKK = NHKK+1
5913 IF (JS(I).GT.0) THEN
5914 ISTHKK(NHKK) = 10+MODE
5915 IF (IMODE.EQ.3) THEN
5916* additional treatment if HADRIN-generator is requested
5917 NHADRI = NHADRI+1
5918 IF (NHADRI.EQ.1) IDXTA = NHKK
5919 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5920 ENDIF
5921 ELSE
5922 ISTHKK(NHKK) = 12+MODE
5923 ENDIF
5924 IF (NMASS.GE.2) THEN
5925* treatment for nuclei
5926 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5927 RR = DT_RNDM(FRAC)
5928 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5929 IDX = 8
5930 NN = NN+1
5931 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5932 IDX = 1
5933 NP = NP+1
5934 ELSEIF (NN.LT.NNEU) THEN
5935 IDX = 8
5936 NN = NN+1
5937 ELSEIF (NP.LT.NCH) THEN
5938 IDX = 1
5939 NP = NP+1
5940 ENDIF
5941 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5942 IDBAM(NHKK) = IDX
5943 IF (MODE.EQ.1) THEN
5944 IPOSP(I) = NHKK
5945 KKPROJ(I) = IDX
5946 ELSE
5947 IPOST(I) = NHKK
5948 KKTARG(I) = IDX
5949 ENDIF
5950 IF (IDX.EQ.1) THEN
5951 PFER = PFERMP(MODE)
5952 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5953 ELSE
5954 PFER = PFERMN(MODE)
5955 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5956 ENDIF
5957 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5958 DO 3 K=1,4
5959 PFTOT(K) = PFTOT(K)+PF(K)
5960 PHKK(K,NHKK) = PF(K)
5961 3 CONTINUE
5962 PHKK(5,NHKK) = AAM(IDX)
5963 ELSE
5964* treatment for hadrons
5965 IDHKK(NHKK) = IDT_IPDGHA(ID)
5966 IDBAM(NHKK) = ID
5967 PHKK(4,NHKK) = AAM(ID)
5968 PHKK(5,NHKK) = AAM(ID)
5969C* VDM assumption
5970C IF (IDHKK(NHKK).EQ.22) THEN
5971C PHKK(4,NHKK) = AAM(33)
5972C PHKK(5,NHKK) = AAM(33)
5973C ENDIF
5974 IF (MODE.EQ.1) THEN
5975 IPOSP(I) = NHKK
5976 KKPROJ(I) = ID
5977 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5978 ELSE
5979 IPOST(I) = NHKK
5980 KKTARG(I) = ID
5981 ENDIF
5982 ENDIF
5983 DO 4 K=1,3
5984 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5985 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5986 4 CONTINUE
5987 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5988 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5989 VHKK(4,NHKK) = 0.0D0
5990 WHKK(4,NHKK) = 0.0D0
5991 2 CONTINUE
5992
5993* balance Fermi-momenta
5994 IF (NMASS.GE.2) THEN
5995 DO 5 I=1,NMASS
5996 NC = NC+1
5997 DO 6 K=1,3
5998 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5999 6 CONTINUE
6000 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
6001 & PHKK(2,NC)**2+PHKK(3,NC)**2)
6002 5 CONTINUE
6003 ENDIF
6004
6005 RETURN
6006 END
6007
6008*$ CREATE DT_FER4M.FOR
6009*COPY DT_FER4M
6010*
6011*===fer4m==============================================================*
6012*
6013 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6014
6015************************************************************************
6016* Sampling of nucleon Fermi-momenta from distributions at T=0. *
6017* processed by S. Roesler, 17.10.95 *
6018************************************************************************
6019
6020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6021 SAVE
6022
6023 PARAMETER ( LINP = 10 ,
6024 & LOUT = 6 ,
6025 & LDAT = 9 )
6026
6027 LOGICAL LSTART
6028
6029* particle properties (BAMJET index convention)
6030 CHARACTER*8 ANAME
6031 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6032 & IICH(210),IIBAR(210),K1(210),K2(210)
6033
6034* nuclear potential
6035 LOGICAL LFERMI
6036 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6037 & EBINDP(2),EBINDN(2),EPOT(2,210),
6038 & ETACOU(2),ICOUL,LFERMI
6039
6040 DATA LSTART /.TRUE./
6041
6042 ILOOP = 0
6043 IF (LFERMI) THEN
6044 IF (LSTART) THEN
6045 WRITE(LOUT,1000)
6046 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6047 LSTART = .FALSE.
6048 ENDIF
6049 1 CONTINUE
6050 CALL DT_DFERMI(PABS)
6051 PABS = PFERM*PABS
6052C IF (PABS.GE.PBIND) THEN
6053C ILOOP = ILOOP+1
6054C IF (MOD(ILOOP,500).EQ.0) THEN
6055C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6056C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6057C & ' energy ',2E12.3,I6)
6058C ENDIF
6059C GOTO 1
6060C ENDIF
6061 CALL DT_DPOLI(POLC,POLS)
6062 CALL DT_DSFECF(SFE,CFE)
6063 CXTA = POLS*CFE
6064 CYTA = POLS*SFE
6065 CZTA = POLC
6066 ET = SQRT(PABS*PABS+AAM(KT)**2)
6067 PXT = CXTA*PABS
6068 PYT = CYTA*PABS
6069 PZT = CZTA*PABS
6070 ELSE
6071 ET = AAM(KT)
6072 PXT = 0.0D0
6073 PYT = 0.0D0
6074 PZT = 0.0D0
6075 ENDIF
6076
6077 RETURN
6078 END
6079
6080*$ CREATE DT_NUC2CM.FOR
6081*COPY DT_NUC2CM
6082*
6083*===nuc2cm=============================================================*
6084*
6085 SUBROUTINE DT_NUC2CM
6086
6087************************************************************************
6088* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6089* nucl. cms. (This subroutine replaces NUCMOM.) *
6090* This version dated 15.01.95 is written by S. Roesler *
6091************************************************************************
6092
6093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6094 SAVE
6095
6096 PARAMETER ( LINP = 10 ,
6097 & LOUT = 6 ,
6098 & LDAT = 9 )
6099
6100 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6101
6102* event history
6103
6104 PARAMETER (NMXHKK=200000)
6105
6106 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6107 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6108 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6109
6110* extended event history
6111 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6112 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6113 & IHIST(2,NMXHKK)
6114
6115* statistics
6116 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6117 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6118 & ICEVTG(8,0:30)
6119
6120* properties of photon/lepton projectiles
6121 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6122
6123* particle properties (BAMJET index convention)
6124 CHARACTER*8 ANAME
6125 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6126 & IICH(210),IIBAR(210),K1(210),K2(210)
6127
6128* Glauber formalism: collision properties
6129 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 6130 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
6131 & NCP,NCT
7b076c76 6132**temporary
6133
6134* statistics: Glauber-formalism
6135 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6136**
6137
6138 ICWP = 0
6139 ICWT = 0
6140 NWTACC = 0
6141 NWAACC = 0
6142 NWBACC = 0
6143
6144 NPOINT(1) = NHKK+1
6145 NEND = NHKK
6146 DO 1 I=1,NEND
6147 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6148 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6149 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6150 MODE = ISTHKK(I)-9
6151C IF (IDHKK(I).EQ.22) THEN
6152C* VDM assumption
6153C PEIN = AAM(33)
6154C IDB = 33
6155C ELSE
6156C PEIN = PHKK(4,I)
6157C IDB = IDBAM(I)
6158C ENDIF
6159C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6160C & PX,PY,PZ,PE,IDB,MODE)
6161 IF (PHKK(5,I).GT.ZERO) THEN
6162 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6163 & PX,PY,PZ,PE,IDBAM(I),MODE)
6164 ELSE
6165 PX = PGAMM(1)
6166 PY = PGAMM(2)
6167 PZ = PGAMM(3)
6168 PE = PGAMM(4)
6169 ENDIF
6170 IST = ISTHKK(I)-2
6171 ID = IDHKK(I)
6172C* VDM assumption
6173C IF (ID.EQ.22) ID = 113
6174 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6175 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6176 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6177 ENDIF
6178 1 CONTINUE
6179
6180 NWTACC = MAX(NWAACC,NWBACC)
6181 ICDPR = ICDPR+ICWP
6182 ICDTA = ICDTA+ICWT
6183**temporary
6184 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6185 CALL DT_EVTOUT(4)
6186 STOP
6187 ENDIF
6188
6189 RETURN
6190 END
6191
6192*$ CREATE DT_SPLPTN.FOR
6193*COPY DT_SPLPTN
6194*
6195*===splptn=============================================================*
6196*
6197 SUBROUTINE DT_SPLPTN(NN)
6198
6199************************************************************************
6200* SamPLing of ParToN momenta and flavors. *
6201* This version dated 15.01.95 is written by S. Roesler *
6202************************************************************************
6203
6204 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6205 SAVE
6206
6207 PARAMETER ( LINP = 10 ,
6208 & LOUT = 6 ,
6209 & LDAT = 9 )
6210
6211* Lorentz-parameters of the current interaction
6212 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6213 & UMO,PPCM,EPROJ,PPROJ
6214
6215* sample flavors of sea-quarks
6216 CALL DT_SPLFLA(NN,1)
6217
6218* sample x-values of partons at chain ends
6219 ECM = UMO
6220 CALL DT_XKSAMP(NN,ECM)
6221
6222* samle flavors
6223 CALL DT_SPLFLA(NN,2)
6224
6225 RETURN
6226 END
6227
6228*$ CREATE DT_SPLFLA.FOR
6229*COPY DT_SPLFLA
6230*
6231*===splfla=============================================================*
6232*
6233 SUBROUTINE DT_SPLFLA(NN,MODE)
6234
6235************************************************************************
6236* SamPLing of FLAvors of partons at chain ends. *
6237* This subroutine replaces FLKSAA/FLKSAM. *
6238* NN number of nucleon-nucleon interactions *
6239* MODE = 1 sea-flavors *
6240* = 2 valence-flavors *
6241* Based on the original version written by J. Ranft/H.-J. Moehring. *
6242* This version dated 16.01.95 is written by S. Roesler *
6243************************************************************************
6244
6245 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6246 SAVE
6247
6248 PARAMETER ( LINP = 10 ,
6249 & LOUT = 6 ,
6250 & LDAT = 9 )
6251
6252 PARAMETER ( MAXNCL = 260,
6253
6254 & MAXVQU = MAXNCL,
6255 & MAXSQU = 20*MAXVQU,
6256 & MAXINT = MAXVQU+MAXSQU)
6257
6258* flavors of partons (DTUNUC 1.x)
6259 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6260 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6261 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6262 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6263 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6264 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6265 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6266
6267* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6268 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6269 & IXPV,IXPS,IXTV,IXTS,
6270 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6271 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6272 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6273 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6274 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6275 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6276 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6277 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6278
6279* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6280 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6281 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6282
6283* particle properties (BAMJET index convention)
6284 CHARACTER*8 ANAME
6285 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6286 & IICH(210),IIBAR(210),K1(210),K2(210)
6287
6288* various options for treatment of partons (DTUNUC 1.x)
6289* (chain recombination, Cronin,..)
6290 LOGICAL LCO2CR,LINTPT
6291 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6292 & LCO2CR,LINTPT
6293
6294 IF (MODE.EQ.1) THEN
6295* sea-flavors
6296 DO 1 I=1,NN
6297 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6298 IPSAQ(I) = -IPSQ(I)
6299 1 CONTINUE
6300 DO 2 I=1,NN
6301 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6302 ITSAQ(I)= -ITSQ(I)
6303 2 CONTINUE
6304 ELSEIF (MODE.EQ.2) THEN
6305* valence flavors
6306 DO 3 I=1,IXPV
6307 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6308 3 CONTINUE
6309 DO 4 I=1,IXTV
6310 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6311 4 CONTINUE
6312 ENDIF
6313
6314 RETURN
6315 END
6316
6317*$ CREATE DT_GETPTN.FOR
6318*COPY DT_GETPTN
6319*
6320*===getptn=============================================================*
6321*
6322 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6323
6324************************************************************************
6325* This subroutine collects partons at chain ends from temporary *
6326* commons and puts them into DTEVT1. *
6327* This version dated 15.01.95 is written by S. Roesler *
6328************************************************************************
6329
6330 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6331 SAVE
6332
6333 PARAMETER ( LINP = 10 ,
6334 & LOUT = 6 ,
6335 & LDAT = 9 )
6336
6337 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6338
6339 LOGICAL LCHK
6340
6341 PARAMETER ( MAXNCL = 260,
6342
6343 & MAXVQU = MAXNCL,
6344 & MAXSQU = 20*MAXVQU,
6345 & MAXINT = MAXVQU+MAXSQU)
6346
6347* event history
6348
6349 PARAMETER (NMXHKK=200000)
6350
6351 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6352 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6353 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6354
6355* extended event history
6356 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6357 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6358 & IHIST(2,NMXHKK)
6359
6360* flags for input different options
6361 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6362 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6363 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6364
6365* auxiliary common for chain system storage (DTUNUC 1.x)
6366 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6367
6368* statistics
6369 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6370 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6371 & ICEVTG(8,0:30)
6372
6373* flags for diffractive interactions (DTUNUC 1.x)
6374 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6375
6376* x-values of partons (DTUNUC 1.x)
6377 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6378 & XTVQ(MAXVQU),XTVD(MAXVQU),
6379 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6380 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6381
6382* flavors of partons (DTUNUC 1.x)
6383 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6384 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6385 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6386 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6387 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6388 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6389 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6390
6391* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6392 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6393 & IXPV,IXPS,IXTV,IXTS,
6394 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6395 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6396 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6397 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6398 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6399 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6400 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6401 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6402
6403* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6404 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6405 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6406
6407 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6408
6409 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6410
6411 IREJ = 0
6412 NCSY = 0
6413 NPOINT(2) = NHKK+1
6414
6415* sea-sea chains
6416 DO 10 I=1,NSS
6417 IF (ISKPCH(1,I).EQ.99) GOTO 10
6418 ICCHAI(1,1) = ICCHAI(1,1)+2
6419 IDXP = INTSS1(I)
6420 IDXT = INTSS2(I)
6421 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6422 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6423 DO 11 K=1,4
6424 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6425 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6426 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6427 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6428 11 CONTINUE
6429 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6430 & +(PP1(3)+PT1(3))**2)
6431 ECH = PP1(4)+PT1(4)
6432 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6433 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6434 & +(PP2(3)+PT2(3))**2)
6435 ECH = PP2(4)+PT2(4)
6436 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6437 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6438 AM1 = SQRT(AM1)
6439 AM2 = SQRT(AM2)
6440 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6441C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6442 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6443 ENDIF
6444 ELSE
6445 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6446 ENDIF
6447 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6448 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6449 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6450 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6451 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6452 & 0,0,1)
6453 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6454 & 0,0,1)
6455 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6456 & 0,0,1)
6457 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6458 & 0,0,1)
6459 NCSY = NCSY+1
6460 10 CONTINUE
6461
6462* disea-sea chains
6463 DO 20 I=1,NDS
6464 IF (ISKPCH(2,I).EQ.99) GOTO 20
6465 ICCHAI(1,2) = ICCHAI(1,2)+2
6466 IDXP = INTDS1(I)
6467 IDXT = INTDS2(I)
6468 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6469 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6470 DO 21 K=1,4
6471 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6472 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6473 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6474 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6475 21 CONTINUE
6476 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6477 & +(PP1(3)+PT1(3))**2)
6478 ECH = PP1(4)+PT1(4)
6479 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6480 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6481 & +(PP2(3)+PT2(3))**2)
6482 ECH = PP2(4)+PT2(4)
6483 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6484 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6485 AM1 = SQRT(AM1)
6486 AM2 = SQRT(AM2)
6487 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6488C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6489 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6490 ENDIF
6491 ELSE
6492 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6493 ENDIF
6494 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6495 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6496 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6497 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6498 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6499 & 0,0,2)
6500 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6501 & 0,0,2)
6502 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6503 & 0,0,2)
6504 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6505 & 0,0,2)
6506 NCSY = NCSY+1
6507 20 CONTINUE
6508
6509* sea-disea chains
6510 DO 30 I=1,NSD
6511 IF (ISKPCH(3,I).EQ.99) GOTO 30
6512 ICCHAI(1,3) = ICCHAI(1,3)+2
6513 IDXP = INTSD1(I)
6514 IDXT = INTSD2(I)
6515 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6516 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6517 DO 31 K=1,4
6518 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6519 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6520 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6521 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6522 31 CONTINUE
6523 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6524 & +(PP1(3)+PT1(3))**2)
6525 ECH = PP1(4)+PT1(4)
6526 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6527 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6528 & +(PP2(3)+PT2(3))**2)
6529 ECH = PP2(4)+PT2(4)
6530 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6531 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6532 AM1 = SQRT(AM1)
6533 AM2 = SQRT(AM2)
6534 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6535C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6536 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6537 ENDIF
6538 ELSE
6539 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6540 ENDIF
6541 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6542 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6543 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6544 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6545 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6546 & 0,0,3)
6547 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6548 & 0,0,3)
6549 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6550 & 0,0,3)
6551 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6552 & 0,0,3)
6553 NCSY = NCSY+1
6554 30 CONTINUE
6555
6556* disea-valence chains
6557 DO 50 I=1,NDV
6558 IF (ISKPCH(5,I).EQ.99) GOTO 50
6559 ICCHAI(1,5) = ICCHAI(1,5)+2
6560 IDXP = INTDV1(I)
6561 IDXT = INTDV2(I)
6562 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6563 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6564 DO 51 K=1,4
6565 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6566 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6567 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6568 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6569 51 CONTINUE
6570 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6571 & +(PP1(3)+PT1(3))**2)
6572 ECH = PP1(4)+PT1(4)
6573 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6574 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6575 & +(PP2(3)+PT2(3))**2)
6576 ECH = PP2(4)+PT2(4)
6577 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6578 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6579 AM1 = SQRT(AM1)
6580 AM2 = SQRT(AM2)
6581 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6582C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6583 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6584 ENDIF
6585 ELSE
6586 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6587 ENDIF
6588 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6589 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6590 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6591 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6592 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6593 & 0,0,5)
6594 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6595 & 0,0,5)
6596 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6597 & 0,0,5)
6598 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6599 & 0,0,5)
6600 NCSY = NCSY+1
6601 50 CONTINUE
6602
6603* valence-sea chains
6604 DO 60 I=1,NVS
6605 IF (ISKPCH(6,I).EQ.99) GOTO 60
6606 ICCHAI(1,6) = ICCHAI(1,6)+2
6607 IDXP = INTVS1(I)
6608 IDXT = INTVS2(I)
6609 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6610 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6611 DO 61 K=1,4
6612 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6613 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6614 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6615 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6616 61 CONTINUE
6617 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6618 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6619 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6620 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6621 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6622 IF (LCHK) THEN
6623 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6624 & 0,0,6)
6625 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6626 & 0,0,6)
6627 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6628 & 0,0,6)
6629 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6630 & 0,0,6)
6631 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6632 & +(PP1(3)+PT1(3))**2)
6633 ECH = PP1(4)+PT1(4)
6634 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6635 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6636 & +(PP2(3)+PT2(3))**2)
6637 ECH = PP2(4)+PT2(4)
6638 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6639 ELSE
6640 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6641 & 0,0,6)
6642 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6643 & 0,0,6)
6644 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6645 & 0,0,6)
6646 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6647 & 0,0,6)
6648 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6649 & +(PP1(3)+PT2(3))**2)
6650 ECH = PP1(4)+PT2(4)
6651 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6652 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6653 & +(PP2(3)+PT1(3))**2)
6654 ECH = PP2(4)+PT1(4)
6655 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6656 ENDIF
6657 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6658 AM1 = SQRT(AM1)
6659 AM2 = SQRT(AM2)
6660 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6661C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6662 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6663 ENDIF
6664 ELSE
6665 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6666 ENDIF
6667 NCSY = NCSY+1
6668 60 CONTINUE
6669
6670* sea-valence chains
6671 DO 40 I=1,NSV
6672 IF (ISKPCH(4,I).EQ.99) GOTO 40
6673 ICCHAI(1,4) = ICCHAI(1,4)+2
6674 IDXP = INTSV1(I)
6675 IDXT = INTSV2(I)
6676 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6677 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6678 DO 41 K=1,4
6679 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6680 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6681 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6682 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6683 41 CONTINUE
6684 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6685 & +(PP1(3)+PT1(3))**2)
6686 ECH = PP1(4)+PT1(4)
6687 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6688 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6689 & +(PP2(3)+PT2(3))**2)
6690 ECH = PP2(4)+PT2(4)
6691 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6692 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6693 AM1 = SQRT(AM1)
6694 AM2 = SQRT(AM2)
6695 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6696C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6697 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6698 ENDIF
6699 ELSE
6700 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6701 ENDIF
6702 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6703 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6704 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6705 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6706 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6707 & 0,0,4)
6708 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6709 & 0,0,4)
6710 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6711 & 0,0,4)
6712 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6713 & 0,0,4)
6714 NCSY = NCSY+1
6715 40 CONTINUE
6716
6717* valence-disea chains
6718 DO 70 I=1,NVD
6719 IF (ISKPCH(7,I).EQ.99) GOTO 70
6720 ICCHAI(1,7) = ICCHAI(1,7)+2
6721 IDXP = INTVD1(I)
6722 IDXT = INTVD2(I)
6723 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6724 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6725 DO 71 K=1,4
6726 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6727 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6728 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6729 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6730 71 CONTINUE
6731 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6732 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6733 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6734 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6735 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6736 IF (LCHK) THEN
6737 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6738 & 0,0,7)
6739 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6740 & 0,0,7)
6741 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6742 & 0,0,7)
6743 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6744 & 0,0,7)
6745 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6746 & +(PP1(3)+PT1(3))**2)
6747 ECH = PP1(4)+PT1(4)
6748 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6749 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6750 & +(PP2(3)+PT2(3))**2)
6751 ECH = PP2(4)+PT2(4)
6752 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6753 ELSE
6754 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6755 & 0,0,7)
6756 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6757 & 0,0,7)
6758 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6759 & 0,0,7)
6760 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6761 & 0,0,7)
6762 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6763 & +(PP1(3)+PT2(3))**2)
6764 ECH = PP1(4)+PT2(4)
6765 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6766 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6767 & +(PP2(3)+PT1(3))**2)
6768 ECH = PP2(4)+PT1(4)
6769 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6770 ENDIF
6771 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6772 AM1 = SQRT(AM1)
6773 AM2 = SQRT(AM2)
6774 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6775C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6776 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6777 ENDIF
6778 ELSE
6779 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6780 ENDIF
6781 NCSY = NCSY+1
6782 70 CONTINUE
6783
6784* valence-valence chains
6785 DO 80 I=1,NVV
6786 IF (ISKPCH(8,I).EQ.99) GOTO 80
6787 ICCHAI(1,8) = ICCHAI(1,8)+2
6788 IDXP = INTVV1(I)
6789 IDXT = INTVV2(I)
6790 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6791 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6792 DO 81 K=1,4
6793 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6794 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6795 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6796 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6797 81 CONTINUE
6798 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6799 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6800 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6801 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6802
6803* check for diffractive event
6804 IDIFF = 0
6805 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6806 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6807 DO 800 K=1,4
6808 PP(K) = PP1(K)+PP2(K)
6809 PT(K) = PT1(K)+PT2(K)
6810 800 CONTINUE
6811 ISTCK = NHKK
6812 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6813 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6814C IF (IREJ1.NE.0) GOTO 9999
6815 IF (IREJ1.NE.0) THEN
6816 IDIFF = 0
6817 NHKK = ISTCK
6818 ENDIF
6819 ELSE
6820 IDIFF = 0
6821 ENDIF
6822
6823 IF (IDIFF.EQ.0) THEN
6824* valence-valence chain system
6825 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6826 IF (LCHK) THEN
6827* baryon-baryon
6828 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6829 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6830 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6831 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6832 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6833 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6834 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6835 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6836 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6837 & +(PP1(3)+PT1(3))**2)
6838 ECH = PP1(4)+PT1(4)
6839 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6840 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6841 & +(PP2(3)+PT2(3))**2)
6842 ECH = PP2(4)+PT2(4)
6843 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6844 ELSE
6845* antibaryon-baryon
6846 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6847 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6848 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6849 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6850 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6851 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6852 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6853 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6854 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6855 & +(PP1(3)+PT2(3))**2)
6856 ECH = PP1(4)+PT2(4)
6857 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6858 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6859 & +(PP2(3)+PT1(3))**2)
6860 ECH = PP2(4)+PT1(4)
6861 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6862 ENDIF
6863 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6864 AM1 = SQRT(AM1)
6865 AM2 = SQRT(AM2)
6866 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6867C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6868 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6869 ENDIF
6870 ELSE
6871 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6872 ENDIF
6873 NCSY = NCSY+1
6874 ENDIF
6875 80 CONTINUE
6876 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6877
6878* energy-momentum & flavor conservation check
6879 IF (ABS(IDIFF).NE.1) THEN
6880 IF (IDIFF.NE.0) THEN
6881 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6882 & 1,3,10,IREJ)
6883 ELSE
6884 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6885 & 1,3,10,IREJ)
6886 ENDIF
6887 IF (IREJ.NE.0) THEN
6888 CALL DT_EVTOUT(4)
6889 STOP
6890 ENDIF
6891 ENDIF
6892
6893 RETURN
6894
6895 9999 CONTINUE
6896 IREJ = 1
6897 RETURN
6898 END
6899
6900*$ CREATE DT_CHKCSY.FOR
6901*COPY DT_CHKCSY
6902*
6903*===chkcsy=============================================================*
6904*
6905 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6906
6907************************************************************************
6908* CHeCk Chain SYstem for consistency of partons at chain ends. *
6909* ID1,ID2 PDG-numbers of partons at chain ends *
6910* LCHK = .true. consistent chain *
6911* = .false. inconsistent chain *
6912* This version dated 18.01.95 is written by S. Roesler *
6913************************************************************************
6914
6915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6916 SAVE
6917
6918 PARAMETER ( LINP = 10 ,
6919 & LOUT = 6 ,
6920 & LDAT = 9 )
6921
6922 LOGICAL LCHK
6923
6924 LCHK = .TRUE.
6925
6926* q-aq chain
6927 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6928 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6929* q-qq, aq-aqaq chain
6930 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6931 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6932 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6933* qq-aqaq chain
6934 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6935 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6936 ENDIF
6937
6938 RETURN
6939 END
6940
6941*$ CREATE DT_EVENTA.FOR
6942*COPY DT_EVENTA
6943*
6944*===eventa=============================================================*
6945*
6946 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6947
6948************************************************************************
6949* Treatment of nucleon-nucleon interactions in a two-chain *
6950* approximation. *
6951* (input) ID BAMJET-index of projectile hadron (in case of *
6952* h-K scattering) *
6953* IP/IT mass number of projectile/target nucleus *
6954* NCSY number of two chain systems *
6955* IREJ rejection flag *
6956* This version dated 15.01.95 is written by S. Roesler *
6957************************************************************************
6958
6959 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6960 SAVE
6961
6962 PARAMETER ( LINP = 10 ,
6963 & LOUT = 6 ,
6964 & LDAT = 9 )
6965
6966 PARAMETER (TINY10=1.0D-10)
6967
6968* event history
6969
6970 PARAMETER (NMXHKK=200000)
6971
6972 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6973 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6974 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6975
6976* extended event history
6977 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6978 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6979 & IHIST(2,NMXHKK)
6980
6981* rejection counter
6982 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6983 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6984 & IREXCI(3),IRDIFF(2),IRINC
6985
6986* flags for diffractive interactions (DTUNUC 1.x)
6987 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6988
6989* particle properties (BAMJET index convention)
6990 CHARACTER*8 ANAME
6991 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6992 & IICH(210),IIBAR(210),K1(210),K2(210)
6993
6994* flags for input different options
6995 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6996 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6997 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6998
6999* various options for treatment of partons (DTUNUC 1.x)
7000* (chain recombination, Cronin,..)
7001 LOGICAL LCO2CR,LINTPT
7002 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7003 & LCO2CR,LINTPT
7004
7005 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7006
7007 IREJ = 0
7008 NPOINT(3) = NHKK+1
7009
7010* skip following treatment for low-mass diffraction
7011 IF (ABS(IFLAGD).EQ.1) THEN
7012 NPOINT(3) = NPOINT(2)
7013 GOTO 5
7014 ENDIF
7015
7016* multiple scattering of chain ends
7017 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7018 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7019
7020 NC = NPOINT(2)
7021* get a two-chain system from DTEVT1
7022 DO 3 I=1,NCSY
7023 IFP1 = IDHKK(NC)
7024 IFT1 = IDHKK(NC+1)
7025 IFP2 = IDHKK(NC+2)
7026 IFT2 = IDHKK(NC+3)
7027 DO 4 K=1,4
7028 PP1(K) = PHKK(K,NC)
7029 PT1(K) = PHKK(K,NC+1)
7030 PP2(K) = PHKK(K,NC+2)
7031 PT2(K) = PHKK(K,NC+3)
7032 4 CONTINUE
7033 MOP1 = NC
7034 MOT1 = NC+1
7035 MOP2 = NC+2
7036 MOT2 = NC+3
7037 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7038 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7039 IF (IREJ1.GT.0) THEN
7040 IRHHA = IRHHA+1
7041 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7042 GOTO 9999
7043 ENDIF
7044 NC = NC+4
7045 3 CONTINUE
7046
7047* meson/antibaryon projectile:
7048* sample single-chain valence-valence systems (Reggeon contrib.)
7049 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7050 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7051 ENDIF
7052
7053 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7054* check DTEVT1 for remaining resonance mass corrections
7055 CALL DT_EVTRES(IREJ1)
7056 IF (IREJ1.GT.0) THEN
7057 IRRES(1) = IRRES(1)+1
7058 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7059 GOTO 9999
7060 ENDIF
7061 ENDIF
7062
7063* assign p_t to two-"chain" systems consisting of two resonances only
7064* since only entries for chains will be affected, this is obsolete
7065* in case of JETSET-fragmetation
7066 CALL DT_RESPT
7067
7068* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7069 IF (LCO2CR) CALL DT_COM2CR
7070
7071 5 CONTINUE
7072
7073* fragmentation of the complete event
7074**uncomment for internal phojet-fragmentation
7075C CALL DT_EVTFRA(IREJ1)
7076 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7077 IF (IREJ1.GT.0) THEN
7078 IRFRAG = IRFRAG+1
7079 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7080 GOTO 9999
7081 ENDIF
7082
7083* decay of possible resonances (should be obsolete)
7084 CALL DT_DECAY1
7085
7086 RETURN
7087
7088 9999 CONTINUE
7089 IREVT = IREVT+1
7090 IREJ = 1
7091 RETURN
7092 END
7093
7094*$ CREATE DT_GETCSY.FOR
7095*COPY DT_GETCSY
7096*
7097*===getcsy=============================================================*
7098*
7099 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7100 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7101
7102************************************************************************
7103* This version dated 15.01.95 is written by S. Roesler *
7104************************************************************************
7105
7106 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7107 SAVE
7108
7109 PARAMETER ( LINP = 10 ,
7110 & LOUT = 6 ,
7111 & LDAT = 9 )
7112
7113 PARAMETER (TINY10=1.0D-10)
7114
7115* event history
7116
7117 PARAMETER (NMXHKK=200000)
7118
7119 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7120 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7121 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7122
7123* extended event history
7124 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7125 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7126 & IHIST(2,NMXHKK)
7127
7128* rejection counter
7129 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7130 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7131 & IREXCI(3),IRDIFF(2),IRINC
7132
7133* flags for input different options
7134 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7135 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7136 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7137
7138* flags for diffractive interactions (DTUNUC 1.x)
7139 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7140
7141 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7142 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7143
7144 IREJ = 0
7145
7146* get quark content of partons
7147 DO 1 I=1,2
7148 IFP1(I) = 0
7149 IFP2(I) = 0
7150 IFT1(I) = 0
7151 IFT2(I) = 0
7152 1 CONTINUE
7153 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7154 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7155 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7156 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7157 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7158 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7159 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7160 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7161
7162* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7163 IDCH1 = 2
7164 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7165 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7166 IDCH2 = 2
7167 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7168 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7169
7170* store initial configuration for energy-momentum cons. check
7171 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7172
7173* sample intrinsic p_t at chain-ends
7174 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7175 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7176 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7177 IF (IREJ1.NE.0) THEN
7178 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7179 IRPT = IRPT+1
7180 GOTO 9999
7181 ENDIF
7182
7183C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7184C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7185C* check second chain for resonance
7186C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7187C & AMCH2,AMCH2N,IDCH2,IREJ1)
7188C IF (IREJ1.NE.0) GOTO 9999
7189C IF (IDR2.NE.0) THEN
7190C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7191C & AMCH2,AMCH2N,AMCH1,IREJ1)
7192C IF (IREJ1.NE.0) GOTO 9999
7193C ENDIF
7194C* check first chain for resonance
7195C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7196C & AMCH1,AMCH1N,IDCH1,IREJ1)
7197C IF (IREJ1.NE.0) GOTO 9999
7198C IF (IDR1.NE.0) IDR1 = 100*IDR1
7199C ELSE
7200C* check first chain for resonance
7201C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7202C & AMCH1,AMCH1N,IDCH1,IREJ1)
7203C IF (IREJ1.NE.0) GOTO 9999
7204C IF (IDR1.NE.0) THEN
7205C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7206C & AMCH1,AMCH1N,AMCH2,IREJ1)
7207C IF (IREJ1.NE.0) GOTO 9999
7208C ENDIF
7209C* check second chain for resonance
7210C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7211C & AMCH2,AMCH2N,IDCH2,IREJ1)
7212C IF (IREJ1.NE.0) GOTO 9999
7213C IF (IDR2.NE.0) IDR2 = 100*IDR2
7214C ENDIF
7215C ENDIF
7216
7217 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7218* check chains for resonances
7219 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7220 & AMCH1,AMCH1N,IDCH1,IREJ1)
7221 IF (IREJ1.NE.0) GOTO 9999
7222 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7223 & AMCH2,AMCH2N,IDCH2,IREJ1)
7224 IF (IREJ1.NE.0) GOTO 9999
7225* change kinematics corresponding to resonance-masses
7226 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7227 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7228 & AMCH1,AMCH1N,AMCH2,IREJ1)
7229 IF (IREJ1.GT.0) GOTO 9999
7230 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7231 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7232 & AMCH2,AMCH2N,IDCH2,IREJ1)
7233 IF (IREJ1.NE.0) GOTO 9999
7234 IF (IDR2.NE.0) IDR2 = 100*IDR2
7235 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7236 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7237 & AMCH2,AMCH2N,AMCH1,IREJ1)
7238 IF (IREJ1.GT.0) GOTO 9999
7239 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7240 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7241 & AMCH1,AMCH1N,IDCH1,IREJ1)
7242 IF (IREJ1.NE.0) GOTO 9999
7243 IF (IDR1.NE.0) IDR1 = 100*IDR1
7244 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7245 AMDIF1 = ABS(AMCH1-AMCH1N)
7246 AMDIF2 = ABS(AMCH2-AMCH2N)
7247 IF (AMDIF2.LT.AMDIF1) THEN
7248 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7249 & AMCH2,AMCH2N,AMCH1,IREJ1)
7250 IF (IREJ1.GT.0) GOTO 9999
7251 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7252 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7253 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7254 IF (IREJ1.NE.0) GOTO 9999
7255 IF (IDR1.NE.0) IDR1 = 100*IDR1
7256 ELSE
7257 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7258 & AMCH1,AMCH1N,AMCH2,IREJ1)
7259 IF (IREJ1.GT.0) GOTO 9999
7260 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7261 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7262 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7263 IF (IREJ1.NE.0) GOTO 9999
7264 IF (IDR2.NE.0) IDR2 = 100*IDR2
7265 ENDIF
7266 ENDIF
7267 ENDIF
7268
7269* store final configuration for energy-momentum cons. check
7270 IF (LEMCCK) THEN
7271 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7272 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7273 IF (IREJ1.NE.0) GOTO 9999
7274 ENDIF
7275
7276* put partons and chains into DTEVT1
7277 DO 10 I=1,4
7278 PCH1(I) = PP1(I)+PT1(I)
7279 PCH2(I) = PP2(I)+PT2(I)
7280 10 CONTINUE
7281 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7282 & PP1(3),PP1(4),0,0,0)
7283 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7284 & PT1(3),PT1(4),0,0,0)
7285 KCH = 100+IDCH(MOP1)*10+1
7286 CALL DT_EVTPUT(KCH,88888,-2,-1,
7287 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7288 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7289 & PP2(3),PP2(4),0,0,0)
7290 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7291 & PT2(3),PT2(4),0,0,0)
7292 KCH = KCH+1
7293 CALL DT_EVTPUT(KCH,88888,-2,-1,
7294 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7295
7296 RETURN
7297
7298 9999 CONTINUE
7299 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7300* "cancel" sea-sea chains
7301 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7302 IF (IREJ1.NE.0) GOTO 9998
7303**sr 16.5. flag for EVENTB
7304 IREJ = -1
7305 RETURN
7306 ENDIF
7307 9998 CONTINUE
7308 IREJ = 1
7309 RETURN
7310 END
7311
7312*$ CREATE DT_CHKINE.FOR
7313*COPY DT_CHKINE
7314*
7315*===chkine=============================================================*
7316*
7317 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7318 & AMCH1,AMCH1N,AMCH2,IREJ)
7319
7320************************************************************************
7321* This subroutine replaces CORMOM. *
7322* This version dated 05.01.95 is written by S. Roesler *
7323************************************************************************
7324
7325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7326 SAVE
7327
7328 PARAMETER ( LINP = 10 ,
7329 & LOUT = 6 ,
7330 & LDAT = 9 )
7331
7332 PARAMETER (TINY10=1.0D-10)
7333
7334* flags for input different options
7335 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7336 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7337 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7338
7339* rejection counter
7340 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7341 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7342 & IREXCI(3),IRDIFF(2),IRINC
7343
7344 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7345 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7346
7347 IREJ = 0
7348 JMSHL = IMSHL
7349
7350 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7351 DO 10 I=1,4
7352 PP1(I) = PP1I(I)
7353 PP2(I) = PP2I(I)
7354 PT1(I) = PT1I(I)
7355 PT2(I) = PT2I(I)
7356 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7357 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7358 PP1(I) = SCALE*PP1(I)
7359 PT1(I) = SCALE*PT1(I)
7360 10 CONTINUE
7361 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7362 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7363
7364 ECH = PP2(4)+PT2(4)
7365 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7366 & (PP2(3)+PT2(3))**2 )
7367 AMCH22 = (ECH-PCH)*(ECH+PCH)
7368 IF (AMCH22.LT.0.0D0) THEN
7369 IF (IOULEV(1).GT.0)
7370 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7371 GOTO 9997
7372 ENDIF
7373
7374 AMCH1 = AMCH1N
7375 AMCH2 = SQRT(AMCH22)
7376
7377* put partons again on mass shell
7378 13 CONTINUE
7379 XM1 = 0.0D0
7380 XM2 = 0.0D0
7381 IF (JMSHL.EQ.1) THEN
7382
7383 XM1 = PYMASS(IFP1)
7384 XM2 = PYMASS(IFT1)
7385
7386 ENDIF
7387 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7388 IF (IREJ1.NE.0) THEN
7389 IF (JMSHL.EQ.0) GOTO 9998
7390 JMSHL = 0
7391 GOTO 13
7392 ENDIF
7393 JMSHL = IMSHL
7394 DO 11 I=1,4
7395 PP1(I) = P1(I)
7396 PT1(I) = P2(I)
7397 11 CONTINUE
7398 14 CONTINUE
7399 XM1 = 0.0D0
7400 XM2 = 0.0D0
7401 IF (JMSHL.EQ.1) THEN
7402
7403 XM1 = PYMASS(IFP2)
7404 XM2 = PYMASS(IFT2)
7405
7406 ENDIF
7407 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7408 IF (IREJ1.NE.0) THEN
7409 IF (JMSHL.EQ.0) GOTO 9998
7410 JMSHL = 0
7411 GOTO 14
7412 ENDIF
7413 DO 12 I=1,4
7414 PP2(I) = P1(I)
7415 PT2(I) = P2(I)
7416 12 CONTINUE
7417 DO 15 I=1,4
7418 PP1I(I) = PP1(I)
7419 PP2I(I) = PP2(I)
7420 PT1I(I) = PT1(I)
7421 PT2I(I) = PT2(I)
7422 15 CONTINUE
7423 RETURN
7424
7425 9997 IRCHKI(1) = IRCHKI(1)+1
7426**sr
7427C GOTO 9999
7428 IREJ = -1
7429 RETURN
7430**
7431 9998 IRCHKI(2) = IRCHKI(2)+1
7432
7433 9999 CONTINUE
7434 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7435 IREJ = 1
7436 RETURN
7437 END
7438
7439*$ CREATE DT_CH2RES.FOR
7440*COPY DT_CH2RES
7441*
7442*===ch2res=============================================================*
7443*
7444 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7445 & AM,AMN,IMODE,IREJ)
7446
7447************************************************************************
7448* Check chains for resonance production. *
7449* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7450* input: *
7451* IF1,2,3,4 input flavors (q,aq in any order) *
7452* AM chain mass *
7453* MODE = 1 check q-aq chain for meson-resonance *
7454* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7455* = 3 check qq-aqaq chain for lower mass cut *
7456* output: *
7457* IDR = 0 no resonances found *
7458* = -1 pseudoscalar meson/octet baryon *
7459* = 1 vector-meson/decuplet baryon *
7460* IDXR BAMJET-index of corresponding resonance *
7461* AMN mass of corresponding resonance *
7462* *
7463* IREJ rejection flag *
7464* This version dated 06.01.95 is written by S. Roesler *
7465************************************************************************
7466
7467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7468 SAVE
7469
7470 PARAMETER ( LINP = 10 ,
7471 & LOUT = 6 ,
7472 & LDAT = 9 )
7473
7474* particle properties (BAMJET index convention)
7475 CHARACTER*8 ANAME
7476 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7477 & IICH(210),IIBAR(210),K1(210),K2(210)
7478
7479* quark-content to particle index conversion (DTUNUC 1.x)
7480 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7481 & IA08(6,21),IA10(6,21)
7482
7483* rejection counter
7484 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7485 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7486 & IREXCI(3),IRDIFF(2),IRINC
7487
7488* flags for input different options
7489 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7490 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7491 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7492
7493 DIMENSION IF(4),JF(4)
7494
7495**sr 4.7. test
7496C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7497 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7498**
7499C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7500
7501 MODE = ABS(IMODE)
7502
7503 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7504 WRITE(LOUT,1000) MODE
7505 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7506 & 1X,' program stopped')
7507 STOP
7508 ENDIF
7509
7510 AMX = AM
7511 IREJ = 0
7512 IDR = 0
7513 IDXR = 0
7514 AMN = AMX
7515 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7516 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7517
7518 IF(1) = IF1
7519 IF(2) = IF2
7520 IF(3) = IF3
7521 IF(4) = IF4
7522 NF = 0
7523 DO 100 I=1,4
7524 IF (IF(I).NE.0) THEN
7525 NF = NF+1
7526 JF(NF) = IF(I)
7527 ENDIF
7528 100 CONTINUE
7529 IF (NF.LE.MODE) THEN
7530 WRITE(LOUT,1001) MODE,IF
7531 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7532 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7533 GOTO 9999
7534 ENDIF
7535
7536 GOTO (1,2,3) MODE
7537
7538* check for meson resonance
7539 1 CONTINUE
7540 IFQ = JF(1)
7541 IFAQ = ABS(JF(2))
7542 IF (JF(2).GT.0) THEN
7543 IFQ = JF(2)
7544 IFAQ = ABS(JF(1))
7545 ENDIF
7546 IFPS = IMPS(IFAQ,IFQ)
7547 IFV = IMVE(IFAQ,IFQ)
7548 AMPS = AAM(IFPS)
7549 AMV = AAM(IFV)
7550 AMHI = AMV+0.3D0
7551 IF (AMX.LT.AMV) THEN
7552 IF (AMX.LT.AMPS) THEN
7553 IF (IMODE.GT.0) THEN
7554 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7555 ELSE
7556 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7557 ENDIF
7558 LOMRES = LOMRES+1
7559 ENDIF
7560* replace chain by pseudoscalar meson
7561 IDR = -1
7562 IDXR = IFPS
7563 AMN = AMPS
7564 ELSEIF (AMX.LT.AMHI) THEN
7565* replace chain by vector-meson
7566 IDR = 1
7567 IDXR = IFV
7568 AMN = AMV
7569 ENDIF
7570 RETURN
7571
7572* check for baryon resonance
7573 2 CONTINUE
7574 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7575 AM8 = AAM(JB8)
7576 AM10 = AAM(JB10)
7577 AMHI = AM10+0.3D0
7578 IF (AMX.LT.AM10) THEN
7579 IF (AMX.LT.AM8) THEN
7580 IF (IMODE.GT.0) THEN
7581 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7582 ELSE
7583 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7584 ENDIF
7585 LOBRES = LOBRES+1
7586 ENDIF
7587* replace chain by oktet baryon
7588 IDR = -1
7589 IDXR = JB8
7590 AMN = AM8
7591 ELSEIF (AMX.LT.AMHI) THEN
7592 IDR = 1
7593 IDXR = JB10
7594 AMN = AM10
7595 ENDIF
7596 RETURN
7597
7598* check qq-aqaq for lower mass cut
7599 3 CONTINUE
7600* empirical definition of AMHI to allow for (b-antib)-pair prod.
7601 AMHI = 2.5D0
7602 IF (AMX.LT.AMHI) GOTO 9999
7603 RETURN
7604
7605 9999 CONTINUE
7606 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7607 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7608 IREJ = 1
7609 IRRES(2) = IRRES(2)+1
7610 RETURN
7611 END
7612
7613*$ CREATE DT_RJSEAC.FOR
7614*COPY DT_RJSEAC
7615*
7616*===rjseac=============================================================*
7617*
7618 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7619
7620************************************************************************
7621* ReJection of SEA-sea Chains. *
7622* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7623* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7624* This version dated 16.01.95 is written by S. Roesler *
7625************************************************************************
7626
7627 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7628 SAVE
7629
7630 PARAMETER ( LINP = 10 ,
7631 & LOUT = 6 ,
7632 & LDAT = 9 )
7633
7634 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7635
7636* event history
7637
7638 PARAMETER (NMXHKK=200000)
7639
7640 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7641 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7642 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7643
7644* extended event history
7645 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7646 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7647 & IHIST(2,NMXHKK)
7648
7649* statistics
7650 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7651 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7652 & ICEVTG(8,0:30)
7653
7654 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7655
7656 IREJ = 0
7657
7658* projectile sea q-aq-pair
7659* indices of sea-pair
7660 IDXSEA(1,1) = MOP1
7661 IDXSEA(1,2) = MOP2
7662* index of mother-nucleon
7663 IDXNUC(1) = JMOHKK(1,MOP1)
7664* status of valence quarks to be corrected
7665 ISTVAL(1) = -21
7666
7667* target sea q-aq-pair
7668* indices of sea-pair
7669 IDXSEA(2,1) = MOT1
7670 IDXSEA(2,2) = MOT2
7671* index of mother-nucleon
7672 IDXNUC(2) = JMOHKK(1,MOT1)
7673* status of valence quarks to be corrected
7674 ISTVAL(2) = -22
7675
7676 DO 1 N=1,2
7677 IDONE = 0
7678 DO 2 I=NPOINT(2),NHKK
7679 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7680 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7681* valence parton found
7682* inrease 4-momentum by sea 4-momentum
7683 DO 3 K=1,4
7684 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7685 & PHKK(K,IDXSEA(N,2))
7686 3 CONTINUE
7687 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7688 & PHKK(2,I)**2-PHKK(3,I)**2))
7689* "cancel" sea-pair
7690 DO 4 J=1,2
7691 ISTHKK(IDXSEA(N,J)) = 100
7692 IDHKK(IDXSEA(N,J)) = 0
7693 JMOHKK(1,IDXSEA(N,J)) = 0
7694 JMOHKK(2,IDXSEA(N,J)) = 0
7695 JDAHKK(1,IDXSEA(N,J)) = 0
7696 JDAHKK(2,IDXSEA(N,J)) = 0
7697 DO 5 K=1,4
7698 PHKK(K,IDXSEA(N,J)) = ZERO
7699 VHKK(K,IDXSEA(N,J)) = ZERO
7700 WHKK(K,IDXSEA(N,J)) = ZERO
7701 5 CONTINUE
7702 PHKK(5,IDXSEA(N,J)) = ZERO
7703 4 CONTINUE
7704 IDONE = 1
7705 ENDIF
7706 2 CONTINUE
7707 IF (IDONE.NE.1) THEN
7708 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7709 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7710 & '-record!',/,1X,' sea-quark pairs ',
7711 & 2I5,4X,2I5,' could not be canceled!')
7712 GOTO 9999
7713 ENDIF
7714 1 CONTINUE
7715 ICRJSS = ICRJSS+1
7716 RETURN
7717
7718 9999 CONTINUE
7719 IREJ = 1
7720 RETURN
7721 END
7722
7723*$ CREATE DT_VV2SCH.FOR
7724*COPY DT_VV2SCH
7725*
7726*===vv2sch=============================================================*
7727*
7728 SUBROUTINE DT_VV2SCH
7729
7730************************************************************************
7731* Change Valence-Valence chain systems to Single CHain systems for *
7732* hadron-nucleus collisions with meson or antibaryon projectile. *
7733* (Reggeon contribution) *
7734* The single chain system is approximately treated as one chain and a *
7735* meson at rest. *
7736* This version dated 18.01.95 is written by S. Roesler *
7737************************************************************************
7738
7739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7740 SAVE
7741
7742 PARAMETER ( LINP = 10 ,
7743 & LOUT = 6 ,
7744 & LDAT = 9 )
7745
7746 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7747
7748 LOGICAL LSTART
7749
7750* event history
7751
7752 PARAMETER (NMXHKK=200000)
7753
7754 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7755 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7756 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7757
7758* extended event history
7759 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7760 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7761 & IHIST(2,NMXHKK)
7762
7763* flags for input different options
7764 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7765 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7766 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7767
7768* statistics
7769 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7770 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7771 & ICEVTG(8,0:30)
7772
7773 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7774 & PCH2(4)
7775
7776 DATA LSTART /.TRUE./
7777
7778 IFSC = 0
7779 IF (LSTART) THEN
7780 WRITE(LOUT,1000)
7781 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7782 & 'valence chains treated')
7783 LSTART = .FALSE.
7784 ENDIF
7785
7786 NSTOP = NHKK
7787
7788* get index of first chain
7789 DO 1 I=NPOINT(3),NHKK
7790 IF (IDHKK(I).EQ.88888) THEN
7791 NC = I
7792 GOTO 2
7793 ENDIF
7794 1 CONTINUE
7795
7796 2 CONTINUE
7797 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7798 & .AND.(NC.LT.NSTOP)) THEN
7799* get valence-valence chains
7800 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7801* get "mother"-hadron indices
7802 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7803 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7804 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7805 KTARG = IDT_ICIHAD(IDHKK(MO2))
7806* Lab momentum of projectile hadron
7807 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7808 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7809 & PHKK(3,MO1)**2)
7810
7811 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7812 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7813 ICVV2S = ICVV2S+1
7814* single chain requested
7815* get flavors of chain-end partons
7816 MO(1) = JMOHKK(1,NC)
7817 MO(2) = JMOHKK(2,NC)
7818 MO(3) = JMOHKK(1,NC+3)
7819 MO(4) = JMOHKK(2,NC+3)
7820 DO 3 I=1,4
7821 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7822 IF(I,2) = 0
7823 IF (ABS(IDHKK(MO(I))).GE.1000)
7824 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7825 3 CONTINUE
7826* which one is the q-aq chain?
7827* N1,N1+1 - DTEVT1-entries for q-aq system
7828* N2,N2+1 - DTEVT1-entries for the other chain
7829 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7830 K1 = 1
7831 K2 = 3
7832 N1 = NC-2
7833 N2 = NC+1
7834 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7835 K1 = 3
7836 K2 = 1
7837 N1 = NC+1
7838 N2 = NC-2
7839 ELSE
7840 GOTO 10
7841 ENDIF
7842 DO 4 K=1,4
7843 PP1(K) = PHKK(K,N1)
7844 PT1(K) = PHKK(K,N1+1)
7845 PP2(K) = PHKK(K,N2)
7846 PT2(K) = PHKK(K,N2+1)
7847 4 CONTINUE
7848 AMCH1 = PHKK(5,N1+2)
7849 AMCH2 = PHKK(5,N2+2)
7850* get meson-identity corresponding to flavors of q-aq chain
7851 ITMP = IRESRJ
7852 IRESRJ = 0
7853 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7854 & ZERO,AMCH1N,1,IDUM)
7855 IRESRJ = ITMP
7856* change kinematics of chains
7857 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7858 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7859 & AMCH1,AMCH1N,AMCH2,IREJ1)
7860 IF (IREJ1.NE.0) GOTO 10
7861* check second chain for resonance
7862 IDCHAI = 2
7863 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7864 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7865 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7866 IF (IREJ1.NE.0) GOTO 10
7867 IF (IDR2.NE.0) IDR2 = 100*IDR2
7868* add partons and chains to DTEVT1
7869 DO 5 K=1,4
7870 PCH1(K) = PP1(K)+PT1(K)
7871 PCH2(K) = PP2(K)+PT2(K)
7872 5 CONTINUE
7873 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7874 & PP1(3),PP1(4),0,0,0)
7875 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7876 & PT1(2),PT1(3),PT1(4),0,0,0)
7877 KCH = ISTHKK(N1+2)+100
7878 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7879 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7880 IDHKK(N1+2) = 22222
7881 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7882 & PP2(3),PP2(4),0,0,0)
7883 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7884 & PT2(2),PT2(3),PT2(4),0,0,0)
7885 KCH = ISTHKK(N2+2)+100
7886 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7887 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7888 IDHKK(N2+2) = 22222
7889 ENDIF
7890 ENDIF
7891 ELSE
7892 GOTO 11
7893 ENDIF
7894 10 CONTINUE
7895 NC = NC+6
7896 GOTO 2
7897
7898 11 CONTINUE
7899
7900 RETURN
7901 END
7902
7903*$ CREATE DT_PHNSCH.FOR
7904*COPY DT_PHNSCH
7905*
7906*=== phnsch ===========================================================*
7907*
7908 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7909
7910*----------------------------------------------------------------------*
7911* *
7912* Probability for Hadron Nucleon Single CHain interactions: *
7913* *
7914* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7915* Infn - Milan *
7916* *
7917* Last change on 04-jan-94 by Alfredo Ferrari *
7918* *
7919* modified by J.R.for use in DTUNUC 6.1.94 *
7920* *
7921* Input variables: *
7922* Kp = hadron projectile index (Part numbering *
7923* scheme) *
7924* Ktarg = target nucleon index (1=proton, 8=neutron) *
7925* Plab = projectile laboratory momentum (GeV/c) *
7926* Output variable: *
7927* Phnsch = probability per single chain (particle *
7928* exchange) interactions *
7929* *
7930*----------------------------------------------------------------------*
7931
7932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7933 SAVE
7934
7935 PARAMETER ( LUNOUT = 6 )
7936 PARAMETER ( LUNERR = 6 )
7937 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7938 PARAMETER ( ZERZER = 0.D+00 )
7939 PARAMETER ( ONEONE = 1.D+00 )
7940 PARAMETER ( TWOTWO = 2.D+00 )
7941 PARAMETER ( FIVFIV = 5.D+00 )
7942 PARAMETER ( HLFHLF = 0.5D+00 )
7943
7944 PARAMETER ( NALLWP = 39 )
7945 PARAMETER ( IDMAXP = 210 )
7946
7947 DIMENSION ICHRGE(39),AM(39)
7948
7949* particle properties (BAMJET index convention)
7950 CHARACTER*8 ANAME
7951 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7952 & IICH(210),IIBAR(210),K1(210),K2(210)
7953
7954 DIMENSION KPTOIP(210)
7955
7956* auxiliary common for reggeon exchange (DTUNUC 1.x)
7957 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7958 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7959 & IQTCHR(-6:6),MQUARK(3,39)
7960
7961 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7962 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7963 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7964 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7965 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7966
7967* Conversion from part to paprop numbering
7968 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7969 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7970 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7971
7972* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7973 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7974 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7975C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7976 DATA SGTCO1 /
7977* 1st reaction: gamma p total
7978 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7979* 2nd reaction: gamma d total
7980 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7981* 3rd reaction: pi+ p total
7982 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7983* 4th reaction: pi- p total
7984 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7985* 5th reaction: pi+/- d total
7986 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7987* 6th reaction: K+ p total
7988 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7989* 7th reaction: K+ n total
7990 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7991* 8th reaction: K+ d total
7992 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7993* 9th reaction: K- p total
7994 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7995* 10th reaction: K- n total
7996 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7997C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7998 DATA SGTCO2 /
7999* 11th reaction: K- d total
8000 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
8001* 12th reaction: p p total
8002 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
8003* 13th reaction: p n total
8004 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
8005* 14th reaction: p d total
8006 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
8007* 15th reaction: pbar p total
8008 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
8009* 16th reaction: pbar n total
8010 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
8011* 17th reaction: pbar d total
8012 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
8013* 18th reaction: Lamda p total
8014 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
8015C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8016 DATA SGTCO3 /
8017* 19th reaction: pi+ p elastic
8018 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8019* 20th reaction: pi- p elastic
8020 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8021* 21st reaction: K+ p elastic
8022 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8023* 22nd reaction: K- p elastic
8024 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8025* 23rd reaction: p p elastic
8026 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8027* 24th reaction: p d elastic
8028 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8029* 25th reaction: pbar p elastic
8030 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8031* 26th reaction: pbar p elastic bis
8032 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8033* 27th reaction: pbar n elastic
8034 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8035* 28th reaction: Lamda p elastic
8036 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8037* 29th reaction: K- p ela bis
8038 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8039* 30th reaction: pi- p cx
8040 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8041* 31st reaction: K- p cx
8042 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8043* 32nd reaction: K+ n cx
8044 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8045* 33rd reaction: pbar p cx
8046 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8047*
8048* +-------------------------------------------------------------------*
8049 ICHRGE(KTARG)=IICH(KTARG)
8050 AM (KTARG)=AAM (KTARG)
8051* | Check for pi0 (d-dbar)
8052 IF ( KP .NE. 26 ) THEN
8053 IP = KPTOIP (KP)
8054 IF(IP.EQ.0)IP=1
8055 ICHRGE(IP)=IICH(KP)
8056 AM (IP)=AAM (KP)
8057* |
8058* +-------------------------------------------------------------------*
8059* |
8060 ELSE
8061 IP = 23
8062 ICHRGE(IP)=0
8063 END IF
8064* |
8065* +-------------------------------------------------------------------*
8066* +-------------------------------------------------------------------*
8067* | No such interactions for baryon-baryon
8068 IF ( IIBAR (KP) .GT. 0 ) THEN
8069 DT_PHNSCH = ZERZER
8070 RETURN
8071* |
8072* +-------------------------------------------------------------------*
8073* | No "annihilation" diagram possible for K+ p/n
8074 ELSE IF ( IP .EQ. 15 ) THEN
8075 DT_PHNSCH = ZERZER
8076 RETURN
8077* |
8078* +-------------------------------------------------------------------*
8079* | No "annihilation" diagram possible for K0 p/n
8080 ELSE IF ( IP .EQ. 24 ) THEN
8081 DT_PHNSCH = ZERZER
8082 RETURN
8083* |
8084* +-------------------------------------------------------------------*
8085* | No "annihilation" diagram possible for Omebar p/n
8086 ELSE IF ( IP .GE. 38 ) THEN
8087 DT_PHNSCH = ZERZER
8088 RETURN
8089 END IF
8090* |
8091* +-------------------------------------------------------------------*
8092* +-------------------------------------------------------------------*
8093* | If the momentum is larger than 50 GeV/c, compute the single
8094* | chain probability at 50 GeV/c and extrapolate to the present
8095* | momentum according to 1/sqrt(s)
8096* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8097* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8098* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8099* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8100* | x sqrt(s/s(50))
8101* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8102 IF ( PLAB .GT. 50.D+00 ) THEN
8103 PLA = 50.D+00
8104 AMPSQ = AM (IP)**2
8105 AMTSQ = AM (KTARG)**2
8106 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8107 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8108 EPROJ = SQRT ( PLA**2 + AMPSQ )
8109 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8110 UMORAT = SQRT ( UMOSQ / UMO50 )
8111* |
8112* +-------------------------------------------------------------------*
8113* | P < 3 GeV/c
8114 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8115 PLA = 3.D+00
8116 AMPSQ = AM (IP)**2
8117 AMTSQ = AM (KTARG)**2
8118 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8119 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8120 EPROJ = SQRT ( PLA**2 + AMPSQ )
8121 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8122 UMORAT = SQRT ( UMOSQ / UMO50 )
8123* |
8124* +-------------------------------------------------------------------*
8125* | P < 50 GeV/c
8126 ELSE
8127 PLA = PLAB
8128 UMORAT = ONEONE
8129 END IF
8130* |
8131* +-------------------------------------------------------------------*
8132 ALGPLA = LOG (PLA)
8133* +-------------------------------------------------------------------*
8134* | Pions:
8135 IF ( IHLP (IP) .EQ. 2 ) THEN
8136 ACOF = SGTCOE (1,3)
8137 BCOF = SGTCOE (2,3)
8138 ENNE = SGTCOE (3,3)
8139 CCOF = SGTCOE (4,3)
8140 DCOF = SGTCOE (5,3)
8141* | Compute the pi+ p total cross section:
8142 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8143 & + DCOF * ALGPLA
8144 ACOF = SGTCOE (1,19)
8145 BCOF = SGTCOE (2,19)
8146 ENNE = SGTCOE (3,19)
8147 CCOF = SGTCOE (4,19)
8148 DCOF = SGTCOE (5,19)
8149* | Compute the pi+ p elastic cross section:
8150 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8151 & + DCOF * ALGPLA
8152* | Compute the pi+ p inelastic cross section:
8153 SPPPIN = SPPPTT - SPPPEL
8154 ACOF = SGTCOE (1,4)
8155 BCOF = SGTCOE (2,4)
8156 ENNE = SGTCOE (3,4)
8157 CCOF = SGTCOE (4,4)
8158 DCOF = SGTCOE (5,4)
8159* | Compute the pi- p total cross section:
8160 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8161 & + DCOF * ALGPLA
8162 ACOF = SGTCOE (1,20)
8163 BCOF = SGTCOE (2,20)
8164 ENNE = SGTCOE (3,20)
8165 CCOF = SGTCOE (4,20)
8166 DCOF = SGTCOE (5,20)
8167* | Compute the pi- p elastic cross section:
8168 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8169 & + DCOF * ALGPLA
8170* | Compute the pi- p inelastic cross section:
8171 SPMPIN = SPMPTT - SPMPEL
8172 SIGDIA = SPMPIN - SPPPIN
8173* | +----------------------------------------------------------------*
8174* | | Charged pions: besides isospin consideration it is supposed
8175* | | that (pi+ n)el is almost equal to (pi- p)el
8176* | | and (pi+ p)el " " " " (pi- n)el
8177* | | and all are almost equal among each others
8178* | | (reasonable above 5 GeV/c)
8179 IF ( ICHRGE (IP) .NE. 0 ) THEN
8180 KHELP = KTARG / 8
8181 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8182 ACOF = SGTCOE (1,JREAC)
8183 BCOF = SGTCOE (2,JREAC)
8184 ENNE = SGTCOE (3,JREAC)
8185 CCOF = SGTCOE (4,JREAC)
8186 DCOF = SGTCOE (5,JREAC)
8187* | | Compute the total cross section:
8188 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8189 & + DCOF * ALGPLA
8190 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8191 ACOF = SGTCOE (1,JREAC)
8192 BCOF = SGTCOE (2,JREAC)
8193 ENNE = SGTCOE (3,JREAC)
8194 CCOF = SGTCOE (4,JREAC)
8195 DCOF = SGTCOE (5,JREAC)
8196* | | Compute the elastic cross section:
8197 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8198 & + DCOF * ALGPLA
8199* | | Compute the inelastic cross section:
8200 SHNCIN = SHNCTT - SHNCEL
8201* | | Number of diagrams:
8202 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8203* | | Now compute the chain end (anti)quark-(anti)diquark
8204 IQFSC1 = 1 + IP - 13
8205 IQFSC2 = 0
8206 IQBSC1 = 1 + KHELP
8207 IQBSC2 = 1 + IP - 13
8208* | |
8209* | +----------------------------------------------------------------*
8210* | | pi0: besides isospin consideration it is supposed that the
8211* | | elastic cross section is not very different from
8212* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8213 ELSE
8214 KHELP = KTARG / 8
8215 K2HLP = ( KP - 23 ) / 3
8216* | | Number of diagrams:
8217* | | For u ubar (k2hlp=0):
8218* NDIAGR = 2 - KHELP
8219* | | For d dbar (k2hlp=1):
8220* NDIAGR = 2 + KHELP - K2HLP
8221 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8222 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8223* | | Now compute the chain end (anti)quark-(anti)diquark
8224 IQFSC1 = 1 + K2HLP
8225 IQFSC2 = 0
8226 IQBSC1 = 1 + KHELP
8227 IQBSC2 = 2 - K2HLP
8228 END IF
8229* | |
8230* | +----------------------------------------------------------------*
8231* | end pi's
8232* +-------------------------------------------------------------------*
8233* | Kaons:
8234 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8235 ACOF = SGTCOE (1,6)
8236 BCOF = SGTCOE (2,6)
8237 ENNE = SGTCOE (3,6)
8238 CCOF = SGTCOE (4,6)
8239 DCOF = SGTCOE (5,6)
8240* | Compute the K+ p total cross section:
8241 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8242 & + DCOF * ALGPLA
8243 ACOF = SGTCOE (1,21)
8244 BCOF = SGTCOE (2,21)
8245 ENNE = SGTCOE (3,21)
8246 CCOF = SGTCOE (4,21)
8247 DCOF = SGTCOE (5,21)
8248* | Compute the K+ p elastic cross section:
8249 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8250 & + DCOF * ALGPLA
8251* | Compute the K+ p inelastic cross section:
8252 SKPPIN = SKPPTT - SKPPEL
8253 ACOF = SGTCOE (1,9)
8254 BCOF = SGTCOE (2,9)
8255 ENNE = SGTCOE (3,9)
8256 CCOF = SGTCOE (4,9)
8257 DCOF = SGTCOE (5,9)
8258* | Compute the K- p total cross section:
8259 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8260 & + DCOF * ALGPLA
8261 ACOF = SGTCOE (1,22)
8262 BCOF = SGTCOE (2,22)
8263 ENNE = SGTCOE (3,22)
8264 CCOF = SGTCOE (4,22)
8265 DCOF = SGTCOE (5,22)
8266* | Compute the K- p elastic cross section:
8267 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8268 & + DCOF * ALGPLA
8269* | Compute the K- p inelastic cross section:
8270 SKMPIN = SKMPTT - SKMPEL
8271 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8272* | +----------------------------------------------------------------*
8273* | | Charged Kaons: actually only K-
8274 IF ( ICHRGE (IP) .NE. 0 ) THEN
8275 KHELP = KTARG / 8
8276* | | +-------------------------------------------------------------*
8277* | | | Proton target:
8278 IF ( KHELP .EQ. 0 ) THEN
8279 SHNCIN = SKMPIN
8280* | | | Number of diagrams:
8281 NDIAGR = 2
8282* | | |
8283* | | +-------------------------------------------------------------*
8284* | | | Neutron target: besides isospin consideration it is supposed
8285* | | | that (K- n)el is almost equal to (K- p)el
8286* | | | (reasonable above 5 GeV/c)
8287 ELSE
8288 ACOF = SGTCOE (1,10)
8289 BCOF = SGTCOE (2,10)
8290 ENNE = SGTCOE (3,10)
8291 CCOF = SGTCOE (4,10)
8292 DCOF = SGTCOE (5,10)
8293* | | | Compute the total cross section:
8294 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8295 & + DCOF * ALGPLA
8296* | | | Compute the elastic cross section:
8297 SHNCEL = SKMPEL
8298* | | | Compute the inelastic cross section:
8299 SHNCIN = SHNCTT - SHNCEL
8300* | | | Number of diagrams:
8301 NDIAGR = 1
8302 END IF
8303* | | |
8304* | | +-------------------------------------------------------------*
8305* | | Now compute the chain end (anti)quark-(anti)diquark
8306 IQFSC1 = 3
8307 IQFSC2 = 0
8308 IQBSC1 = 1 + KHELP
8309 IQBSC2 = 2
8310* | |
8311* | +----------------------------------------------------------------*
8312* | | K0's: (actually only K0bar)
8313 ELSE
8314 KHELP = KTARG / 8
8315* | | +-------------------------------------------------------------*
8316* | | | Proton target: (K0bar p)in supposed to be given by
8317* | | | (K- p)in - Sig_diagr
8318 IF ( KHELP .EQ. 0 ) THEN
8319 SHNCIN = SKMPIN - SIGDIA
8320* | | | Number of diagrams:
8321 NDIAGR = 1
8322* | | |
8323* | | +-------------------------------------------------------------*
8324* | | | Neutron target: (K0bar n)in supposed to be given by
8325* | | | (K- n)in + Sig_diagr
8326* | | | besides isospin consideration it is supposed
8327* | | | that (K- n)el is almost equal to (K- p)el
8328* | | | (reasonable above 5 GeV/c)
8329 ELSE
8330 ACOF = SGTCOE (1,10)
8331 BCOF = SGTCOE (2,10)
8332 ENNE = SGTCOE (3,10)
8333 CCOF = SGTCOE (4,10)
8334 DCOF = SGTCOE (5,10)
8335* | | | Compute the total cross section:
8336 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8337 & + DCOF * ALGPLA
8338* | | | Compute the elastic cross section:
8339 SHNCEL = SKMPEL
8340* | | | Compute the inelastic cross section:
8341 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8342* | | | Number of diagrams:
8343 NDIAGR = 2
8344 END IF
8345* | | |
8346* | | +-------------------------------------------------------------*
8347* | | Now compute the chain end (anti)quark-(anti)diquark
8348 IQFSC1 = 3
8349 IQFSC2 = 0
8350 IQBSC1 = 1
8351 IQBSC2 = 1 + KHELP
8352 END IF
8353* | |
8354* | +----------------------------------------------------------------*
8355* | end Kaon's
8356* +-------------------------------------------------------------------*
8357* | Antinucleons:
8358 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8359* | For momenta between 3 and 5 GeV/c the use of tabulated data
8360* | should be implemented!
8361 ACOF = SGTCOE (1,15)
8362 BCOF = SGTCOE (2,15)
8363 ENNE = SGTCOE (3,15)
8364 CCOF = SGTCOE (4,15)
8365 DCOF = SGTCOE (5,15)
8366* | Compute the pbar p total cross section:
8367 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8368 & + DCOF * ALGPLA
8369 IF ( PLA .LT. FIVFIV ) THEN
8370 JREAC = 26
8371 ELSE
8372 JREAC = 25
8373 END IF
8374 ACOF = SGTCOE (1,JREAC)
8375 BCOF = SGTCOE (2,JREAC)
8376 ENNE = SGTCOE (3,JREAC)
8377 CCOF = SGTCOE (4,JREAC)
8378 DCOF = SGTCOE (5,JREAC)
8379* | Compute the pbar p elastic cross section:
8380 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8381 & + DCOF * ALGPLA
8382* | Compute the pbar p inelastic cross section:
8383 SAPPIN = SAPPTT - SAPPEL
8384 ACOF = SGTCOE (1,12)
8385 BCOF = SGTCOE (2,12)
8386 ENNE = SGTCOE (3,12)
8387 CCOF = SGTCOE (4,12)
8388 DCOF = SGTCOE (5,12)
8389* | Compute the p p total cross section:
8390 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8391 & + DCOF * ALGPLA
8392 ACOF = SGTCOE (1,23)
8393 BCOF = SGTCOE (2,23)
8394 ENNE = SGTCOE (3,23)
8395 CCOF = SGTCOE (4,23)
8396 DCOF = SGTCOE (5,23)
8397* | Compute the p p elastic cross section:
8398 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8399 & + DCOF * ALGPLA
8400* | Compute the K- p inelastic cross section:
8401 SPPINE = SPPTOT - SPPELA
8402 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8403 KHELP = KTARG / 8
8404* | +----------------------------------------------------------------*
8405* | | Pbar:
8406 IF ( ICHRGE (IP) .NE. 0 ) THEN
8407 NDIAGR = 5 - KHELP
8408* | | +-------------------------------------------------------------*
8409* | | | Proton target:
8410 IF ( KHELP .EQ. 0 ) THEN
8411* | | | Number of diagrams:
8412 SHNCIN = SAPPIN
8413 PUUBAR = 0.8D+00
8414* | | |
8415* | | +-------------------------------------------------------------*
8416* | | | Neutron target: it is supposed that (ap n)el is almost equal
8417* | | | to (ap p)el (reasonable above 5 GeV/c)
8418 ELSE
8419 ACOF = SGTCOE (1,16)
8420 BCOF = SGTCOE (2,16)
8421 ENNE = SGTCOE (3,16)
8422 CCOF = SGTCOE (4,16)
8423 DCOF = SGTCOE (5,16)
8424* | | | Compute the total cross section:
8425 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8426 & + DCOF * ALGPLA
8427* | | | Compute the elastic cross section:
8428 SHNCEL = SAPPEL
8429* | | | Compute the inelastic cross section:
8430 SHNCIN = SHNCTT - SHNCEL
8431 PUUBAR = HLFHLF
8432 END IF
8433* | | |
8434* | | +-------------------------------------------------------------*
8435* | | Now compute the chain end (anti)quark-(anti)diquark
8436* | | there are different possibilities, make a random choiche:
8437 IQFSC1 = -1
8438 RNCHEN = DT_RNDM(PUUBAR)
8439 IF ( RNCHEN .LT. PUUBAR ) THEN
8440 IQFSC2 = -2
8441 ELSE
8442 IQFSC2 = -1
8443 END IF
8444 IQBSC1 = -IQFSC1 + KHELP
8445 IQBSC2 = -IQFSC2
8446* | |
8447* | +----------------------------------------------------------------*
8448* | | nbar:
8449 ELSE
8450 NDIAGR = 4 + KHELP
8451* | | +-------------------------------------------------------------*
8452* | | | Proton target: (nbar p)in supposed to be given by
8453* | | | (pbar p)in - Sig_diagr
8454 IF ( KHELP .EQ. 0 ) THEN
8455 SHNCIN = SAPPIN - SIGDIA
8456 PDDBAR = HLFHLF
8457* | | |
8458* | | +-------------------------------------------------------------*
8459* | | | Neutron target: (nbar n)el is supposed to be equal to
8460* | | | (pbar p)el (reasonable above 5 GeV/c)
8461 ELSE
8462* | | | Compute the total cross section:
8463 SHNCTT = SAPPTT
8464* | | | Compute the elastic cross section:
8465 SHNCEL = SAPPEL
8466* | | | Compute the inelastic cross section:
8467 SHNCIN = SHNCTT - SHNCEL
8468 PDDBAR = 0.8D+00
8469 END IF
8470* | | |
8471* | | +-------------------------------------------------------------*
8472* | | Now compute the chain end (anti)quark-(anti)diquark
8473* | | there are different possibilities, make a random choiche:
8474 IQFSC1 = -2
8475 RNCHEN = DT_RNDM(RNCHEN)
8476 IF ( RNCHEN .LT. PDDBAR ) THEN
8477 IQFSC2 = -1
8478 ELSE
8479 IQFSC2 = -2
8480 END IF
8481 IQBSC1 = -IQFSC1 + KHELP - 1
8482 IQBSC2 = -IQFSC2
8483 END IF
8484* | |
8485* | +----------------------------------------------------------------*
8486* |
8487* +-------------------------------------------------------------------*
8488* | Others: not yet implemented
8489 ELSE
8490 SIGDIA = ZERZER
8491 SHNCIN = ONEONE
8492 NDIAGR = 0
8493 DT_PHNSCH = ZERZER
8494 RETURN
8495 END IF
8496* | end others
8497* +-------------------------------------------------------------------*
8498 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8499 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8500 & + IQECHR (IQBSC2)
8501 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8502 & + IQBCHR (IQBSC2)
8503 IQECHC = IQECHC / 3
8504 IQBCHC = IQBCHC / 3
8505 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8506 & + IQSCHR (IQBSC2)
8507 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8508 & + IQSCHR (MQUARK(3,IP))
8509* +-------------------------------------------------------------------*
8510* | Consistency check:
8511 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8512 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8513 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8514 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8515 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8516 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8517 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8518 END IF
8519* |
8520* +-------------------------------------------------------------------*
8521* +-------------------------------------------------------------------*
8522* | Consistency check:
8523 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8524 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8525 WRITE (LUNOUT,*)
8526 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8527 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8528 WRITE (LUNERR,*)
8529 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8530 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8531 END IF
8532* |
8533* +-------------------------------------------------------------------*
8534* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8535 IF ( UMORAT .GT. ONEPLS )
8536 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8537 & - ONEONE ) * UMORAT + ONEONE )
8538 RETURN
8539*
8540 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8541 DT_SCHQUA = ONEONE
8542 JQFSC1 = IQFSC1
8543 JQFSC2 = IQFSC2
8544 JQBSC1 = IQBSC1
8545 JQBSC2 = IQBSC2
8546*=== End of function Phnsch ===========================================*
8547 RETURN
8548 END
8549
8550*$ CREATE DT_RESPT.FOR
8551*COPY DT_RESPT
8552*
8553*===respt==============================================================*
8554*
8555 SUBROUTINE DT_RESPT
8556
8557************************************************************************
8558* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8559* This version dated 18.01.95 is written by S. Roesler *
8560************************************************************************
8561
8562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8563 SAVE
8564
8565 PARAMETER ( LINP = 10 ,
8566 & LOUT = 6 ,
8567 & LDAT = 9 )
8568
8569 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8570
8571* event history
8572
8573 PARAMETER (NMXHKK=200000)
8574
8575 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8576 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8577 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8578
8579* extended event history
8580 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8581 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8582 & IHIST(2,NMXHKK)
8583
8584* get index of first chain
8585 DO 1 I=NPOINT(3),NHKK
8586 IF (IDHKK(I).EQ.88888) THEN
8587 NC = I
8588 GOTO 2
8589 ENDIF
8590 1 CONTINUE
8591
8592 2 CONTINUE
8593 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8594C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8595* skip VV-,SS- systems
8596 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8597 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8598* check if both "chains" are resonances
8599 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8600 CALL DT_SAPTRE(NC,NC+3)
8601 ENDIF
8602 ENDIF
8603 ELSE
8604 GOTO 3
8605 ENDIF
8606 NC = NC+6
8607 GOTO 2
8608
8609 3 CONTINUE
8610
8611 RETURN
8612 END
8613
8614*$ CREATE DT_EVTRES.FOR
8615*COPY DT_EVTRES
8616*
8617*===evtres=============================================================*
8618*
8619 SUBROUTINE DT_EVTRES(IREJ)
8620
8621************************************************************************
8622* This version dated 14.12.94 is written by S. Roesler *
8623************************************************************************
8624
8625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8626 SAVE
8627
8628 PARAMETER ( LINP = 10 ,
8629 & LOUT = 6 ,
8630 & LDAT = 9 )
8631
8632 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8633
8634* event history
8635
8636 PARAMETER (NMXHKK=200000)
8637
8638 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8639 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8640 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8641
8642* extended event history
8643 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8644 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8645 & IHIST(2,NMXHKK)
8646
8647* flags for input different options
8648 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8649 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8650 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8651
8652* particle properties (BAMJET index convention)
8653 CHARACTER*8 ANAME
8654 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8655 & IICH(210),IIBAR(210),K1(210),K2(210)
8656
8657 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8658
8659 IREJ = 0
8660
8661 DO 1 I=NPOINT(3),NHKK
8662 IF (ABS(IDRES(I)).GE.100) THEN
8663 AMMX = 0.0D0
8664 DO 2 J=NPOINT(3),NHKK
8665 IF (IDHKK(J).EQ.88888) THEN
8666 IF (PHKK(5,J).GT.AMMX) THEN
8667 AMMX = PHKK(5,J)
8668 IMMX = J
8669 ENDIF
8670 ENDIF
8671 2 CONTINUE
8672 IF (IDRES(IMMX).NE.0) THEN
8673 IF (IOULEV(3).GT.0) THEN
8674 WRITE(LOUT,'(1X,A)')
8675 & 'EVTRES: no chain for correc. found'
8676C GOTO 6
8677 GOTO 9999
8678 ELSE
8679 GOTO 9999
8680 ENDIF
8681 ENDIF
8682 IMO11 = JMOHKK(1,I)
8683 IMO12 = JMOHKK(2,I)
8684 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8685 IMO11 = JMOHKK(2,I)
8686 IMO12 = JMOHKK(1,I)
8687 ENDIF
8688 IMO21 = JMOHKK(1,IMMX)
8689 IMO22 = JMOHKK(2,IMMX)
8690 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8691 IMO21 = JMOHKK(2,IMMX)
8692 IMO22 = JMOHKK(1,IMMX)
8693 ENDIF
8694 AMCH1 = PHKK(5,I)
8695 AMCH1N = AAM(IDXRES(I))
8696
8697 IFPR1 = IDHKK(IMO11)
8698 IFPR2 = IDHKK(IMO21)
8699 IFTA1 = IDHKK(IMO12)
8700 IFTA2 = IDHKK(IMO22)
8701 DO 4 J=1,4
8702 PP1(J) = PHKK(J,IMO11)
8703 PP2(J) = PHKK(J,IMO21)
8704 PT1(J) = PHKK(J,IMO12)
8705 PT2(J) = PHKK(J,IMO22)
8706 4 CONTINUE
8707* store initial configuration for energy-momentum cons. check
8708 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8709* correct kinematics of second chain
8710 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8711 & AMCH1,AMCH1N,AMCH2,IREJ1)
8712 IF (IREJ1.NE.0) GOTO 9999
8713* check now this chain for resonance mass
8714 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8715 IFP(2) = 0
8716 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8717 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8718 IFT(2) = 0
8719 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8720 IDCH2 = 2
8721 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8722 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8723 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8724 & AMCH2,AMCH2N,IDCH2,IREJ1)
8725 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8726 IF (IOULEV(1).GT.0)
8727 & WRITE(LOUT,*) ' correction for resonance not poss.'
8728**sr test
8729C GOTO 1
8730C GOTO 9999
8731**
8732 ENDIF
8733* store final configuration for energy-momentum cons. check
8734 IF (LEMCCK) THEN
8735 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8736 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8737 IF (IREJ1.NE.0) GOTO 9999
8738 ENDIF
8739 DO 5 J=1,4
8740 PHKK(J,IMO11) = PP1(J)
8741 PHKK(J,IMO21) = PP2(J)
8742 PHKK(J,IMO12) = PT1(J)
8743 PHKK(J,IMO22) = PT2(J)
8744 5 CONTINUE
8745* correct entries of chains
8746 DO 3 K=1,4
8747 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8748 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8749 3 CONTINUE
8750 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8751 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8752 & PHKK(3,IMMX)**2
8753* ?? the following should now be obsolete
8754**sr test
8755C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8756 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8757**
8758 WRITE(LOUT,'(1X,A,4G10.3)')
8759 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8760C GOTO 9999
8761 GOTO 1
8762 ENDIF
8763 PHKK(5,I) = SQRT(AM1)
8764 PHKK(5,IMMX) = SQRT(AM2)
8765 IDRES(I) = IDRES(I)/100
8766 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8767 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8768 WRITE(LOUT,'(1X,A,4G10.3)')
8769 & 'EVTRES: inconsistent chain-masses',
8770 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8771 GOTO 9999
8772 ENDIF
8773 ENDIF
8774 1 CONTINUE
8775 6 CONTINUE
8776 RETURN
8777
8778 9999 CONTINUE
8779 IREJ = 1
8780 RETURN
8781 END
8782
8783*$ CREATE DT_GETSPT.FOR
8784*COPY DT_GETSPT
8785*
8786*===getspt=============================================================*
8787*
8788 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8789 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8790 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8791
8792************************************************************************
8793* This version dated 12.12.94 is written by S. Roesler *
8794************************************************************************
8795
8796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8797 SAVE
8798
8799 PARAMETER ( LINP = 10 ,
8800 & LOUT = 6 ,
8801 & LDAT = 9 )
8802
8803 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8804
8805* various options for treatment of partons (DTUNUC 1.x)
8806* (chain recombination, Cronin,..)
8807 LOGICAL LCO2CR,LINTPT
8808 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8809 & LCO2CR,LINTPT
8810
8811* flags for input different options
8812 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8813 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8814 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8815
8816* flags for diffractive interactions (DTUNUC 1.x)
8817 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8818
8819 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8820 & PT2(4),PT2I(4),P1(4),P2(4),
8821 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8822 & PTOTI(4),PTOTF(4),DIFF(4)
8823
8824 IC = 0
8825 IREJ = 0
8826C B33P = 4.0D0
8827C B33T = 4.0D0
8828C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8829C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8830 REDU = 1.0D0
8831C B33P = 3.5D0
8832C B33T = 3.5D0
8833 B33P = 4.0D0
8834 B33T = 4.0D0
8835 IF (IDIFF.NE.0) THEN
8836 B33P = 16.0D0
8837 B33T = 16.0D0
8838 ENDIF
8839
8840 DO 1 I=1,4
8841 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8842 PP1(I) = PP1I(I)
8843 PP2(I) = PP2I(I)
8844 PT1(I) = PT1I(I)
8845 PT2(I) = PT2I(I)
8846 1 CONTINUE
8847* get initial chain masses
8848 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8849 & +(PP1(3)+PT1(3))**2)
8850 ECH = PP1(4)+PT1(4)
8851 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8852 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8853 & +(PP2(3)+PT2(3))**2)
8854 ECH = PP2(4)+PT2(4)
8855 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8856 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8857 IF (IOULEV(1).GT.0)
8858 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8859 & AM1,AM2
8860 GOTO 9999
8861 ENDIF
8862 AM1 = SQRT(AM1)
8863 AM2 = SQRT(AM2)
8864 AM1N = ZERO
8865 AM2N = ZERO
8866
8867 MODE = 0
8868C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8869C MODE = 0
8870C ELSE
8871C MODE = 1
8872C IF (AM1.LT.0.6) THEN
8873C B33P = 10.0D0
8874C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8875CC B33P = 4.0D0
8876C ENDIF
8877C IF (AM2.LT.0.6) THEN
8878C B33T = 10.0D0
8879C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8880CC B33T = 4.0D0
8881C ENDIF
8882C ENDIF
8883
8884* check chain masses for very low mass chains
8885C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8886C & AM1,DUM,-IDCH1,IREJ1)
8887C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8888C & AM2,DUM,-IDCH2,IREJ2)
8889C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8890C B33P = 20.0D0
8891C B33T = 20.0D0
8892C ENDIF
8893
8894 JMSHL = IMSHL
8895
8896 2 CONTINUE
8897 IC = IC+1
8898 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8899 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8900 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8901C IF (MOD(IC,19).EQ.0) JMSHL = 0
8902 IF (MOD(IC,20).EQ.0) GOTO 7
8903C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8904C RETURN
8905C GOTO 9999
8906C ENDIF
8907
8908* get transverse momentum
8909 IF (LINTPT) THEN
8910 ES = -2.0D0/(B33P**2)
8911 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8912 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8913 HPSP = HPSP*REDU
8914 ES = -2.0D0/(B33T**2)
8915 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8916 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8917 HPST = HPST*REDU
8918 ELSE
8919 HPSP = ZERO
8920 HPST = ZERO
8921 ENDIF
8922 CALL DT_DSFECF(SFE1,CFE1)
8923 CALL DT_DSFECF(SFE2,CFE2)
8924 IF (MODE.EQ.0) THEN
8925 PP1(1) = PP1I(1)+HPSP*CFE1
8926 PP1(2) = PP1I(2)+HPSP*SFE1
8927 PP2(1) = PP2I(1)-HPSP*CFE1
8928 PP2(2) = PP2I(2)-HPSP*SFE1
8929 PT1(1) = PT1I(1)+HPST*CFE2
8930 PT1(2) = PT1I(2)+HPST*SFE2
8931 PT2(1) = PT2I(1)-HPST*CFE2
8932 PT2(2) = PT2I(2)-HPST*SFE2
8933 ELSE
8934 PP1(1) = PP1I(1)+HPSP*CFE1
8935 PP1(2) = PP1I(2)+HPSP*SFE1
8936 PT1(1) = PT1I(1)-HPSP*CFE1
8937 PT1(2) = PT1I(2)-HPSP*SFE1
8938 PP2(1) = PP2I(1)+HPST*CFE2
8939 PP2(2) = PP2I(2)+HPST*SFE2
8940 PT2(1) = PT2I(1)-HPST*CFE2
8941 PT2(2) = PT2I(2)-HPST*SFE2
8942 ENDIF
8943
8944* put partons on mass shell
8945 XMP1 = 0.0D0
8946 XMT1 = 0.0D0
8947 IF (JMSHL.EQ.1) THEN
8948
8949 XMP1 = PYMASS(IFPR1)
8950 XMT1 = PYMASS(IFTA1)
8951
8952 ENDIF
8953 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8954 IF (IREJ1.NE.0) GOTO 2
8955 DO 3 I=1,4
8956 PTOTF(I) = P1(I)+P2(I)
8957 PP1(I) = P1(I)
8958 PT1(I) = P2(I)
8959 3 CONTINUE
8960 XMP2 = 0.0D0
8961 XMT2 = 0.0D0
8962 IF (JMSHL.EQ.1) THEN
8963
8964 XMP2 = PYMASS(IFPR2)
8965 XMT2 = PYMASS(IFTA2)
8966
8967 ENDIF
8968 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8969 IF (IREJ1.NE.0) GOTO 2
8970 DO 4 I=1,4
8971 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8972 PP2(I) = P1(I)
8973 PT2(I) = P2(I)
8974 4 CONTINUE
8975
8976* check consistency
8977 DO 5 I=1,4
8978 DIFF(I) = PTOTI(I)-PTOTF(I)
8979 5 CONTINUE
8980 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8981 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8982 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8983 GOTO 9999
8984 ENDIF
8985 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8986 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8987 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8988 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8989 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8990 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8991 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8992 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8993 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8994 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8995 & THEN
8996 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8997 & 'GETSPT: inconsistent masses',
8998 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8999* sr 22.11.00: commented. It should only have inconsistent masses for
9000* ultrahigh energies due to rounding problems
9001C GOTO 9999
9002 ENDIF
9003
9004* get chain masses
9005 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9006 & +(PP1(3)+PT1(3))**2)
9007 ECH = PP1(4)+PT1(4)
9008 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
9009 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9010 & +(PP2(3)+PT2(3))**2)
9011 ECH = PP2(4)+PT2(4)
9012 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
9013 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9014 IF (IOULEV(1).GT.0)
9015 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9016 & AM1N,AM2N
9017 GOTO 2
9018 ENDIF
9019 AM1N = SQRT(AM1N)
9020 AM2N = SQRT(AM2N)
9021
9022* check chain masses for very low mass chains
9023 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9024 & AM1N,DUM,-IDCH1,IREJ1)
9025 IF (IREJ1.NE.0) GOTO 2
9026 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9027 & AM2N,DUM,-IDCH2,IREJ2)
9028 IF (IREJ2.NE.0) GOTO 2
9029
9030 7 CONTINUE
9031 IF (AM1N.GT.ZERO) THEN
9032 AM1 = AM1N
9033 AM2 = AM2N
9034 ENDIF
9035 DO 6 I=1,4
9036 PP1I(I) = PP1(I)
9037 PP2I(I) = PP2(I)
9038 PT1I(I) = PT1(I)
9039 PT2I(I) = PT2(I)
9040 6 CONTINUE
9041
9042 RETURN
9043
9044 9999 CONTINUE
9045 IREJ = 1
9046 RETURN
9047 END
9048
9049*$ CREATE DT_SAPTRE.FOR
9050*COPY DT_SAPTRE
9051*
9052*===saptre=============================================================*
9053*
9054 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9055
9056************************************************************************
9057* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9058* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9059* Adopted from the original SAPTRE written by J. Ranft. *
9060* This version dated 18.01.95 is written by S. Roesler *
9061************************************************************************
9062
9063 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9064 SAVE
9065
9066 PARAMETER ( LINP = 10 ,
9067 & LOUT = 6 ,
9068 & LDAT = 9 )
9069
9070 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9071
9072* event history
9073
9074 PARAMETER (NMXHKK=200000)
9075
9076 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9077 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9078 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9079
9080* extended event history
9081 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9082 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9083 & IHIST(2,NMXHKK)
9084
9085* flags for input different options
9086 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9087 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9088 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9089
9090 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9091
9092 DATA B3 /4.0D0/
9093
9094 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9095 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9096 ESMAX = MIN(ESMAX1,ESMAX2)
9097 IF (ESMAX.LE.0.05D0) RETURN
9098
9099 HMA = PHKK(5,IDX1)
9100 DO 1 K=1,4
9101 PA1(K) = PHKK(K,IDX1)
9102 PA2(K) = PHKK(K,IDX2)
9103 1 CONTINUE
9104
9105 IF (LEMCCK) THEN
9106 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9107 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9108 ENDIF
9109
9110 EXEB = 0.0D0
9111 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9112 BEXP = HMA*(1.0D0-EXEB)/B3
9113 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9114 WA = AXEXP/(BEXP+AXEXP)
9115 XAB = DT_RNDM(WA)
9116 10 CONTINUE
9117* ES is the transverse kinetic energy
9118 IF (XAB.LT.WA)THEN
9119 X = DT_RNDM(WA)
9120 Y = DT_RNDM(WA)
9121 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9122 ELSE
9123 X = DT_RNDM(Y)
9124 ES = ABS(-LOG(X+TINY7)/B3)
9125 ENDIF
9126 IF (ES.GT.ESMAX) GOTO 10
9127 ES = ES+HMA
9128* transverse momentum
9129 HPS = SQRT((ES-HMA)*(ES+HMA))
9130
9131 CALL DT_DSFECF(SFE,CFE)
9132 HPX = HPS*CFE
9133 HPY = HPS*SFE
9134 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9135 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9136 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9137
9138C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9139C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9140 PA1(1) = PA1(1)+HPX
9141 PA1(2) = PA1(2)+HPY
9142 PA2(1) = PA2(1)-HPX
9143 PA2(2) = PA2(2)-HPY
9144
9145* put resonances on mass-shell again
9146 XM1 = PHKK(5,IDX1)
9147 XM2 = PHKK(5,IDX2)
9148 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9149 IF (IREJ1.NE.0) RETURN
9150
9151 IF (LEMCCK) THEN
9152 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9153 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9154 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9155 IF (IREJ1.NE.0) RETURN
9156 ENDIF
9157
9158 DO 2 K=1,4
9159 PHKK(K,IDX1) = P1(K)
9160 PHKK(K,IDX2) = P2(K)
9161 2 CONTINUE
9162
9163 RETURN
9164 END
9165
9166*$ CREATE DT_CRONIN.FOR
9167*COPY DT_CRONIN
9168*
9169*===cronin=============================================================*
9170*
9171 SUBROUTINE DT_CRONIN(INCL)
9172
9173************************************************************************
9174* Cronin-Effect. Multiple scattering of partons at chain ends. *
9175* INCL = 1 multiple sc. in projectile *
9176* = 2 multiple sc. in target *
9177* This version dated 05.01.96 is written by S. Roesler. *
9178************************************************************************
9179
9180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9181 SAVE
9182
9183 PARAMETER ( LINP = 10 ,
9184 & LOUT = 6 ,
9185 & LDAT = 9 )
9186
9187 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9188
9189* event history
9190
9191 PARAMETER (NMXHKK=200000)
9192
9193 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9194 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9195 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9196
9197* extended event history
9198 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9199 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9200 & IHIST(2,NMXHKK)
9201
9202* rejection counter
9203 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9204 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9205 & IREXCI(3),IRDIFF(2),IRINC
9206
9207* Glauber formalism: collision properties
9208 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 9209 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9210 & NCP,NCT
7b076c76 9211 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9212
9213 DO 1 K=1,4
9214 DEV(K) = ZERO
9215 1 CONTINUE
9216
9217 DO 2 I=NPOINT(2),NHKK
9218 IF (ISTHKK(I).LT.0) THEN
9219* get z-position of the chain
9220 R(1) = VHKK(1,I)*1.0D12
9221 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9222 R(2) = VHKK(2,I)*1.0D12
9223 IDXNU = JMOHKK(1,I)
9224 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9225 & IDXNU = JMOHKK(1,I-1)
9226 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9227 & IDXNU = JMOHKK(1,I+1)
9228 R(3) = VHKK(3,IDXNU)*1.0D12
9229* position of target parton the chain is connected to
9230 DO 3 K=1,4
9231 PIN(K) = PHKK(K,I)
9232 3 CONTINUE
9233* multiple scattering of parton with DTEVT1-index I
9234 CALL DT_CROMSC(PIN,R,POUT,INCL)
9235**testprint
9236C IF (NEVHKK.EQ.5) THEN
9237C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9238C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9239C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9240C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9241C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9242C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9243C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9244C ENDIF
9245**
9246* increase accumulator by energy-momentum difference
9247 DO 4 K=1,4
9248 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9249 PHKK(K,I) = POUT(K)
9250 4 CONTINUE
9251 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9252 & PHKK(2,I)**2-PHKK(3,I)**2))
9253 ENDIF
9254 2 CONTINUE
9255
9256* dump accumulator to momenta of valence partons
9257 NVAL = 0
9258 ETOT = 0.0D0
9259 DO 5 I=NPOINT(2),NHKK
9260 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9261 NVAL = NVAL+1
9262 ETOT = ETOT+PHKK(4,I)
9263 ENDIF
9264 5 CONTINUE
9265C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9266 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9267 & 9X,4E12.4)
9268 DO 6 I=NPOINT(2),NHKK
9269 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9270 E = PHKK(4,I)
9271 DO 7 K=1,4
9272C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9273 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9274 7 CONTINUE
9275 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9276 & PHKK(2,I)**2-PHKK(3,I)**2))
9277 ENDIF
9278 6 CONTINUE
9279
9280 RETURN
9281 END
9282
9283*$ CREATE DT_CROMSC.FOR
9284*COPY DT_CROMSC
9285*
9286*===cromsc=============================================================*
9287*
9288 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9289
9290************************************************************************
9291* Cronin-Effect. Multiple scattering of one parton passing through *
9292* nuclear matter. *
9293* PIN(4) input 4-momentum of parton *
9294* POUT(4) 4-momentum of parton after mult. scatt. *
9295* R(3) spatial position of parton in target nucleus *
9296* INCL = 1 multiple sc. in projectile *
9297* = 2 multiple sc. in target *
9298* This is a revised version of the original version written by J. Ranft*
9299* This version dated 17.01.95 is written by S. Roesler. *
9300************************************************************************
9301
9302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9303 SAVE
9304
9305 PARAMETER ( LINP = 10 ,
9306 & LOUT = 6 ,
9307 & LDAT = 9 )
9308
9309 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9310
9311 LOGICAL LSTART
9312
9313* rejection counter
9314 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9315 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9316 & IREXCI(3),IRDIFF(2),IRINC
9317
9318* Glauber formalism: collision properties
9319 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 9320 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9321 & NCP,NCT
7b076c76 9322
9323* various options for treatment of partons (DTUNUC 1.x)
9324* (chain recombination, Cronin,..)
9325 LOGICAL LCO2CR,LINTPT
9326 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9327 & LCO2CR,LINTPT
9328
9329 DIMENSION PIN(4),POUT(4),R(3)
9330
9331 DATA LSTART /.TRUE./
9332
9333 IRCRON(1) = IRCRON(1)+1
9334
9335 IF (LSTART) THEN
9336 WRITE(LOUT,1000) CRONCO
9337 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9338 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9339 LSTART = .FALSE.
9340 ENDIF
9341
9342 NCBACK = 0
9343 RNCL = RPROJ
9344 IF (INCL.EQ.2) RNCL = RTARG
9345
9346* Lorentz-transformation into Lab.
9347 MODE = -(INCL+1)
9348 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9349
9350 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9351 IF (PTOT.LE.8.0D0) GOTO 9997
9352
9353* direction cosines of parton before mult. scattering
9354 COSX = PIN(1)/PTOT
9355 COSY = PIN(2)/PTOT
9356 COSZ = PZ/PTOT
9357
9358 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9359 IF (RTESQ.GE.-TINY3) GOTO 9999
9360
9361* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9362* in the direction of particle motion
9363
9364 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9365 TMP = A**2-RTESQ
9366 IF (TMP.LT.ZERO) GOTO 9998
9367 DIST = -A+SQRT(TMP)
9368
9369* multiple scattering angle
9370 THETO = CRONCO*SQRT(DIST)/PTOT
9371 IF (THETO.GT.0.1D0) THETO=0.1D0
9372
9373 1 CONTINUE
9374* Gaussian sampling of spatial angle
9375 CALL DT_RANNOR(R1,R2)
9376 THETA = ABS(R1*THETO)
9377 IF (THETA.GT.0.3D0) GOTO 9997
9378 CALL DT_DSFECF(SFE,CFE)
9379 COSTH = COS(THETA)
9380 SINTH = SIN(THETA)
9381
9382* new direction cosines
9383 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9384 & COSXN,COSYN,COSZN)
9385
9386 POUT(1) = COSXN*PTOT
9387 POUT(2) = COSYN*PTOT
9388 PZ = COSZN*PTOT
9389* Lorentz-transformation into nucl.-nucl. cms
9390 MODE = INCL+1
9391 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9392
9393C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9394C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9395 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9396 THETO = THETO/2.0D0
9397 NCBACK = NCBACK+1
9398 IF (MOD(NCBACK,200).EQ.0) THEN
9399 WRITE(LOUT,1001) THETO,PIN,POUT
9400 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9401 & E12.4,/,1X,' PIN :',4E12.4,/,
9402 & 1X,' POUT:',4E12.4)
9403 GOTO 9997
9404 ENDIF
9405 GOTO 1
9406 ENDIF
9407
9408 RETURN
9409
9410 9997 IRCRON(2) = IRCRON(2)+1
9411 GOTO 9999
9412 9998 IRCRON(3) = IRCRON(3)+1
9413
9414 9999 CONTINUE
9415 DO 100 K=1,4
9416 POUT(K) = PIN(K)
9417 100 CONTINUE
9418 RETURN
9419 END
9420
9421*$ CREATE DT_COM2CR.FOR
9422*COPY DT_COM2CR
9423*
9424*===com2sr=============================================================*
9425*
9426 SUBROUTINE DT_COM2CR
9427
9428************************************************************************
9429* COMbine q-aq chains to Color Ropes (qq-aqaq). *
9430* CUTOF parameter determining minimum number of not *
9431* combined q-aq chains *
9432* This subroutine replaces KKEVCC etc. *
9433* This version dated 11.01.95 is written by S. Roesler. *
9434************************************************************************
9435
9436 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9437 SAVE
9438
9439 PARAMETER ( LINP = 10 ,
9440 & LOUT = 6 ,
9441 & LDAT = 9 )
9442
9443* event history
9444
9445 PARAMETER (NMXHKK=200000)
9446
9447 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9448 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9449 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9450
9451* extended event history
9452 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9453 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9454 & IHIST(2,NMXHKK)
9455
9456* statistics
9457 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9458 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9459 & ICEVTG(8,0:30)
9460
9461* various options for treatment of partons (DTUNUC 1.x)
9462* (chain recombination, Cronin,..)
9463 LOGICAL LCO2CR,LINTPT
9464 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9465 & LCO2CR,LINTPT
9466
9467 DIMENSION IDXQA(248),IDXAQ(248)
9468
9469 ICCHAI(1,9) = ICCHAI(1,9)+1
9470 NQA = 0
9471 NAQ = 0
9472* scan DTEVT1 for q-aq, aq-q chains
9473 DO 10 I=NPOINT(3),NHKK
9474* skip "chains" which are resonances
9475 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9476 MO1 = JMOHKK(1,I)
9477 MO2 = JMOHKK(2,I)
9478 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9479* q-aq, aq-q chain found, keep index
9480 IF (IDHKK(MO1).GT.0) THEN
9481 NQA = NQA+1
9482 IDXQA(NQA) = I
9483 ELSE
9484 NAQ = NAQ+1
9485 IDXAQ(NAQ) = I
9486 ENDIF
9487 ENDIF
9488 ENDIF
9489 10 CONTINUE
9490
9491* minimum number of q-aq chains requested for the same projectile/
9492* target
9493 NCHMIN = IDT_NPOISS(CUTOF)
9494
9495* combine q-aq chains of the same projectile
9496 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9497* combine q-aq chains of the same target
9498 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9499* combine aq-q chains of the same projectile
9500 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9501* combine aq-q chains of the same target
9502 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9503
9504 RETURN
9505 END
9506
9507*$ CREATE DT_SCN4CR.FOR
9508*COPY DT_SCN4CR
9509*
9510*===scn4cr=============================================================*
9511*
9512 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9513
9514************************************************************************
9515* SCan q-aq chains for Color Ropes. *
9516* This version dated 11.01.95 is written by S. Roesler. *
9517************************************************************************
9518
9519 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9520 SAVE
9521
9522 PARAMETER ( LINP = 10 ,
9523 & LOUT = 6 ,
9524 & LDAT = 9 )
9525
9526* event history
9527
9528 PARAMETER (NMXHKK=200000)
9529
9530 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9531 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9532 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9533
9534* extended event history
9535 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9536 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9537 & IHIST(2,NMXHKK)
9538
9539 DIMENSION IDXCH(248),IDXJN(248)
9540
9541 DO 1 I=1,NCH
9542 IF (IDXCH(I).GT.0) THEN
9543 NJOIN = 1
9544 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9545 IDXJN(NJOIN) = I
9546 IF (I.LT.NCH) THEN
9547 DO 2 J=I+1,NCH
9548 IF (IDXCH(J).GT.0) THEN
9549 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9550 IF (IDXMO.EQ.IDXMO1) THEN
9551 NJOIN = NJOIN+1
9552 IDXJN(NJOIN) = J
9553 ENDIF
9554 ENDIF
9555 2 CONTINUE
9556 ENDIF
9557 IF (NJOIN.GE.NCHMIN+2) THEN
9558 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9559 DO 3 J=1,2*NJ,2
9560 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9561 IF (IREJ1.NE.0) GOTO 3
9562 IDXCH(IDXJN(J)) = 0
9563 IDXCH(IDXJN(J+1)) = 0
9564 3 CONTINUE
9565 ENDIF
9566 ENDIF
9567 1 CONTINUE
9568
9569 RETURN
9570 END
9571
9572*$ CREATE DT_JOIN.FOR
9573*COPY DT_JOIN
9574*
9575*===join===============================================================*
9576*
9577 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9578
9579************************************************************************
9580* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9581* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9582* This version dated 11.01.95 is written by S. Roesler. *
9583************************************************************************
9584
9585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9586 SAVE
9587
9588 PARAMETER ( LINP = 10 ,
9589 & LOUT = 6 ,
9590 & LDAT = 9 )
9591
9592* event history
9593
9594 PARAMETER (NMXHKK=200000)
9595
9596 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9597 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9598 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9599
9600* extended event history
9601 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9602 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9603 & IHIST(2,NMXHKK)
9604
9605* flags for input different options
9606 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9607 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9608 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9609
9610* statistics
9611 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9612 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9613 & ICEVTG(8,0:30)
9614
9615 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9616
9617 IREJ = 0
9618
9619 IDX(1) = IDX1
9620 IDX(2) = IDX2
9621 DO 1 I=1,2
9622 DO 2 J=1,2
9623 MO(I,J) = JMOHKK(J,IDX(I))
9624 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9625 2 CONTINUE
9626 1 CONTINUE
9627
9628* check consistency
9629 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9630 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9631 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9632 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9633 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9634 & MO(2,2)
9635 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9636 & 2I5,' chain ',I4,':',2I5)
9637 ENDIF
9638
9639* join chains
9640 DO 3 K=1,4
9641 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9642 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9643 3 CONTINUE
9644 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9645 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9646 IST1 = ISTHKK(MO(1,1))
9647 IST2 = ISTHKK(MO(1,2))
9648
9649* put partons again on mass shell
9650 XM1 = 0.0D0
9651 XM2 = 0.0D0
9652 IF (IMSHL.EQ.1) THEN
9653
9654 XM1 = PYMASS(IF1)
9655 XM2 = PYMASS(IF2)
9656
9657 ENDIF
9658 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9659 IF (IREJ1.NE.0) GOTO 9999
9660 DO 4 I=1,4
9661 PP(I) = P1(I)
9662 PT(I) = P2(I)
9663 4 CONTINUE
9664
9665* store new partons in DTEVT1
9666 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9667 & 0,0,0)
9668 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9669 & 0,0,0)
9670 DO 5 K=1,4
9671 PCH(K) = PP(K)+PT(K)
9672 5 CONTINUE
9673
9674* check new chain for lower mass limit
9675 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9676 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9677 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9678 & AMCH,AMCHN,3,IREJ1)
9679 IF (IREJ1.NE.0) THEN
9680 NHKK = NHKK-2
9681 GOTO 9999
9682 ENDIF
9683 ENDIF
9684
9685 ICCHAI(2,9) = ICCHAI(2,9)+1
9686* store new chain in DTEVT1
9687 KCH = 191
9688 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9689 IDHKK(IDX(1)) = 22222
9690 IDHKK(IDX(2)) = 22222
9691* special treatment for space-time coordinates
9692 DO 6 K=1,4
9693 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9694 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9695 6 CONTINUE
9696 RETURN
9697
9698 9999 CONTINUE
9699 IREJ = 1
9700 RETURN
9701 END
9702*$ CREATE DT_XSGLAU.FOR
9703*COPY DT_XSGLAU
9704*
9705*===xsglau=============================================================*
9706*
9707 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9708
9709************************************************************************
9710* Total, elastic, quasi-elastic, inelastic cross sections according to *
9711* Glauber's approach. *
9712* NA / NB mass numbers of proj./target nuclei *
9713* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9714* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9715* IE,IQ indices of energy and virtuality (the latter for gamma *
9716* projectiles only) *
9717* NIDX index of projectile/target nucleus *
9718* This version dated 17.3.98 is written by S. Roesler *
9719************************************************************************
9720
9721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9722 SAVE
9723
9724 PARAMETER ( LINP = 10 ,
9725 & LOUT = 6 ,
9726 & LDAT = 9 )
9727
9728 COMPLEX*16 CZERO,CONE,CTWO
9729 CHARACTER*12 CFILE
9730 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9731 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9732 PARAMETER (TWOPI = 6.283185307179586454D+00,
9733 & PI = TWOPI/TWO,
9734 & GEV2MB = 0.38938D0,
9735 & GEV2FM = 0.1972D0,
9736 & ALPHEM = ONE/137.0D0,
9737* proton mass
9738 & AMP = 0.938D0,
9739 & AMP2 = AMP**2,
9740* approx. nucleon radius
9741 & RNUCLE = 1.12D0)
9742
9743* particle properties (BAMJET index convention)
9744 CHARACTER*8 ANAME
9745 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9746 & IICH(210),IIBAR(210),K1(210),K2(210)
9747
9748 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9749
9750 PARAMETER ( MAXNCL = 260,
9751
9752 & MAXVQU = MAXNCL,
9753 & MAXSQU = 20*MAXVQU,
9754 & MAXINT = MAXVQU+MAXSQU)
9755
9756* Glauber formalism: parameters
9757 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9758 & BMAX(NCOMPX),BSTEP(NCOMPX),
9759 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9760 & NSITEB,NSTATB
9761
9762* Glauber formalism: cross sections
9763 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9764 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9765 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9766 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9767 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9768 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9769 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9770 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9771 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9772 & BSLOPE,NEBINI,NQBINI
9773
9774* Glauber formalism: flags and parameters for statistics
9775 LOGICAL LPROD
9776 CHARACTER*8 CGLB
9777 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9778
9779* nucleon-nucleon event-generator
9780 CHARACTER*8 CMODEL
9781 LOGICAL LPHOIN
9782 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9783
9784* VDM parameter for photon-nucleus interactions
9785 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9786
9787* parameters for hA-diffraction
9788 COMMON /DTDIHA/ DIBETA,DIALPH
9789
9790 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9791 & OMPP11,OMPP12,OMPP21,OMPP22,
9792 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9793 & PPTMP1,PPTMP2
9794 COMPLEX*16 C,CA,CI
9795 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9796 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9797 & BPROD(KSITEB)
9798
9799 PARAMETER (NPOINT=16)
9800 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9801
9802 LOGICAL LFIRST,LOPEN
9803 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9804
9805 NTARG = ABS(NIDX)
9806* for quasi-elastic neutrino scattering set projectile to proton
9807* it should not have an effect since the whole Glauber-formalism is
9808* not needed for these interactions..
9809 IF (MCGENE.EQ.4) THEN
9810 IJPROJ = 1
9811 ELSE
9812 IJPROJ = JJPROJ
9813 ENDIF
9814
9815 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9816 I = INDEX(CGLB,' ')
9817 IF (I.EQ.0) THEN
9818 CFILE = CGLB//'.glb'
9819 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9820 ELSEIF (I.GT.1) THEN
9821 CFILE = CGLB(1:I-1)//'.glb'
9822 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9823 ELSE
9824 STOP 'XSGLAU 1'
9825 ENDIF
9826 LOPEN = .TRUE.
9827 ENDIF
9828
9829 CZERO = DCMPLX(ZERO,ZERO)
9830 CONE = DCMPLX(ONE,ZERO)
9831 CTWO = DCMPLX(TWO,ZERO)
9832 NEBINI = IE
9833 NQBINI = IQ
9834
9835* re-define kinematics
9836 S = ECMI**2
9837 Q2 = Q2I
9838 X = XI
9839* g(Q2=0)-A, h-A, A-A scattering
9840 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9841 Q2 = 0.0001D0
9842 X = Q2/(S+Q2-AMP2)
9843* g(Q2>0)-A scattering
9844 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9845 X = Q2/(S+Q2-AMP2)
9846 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9847 Q2 = (S-AMP2)*X/(ONE-X)
9848 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9849 S = Q2*(ONE-X)/X+AMP2
9850 ELSE
9851 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9852 STOP
9853 ENDIF
9854 ECMNN(IE) = SQRT(S)
9855 Q2G(IQ) = Q2
9856 XNU = (S+Q2-AMP2)/(TWO*AMP)
9857
9858* parameters determining statistics in evaluating Glauber-xsection
9859 NSTATB = JSTATB
9860 NSITEB = JBINSB
9861 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9862
9863* set up interaction geometry (common /DTGLAM/)
9864* projectile/target radii
9865 RPRNCL = DT_RNCLUS(NA)
9866 RTANCL = DT_RNCLUS(NB)
9867 IF (IJPROJ.EQ.7) THEN
9868 RASH(1) = ZERO
9869 RBSH(NTARG) = RTANCL
9870 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9871 ELSE
9872 IF (NIDX.LE.-1) THEN
9873 RASH(1) = RPRNCL
9874 RBSH(NTARG) = RTANCL
9875 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9876 ELSE
9877 RASH(NTARG) = RPRNCL
9878 RBSH(1) = RTANCL
9879 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9880 ENDIF
9881 ENDIF
9882* maximum impact-parameter
9883 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9884
9885* slope, rho ( Re(f(0))/Im(f(0)) )
9886 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9887 IF (MCGENE.EQ.2) THEN
9888 ZERO1 = ZERO
9889 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9890 & BSLOPE,0)
9891 ELSE
9892 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9893 ENDIF
9894 IF (ECMNN(IE).LE.3.0D0) THEN
9895 ROSH = -0.43D0
9896 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9897 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9898 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9899 ROSH = 0.1D0
9900 ENDIF
9901 ELSEIF (IJPROJ.EQ.7) THEN
9902 ROSH = 0.1D0
9903 ELSE
9904 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9905 ROSH = 0.01D0
9906 ENDIF
9907
9908* projectile-nucleon xsection (in fm)
9909 IF (IJPROJ.EQ.7) THEN
9910 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9911 ELSE
9912 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9913 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9914C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9915 DUMZER = ZERO
9916 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9917 SIGSH = SIGSH/10.0D0
9918 ENDIF
9919
9920* parameters for projectile diffraction (hA scattering only)
9921 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9922 & .AND.(DIBETA.GE.ZERO)) THEN
9923 ZERO1 = ZERO
9924 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9925C DIBETA = SDIF1/STOT
9926 DIBETA = 0.2D0
9927 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9928 IF (DIBETA.LE.ZERO) THEN
9929 ALPGAM = ONE
9930 ELSE
9931 ALPGAM = DIALPH/DIGAMM
9932 ENDIF
9933 FACDI1 = ONE-ALPGAM
9934 FACDI2 = ONE+ALPGAM
9935 FACDI = SQRT(FACDI1*FACDI2)
9936 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9937 ELSE
9938 DIBETA = -1.0D0
9939 DIALPH = ZERO
9940 DIGAMM = ZERO
9941 FACDI1 = ZERO
9942 FACDI2 = 2.0D0
9943 FACDI = ZERO
9944 ENDIF
9945
9946* initializations
9947 DO 10 I=1,NSITEB
9948 BSITE( 0,IQ,NTARG,I) = ZERO
9949 BSITE(IE,IQ,NTARG,I) = ZERO
9950 BPROD(I) = ZERO
9951 10 CONTINUE
9952 STOT = ZERO
9953 STOT2 = ZERO
9954 SELA = ZERO
9955 SELA2 = ZERO
9956 SQEP = ZERO
9957 SQEP2 = ZERO
9958 SQET = ZERO
9959 SQET2 = ZERO
9960 SQE2 = ZERO
9961 SQE22 = ZERO
9962 SPRO = ZERO
9963 SPRO2 = ZERO
9964 SDEL = ZERO
9965 SDEL2 = ZERO
9966 SDQE = ZERO
9967 SDQE2 = ZERO
9968 FACN = ONE/DBLE(NSTATB)
9969
9970 IPNT = 0
9971 RPNT = ZERO
9972
9973* initialize Gauss-integration for photon-proj.
9974 JPOINT = 1
9975 IF (IJPROJ.EQ.7) THEN
9976 IF (INTRGE(1).EQ.1) THEN
9977 AMLO2 = (3.0D0*AAM(13))**2
9978 ELSEIF (INTRGE(1).EQ.2) THEN
9979 AMLO2 = AAM(33)**2
9980 ELSE
9981 AMLO2 = AAM(96)**2
9982 ENDIF
9983 IF (INTRGE(2).EQ.1) THEN
9984 AMHI2 = S/TWO
9985 ELSEIF (INTRGE(2).EQ.2) THEN
9986 AMHI2 = S/4.0D0
9987 ELSE
9988 AMHI2 = S
9989 ENDIF
9990 AMHI20 = (ECMNN(IE)-AMP)**2
9991 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9992 XAMLO = LOG( AMLO2+Q2 )
9993 XAMHI = LOG( AMHI2+Q2 )
9994**PHOJET105a
9995C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9996**PHOJET112
9997
9998 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9999
10000**
10001 JPOINT = NPOINT
10002* ratio direct/total photon-nucleon xsection
10003 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10004 ENDIF
10005
10006* read pre-initialized profile-function from file
10007 IF (IOGLB.EQ.1) THEN
10008 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10009 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10010 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10011 & NA,NB,NSTATB,NSITEB
10012 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10013 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10014 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
10015 STOP
10016 ENDIF
10017 IF (LFIRST) WRITE(LOUT,1001) CFILE
10018 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10019 & 'file ',A12,/)
10020 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10021 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10022 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10023 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10024 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10025 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10026 NLINES = INT(DBLE(NSITEB)/7.0D0)
10027 IF (NLINES.GT.0) THEN
10028 DO 21 I=1,NLINES
10029 ISTART = 7*I-6
10030 READ(LDAT,'(7E11.4)')
10031 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10032 21 CONTINUE
10033 ENDIF
10034 ISTART = 7*NLINES+1
10035 IF (ISTART.LE.NSITEB) THEN
10036 READ(LDAT,'(7E11.4)')
10037 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10038 ENDIF
10039 LFIRST = .FALSE.
10040 GOTO 100
10041* variable projectile/target/energy runs:
10042* read pre-initialized profile-functions from file
10043 ELSEIF (IOGLB.EQ.100) THEN
10044 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10045 GOTO 100
10046 ENDIF
10047
10048* cross sections averaged over NSTATB nucleon configurations
10049 DO 11 IS=1,NSTATB
10050C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10051 STOTN = ZERO
10052 SELAN = ZERO
10053 SQEPN = ZERO
10054 SQETN = ZERO
10055 SQE2N = ZERO
10056 SPRON = ZERO
10057 SDELN = ZERO
10058 SDQEN = ZERO
10059
10060 IF (NIDX.LE.-1) THEN
10061 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10062 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10063 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10064 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10065 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10066 ENDIF
10067 ELSE
10068 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10069 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10070 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10071 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10072 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10073 ENDIF
10074 ENDIF
10075
10076* integration over impact parameter B
10077 DO 12 IB=1,NSITEB-1
10078 STOTB = ZERO
10079 SELAB = ZERO
10080 SQEPB = ZERO
10081 SQETB = ZERO
10082 SQE2B = ZERO
10083 SPROB = ZERO
10084 SDIR = ZERO
10085 SDELB = ZERO
10086 SDQEB = ZERO
10087 B = DBLE(IB)*BSTEP(NTARG)
10088 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10089
10090* integration over M_V^2 for photon-proj.
10091 DO 14 IM=1,JPOINT
10092 PP11(1) = CONE
10093 PP12(1) = CONE
10094 PP21(1) = CONE
10095 PP22(1) = CONE
10096 IF (IJPROJ.EQ.7) THEN
10097 DO 13 K=2,NB
10098 PP11(K) = CONE
10099 PP12(K) = CONE
10100 PP21(K) = CONE
10101 PP22(K) = CONE
10102 13 CONTINUE
10103 ENDIF
10104 SHI = ZERO
10105 FACM = ONE
10106 DCOH = 1.0D10
10107
10108 IF (IJPROJ.EQ.7) THEN
10109 AMV2 = EXP(ABSZX(IM))-Q2
10110 AMV = SQRT(AMV2)
10111 IF (AMV2.LT.16.0D0) THEN
10112 R = TWO
10113 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10114 R = 10.0D0/3.0D0
10115 ELSE
10116 R = 11.0D0/3.0D0
10117 ENDIF
10118* define M_V dependent properties of nucleon scattering amplitude
10119* V_M-nucleon xsection
10120 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10121 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10122* slope-parametrisation a la Kaidalov
10123 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10124 & +0.25D0*LOG(S/(AMV2+Q2)))
10125* coherence length
10126 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10127* integration weight factor
10128 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10129 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10130 ENDIF
10131 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10132 GAM = GSH
10133 IF (IJPROJ.EQ.7) THEN
10134 RCA = GAM*SIGMV/TWOPI
10135 ELSE
10136 RCA = GAM*SIGSH/TWOPI
10137 ENDIF
10138 FCA = -ROSH*RCA
10139 CA = DCMPLX(RCA,FCA)
10140 CI = CONE
10141
10142 DO 15 INA=1,NA
10143 KK1 = 1
10144 INT1 = 1
10145 KK2 = 1
10146 INT2 = 1
10147 DO 16 INB=1,NB
10148* photon-projectile: check for supression by coherence length
10149 IF (IJPROJ.EQ.7) THEN
10150 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10151 KK1 = INB
10152 INT1 = INT1+1
10153 ENDIF
10154 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10155 KK2 = INB
10156 INT2 = INT2+1
10157 ENDIF
10158 ENDIF
10159
10160 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10161 Y11 = COOT1(2,INB)-COOP1(2,INA)
10162 XY11 = GAM*(X11*X11+Y11*Y11)
10163 IF (XY11.LE.15.0D0) THEN
10164 C = CONE-CA*EXP(-XY11)
10165 AR = DBLE(PP11(INT1))
10166 AI = DIMAG(PP11(INT1))
10167 IF (ABS(AR).LT.TINY25) AR = ZERO
10168 IF (ABS(AI).LT.TINY25) AI = ZERO
10169 PP11(INT1) = DCMPLX(AR,AI)
10170 PP11(INT1) = PP11(INT1)*C
10171 AR = DBLE(C)
10172 AI = DIMAG(C)
10173 SHI = SHI+LOG(AR*AR+AI*AI)
10174 ENDIF
10175 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10176 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10177 Y12 = COOT2(2,INB)-COOP1(2,INA)
10178 XY12 = GAM*(X12*X12+Y12*Y12)
10179 IF (XY12.LE.15.0D0) THEN
10180 C = CONE-CA*EXP(-XY12)
10181 AR = DBLE(PP12(INT2))
10182 AI = DIMAG(PP12(INT2))
10183 IF (ABS(AR).LT.TINY25) AR = ZERO
10184 IF (ABS(AI).LT.TINY25) AI = ZERO
10185 PP12(INT2) = DCMPLX(AR,AI)
10186 PP12(INT2) = PP12(INT2)*C
10187 ENDIF
10188 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10189 Y21 = COOT1(2,INB)-COOP2(2,INA)
10190 XY21 = GAM*(X21*X21+Y21*Y21)
10191 IF (XY21.LE.15.0D0) THEN
10192 C = CONE-CA*EXP(-XY21)
10193 AR = DBLE(PP21(INT1))
10194 AI = DIMAG(PP21(INT1))
10195 IF (ABS(AR).LT.TINY25) AR = ZERO
10196 IF (ABS(AI).LT.TINY25) AI = ZERO
10197 PP21(INT1) = DCMPLX(AR,AI)
10198 PP21(INT1) = PP21(INT1)*C
10199 ENDIF
10200 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10201 Y22 = COOT2(2,INB)-COOP2(2,INA)
10202 XY22 = GAM*(X22*X22+Y22*Y22)
10203 IF (XY22.LE.15.0D0) THEN
10204 C = CONE-CA*EXP(-XY22)
10205 AR = DBLE(PP22(INT2))
10206 AI = DIMAG(PP22(INT2))
10207 IF (ABS(AR).LT.TINY25) AR = ZERO
10208 IF (ABS(AI).LT.TINY25) AI = ZERO
10209 PP22(INT2) = DCMPLX(AR,AI)
10210 PP22(INT2) = PP22(INT2)*C
10211 ENDIF
10212 ENDIF
10213 16 CONTINUE
10214 15 CONTINUE
10215
10216 OMPP11 = CZERO
10217 OMPP21 = CZERO
10218 DIPP11 = CZERO
10219 DIPP21 = CZERO
10220 DO 17 K=1,INT1
10221 IF (PP11(K).EQ.CZERO) THEN
10222 PPTMP1 = CZERO
10223 PPTMP2 = CZERO
10224 ELSE
10225 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10226 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10227 ENDIF
10228 AVDIPP = 0.5D0*
10229 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10230 OMPP11 = OMPP11+AVDIPP
10231C OMPP11 = OMPP11+(CONE-PP11(K))
10232 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10233 DIPP11 = DIPP11+AVDIPP
10234 IF (PP21(K).EQ.CZERO) THEN
10235 PPTMP1 = CZERO
10236 PPTMP2 = CZERO
10237 ELSE
10238 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10239 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10240 ENDIF
10241 AVDIPP = 0.5D0*
10242 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10243 OMPP21 = OMPP21+AVDIPP
10244C OMPP21 = OMPP21+(CONE-PP21(K))
10245 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10246 DIPP21 = DIPP21+AVDIPP
10247 17 CONTINUE
10248 OMPP12 = CZERO
10249 OMPP22 = CZERO
10250 DIPP12 = CZERO
10251 DIPP22 = CZERO
10252 DO 18 K=1,INT2
10253 IF (PP12(K).EQ.CZERO) THEN
10254 PPTMP1 = CZERO
10255 PPTMP2 = CZERO
10256 ELSE
10257 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10258 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10259 ENDIF
10260 AVDIPP = 0.5D0*
10261 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10262 OMPP12 = OMPP12+AVDIPP
10263C OMPP12 = OMPP12+(CONE-PP12(K))
10264 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10265 DIPP12 = DIPP12+AVDIPP
10266 IF (PP22(K).EQ.CZERO) THEN
10267 PPTMP1 = CZERO
10268 PPTMP2 = CZERO
10269 ELSE
10270 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10271 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10272 ENDIF
10273 AVDIPP = 0.5D0*
10274 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10275 OMPP22 = OMPP22+AVDIPP
10276C OMPP22 = OMPP22+(CONE-PP22(K))
10277 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10278 DIPP22 = DIPP22+AVDIPP
10279 18 CONTINUE
10280
10281 SPROM = ONE-EXP(SHI)
10282 SPROB = SPROB+FACM*SPROM
10283 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10284 STOTM = DBLE(OMPP11+OMPP22)
10285 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10286 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10287 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10288 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10289 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10290 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10291 STOTB = STOTB+FACM*STOTM
10292 SELAB = SELAB+FACM*SELAM
10293 SDELB = SDELB+FACM*SDELM
10294 IF (NB.GT.1) THEN
10295 SQEPB = SQEPB+FACM*SQEPM
10296 SDQEB = SDQEB+FACM*SDQEM
10297 ENDIF
10298 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10299 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10300 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10301 ENDIF
10302
10303 14 CONTINUE
10304
10305 STOTN = STOTN+FACB*STOTB
10306 SELAN = SELAN+FACB*SELAB
10307 SQEPN = SQEPN+FACB*SQEPB
10308 SQETN = SQETN+FACB*SQETB
10309 SQE2N = SQE2N+FACB*SQE2B
10310 SPRON = SPRON+FACB*SPROB
10311 SDELN = SDELN+FACB*SDELB
10312 SDQEN = SDQEN+FACB*SDQEB
10313
10314 IF (IJPROJ.EQ.7) THEN
10315 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10316 ELSE
10317 IF (DIBETA.GT.ZERO) THEN
10318 BPROD(IB+1)= BPROD(IB+1)
10319 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10320 ELSE
10321 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10322 ENDIF
10323 ENDIF
10324
10325 12 CONTINUE
10326
10327 STOT = STOT +FACN*STOTN
10328 STOT2 = STOT2+FACN*STOTN**2
10329 SELA = SELA +FACN*SELAN
10330 SELA2 = SELA2+FACN*SELAN**2
10331 SQEP = SQEP +FACN*SQEPN
10332 SQEP2 = SQEP2+FACN*SQEPN**2
10333 SQET = SQET +FACN*SQETN
10334 SQET2 = SQET2+FACN*SQETN**2
10335 SQE2 = SQE2 +FACN*SQE2N
10336 SQE22 = SQE22+FACN*SQE2N**2
10337 SPRO = SPRO +FACN*SPRON
10338 SPRO2 = SPRO2+FACN*SPRON**2
10339 SDEL = SDEL +FACN*SDELN
10340 SDEL2 = SDEL2+FACN*SDELN**2
10341 SDQE = SDQE +FACN*SDQEN
10342 SDQE2 = SDQE2+FACN*SDQEN**2
10343
10344 11 CONTINUE
10345
10346* final cross sections
10347* 1) total
10348 XSTOT(IE,IQ,NTARG) = STOT
10349 IF (IJPROJ.EQ.7)
10350 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10351* 2) elastic
10352 XSELA(IE,IQ,NTARG) = SELA
10353* 3) quasi-el.: A+B-->A+X (excluding 2)
10354 XSQEP(IE,IQ,NTARG) = SQEP
10355* 4) quasi-el.: A+B-->X+B (excluding 2)
10356 XSQET(IE,IQ,NTARG) = SQET
10357* 5) quasi-el.: A+B-->X (excluding 2-4)
10358 XSQE2(IE,IQ,NTARG) = SQE2
10359* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10360 IF (SDEL.GT.ZERO) THEN
10361 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10362 ELSE
10363 XSPRO(IE,IQ,NTARG) = SPRO
10364 ENDIF
10365* 7) projectile diffraction (el. scatt. off target)
10366 XSDEL(IE,IQ,NTARG) = SDEL
10367* 8) projectile diffraction (quasi-el. scatt. off target)
10368 XSDQE(IE,IQ,NTARG) = SDQE
10369* stat. errors
10370 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10371 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10372 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10373 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10374 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10375 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10376 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10377 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10378
10379 IF (IJPROJ.EQ.7) THEN
10380 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10381 & -XSQEP(IE,IQ,NTARG)
10382 ELSE
10383 BNORM = XSPRO(IE,IQ,NTARG)
10384 ENDIF
10385 DO 19 I=2,NSITEB
10386 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10387 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10388 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10389 19 CONTINUE
10390
10391* write profile function data into file
10392 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10393 WRITE(LDAT,'(5I10,1P,E15.5)')
10394 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10395 WRITE(LDAT,'(1P,6E12.5)')
10396 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10397 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10398 WRITE(LDAT,'(1P,6E12.5)')
10399 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10400 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10401 NLINES = INT(DBLE(NSITEB)/7.0D0)
10402 IF (NLINES.GT.0) THEN
10403 DO 20 I=1,NLINES
10404 ISTART = 7*I-6
10405 WRITE(LDAT,'(1P,7E11.4)')
10406 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10407 20 CONTINUE
10408 ENDIF
10409 ISTART = 7*NLINES+1
10410 IF (ISTART.LE.NSITEB) THEN
10411 WRITE(LDAT,'(1P,7E11.4)')
10412 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10413 ENDIF
10414 ENDIF
10415
10416 100 CONTINUE
10417
10418C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10419
10420 RETURN
10421 END
10422
10423*$ CREATE DT_GETBXS.FOR
10424*COPY DT_GETBXS
10425*
10426*===getbxs=============================================================*
10427*
10428 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10429
10430************************************************************************
10431* Biasing in impact parameter space. *
10432* XSFRAC = 0 : BLO - minimum impact parameter (input) *
10433* BHI - maximum impact parameter (input) *
10434* XSFRAC - fraction of cross section corresponding *
10435* to impact parameter range (BLO,BHI) *
10436* (output) *
10437* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10438* BHI - maximum impact parameter giving requested *
10439* fraction of cross section in impact *
10440* parameter range (0,BMAX) (output) *
10441* This version dated 17.03.00 is written by S. Roesler *
10442************************************************************************
10443
10444 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10445 SAVE
10446
10447 PARAMETER ( LINP = 10 ,
10448 & LOUT = 6 ,
10449 & LDAT = 9 )
10450
10451 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10452
10453* Glauber formalism: parameters
10454 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10455 & BMAX(NCOMPX),BSTEP(NCOMPX),
10456 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10457 & NSITEB,NSTATB
10458
10459 NTARG = ABS(NIDX)
10460 IF (XSFRAC.LE.0.0D0) THEN
10461 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10462 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10463 IF (ILO.GE.IHI) THEN
10464 XSFRAC = 0.0D0
10465 RETURN
10466 ENDIF
10467 IF (ILO.EQ.NSITEB-1) THEN
10468 FRCLO = BSITE(0,1,NTARG,NSITEB)
10469 ELSE
10470 FRCLO = BSITE(0,1,NTARG,ILO+1)
10471 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10472 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10473 ENDIF
10474 IF (IHI.EQ.NSITEB-1) THEN
10475 FRCHI = BSITE(0,1,NTARG,NSITEB)
10476 ELSE
10477 FRCHI = BSITE(0,1,NTARG,IHI+1)
10478 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10479 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10480 ENDIF
10481 XSFRAC = FRCHI-FRCLO
10482 ELSE
10483 BLO = 0.0D0
10484 BHI = BMAX(NTARG)
10485 DO 1 I=1,NSITEB-1
10486 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10487 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10488 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10489 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10490 GOTO 2
10491 ENDIF
10492 1 CONTINUE
10493 2 CONTINUE
10494 ENDIF
10495
10496 RETURN
10497 END
10498
10499*$ CREATE DT_CONUCL.FOR
10500*COPY DT_CONUCL
10501*
10502*===conucl=============================================================*
10503*
10504 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10505
10506************************************************************************
10507* Calculation of coordinates of nucleons within nuclei. *
10508* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10509* N / R number of nucleons / radius of nucleus (input) *
10510* MODE = 0 coordinates not sorted *
10511* = 1 coordinates sorted with increasing X(3,i) *
10512* = 2 coordinates sorted with decreasing X(3,i) *
10513* This version dated 26.10.95 is revised by S. Roesler *
10514************************************************************************
10515
10516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10517 SAVE
10518
10519 PARAMETER ( LINP = 10 ,
10520 & LOUT = 6 ,
10521 & LDAT = 9 )
10522
10523 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10524 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10525
10526 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10527
10528 PARAMETER (NSRT=10)
10529 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10530 DIMENSION X(3,N),XTMP(3,260)
10531
10532 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10533
10534 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10535 K = 0
10536 DO 1 I=1,NSRT
10537 IF (MODE.EQ.2) THEN
10538 ISRT = NSRT+1-I
10539 ELSE
10540 ISRT = I
10541 ENDIF
10542 K1 = K
10543 DO 2 J=1,ICSRT(ISRT)
10544 K = K+1
10545 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10546 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10547 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10548 2 CONTINUE
10549 IF (ICSRT(ISRT).GT.1) THEN
10550 I0 = K1+1
10551 I1 = K
10552 CALL DT_SORT(X,N,I0,I1,MODE)
10553 ENDIF
10554 1 CONTINUE
10555 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10556 DO 3 I=1,N
10557 X(1,I) = XTMP(1,I)
10558 X(2,I) = XTMP(2,I)
10559 X(3,I) = XTMP(3,I)
10560 3 CONTINUE
10561 CALL DT_SORT(X,N,1,N,MODE)
10562 ELSE
10563 DO 4 I=1,N
10564 X(1,I) = XTMP(1,I)
10565 X(2,I) = XTMP(2,I)
10566 X(3,I) = XTMP(3,I)
10567 4 CONTINUE
10568 ENDIF
10569
10570 RETURN
10571 END
10572
10573*$ CREATE DT_COORDI.FOR
10574*COPY DT_COORDI
10575*
10576*===coordi=============================================================*
10577*
10578 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10579
10580************************************************************************
10581* Calculation of coordinates of nucleons within nuclei. *
10582* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10583* N / R number of nucleons / radius of nucleus (input) *
10584* Based on the original version by Shmakov et al. *
10585* This version dated 26.10.95 is revised by S. Roesler *
10586************************************************************************
10587
10588 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10589 SAVE
10590
10591 PARAMETER ( LINP = 10 ,
10592 & LOUT = 6 ,
10593 & LDAT = 9 )
10594
10595 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10596 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10597
10598 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10599
10600 LOGICAL LSTART
10601
10602 PARAMETER (NSRT=10)
10603 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10604 DIMENSION X(3,260),WD(4),RD(3)
10605
10606 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10607 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10608 DATA RD /2.09D0, 0.935D0, 0.697D0/
10609
10610 X1SUM = ZERO
10611 X2SUM = ZERO
10612 X3SUM = ZERO
10613
10614 IF (N.EQ.1) THEN
10615 X(1,1) = ZERO
10616 X(2,1) = ZERO
10617 X(3,1) = ZERO
10618 ELSEIF (N.EQ.2) THEN
10619 EPS = DT_RNDM(RD(1))
10620 DO 30 I=1,3
10621 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10622 30 CONTINUE
10623 40 CONTINUE
10624 DO 50 J=1,3
10625 CALL DT_RANNOR(X1,X2)
10626 X(J,1) = RD(I)*X1
10627 X(J,2) = -X(J,1)
10628 50 CONTINUE
10629 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10630 SIGMA = R/SQRTWO
10631 LSTART = .TRUE.
10632 CALL DT_RANNOR(X3,X4)
10633 DO 100 I=1,N
10634 CALL DT_RANNOR(X1,X2)
10635 X(1,I) = SIGMA*X1
10636 X(2,I) = SIGMA*X2
10637 IF (LSTART) GOTO 80
10638 X(3,I) = SIGMA*X4
10639 CALL DT_RANNOR(X3,X4)
10640 GOTO 90
10641 80 CONTINUE
10642 X(3,I) = SIGMA*X3
10643 90 CONTINUE
10644 LSTART = .NOT.LSTART
10645 X1SUM = X1SUM+X(1,I)
10646 X2SUM = X2SUM+X(2,I)
10647 X3SUM = X3SUM+X(3,I)
10648 100 CONTINUE
10649 X1SUM = X1SUM/DBLE(N)
10650 X2SUM = X2SUM/DBLE(N)
10651 X3SUM = X3SUM/DBLE(N)
10652 DO 101 I=1,N
10653 X(1,I) = X(1,I)-X1SUM
10654 X(2,I) = X(2,I)-X2SUM
10655 X(3,I) = X(3,I)-X3SUM
10656 101 CONTINUE
10657 ELSE
10658
10659* maximum nuclear radius for coordinate sampling
10660 RMAX = R+4.605D0*PDIF
10661
10662* initialize pre-sorting
10663 DO 121 I=1,NSRT
10664 ICSRT(I) = 0
10665 121 CONTINUE
10666 DR = TWO*RMAX/DBLE(NSRT)
10667
10668* sample coordinates for N nucleons
10669 DO 140 I=1,N
10670 120 CONTINUE
10671 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10672 F = DT_DENSIT(N,RAD,R)
10673 IF (DT_RNDM(RAD).GT.F) GOTO 120
10674* theta, phi uniformly distributed
10675 CT = ONE-TWO*DT_RNDM(F)
10676 ST = SQRT((ONE-CT)*(ONE+CT))
10677 CALL DT_DSFECF(SFE,CFE)
10678 X(1,I) = RAD*ST*CFE
10679 X(2,I) = RAD*ST*SFE
10680 X(3,I) = RAD*CT
10681* ensure that distance between two nucleons is greater than R2MIN
10682 IF (I.LT.2) GOTO 122
10683 I1 = I-1
10684 DO 130 I2=1,I1
10685 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10686 & (X(3,I)-X(3,I2))**2
10687 IF (DIST2.LE.R2MIN) GOTO 120
10688 130 CONTINUE
10689 122 CONTINUE
10690* save index according to z-bin
10691 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10692 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10693 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10694 X1SUM = X1SUM+X(1,I)
10695 X2SUM = X2SUM+X(2,I)
10696 X3SUM = X3SUM+X(3,I)
10697 140 CONTINUE
10698 X1SUM = X1SUM/DBLE(N)
10699 X2SUM = X2SUM/DBLE(N)
10700 X3SUM = X3SUM/DBLE(N)
10701 DO 141 I=1,N
10702 X(1,I) = X(1,I)-X1SUM
10703 X(2,I) = X(2,I)-X2SUM
10704 X(3,I) = X(3,I)-X3SUM
10705 141 CONTINUE
10706
10707 ENDIF
10708
10709 RETURN
10710 END
10711
10712*$ CREATE DT_DENSIT.FOR
10713*COPY DT_DENSIT
10714*
10715*===densit=============================================================*
10716*
10717 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10718
10719 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10720 SAVE
10721
10722 PARAMETER ( LINP = 10 ,
10723 & LOUT = 6 ,
10724 & LDAT = 9 )
10725
10726 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10727 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10728 & PI = TWOPI/TWO)
10729
10730 DIMENSION R0(18),FNORM(18)
10731 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10732 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10733 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10734 & 2.72D0, 2.66D0, 2.79D0/
10735 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10736 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10737 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10738 & .1214D+01,.1265D+01,.1318D+01/
10739 DATA PDIF /0.545D0/
10740
10741 DT_DENSIT = ZERO
10742* shell model
10743 IF (NA.LE.4) THEN
10744 STOP 'DT_DENSIT-0'
10745 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10746 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10747 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10748 & *EXP(-(R/R1)**2)/FNORM(NA)
10749* Woods-Saxon
10750 ELSEIF (NA.GT.18) THEN
10751 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10752 ENDIF
10753
10754 RETURN
10755 END
10756
10757*$ CREATE DT_RNCLUS.FOR
10758*COPY DT_RNCLUS
10759*
10760*===rnclus=============================================================*
10761*
10762 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10763
10764************************************************************************
10765* Nuclear radius for nucleus with mass number N. *
10766* This version dated 26.9.00 is written by S. Roesler *
10767************************************************************************
10768
10769 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10770 SAVE
10771
10772 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10773
10774* nucleon radius
10775 PARAMETER (RNUCLE = 1.12D0)
10776
10777* nuclear radii for selected nuclei
10778 DIMENSION RADNUC(18)
10779 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10780 & 2.58D0,2.71D0,2.66D0,2.71D0/
10781
10782 IF (N.LE.18) THEN
10783 IF (RADNUC(N).GT.0.0D0) THEN
10784 DT_RNCLUS = RADNUC(N)
10785 ELSE
10786 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10787 ENDIF
10788 ELSE
10789 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10790 ENDIF
10791
10792 RETURN
10793 END
10794
10795*$ CREATE DT_DENTST.FOR
10796*COPY DT_DENTST
10797*
10798*===dentst=============================================================*
10799*
10800C PROGRAM DT_DENTST
10801 SUBROUTINE DT_DENTST
10802
10803 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10804 SAVE
10805
10806 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10807 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10808
10809 RMIN = 0.0D0
10810 RMAX = 8.0D0
10811 NBINS = 500.0D0
10812 DR = (RMAX-RMIN)/DBLE(NBINS)
10813 DO 1 IA=5,18
10814 FMAX = 0.0D0
10815 DO 2 IR=1,NBINS+1
10816 R = RMIN+DBLE(IR-1)*DR
10817 F = DT_DENSIT(IA,R,R)
10818 IF (F.GT.FMAX) FMAX = F
10819 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10820 2 CONTINUE
10821 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10822 1 CONTINUE
10823
10824 CLOSE(40)
10825 CLOSE(41)
10826
10827 END
10828
10829*$ CREATE DT_SHMAKI.FOR
10830*COPY DT_SHMAKI
10831*
10832*===shmaki=============================================================*
10833*
10834 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10835
10836************************************************************************
10837* Initialisation of Glauber formalism. This subroutine has to be *
10838* called once (in case of target emulsions as often as many different *
10839* target nuclei are considered) before events are sampled. *
10840* NA / NCA mass number/charge of projectile nucleus *
10841* NB / NCB mass number/charge of target nucleus *
10842* IJP identity of projectile (hadrons/leptons/photons) *
10843* PPN projectile momentum (for projectile nuclei: *
10844* momentum per nucleon) in target rest system *
10845* MODE = 0 Glauber formalism invoked *
10846* = 1 fitted results are loaded from data-file *
10847* = 99 NTARG is forced to be 1 *
10848* (used in connection with GLAUBERI-card only) *
10849* This version dated 22.03.96 is based on the original SHMAKI-routine *
10850* and revised by S. Roesler. *
10851************************************************************************
10852
10853 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10854 SAVE
10855
10856 PARAMETER ( LINP = 10 ,
10857 & LOUT = 6 ,
10858 & LDAT = 9 )
10859
10860 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10861 & THREE=3.0D0)
10862
10863 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10864
10865* Glauber formalism: parameters
10866 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10867 & BMAX(NCOMPX),BSTEP(NCOMPX),
10868 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10869 & NSITEB,NSTATB
10870
10871* Lorentz-parameters of the current interaction
10872 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10873 & UMO,PPCM,EPROJ,PPROJ
10874
10875* properties of photon/lepton projectiles
10876 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10877
10878* kinematical cuts for lepton-nucleus interactions
10879 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10880 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10881
10882* Glauber formalism: cross sections
10883 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10884 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10885 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10886 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10887 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10888 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10889 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10890 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10891 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10892 & BSLOPE,NEBINI,NQBINI
10893
10894* cuts for variable energy runs
10895 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10896
10897* nucleon-nucleon event-generator
10898 CHARACTER*8 CMODEL
10899 LOGICAL LPHOIN
10900 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10901
10902* Glauber formalism: flags and parameters for statistics
10903 LOGICAL LPROD
10904 CHARACTER*8 CGLB
10905 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10906
10907 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10908
10909C CALL DT_HISHAD
10910C STOP
10911
10912 NTARG = NTARG+1
10913 IF (MODE.EQ.99) NTARG = 1
10914 NIDX = -NTARG
10915 IF (MODE.EQ.-1) NIDX = NTARG
10916
10917 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10918 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10919 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10920 & ' initialization',/,12X,'--------------------------',
10921 & '-------------------------',/)
10922
10923 IF (MODE.EQ.2) THEN
10924 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10925 CALL DT_SHFAST(MODE,PPN,IBACK)
10926 STOP ' Glauber pre-initialization done'
10927 ENDIF
10928 IF (MODE.EQ.1) THEN
10929 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10930 ELSE
10931 IBACK = 1
10932 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10933 IF (IBACK.EQ.1) THEN
10934* lepton-nucleus (variable energy runs)
10935 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10936 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10937 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10938 & WRITE(LOUT,1002) NB,NCB
10939 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10940 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10941 & 'E_cm (GeV) Q^2 (GeV^2)',
10942 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10943 & '--------------------------------',
10944 & '------------------------------')
10945 AECMLO = LOG10(MIN(UMO,ECMLI))
10946 AECMHI = LOG10(MIN(UMO,ECMHI))
10947 IESTEP = NEB-1
10948 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10949 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10950 DO 1 I=1,IESTEP+1
10951 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10952 IF (Q2HI.GT.0.1D0) THEN
10953 IF (Q2LI.LT.0.01D0) THEN
10954 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10955 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10956 & WRITE(LOUT,1003)
10957 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10958 Q2LI = 0.01D0
10959 IBIN = 2
10960 ELSE
10961 IBIN = 1
10962 ENDIF
10963 IQSTEP = NQB-IBIN
10964 AQ2LO = LOG10(Q2LI)
10965 AQ2HI = LOG10(Q2HI)
10966 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10967 DO 2 J=IBIN,IQSTEP+IBIN
10968 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10969 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10970 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10971 & WRITE(LOUT,1003) ECMNN(I),
10972 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10973 2 CONTINUE
10974 ELSE
10975 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10976 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10977 & WRITE(LOUT,1003)
10978 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10979 ENDIF
10980 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10981 1 CONTINUE
10982 IVEOUT = 1
10983 ELSE
10984* hadron/photon/nucleus-nucleus
10985 IF ((ABS(VAREHI).GT.ZERO).AND.
10986 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10987 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10988 WRITE(LOUT,1004) NA,NB,NCB
10989 1004 FORMAT(1X,'variable energy run: projectile-id:',
10990 & I3,' target A/Z: ',I3,' /',I3,/)
10991 WRITE(LOUT,1005)
10992 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10993 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10994 & ' -------------------------------------',
10995 & '--------------------------------------')
10996 ENDIF
10997 AECMLO = LOG10(VARCLO)
10998 AECMHI = LOG10(VARCHI)
10999 IESTEP = NEB-1
11000 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
11001 IF (AECMLO.EQ.AECMHI) IESTEP = 0
11002 DO 3 I=1,IESTEP+1
11003 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11004 AMP = 0.938D0
11005 AMT = 0.938D0
11006 AMP2 = AMP**2
11007 AMT2 = AMT**2
11008 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11009 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11010 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11011 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11012 & WRITE(LOUT,1006)
11013 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11014 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11015 3 CONTINUE
11016 IVEOUT = 1
11017 ELSE
11018 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11019 ENDIF
11020 ENDIF
11021 ENDIF
11022 ENDIF
11023
11024 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11025 & (IOGLB.NE.100)) THEN
11026 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11027 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11028 1001 FORMAT(38X,'projectile',
11029 & ' target',/,1X,'Mass number / charge',
11030 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11031 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11032 & 'Parameters of elastic scattering amplitude:',/,5X,
11033 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11034 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11035 & 'statistics at each b-step',4X,I5,/,/,1X,
11036 & 'Prod. cross section ',5X,F10.4,' mb',/)
11037 ENDIF
11038
11039 RETURN
11040 END
11041
11042*$ CREATE DT_PROFBI.FOR
11043*COPY DT_PROFBI
11044*
11045*===profbi=============================================================*
11046*
11047 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11048
11049************************************************************************
11050* Integral over profile function (to be used for impact-parameter *
11051* sampling during event generation). *
11052* Fitted results are used. *
11053* NA / NB mass numbers of proj./target nuclei *
11054* PPN projectile momentum (for projectile nuclei: *
11055* momentum per nucleon) in target rest system *
11056* NTARG index of target material (i.e. kind of nucleus) *
11057* This version dated 31.05.95 is revised by S. Roesler *
11058************************************************************************
11059
11060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11061 SAVE
11062
11063 PARAMETER ( LINP = 10 ,
11064 & LOUT = 6 ,
11065 & LDAT = 9 )
11066
11067 SAVE
11068
11069 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11070
11071 LOGICAL LSTART
11072 CHARACTER CNAME*80
11073
11074 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11075
11076* Glauber formalism: parameters
11077 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11078 & BMAX(NCOMPX),BSTEP(NCOMPX),
11079 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11080 & NSITEB,NSTATB
11081
11082* Glauber formalism: cross sections
11083 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11084 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11085 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11086 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11087 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11088 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11089 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11090 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11091 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11092 & BSLOPE,NEBINI,NQBINI
11093
11094 PARAMETER (NGLMAX=8000)
11095 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11096 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11097
11098 DATA LSTART /.TRUE./
11099
11100 IF (LSTART) THEN
11101* read fit-parameters from file
11102 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11103 I = 0
11104 1 CONTINUE
11105 READ(47,'(A80)') CNAME
11106 IF (CNAME.EQ.'STOP') GOTO 2
11107 I = I+1
11108 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11109 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11110 & GLAFIT(4,I),GLAFIT(5,I)
11111 IF (I+1.GT.NGLMAX) THEN
11112 WRITE(LOUT,1000)
11113 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11114 & 'program stopped')
11115 STOP
11116 ENDIF
11117 GOTO 1
11118 2 CONTINUE
11119 NGLPAR = I
11120 LSTART = .FALSE.
11121 ENDIF
11122
11123 NNA = NA
11124 NNB = NB
11125 IF (NA.GT.NB) THEN
11126 NNA = NB
11127 NNB = NA
11128 ENDIF
11129 IDXGLA = 0
11130 DO 3 J=1,NGLPAR
11131 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11132 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11133 DO 4 K=1,J-1
11134 IPOINT = J-K
11135 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11136 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11137 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11138 IF (IPOINT.EQ.1) IPOINT = 0
11139 NATMP = NGLIP(IPOINT+1)
11140 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11141 IDXGLA = IPOINT+1
11142 GOTO 6
11143 ELSE
11144 J1BEG = IPOINT+1
11145 J1END = J
11146C IF (J.EQ.NGLPAR) THEN
11147C J1BEG = IPOINT
11148C J1END = J
11149C ENDIF
11150 DO 5 J1=J1BEG,J1END
11151 IF (NGLIP(J1).EQ.NATMP) THEN
11152 IF (PPN.LT.GLAPPN(J1)) THEN
11153 IDXGLA = J1
11154 GOTO 6
11155 ENDIF
11156 ELSE
11157 IDXGLA = J1-1
11158 GOTO 6
11159 ENDIF
11160 5 CONTINUE
11161 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11162 & IDXGLA = NGLPAR
11163 ENDIF
11164 ENDIF
11165 4 CONTINUE
11166 ENDIF
11167 3 CONTINUE
11168
11169 6 CONTINUE
11170 IF (IDXGLA.EQ.0) THEN
11171 WRITE(LOUT,1001) NNA,NNB,PPN
11172 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11173 & 2I4,F6.0,') not found ')
11174 STOP
11175 ENDIF
11176
11177* no interpolation yet available
11178 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11179
11180 BSITE(1,1,NTARG,1) = ZERO
11181 DO 10 I=2,NSITEB
11182 XX = DBLE(I)
11183 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11184 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11185 & GLAFIT(5,IDXGLA)*XX**4
11186 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11187 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11188 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11189 10 CONTINUE
11190
11191 RETURN
11192 END
11193
11194*$ CREATE DT_GLAUBE.FOR
11195*COPY DT_GLAUBE
11196*
11197*===glaube=============================================================*
11198*
11199 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11200
11201************************************************************************
11202* Calculation of configuartion of interacting nucleons for one event. *
11203* NB / NB mass numbers of proj./target nuclei (input) *
11204* B impact parameter (output) *
11205* INTT total number of wounded nucleons " *
11206* INTA / INTB number of wounded nucleons in proj. / target " *
11207* JS / JT(i) number of collisions proj. / target nucleon i is *
11208* involved (output) *
11209* NIDX index of projectile/target material (input) *
11210* = -2 call within FLUKA transport calculation *
11211* This is an update of the original routine SHMAKO by J.Ranft/HJM *
11212* This version dated 22.03.96 is revised by S. Roesler *
11213* *
11214* Last change 27.12.2006 by S. Roesler. *
11215************************************************************************
11216
11217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11218 SAVE
11219
11220 PARAMETER ( LINP = 10 ,
11221 & LOUT = 6 ,
11222 & LDAT = 9 )
11223
11224 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11225 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11226
11227 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11228
11229 PARAMETER ( MAXNCL = 260,
11230
11231 & MAXVQU = MAXNCL,
11232 & MAXSQU = 20*MAXVQU,
11233 & MAXINT = MAXVQU+MAXSQU)
11234
11235* Glauber formalism: parameters
11236 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11237 & BMAX(NCOMPX),BSTEP(NCOMPX),
11238 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11239 & NSITEB,NSTATB
11240
11241* Glauber formalism: cross sections
11242 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11243 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11244 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11245 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11246 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11247 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11248 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11249 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11250 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11251 & BSLOPE,NEBINI,NQBINI
11252
11253* Lorentz-parameters of the current interaction
11254 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11255 & UMO,PPCM,EPROJ,PPROJ
11256
11257* properties of photon/lepton projectiles
11258 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11259
11260* Glauber formalism: collision properties
11261 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 11262 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
11263 & NCP,NCT
7b076c76 11264* Glauber formalism: flags and parameters for statistics
11265 LOGICAL LPROD
11266 CHARACTER*8 CGLB
11267 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11268
11269 DIMENSION JS(MAXNCL),JT(MAXNCL)
11270
11271 NTARG = ABS(NIDX)
11272
11273* get actual energy from /DTLTRA/
11274 ECMNOW = UMO
11275 Q2 = VIRT
11276*
11277* new patch for pre-initialized variable projectile/target/energy runs,
11278* bypassed for use within FLUKA (Nidx=-2)
11279 IF (IOGLB.EQ.100) THEN
11280 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11281*
11282* variable energy run, interpolate profile function
11283 ELSE
11284 I1 = 1
11285 I2 = 1
11286 RATE = ONE
11287 IF (NEBINI.GT.1) THEN
11288 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11289 I1 = NEBINI
11290 I2 = NEBINI
11291 RATE = ONE
11292 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11293 DO 1 I=2,NEBINI
11294 IF (ECMNOW.LT.ECMNN(I)) THEN
11295 I1 = I-1
11296 I2 = I
11297 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11298 GOTO 2
11299 ENDIF
11300 1 CONTINUE
11301 2 CONTINUE
11302 ENDIF
11303 ENDIF
11304 J1 = 1
11305 J2 = 1
11306 RATQ = ONE
11307 IF (NQBINI.GT.1) THEN
11308 IF (Q2.GE.Q2G(NQBINI)) THEN
11309 J1 = NQBINI
11310 J2 = NQBINI
11311 RATQ = ONE
11312 ELSEIF (Q2.GT.Q2G(1)) THEN
11313 DO 3 I=2,NQBINI
11314 IF (Q2.LT.Q2G(I)) THEN
11315 J1 = I-1
11316 J2 = I
11317 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11318 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11319C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11320 GOTO 4
11321 ENDIF
11322 3 CONTINUE
11323 4 CONTINUE
11324 ENDIF
11325 ENDIF
11326
11327 DO 5 I=1,KSITEB
11328 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11329 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11330 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11331 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11332 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11333 5 CONTINUE
11334 ENDIF
11335
11336 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11337 IF (NIDX.LE.-1) THEN
11338 RPROJ = RASH(1)
11339 RTARG = RBSH(NTARG)
11340 ELSE
11341 RPROJ = RASH(NTARG)
11342 RTARG = RBSH(1)
11343 ENDIF
11344
11345 RETURN
11346 END
11347
11348*$ CREATE DT_DIAGR.FOR
11349*COPY DT_DIAGR
11350*
11351*===diagr==============================================================*
11352*
11353 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11354 & NIDX)
11355
11356************************************************************************
11357* Based on the original version by Shmakov et al. *
11358* This version dated 21.04.95 is revised by S. Roesler *
11359************************************************************************
11360
11361 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11362 SAVE
11363
11364 PARAMETER ( LINP = 10 ,
11365 & LOUT = 6 ,
11366 & LDAT = 9 )
11367
11368 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11369 PARAMETER (TWOPI = 6.283185307179586454D+00,
11370 & PI = TWOPI/TWO,
11371 & GEV2MB = 0.38938D0,
11372 & GEV2FM = 0.1972D0,
11373 & ALPHEM = ONE/137.0D0,
11374* proton mass
11375 & AMP = 0.938D0,
11376 & AMP2 = AMP**2,
11377* rho0 mass
11378 & AMRHO0 = 0.77D0)
11379
11380 COMPLEX*16 C,CA,CI
11381
11382 PARAMETER ( MAXNCL = 260,
11383
11384 & MAXVQU = MAXNCL,
11385 & MAXSQU = 20*MAXVQU,
11386 & MAXINT = MAXVQU+MAXSQU)
11387
11388* particle properties (BAMJET index convention)
11389 CHARACTER*8 ANAME
11390 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11391 & IICH(210),IIBAR(210),K1(210),K2(210)
11392
11393 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11394
11395* emulsion treatment
11396 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11397 & NCOMPO,IEMUL
11398
11399* Glauber formalism: parameters
11400 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11401 & BMAX(NCOMPX),BSTEP(NCOMPX),
11402 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11403 & NSITEB,NSTATB
11404
11405* Glauber formalism: cross sections
11406 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11407 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11408 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11409 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11410 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11411 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11412 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11413 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11414 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11415 & BSLOPE,NEBINI,NQBINI
11416
11417* VDM parameter for photon-nucleus interactions
11418 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11419
11420* nucleon-nucleon event-generator
11421 CHARACTER*8 CMODEL
11422 LOGICAL LPHOIN
11423 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11424**PHOJET105a
11425C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11426**PHOJET112
11427
11428C obsolete cut-off information
11429 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11430 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11431**
11432
11433* coordinates of nucleons
11434 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11435
11436* interface between Glauber formalism and DPM
11437 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11438 & INTER1(MAXINT),INTER2(MAXINT)
11439
11440* statistics: Glauber-formalism
11441 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11442
11443* n-n cross section fluctuations
11444 PARAMETER (NBINS = 1000)
11445 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11446
11447 DIMENSION JS(MAXNCL),JT(MAXNCL),
11448 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11449 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11450 DIMENSION NWA(0:210),NWB(0:210)
11451
11452 LOGICAL LFIRST
11453 DATA LFIRST /.TRUE./
11454
11455 DATA NTARGO,ICNT /0,0/
11456
11457 NTARG = ABS(NIDX)
11458
11459 IF (LFIRST) THEN
11460 LFIRST = .FALSE.
11461 IF (NCOMPO.EQ.0) THEN
11462 NCALL = 0
11463 NWAMAX = NA
11464 NWBMAX = NB
11465 DO 17 I=0,210
11466 NWA(I) = 0
11467 NWB(I) = 0
11468 17 CONTINUE
11469 ENDIF
11470 ENDIF
11471 IF (NTARG.EQ.-1) THEN
11472 IF (NCOMPO.EQ.0) THEN
11473 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11474 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11475 & NCALL,NWAMAX,NWBMAX
11476 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11477 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11478 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11479 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11480 18 CONTINUE
11481 ENDIF
11482 RETURN
11483 ENDIF
11484
11485 DCOH = 1.0D10
11486 IPNT = 0
11487
11488 SQ2 = Q2
11489 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11490 S = ECMNOW**2
11491 X = SQ2/(S+SQ2-AMP2)
11492 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11493* photon projectiles: recalculate photon-nucleon amplitude
11494 IF (IJPROJ.EQ.7) THEN
11495 15 CONTINUE
11496* VDM assumption: mass of V-meson
11497 AMV2 = DT_SAM2(SQ2,ECMNOW)
11498 AMV = SQRT(AMV2)
11499 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11500* check for pointlike interaction
11501 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11502**sr 27.10.
11503C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11504 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11505**
11506 ROSH = 0.1D0
11507 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11508 & +0.25D0*LOG(S/(AMV2+SQ2)))
11509* coherence length
11510 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11511 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11512 IF (MCGENE.EQ.2) THEN
11513 ZERO1 = ZERO
11514 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11515 & BSLOPE,0)
11516 ELSE
11517 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11518 ENDIF
11519 IF (ECMNOW.LE.3.0D0) THEN
11520 ROSH = -0.43D0
11521 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11522 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11523 ELSEIF (ECMNOW.GT.50.0D0) THEN
11524 ROSH = 0.1D0
11525 ENDIF
11526 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11527 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11528 IF (MCGENE.EQ.2) THEN
11529 ZERO1 = ZERO
11530 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11531 & BDUM,0)
11532 SIGSH = SIGSH/10.0D0
11533 ELSE
11534C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11535 DUMZER = ZERO
11536 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11537 SIGSH = SIGSH/10.0D0
11538 ENDIF
11539 ELSE
11540 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11541 ROSH = 0.01D0
11542 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11543 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11544C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11545 DUMZER = ZERO
11546 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11547 SIGSH = SIGSH/10.0D0
11548 ENDIF
11549 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11550 GAM = GSH
11551 RCA = GAM*SIGSH/TWOPI
11552 FCA = -ROSH*RCA
11553 CA = DCMPLX(RCA,FCA)
11554 CI = DCMPLX(ONE,ZERO)
11555
11556 16 CONTINUE
11557* impact parameter
11558 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11559
11560 NTRY = 0
11561 3 CONTINUE
11562 NTRY = NTRY+1
11563* initializations
11564 JNT = 0
11565 DO 1 I=1,NA
11566 JS(I) = 0
11567 1 CONTINUE
11568 DO 2 I=1,NB
11569 JT(I) = 0
11570 2 CONTINUE
11571 IF (IJPROJ.EQ.7) THEN
11572 DO 8 I=1,MAXNCL
11573 JS0(I) = 0
11574 JNT0(I)= 0
11575 DO 9 J=1,NB
11576 JT0(I,J) = 0
11577 9 CONTINUE
11578 8 CONTINUE
11579 ENDIF
11580
11581* nucleon configuration
11582C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11583 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11584C CALL DT_CONUCL(PKOO,NA,RASH,2)
11585C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11586 IF (NIDX.LE.-1) THEN
11587 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11588 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11589 ELSE
11590 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11591 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11592 ENDIF
11593 NTARGO = NTARG
11594 ENDIF
11595 ICNT = ICNT+1
11596
11597* LEPTO: pick out one struck nucleon
11598 IF (MCGENE.EQ.3) THEN
11599 JNT = 1
11600 JS(1) = 1
11601 IDX = INT(DT_RNDM(X)*NB)+1
11602 JT(IDX) = 1
11603 B = ZERO
11604 GOTO 19
11605 ENDIF
11606
11607 DO 4 INA=1,NA
11608* cross section fluctuations
11609 AFLUC = ONE
11610 IF (IFLUCT.EQ.1) THEN
11611 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11612 AFLUC = FLUIXX(IFLUK)
11613 ENDIF
11614 KK1 = 1
11615 KINT = 1
11616 DO 5 INB=1,NB
11617* photon-projectile: check for supression by coherence length
11618 IF (IJPROJ.EQ.7) THEN
11619 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11620 KK1 = INB
11621 KINT = KINT+1
11622 ENDIF
11623 ENDIF
11624 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11625 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11626 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11627 IF (XY.LE.15.0D0) THEN
11628 C = CI-CA*AFLUC*EXP(-XY)
11629 AR = DBLE(C)
11630 AI = DIMAG(C)
11631 P = AR*AR+AI*AI
11632 IF (DT_RNDM(XY).GE.P) THEN
11633 JNT = JNT+1
11634 IF (IJPROJ.EQ.7) THEN
11635 JNT0(KINT) = JNT0(KINT)+1
11636 IF (JNT0(KINT).GT.MAXNCL) THEN
11637 WRITE(LOUT,1001) MAXNCL
11638 1001 FORMAT(1X,
11639 & 'DIAGR: no. of requested interactions',
11640 & ' exceeds array dimensions ',I4)
11641 STOP
11642 ENDIF
11643 JS0(KINT) = JS0(KINT)+1
11644 JT0(KINT,INB) = JT0(KINT,INB)+1
11645 JI1(KINT,JNT0(KINT)) = INA
11646 JI2(KINT,JNT0(KINT)) = INB
11647 ELSE
11648 IF (JNT.GT.MAXINT) THEN
11649 WRITE(LOUT,1000) JNT, MAXINT
11650 1000 FORMAT(1X,
11651 & 'DIAGR: no. of requested interactions ('
11652 & ,I4,') exceeds array dimensions (',I4,')')
11653 STOP
11654 ENDIF
11655 JS(INA) = JS(INA)+1
11656 JT(INB) = JT(INB)+1
11657 INTER1(JNT) = INA
11658 INTER2(JNT) = INB
11659 ENDIF
11660 ENDIF
11661 ENDIF
11662 5 CONTINUE
11663 4 CONTINUE
11664
11665 IF (JNT.EQ.0) THEN
11666 IF (NTRY.LT.500) THEN
11667 GOTO 3
11668 ELSE
11669C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11670 GOTO 16
11671 ENDIF
11672 ENDIF
11673
11674 IDIREC = 0
11675 IF (IJPROJ.EQ.7) THEN
11676 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11677 10 CONTINUE
11678 IF (JNT0(K).EQ.0) THEN
11679 K = K+1
11680 IF (K.GT.KINT) K = 1
11681 GOTO 10
11682 ENDIF
11683* supress Glauber-cascade by direct photon processes
11684 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11685 IF (IPNT.GT.0) THEN
11686 JNT = 1
11687 JS(1) = 1
11688 DO 11 INB=1,NB
11689 JT(INB) = JT0(K,INB)
11690 IF (JT(INB).GT.0) GOTO 12
11691 11 CONTINUE
11692 12 CONTINUE
11693 INTER1(1) = 1
11694 INTER2(1) = INB
11695 IDIREC = IPNT
11696 ELSE
11697 JNT = JNT0(K)
11698 JS(1) = JS0(K)
11699 DO 13 INB=1,NB
11700 JT(INB) = JT0(K,INB)
11701 13 CONTINUE
11702 DO 14 I=1,JNT
11703 INTER1(I) = JI1(K,I)
11704 INTER2(I) = JI2(K,I)
11705 14 CONTINUE
11706 ENDIF
11707 ENDIF
11708
11709 19 CONTINUE
11710 INTA = 0
11711 INTB = 0
11712 DO 6 I=1,NA
11713 IF (JS(I).NE.0) INTA=INTA+1
11714 6 CONTINUE
11715 DO 7 I=1,NB
11716 IF (JT(I).NE.0) INTB=INTB+1
11717 7 CONTINUE
11718 ICWPG = INTA
11719 ICWTG = INTB
11720 ICIG = JNT
11721 IPGLB = IPGLB+INTA
11722 ITGLB = ITGLB+INTB
11723 NGLB = NGLB+1
11724
11725 IF (NCOMPO.EQ.0) THEN
11726 NCALL = NCALL+1
11727 NWA(INTA) = NWA(INTA)+1
11728 NWB(INTB) = NWB(INTB)+1
11729 ENDIF
11730
11731 RETURN
11732 END
11733
11734*$ CREATE DT_MODB.FOR
11735*COPY DT_MODB
11736*
11737*===modb===============================================================*
11738*
11739 SUBROUTINE DT_MODB(B,NIDX)
11740
11741************************************************************************
11742* Sampling of impact parameter of collision. *
11743* B impact parameter (output) *
11744* NIDX index of projectile/target material (input)*
11745* Based on the original version by Shmakov et al. *
11746* This version dated 21.04.95 is revised by S. Roesler *
11747* *
11748* Last change 27.12.2006 by S. Roesler. *
11749************************************************************************
11750
11751 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11752 SAVE
11753
11754 PARAMETER ( LINP = 10 ,
11755 & LOUT = 6 ,
11756 & LDAT = 9 )
11757
11758 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11759
11760 LOGICAL LEFT,LFIRST
11761
11762* central particle production, impact parameter biasing
11763 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11764
11765 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11766
11767* Glauber formalism: parameters
11768 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11769 & BMAX(NCOMPX),BSTEP(NCOMPX),
11770 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11771 & NSITEB,NSTATB
11772
11773* Glauber formalism: cross sections
11774 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11775 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11776 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11777 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11778 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11779 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11780 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11781 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11782 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11783 & BSLOPE,NEBINI,NQBINI
11784
11785 DATA LFIRST /.TRUE./
11786
11787 NTARG = ABS(NIDX)
11788 IF (NIDX.LE.-1) THEN
11789 RA = RASH(1)
11790 RB = RBSH(NTARG)
11791 ELSE
11792 RA = RASH(NTARG)
11793 RB = RBSH(1)
11794 ENDIF
11795
11796 IF (ICENTR.EQ.2) THEN
11797 IF (RA.EQ.RB) THEN
11798 BB = DT_RNDM(B)*(0.3D0*RA)**2
11799 B = SQRT(BB)
11800 ELSEIF(RA.LT.RB)THEN
11801 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11802 B = SQRT(BB)
11803 ELSEIF(RA.GT.RB)THEN
11804 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11805 B = SQRT(BB)
11806 ENDIF
11807 ELSE
11808 9 CONTINUE
11809 Y = DT_RNDM(BB)
11810 I0 = 1
11811 I2 = NSITEB
11812 10 CONTINUE
11813 I1 = (I0+I2)/2
11814 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11815 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11816 IF (LEFT) GOTO 20
11817 I0 = I1
11818 GOTO 30
11819 20 CONTINUE
11820 I2 = I1
11821 30 CONTINUE
11822 IF (I2-I0-2) 40,50,60
11823 40 CONTINUE
11824 I1 = I2+1
11825 IF (I1.GT.NSITEB) I1 = I0-1
11826 GOTO 70
11827 50 CONTINUE
11828 I1 = I0+1
11829 GOTO 70
11830 60 CONTINUE
11831 GOTO 10
11832 70 CONTINUE
11833 X0 = DBLE(I0-1)*BSTEP(NTARG)
11834 X1 = DBLE(I1-1)*BSTEP(NTARG)
11835 X2 = DBLE(I2-1)*BSTEP(NTARG)
11836 Y0 = BSITE(0,1,NTARG,I0)
11837 Y1 = BSITE(0,1,NTARG,I1)
11838 Y2 = BSITE(0,1,NTARG,I2)
11839 80 CONTINUE
11840 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11841 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11842 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11843**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11844 B = B+0.5D0*BSTEP(NTARG)
11845 IF (B.LT.ZERO) B = X1
11846 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11847 IF (ICENTR.LT.0) THEN
11848 IF (LFIRST) THEN
11849 LFIRST = .FALSE.
11850 IF (ICENTR.LE.-100) THEN
11851 BIMIN = 0.0D0
11852 ELSE
11853 XSFRAC = 0.0D0
11854 ENDIF
11855 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11856 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11857 & BIMIN,BIMAX,XSFRAC*100.0D0,
11858 & XSFRAC*XSPRO(1,1,NTARG)
11859 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11860 & /,15X,'---------------------------'/,/,4X,
11861 & 'average radii of proj / targ :',F10.3,' fm /',
11862 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11863 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11864 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11865 & ' cross section :',F10.3,' %',/,5X,
11866 & 'corresponding cross section :',F10.3,' mb',/)
11867 ENDIF
11868 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11869 B = BIMIN
11870 ELSE
11871 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11872 ENDIF
11873 ENDIF
11874 ENDIF
11875
11876 RETURN
11877 END
11878
11879*$ CREATE DT_SHFAST.FOR
11880*COPY DT_SHFAST
11881*
11882*===shfast=============================================================*
11883*
11884 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11885
11886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11887 SAVE
11888
11889 PARAMETER ( LINP = 10 ,
11890 & LOUT = 6 ,
11891 & LDAT = 9 )
11892
11893 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11894 & ONE=1.0D0,TWO=2.0D0)
11895
11896 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11897
11898* Glauber formalism: parameters
11899 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11900 & BMAX(NCOMPX),BSTEP(NCOMPX),
11901 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11902 & NSITEB,NSTATB
11903
11904* properties of interacting particles
11905 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11906
11907* Glauber formalism: cross sections
11908 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11909 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11910 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11911 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11912 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11913 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11914 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11915 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11916 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11917 & BSLOPE,NEBINI,NQBINI
11918
11919 IBACK = 0
11920
11921 IF (MODE.EQ.2) THEN
11922 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11923 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11924 1000 FORMAT(1X,8I5,E15.5)
11925 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11926 1001 FORMAT(1X,4E15.5)
11927 WRITE(47,1002) SIGSH,ROSH,GSH
11928 1002 FORMAT(1X,3E15.5)
11929 DO 10 I=1,100
11930 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11931 10 CONTINUE
11932 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11933 1003 FORMAT(1X,2I10,3E15.5)
11934 CLOSE(47)
11935 ELSE
11936 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11937 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11938 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11939 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11940 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11941 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11942 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11943 READ(47,1002) SIGSH,ROSH,GSH
11944 DO 11 I=1,100
11945 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11946 11 CONTINUE
11947 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11948 ELSE
11949 IBACK = 1
11950 ENDIF
11951 CLOSE(47)
11952 ENDIF
11953
11954 RETURN
11955 END
11956
11957*$ CREATE DT_POILIK.FOR
11958*COPY DT_POILIK
11959*
11960*===poilik=============================================================*
11961*
11962 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11963
11964 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11965 SAVE
11966
11967 PARAMETER ( LINP = 10 ,
11968 & LOUT = 6 ,
11969 & LDAT = 9 )
11970
11971 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11972 PARAMETER (NE = 8)
11973
11974**PHOJET105a
11975C CHARACTER*8 MDLNA
11976C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11977C PARAMETER (IEETAB=10)
11978C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11979**PHOJET110
11980
11981C model switches and parameters
11982 CHARACTER*8 MDLNA
11983 INTEGER ISWMDL,IPAMDL
11984 DOUBLE PRECISION PARMDL
11985 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11986
11987C energy-interpolation table
11988 INTEGER IEETA2
11989 PARAMETER ( IEETA2 = 20 )
11990 INTEGER ISIMAX
11991 DOUBLE PRECISION SIGTAB,SIGECM
11992 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11993**
11994
11995* VDM parameter for photon-nucleus interactions
11996 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11997**sr 22.7.97
11998
11999 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12000
12001* Glauber formalism: cross sections
12002 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12003 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12004 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12005 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12006 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12007 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12008 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12009 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12010 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12011 & BSLOPE,NEBINI,NQBINI
12012**
12013
12014 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12015
12016 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12017
12018* load cross sections from interpolation table
12019 IP = 1
12020 IF(ECM.LE.SIGECM(IP,1)) THEN
12021 I1 = 1
12022 I2 = 1
12023 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12024 DO 50 I=2,ISIMAX
12025 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12026 50 CONTINUE
12027 200 CONTINUE
12028 I1 = I-1
12029 I2 = I
12030 ELSE
12031 WRITE(LOUT,'(/1X,A,2E12.3)')
12032 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12033 I1 = ISIMAX
12034 I2 = ISIMAX
12035 ENDIF
12036 FAC2 = ZERO
12037 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12038 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12039 FAC1 = ONE-FAC2
12040
12041 SIGANO = DT_SANO(ECM)
12042
12043* cross section dependence on photon virtuality
12044 FSUP1 = ZERO
12045 DO 150 I=1,3
12046 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12047 & /(ONE+VIRT/PARMDL(30+I))**2
12048 150 CONTINUE
12049 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12050 FAC1 = FAC1*FSUP1
12051 FAC2 = FAC2*FSUP1
12052 FSUP2 = ONE
12053
12054 ECMOLD = ECM
12055 Q2OLD = VIRT
12056
12057 3 CONTINUE
12058
12059C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12060 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12061 IF (ISHAD(1).EQ.1) THEN
12062 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12063 ELSE
12064 SIGDIR = ZERO
12065 ENDIF
12066 SIGANO = FSUP1*FSUP2*SIGANO
12067 SIGTOT = SIGTOT-SIGDIR-SIGANO
12068 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12069 SIGANO = SIGANO/(FSUP1*FSUP2)
12070 SIGTOT = SIGTOT+SIGDIR+SIGANO
12071
12072 RR = DT_RNDM(SIGTOT)
12073 IF (RR.LT.SIGDIR/SIGTOT) THEN
12074 IPNT = 1
12075 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12076 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12077 IPNT = 2
12078 ELSE
12079 IPNT = 0
12080 ENDIF
12081 RPNT = (SIGDIR+SIGANO)/SIGTOT
12082C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12083C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12084C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12085C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12086 IF (MODE.EQ.1) RETURN
12087
12088**sr 22.7.97
12089 K1 = 1
12090 K2 = 1
12091 RATE = ZERO
12092 IF (ECM.GE.ECMNN(NEBINI)) THEN
12093 K1 = NEBINI
12094 K2 = NEBINI
12095 RATE = ONE
12096 ELSEIF (ECM.GT.ECMNN(1)) THEN
12097 DO 10 I=2,NEBINI
12098 IF (ECM.LT.ECMNN(I)) THEN
12099 K1 = I-1
12100 K2 = I
12101 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12102 GOTO 11
12103 ENDIF
12104 10 CONTINUE
12105 11 CONTINUE
12106 ENDIF
12107 J1 = 1
12108 J2 = 1
12109 RATQ = ZERO
12110 IF (NQBINI.GT.1) THEN
12111 IF (VIRT.GE.Q2G(NQBINI)) THEN
12112 J1 = NQBINI
12113 J2 = NQBINI
12114 RATQ = ONE
12115 ELSEIF (VIRT.GT.Q2G(1)) THEN
12116 DO 12 I=2,NQBINI
12117 IF (VIRT.LT.Q2G(I)) THEN
12118 J1 = I-1
12119 J2 = I
12120 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12121 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12122 GOTO 13
12123 ENDIF
12124 12 CONTINUE
12125 13 CONTINUE
12126 ENDIF
12127 ENDIF
12128 SGA = XSPRO(K1,J1,NTARG)+
12129 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12130 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12131 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12132 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12133 SDI = DBLE(NB)*SIGDIR
12134 SAN = DBLE(NB)*SIGANO
12135 SPL = SDI+SAN
12136 RR = DT_RNDM(SPL)
12137 IF (RR.LT.SDI/SGA) THEN
12138 IPNT = 1
12139 ELSEIF ((RR.GE.SDI/SGA).AND.
12140 & (RR.LT.SPL/SGA)) THEN
12141 IPNT = 2
12142 ELSE
12143 IPNT = 0
12144 ENDIF
12145 RPNT = SPL/SGA
12146C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12147**
12148
12149 RETURN
12150 END
12151
12152*$ CREATE DT_GLBINI.FOR
12153*COPY DT_GLBINI
12154*
12155*===glbini=============================================================*
12156*
12157 SUBROUTINE DT_GLBINI(WHAT)
12158
12159************************************************************************
12160* Pre-initialization of profile function *
12161* This version dated 28.11.00 is written by S. Roesler. *
12162* *
12163* Last change 27.12.2006 by S. Roesler. *
12164************************************************************************
12165
12166 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12167 SAVE
12168
12169 PARAMETER ( LINP = 10 ,
12170 & LOUT = 6 ,
12171 & LDAT = 9 )
12172
12173 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12174
12175 LOGICAL LCMS
12176
12177* particle properties (BAMJET index convention)
12178 CHARACTER*8 ANAME
12179 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12180 & IICH(210),IIBAR(210),K1(210),K2(210)
12181
12182* properties of interacting particles
12183 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12184
12185 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12186
12187* emulsion treatment
12188 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12189 & NCOMPO,IEMUL
12190
12191* Glauber formalism: flags and parameters for statistics
12192 LOGICAL LPROD
12193 CHARACTER*8 CGLB
12194 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12195
12196* number of data sets other than protons and nuclei
12197* at the moment = 2 (pions and kaons)
12198 PARAMETER (MAXOFF=2)
12199 DIMENSION IJPINI(5),IOFFST(25)
12200 DATA IJPINI / 13, 15, 0, 0, 0/
12201* Glauber data-set to be used for hadron projectiles
12202* (0=proton, 1=pion, 2=kaon)
12203 DATA (IOFFST(K),K=1,25) /
12204 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12205 & 0, 0, 1, 2, 2/
12206* Acceptance interval for target nucleus mass
12207 PARAMETER (KBACC = 6)
12208
12209* flags for input different options
12210 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12211 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12212 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12213
12214 PARAMETER (MAXMSS = 100)
12215 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12216 DIMENSION WHAT(6)
12217
12218 DATA JPEACH,JPSTEP / 18, 5 /
12219
12220* temporary patch until fix has been implemented in phojet:
12221* maximum energy for pion projectile
12222 DATA ECMXPI / 100000.0D0 /
12223*
12224*--------------------------------------------------------------------------
12225* general initializations
12226*
12227* steps in projectile mass number for initialization
12228 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12229 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12230*
12231* energy range and binning
12232 ELO = ABS(WHAT(1))
12233 EHI = ABS(WHAT(2))
12234 IF (ELO.GT.EHI) ELO = EHI
12235 NEBIN = MAX(INT(WHAT(3)),1)
12236 IF (ELO.EQ.EHI) NEBIN = 0
12237 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12238 IF (LCMS) THEN
12239 ECMINI = EHI
12240 ELSE
12241 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12242 & +2.0D0*AAM(IJTARG)*EHI)
12243 ENDIF
12244*
12245* default arguments for Glauber-routine
12246 XI = ZERO
12247 Q2I = ZERO
12248*
12249* initialize nuclear parameters, etc.
12250
12251* initialize evaporation if the code is not used as Fluka event generator
12252 IF (ITRSPT.NE.1) THEN
12253 CALL NCDTRD
12254 CALL INCINI
12255 ENDIF
12256
12257*
12258* open Glauber-data output file
12259 IDX = INDEX(CGLB,' ')
12260 K = 12
12261 IF (IDX.GT.1) K = IDX-1
12262 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12263*
12264*--------------------------------------------------------------------------
12265* Glauber-initialization for proton and nuclei projectiles
12266*
12267* initialize phojet for proton-proton interactions
12268 ELAB = ZERO
12269 PLAB = ZERO
12270 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12271 CALL DT_PHOINI
12272*
12273* record projectile masses
12274 NASAV = 0
12275 NPROJ = MIN(IP,JPEACH)
12276 DO 10 KPROJ=1,NPROJ
12277 NASAV = NASAV+1
12278 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12279 IASAV(NASAV) = KPROJ
12280 10 CONTINUE
12281 IF (IP.GT.JPEACH) THEN
12282 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12283 IF (NPROJ.EQ.0) THEN
12284 NASAV = NASAV+1
12285 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12286 IASAV(NASAV) = IP
12287 ELSE
12288 DO 11 IPROJ=1,NPROJ
12289 KPROJ = JPEACH+IPROJ*JPSTEP
12290 NASAV = NASAV+1
12291 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12292 IASAV(NASAV) = KPROJ
12293 11 CONTINUE
12294 IF (KPROJ.LT.IP) THEN
12295 NASAV = NASAV+1
12296 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12297 IASAV(NASAV) = IP
12298 ENDIF
12299 ENDIF
12300 ENDIF
12301*
12302* record target masses
12303 NBSAV = 0
12304 NTARG = 1
12305 IF (NCOMPO.GT.0) NTARG = NCOMPO
12306 DO 12 ITARG=1,NTARG
12307 NBSAV = NBSAV+1
12308 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12309 IF (NCOMPO.GT.0) THEN
12310 IBSAV(NBSAV) = IEMUMA(ITARG)
12311 ELSE
12312 IBSAV(NBSAV) = IT
12313 ENDIF
12314 12 CONTINUE
12315*
12316* print masses
12317 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12318 1000 FORMAT(I4,A,1P,2E13.5)
12319 NLINES = DBLE(NASAV)/18.0D0
12320 IF (NLINES.GT.0) THEN
12321 DO 13 I=1,NLINES
12322 IF (I.EQ.1) THEN
12323 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12324 ELSE
12325 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12326 ENDIF
12327 13 CONTINUE
12328 ENDIF
12329 I0 = 18*NLINES+1
12330 IF (I0.LE.NASAV) THEN
12331 IF (I0.EQ.1) THEN
12332 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12333 ELSE
12334 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12335 ENDIF
12336 ENDIF
12337 NLINES = DBLE(NBSAV)/18.0D0
12338 IF (NLINES.GT.0) THEN
12339 DO 14 I=1,NLINES
12340 IF (I.EQ.1) THEN
12341 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12342 ELSE
12343 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12344 ENDIF
12345 14 CONTINUE
12346 ENDIF
12347 I0 = 18*NLINES+1
12348 IF (I0.LE.NBSAV) THEN
12349 IF (I0.EQ.1) THEN
12350 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12351 ELSE
12352 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12353 ENDIF
12354 ENDIF
12355*
12356* calculate Glauber-data for each energy and mass combination
12357*
12358* loop over energy bins
12359 ELO = LOG10(ELO)
12360 EHI = LOG10(EHI)
12361 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12362 DO 1 IE=1,NEBIN+1
12363 E = ELO+DBLE(IE-1)*DEBIN
12364 E = 10**E
12365 IF (LCMS) THEN
12366 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12367 ECM = E
12368 ELSE
12369 PLAB = ZERO
12370 ECM = ZERO
12371 E = MAX(AAM(IJPROJ)+0.1D0,E)
12372 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12373 ENDIF
12374*
12375* loop over projectile and target masses
12376 DO 2 ITARG=1,NBSAV
12377 DO 3 IPROJ=1,NASAV
12378 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12379 & XI,Q2I,ECM,1,1,-1)
12380 3 CONTINUE
12381 2 CONTINUE
12382*
12383 1 CONTINUE
12384*
12385*--------------------------------------------------------------------------
12386* Glauber-initialization for pion, kaon, ... projectiles
12387*
12388 DO 6 IJ=1,MAXOFF
12389*
12390* initialize phojet for this interaction
12391 ELAB = ZERO
12392 PLAB = ZERO
12393 IJPROJ = IJPINI(IJ)
12394 IP = 1
12395 IPZ = 1
12396*
12397* temporary patch until fix has been implemented in phojet:
12398 IF (ECMINI.GT.ECMXPI) THEN
12399 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12400 ELSE
12401 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12402 ENDIF
12403 CALL DT_PHOINI
12404*
12405* calculate Glauber-data for each energy and mass combination
12406*
12407* loop over energy bins
12408 DO 4 IE=1,NEBIN+1
12409 E = ELO+DBLE(IE-1)*DEBIN
12410 E = 10**E
12411 IF (LCMS) THEN
12412 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12413 ECM = E
12414 ELSE
12415 PLAB = ZERO
12416 ECM = ZERO
12417 E = MAX(AAM(IJPROJ)+TINY14,E)
12418 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12419 ENDIF
12420*
12421* loop over projectile and target masses
12422 DO 5 ITARG=1,NBSAV
12423 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12424 5 CONTINUE
12425*
12426 4 CONTINUE
12427*
12428 6 CONTINUE
12429
12430*--------------------------------------------------------------------------
12431* close output unit(s), etc.
12432*
12433 CLOSE(LDAT)
12434
12435 RETURN
12436 END
12437
12438*$ CREATE DT_GLBSET.FOR
12439*COPY DT_GLBSET
12440*
12441*===glbset=============================================================*
12442*
12443 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12444************************************************************************
12445* Interpolation of pre-initialized profile functions *
12446* This version dated 28.11.00 is written by S. Roesler. *
12447************************************************************************
12448
12449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12450 SAVE
12451
12452 PARAMETER ( LINP = 10 ,
12453 & LOUT = 6 ,
12454 & LDAT = 9 )
12455
12456 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12457
12458 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12459
12460* particle properties (BAMJET index convention)
12461 CHARACTER*8 ANAME
12462 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12463 & IICH(210),IIBAR(210),K1(210),K2(210)
12464
12465* Glauber formalism: flags and parameters for statistics
12466 LOGICAL LPROD
12467 CHARACTER*8 CGLB
12468 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12469
12470 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12471
12472* Glauber formalism: parameters
12473 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12474 & BMAX(NCOMPX),BSTEP(NCOMPX),
12475 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12476 & NSITEB,NSTATB
12477
12478* Glauber formalism: cross sections
12479 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12480 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12481 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12482 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12483 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12484 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12485 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12486 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12487 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12488 & BSLOPE,NEBINI,NQBINI
12489
12490* number of data sets other than protons and nuclei
12491* at the moment = 2 (pions and kaons)
12492 PARAMETER (MAXOFF=2)
12493 DIMENSION IJPINI(5),IOFFST(25)
12494 DATA IJPINI / 13, 15, 0, 0, 0/
12495* Glauber data-set to be used for hadron projectiles
12496* (0=proton, 1=pion, 2=kaon)
12497 DATA (IOFFST(K),K=1,25) /
12498 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12499 & 0, 0, 1, 2, 2/
12500* Acceptance interval for target nucleus mass
12501 PARAMETER (KBACC = 6)
12502
12503* emulsion treatment
12504 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12505 & NCOMPO,IEMUL
12506
12507 PARAMETER (MAXSET=5000,
12508 & MAXBIN=100)
12509 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12510 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12511 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12512 & IAIDX(10)
12513
12514 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12515*
12516* read data from file
12517*
12518 IF (MODE.EQ.0) THEN
12519
12520 IF (LREAD) RETURN
12521
12522 DO 1 I=1,MAXSET
12523 DO 2 J=1,6
12524 XSIG(I,J) = ZERO
12525 XERR(I,J) = ZERO
12526 2 CONTINUE
12527 DO 3 J=1,KSITEB
12528 BPROFL(I,J) = ZERO
12529 3 CONTINUE
12530 1 CONTINUE
12531 DO 4 I=1,MAXBIN
12532 IABIN(I) = 0
12533 IBBIN(I) = 0
12534 4 CONTINUE
12535 DO 5 I=1,KSITEB
12536 BPRO0(I) = ZERO
12537 BPRO1(I) = ZERO
12538 BPRO(I) = ZERO
12539 5 CONTINUE
12540
12541 IDX = INDEX(CGLB,' ')
12542 K = 12
12543 IF (IDX.GT.1) K = IDX-1
12544 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12545 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12546 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12547 & 'file ',A12,/)
12548*
12549* read binning information
12550 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12551* return lower energy threshold to Fluka-interface
12552 ELAB = ELO
12553 LCMS = ELO.LT.ZERO
12554 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12555 IF (LCMS) THEN
12556 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12557 ELSE
12558 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12559 ENDIF
12560 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12561 & 'No. of bins:',I5,/)
12562 ELO = LOG10(ABS(ELO))
12563 EHI = LOG10(ABS(EHI))
12564 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12565 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12566 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12567 IF (NABIN.LT.18) THEN
12568 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12569 ELSE
12570 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12571 ENDIF
12572 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12573 IF (NABIN.GT.18) THEN
12574 NLINES = DBLE(NABIN-18)/18.0D0
12575 IF (NLINES.GT.0) THEN
12576 DO 7 I=1,NLINES
12577 I0 = 18*(I+1)-17
12578 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12579 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12580 7 CONTINUE
12581 ENDIF
12582 I0 = 18*(NLINES+1)+1
12583 IF (I0.LE.NABIN) THEN
12584 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12585 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12586 ENDIF
12587 ENDIF
12588 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12589 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12590 IF (NBBIN.LT.18) THEN
12591 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12592 ELSE
12593 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12594 ENDIF
12595 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12596 IF (NBBIN.GT.18) THEN
12597 NLINES = DBLE(NBBIN-18)/18.0D0
12598 IF (NLINES.GT.0) THEN
12599 DO 8 I=1,NLINES
12600 I0 = 18*(I+1)-17
12601 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12602 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12603 8 CONTINUE
12604 ENDIF
12605 I0 = 18*(NLINES+1)+1
12606 IF (I0.LE.NBBIN) THEN
12607 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12608 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12609 ENDIF
12610 ENDIF
12611* number of data sets to follow in the Glauber data file
12612* this variable is used for checks of consistency of projectile
12613* and target mass configurations given in header of Glauber data
12614* file and the data-sets which follow in this file
12615 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12616*
12617* read profile function data
12618 NSET = 0
12619 NAIDX = 0
12620 IPOLD = 0
12621 10 CONTINUE
12622 NSET = NSET+1
12623 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12624 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12625 1002 FORMAT(5I10,E15.5)
12626 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12627 NAIDX = NAIDX+1
12628 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12629 IAIDX(NAIDX) = IP
12630 IPOLD = IP
12631 ENDIF
12632 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12633 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12634 NLINES = INT(DBLE(ISITEB)/7.0D0)
12635 IF (NLINES.GT.0) THEN
12636 DO 11 I=1,NLINES
12637 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12638 11 CONTINUE
12639 ENDIF
12640 I0 = 7*NLINES+1
12641 IF (I0.LE.ISITEB)
12642 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12643 GOTO 10
12644 100 CONTINUE
12645 NSET = NSET-1
12646 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12647 WRITE(LOUT,'(/,1X,A)')
12648 & ' projectiles other than protons and nuclei: (particle index)'
12649 IF (NAIDX.GT.0) THEN
12650 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12651 ELSE
12652 WRITE(LOUT,'(6X,A)') 'none'
12653 ENDIF
12654*
12655 CLOSE(LDAT)
12656 WRITE(LOUT,*)
12657 LREAD = .TRUE.
12658
12659 IF (NCOMPO.EQ.0) THEN
12660 DO 12 J=1,NBBIN
12661 NCOMPO = NCOMPO+1
12662 IEMUMA(NCOMPO) = IBBIN(J)
12663 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12664 EMUFRA(NCOMPO) = 1.0D0
12665 12 CONTINUE
12666 IEMUL = 1
12667 ENDIF
12668*
12669* calculate profile function for certain set of parameters
12670*
12671 ELSE
12672
12673c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12674*
12675* check for type of projectile and set index-offset to entry in
12676* Glauber data array correspondingly
12677 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12678 IF (IOFFST(IDPROJ).EQ.-1) THEN
12679 STOP ' GLBSET: no data for this projectile !'
12680 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12681 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12682 ELSE
12683 IDXOFF = 0
12684 ENDIF
12685*
12686* get energy bin and interpolation factor
12687 IF (LCMS) THEN
12688 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12689 ELSE
12690 E = ELAB
12691 ENDIF
12692 E = LOG10(E)
12693 IF (E.LT.ELO) THEN
12694 IF (LFRST1) THEN
12695 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12696 LFRST1 = .FALSE.
12697 ENDIF
12698 E = ELO
12699 ENDIF
12700 IF (E.GT.EHI) THEN
12701 IF (LFRST2) THEN
12702 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12703 LFRST2 = .FALSE.
12704 ENDIF
12705 E = EHI
12706 ENDIF
12707 IE0 = (E-ELO)/DEBIN+1
12708 IE1 = IE0+1
12709 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12710*
12711* get target nucleus index
12712 KB = 0
12713 NBACC = KBACC
12714 DO 20 I=1,NBBIN
12715 NBDIFF = ABS(NB-IBBIN(I))
12716 IF (NB.EQ.IBBIN(I)) THEN
12717 KB = I
12718 GOTO 21
12719 ELSEIF (NBDIFF.LE.NBACC) THEN
12720 KB = I
12721 NBACC = NBDIFF
12722 ENDIF
12723 20 CONTINUE
12724 IF (KB.NE.0) GOTO 21
12725 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12726 STOP
12727 21 CONTINUE
12728*
12729* get projectile nucleus bin and interpolation factor
12730 KA0 = 0
12731 KA1 = 0
12732 FACNA = 0
12733 IF (IDXOFF.GT.0) THEN
12734 KA0 = 1
12735 KA1 = 1
12736 KABIN = 1
12737 ELSE
12738 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12739 DO 22 I=1,NABIN
12740 IF (NA.EQ.IABIN(I)) THEN
12741 KA0 = I
12742 KA1 = I
12743 GOTO 23
12744 ELSEIF (NA.LT.IABIN(I)) THEN
12745 KA0 = I-1
12746 KA1 = I
12747 GOTO 23
12748 ENDIF
12749 22 CONTINUE
12750 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12751 STOP
12752 23 CONTINUE
12753 IF (KA0.NE.KA1)
12754 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12755 KABIN = NABIN
12756 ENDIF
12757*
12758* interpolate profile functions for interactions ka0-kb and ka1-kb
12759* for energy E separately
12760 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12761 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12762 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12763 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12764 DO 30 I=1,ISITEB
12765 BPRO0(I) = BPROFL(IDX0,I)
12766 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12767 BPRO1(I) = BPROFL(IDY0,I)
12768 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12769 30 CONTINUE
12770 RADB = DT_RNCLUS(NB)
12771 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12772 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12773*
12774* interpolate cross sections for energy E and projectile mass
12775 DO 31 I=1,6
12776 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12777 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12778 XS(I) = XS0+FACNA*(XS1-XS0)
12779 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12780 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12781 XE(I) = XE0+FACNA*(XE1-XE0)
12782 31 CONTINUE
12783*
12784* interpolate between ka0 and ka1
12785 RADA = DT_RNCLUS(NA)
12786 BMX = 2.0D0*(RADA+RADB)
12787 BSTP = BMX/DBLE(ISITEB-1)
12788 BPRO(1) = ZERO
12789 DO 32 I=1,ISITEB-1
12790 B = DBLE(I)*BSTP
12791*
12792* calculate values of profile functions at B
12793 IDX0 = B/BSTP0+1
12794 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12795 IDX1 = MIN(IDX0+1,ISITEB)
12796 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12797 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12798 IDX0 = B/BSTP1+1
12799 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12800 IDX1 = MIN(IDX0+1,ISITEB)
12801 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12802 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12803*
12804 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12805 32 CONTINUE
12806*
12807* fill common dtglam
12808 NSITEB = ISITEB
12809 RASH(1) = RADA
12810 RBSH(1) = RADB
12811 BMAX(1) = BMX
12812 BSTEP(1) = BSTP
12813 DO 33 I=1,KSITEB
12814 BSITE(0,1,1,I) = BPRO(I)
12815 33 CONTINUE
12816*
12817* fill common dtglxs
12818 XSTOT(1,1,1) = XS(1)
12819 XSELA(1,1,1) = XS(2)
12820 XSQEP(1,1,1) = XS(3)
12821 XSQET(1,1,1) = XS(4)
12822 XSQE2(1,1,1) = XS(5)
12823 XSPRO(1,1,1) = XS(6)
12824 XETOT(1,1,1) = XE(1)
12825 XEELA(1,1,1) = XE(2)
12826 XEQEP(1,1,1) = XE(3)
12827 XEQET(1,1,1) = XE(4)
12828 XEQE2(1,1,1) = XE(5)
12829 XEPRO(1,1,1) = XE(6)
12830
12831 ENDIF
12832
12833 RETURN
12834 END
12835*$ CREATE DT_XKSAMP.FOR
12836*COPY DT_XKSAMP
12837*
12838*===xksamp=============================================================*
12839*
12840 SUBROUTINE DT_XKSAMP(NN,ECM)
12841
12842************************************************************************
12843* Sampling of parton x-values and chain system for one interaction. *
12844* processed by S. Roesler, 9.8.95 *
12845************************************************************************
12846
12847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12848 SAVE
12849
12850 PARAMETER ( LINP = 10 ,
12851 & LOUT = 6 ,
12852 & LDAT = 9 )
12853
12854 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12855 SAVE
12856
12857 PARAMETER (
12858* lower cuts for (valence-sea/sea-valence) chain masses
12859* antiquark-quark (u/d-sea quark) (s-sea quark)
12860 & AMIU = 0.5D0, AMIS = 0.8D0,
12861* quark-diquark (u/d-sea quark) (s-sea quark)
12862 & AMAU = 2.6D0, AMAS = 2.6D0,
12863* maximum lower valence-x threshold
12864 & XVMAX = 0.98D0,
12865* fraction of sea-diquarks sampled out of sea-partons
12866**test
12867C & FRCDIQ = 0.9D0,
12868**
12869*
12870 & SQMA = 0.7D0,
12871*
12872* maximum number of trials to generate x's for the required number
12873* of sea quark pairs for a given hadron
12874 & NSEATY = 12
12875C & NSEATY = 3
12876 & )
12877
12878 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12879
12880 PARAMETER ( MAXNCL = 260,
12881
12882 & MAXVQU = MAXNCL,
12883 & MAXSQU = 20*MAXVQU,
12884 & MAXINT = MAXVQU+MAXSQU)
12885
12886* event history
12887
12888 PARAMETER (NMXHKK=200000)
12889
12890 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12891 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12892 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12893
12894* particle properties (BAMJET index convention)
12895 CHARACTER*8 ANAME
12896 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12897 & IICH(210),IIBAR(210),K1(210),K2(210)
12898
12899* interface between Glauber formalism and DPM
12900 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12901 & INTER1(MAXINT),INTER2(MAXINT)
12902
12903* properties of interacting particles
12904 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12905
12906* threshold values for x-sampling (DTUNUC 1.x)
12907 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12908 & SSMIMQ,VVMTHR
12909
12910* x-values of partons (DTUNUC 1.x)
12911 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12912 & XTVQ(MAXVQU),XTVD(MAXVQU),
12913 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12914 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12915
12916* flavors of partons (DTUNUC 1.x)
12917 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12918 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12919 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12920 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12921 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12922 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12923 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12924
12925* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12926 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12927 & IXPV,IXPS,IXTV,IXTS,
12928 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12929 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12930 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12931 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12932 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12933 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12934 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12935 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12936
12937* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12938 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12939 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12940
12941* auxiliary common for chain system storage (DTUNUC 1.x)
12942 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12943
12944* flags for input different options
12945 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12946 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12947 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12948
12949* various options for treatment of partons (DTUNUC 1.x)
12950* (chain recombination, Cronin,..)
12951 LOGICAL LCO2CR,LINTPT
12952 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12953 & LCO2CR,LINTPT
12954
12955 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12956 & INTLO(MAXINT)
12957
12958* (1) initializations
12959*-----------------------------------------------------------------------
12960
12961**test
12962 IF (ECM.LT.4.5D0) THEN
12963C FRCDIQ = 0.6D0
12964 FRCDIQ = 0.4D0
12965 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12966C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12967 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12968 ELSE
12969C FRCDIQ = 0.9D0
12970 FRCDIQ = 0.7D0
12971 ENDIF
12972**
12973 DO 30 I=1,MAXSQU
12974 ZUOSP(I) = .FALSE.
12975 ZUOST(I) = .FALSE.
12976 IF (I.LE.MAXVQU) THEN
12977 ZUOVP(I) = .FALSE.
12978 ZUOVT(I) = .FALSE.
12979 ENDIF
12980 30 CONTINUE
12981
12982* lower thresholds for x-selection
12983* sea-quarks (default: CSEA=0.2)
12984 IF (ECM.LT.10.0D0) THEN
12985**!!test
12986 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12987C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12988 NSEA = NSEATY
12989C XSTHR = ONE/ECM**2
12990 ELSE
12991**sr 30.3.98
12992C XSTHR = CSEA/ECM
12993 XSTHR = CSEA/ECM**2
12994C XSTHR = ONE/ECM**2
12995**
12996 IF ((IP.GE.150).AND.(IT.GE.150))
12997 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12998 NSEA = NSEATY
12999 ENDIF
13000* (default: SSMIMA=0.14) used for sea-diquarks (?)
13001 XSSTHR = SSMIMA/ECM
13002 BSQMA = SQMA/ECM
13003* valence-quarks (default: CVQ=1.0)
13004 XVTHR = CVQ/ECM
13005* valence-diquarks (default: CDQ=2.0)
13006 XDTHR = CDQ/ECM
13007
13008* maximum-x for sea-quarks
13009 XVCUT = XVTHR+XDTHR
13010 IF (XVCUT.GT.XVMAX) THEN
13011 XVCUT = XVMAX
13012 XVTHR = XVCUT/3.0D0
13013 XDTHR = XVCUT-XVTHR
13014 ENDIF
13015 XXSEAM = ONE-XVCUT
13016**sr 18.4. test: DPMJET
13017C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13018C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13019C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13020**
13021* maximum number of sea-pairs allowed kinematically
13022C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13023 RNSMAX = OHALF*XXSEAM/XSTHR
13024 IF (RNSMAX.GT.10000.0D0) THEN
13025 NSMAX = 10000
13026 ELSE
13027 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13028 ENDIF
13029* check kinematical limit for valence-x thresholds
13030* (should be obsolete now)
13031 IF (XVCUT.GT.XVMAX) THEN
13032 WRITE(LOUT,1000) XVCUT,ECM
13033 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13034 & ' thresholds not allowed (',2E9.3,')')
13035C XVTHR = XVMAX-XDTHR
13036C IF (XVTHR.LT.ZERO) STOP
13037 STOP
13038 ENDIF
13039
13040* set eta for valence-x sampling (BETREJ)
13041* (UNON per default, UNOM used for projectile mesons only)
13042 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13043 UNOPRV = UNOM
13044 ELSE
13045 UNOPRV = UNON
13046 ENDIF
13047
13048* (2) select parton x-values of interacting projectile nucleons
13049*-----------------------------------------------------------------------
13050
13051 IXPV = 0
13052 IXPS = 0
13053
13054 DO 100 IPP=1,IP
13055* get interacting projectile nucleon as sampled by Glauber
13056 IF (JSSH(IPP).NE.0) THEN
13057 IXSTMP = IXPS
13058 IXVTMP = IXPV
13059 99 CONTINUE
13060 IXPS = IXSTMP
13061 IXPV = IXVTMP
13062* JIPP is the actual number of sea-pairs sampled for this nucleon
13063 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13064 41 CONTINUE
13065 XXSEA = ZERO
13066 IF (JIPP.GT.0) THEN
13067 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13068*???
13069 IF (XSTHR.GE.XSMAX) THEN
13070 JIPP = JIPP-1
13071 GOTO 41
13072 ENDIF
13073
13074*>>>get x-values of sea-quark pairs
13075 NSCOUN = 0
13076 PLW = 0.5D0
13077 40 CONTINUE
13078* accumulator for sea x-values
13079 XXSEA = ZERO
13080 NSCOUN = NSCOUN+1
13081 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13082 IF (NSCOUN.GT.NSEA) THEN
13083* decrease the number of interactions after NSEA trials
13084 JIPP = JIPP-1
13085 NSCOUN = 0
13086 ENDIF
13087 DO 70 ISQ=1,JIPP
13088* sea-quarks
13089 IF (IPSQ(IXPS+1).LE.2) THEN
13090**sr 8.4.98 (1/sqrt(x))
13091C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13092C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13093 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13094**
13095 ELSE
13096 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13097 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13098 ELSE
13099**sr 8.4.98 (1/sqrt(x))
13100C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13101C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13102 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13103**
13104 ENDIF
13105 ENDIF
13106* sea-antiquarks
13107 IF (IPSAQ(IXPS+1).GE.-2) THEN
13108**sr 8.4.98 (1/sqrt(x))
13109C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13110C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13111 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13112**
13113 ELSE
13114 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13115 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13116 ELSE
13117**sr 8.4.98 (1/sqrt(x))
13118C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13119C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13120 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13121**
13122 ENDIF
13123 ENDIF
13124 XXSEA = XXSEA+XPSQI+XPSAQI
13125* check for maximum allowed sea x-value
13126 IF (XXSEA.GE.XXSEAM) THEN
13127 IXPS = IXPS-ISQ+1
13128 GOTO 40
13129 ENDIF
13130* accept this sea-quark pair
13131 IXPS = IXPS+1
13132 XPSQ(IXPS) = XPSQI
13133 XPSAQ(IXPS) = XPSAQI
13134 IFROSP(IXPS) = IPP
13135 ZUOSP(IXPS) = .TRUE.
13136 70 CONTINUE
13137 ENDIF
13138
13139*>>>get x-values of valence partons
13140* valence quark
13141 IF (XVTHR.GT.0.05D0) THEN
13142 XVHI = ONE-XXSEA-XDTHR
13143 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13144 ELSE
13145 90 CONTINUE
13146 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13147 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13148 & GOTO 90
13149 ENDIF
13150* valence diquark
13151 XPVDI = ONE-XPVQI-XXSEA
13152* reject according to x**1.5
13153 XDTMP = XPVDI**1.5D0
13154 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13155* accept these valence partons
13156 IXPV = IXPV+1
13157 XPVQ(IXPV) = XPVQI
13158 XPVD(IXPV) = XPVDI
13159 IFROVP(IXPV) = IPP
13160 ITOVP(IPP) = IXPV
13161 ZUOVP(IXPV) = .TRUE.
13162
13163 ENDIF
13164 100 CONTINUE
13165
13166* (3) select parton x-values of interacting target nucleons
13167*-----------------------------------------------------------------------
13168
13169 IXTV = 0
13170 IXTS = 0
13171
13172 DO 170 ITT=1,IT
13173* get interacting target nucleon as sampled by Glauber
13174 IF (JTSH(ITT).NE.0) THEN
13175 IXSTMP = IXTS
13176 IXVTMP = IXTV
13177 169 CONTINUE
13178 IXTS = IXSTMP
13179 IXTV = IXVTMP
13180* JITT is the actual number of sea-pairs sampled for this nucleon
13181 JITT = MIN(JTSH(ITT)-1,NSMAX)
13182 111 CONTINUE
13183 XXSEA = ZERO
13184 IF (JITT.GT.0) THEN
13185 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13186*???
13187 IF (XSTHR.GE.XSMAX) THEN
13188 JITT = JITT-1
13189 GOTO 111
13190 ENDIF
13191
13192*>>>get x-values of sea-quark pairs
13193 NSCOUN = 0
13194 PLW = 0.5D0
13195 110 CONTINUE
13196* accumulator for sea x-values
13197 XXSEA = ZERO
13198 NSCOUN = NSCOUN+1
13199 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13200 IF (NSCOUN.GT.NSEA)THEN
13201* decrease the number of interactions after NSEA trials
13202 JITT = JITT-1
13203 NSCOUN = 0
13204 ENDIF
13205 DO 140 ISQ=1,JITT
13206* sea-quarks
13207 IF (ITSQ(IXTS+1).LE.2) THEN
13208**sr 8.4.98 (1/sqrt(x))
13209C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13210C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13211 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13212**
13213 ELSE
13214 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13215 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13216 ELSE
13217**sr 8.4.98 (1/sqrt(x))
13218C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13219C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13220 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13221**
13222 ENDIF
13223 ENDIF
13224* sea-antiquarks
13225 IF (ITSAQ(IXTS+1).GE.-2) THEN
13226**sr 8.4.98 (1/sqrt(x))
13227C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13228C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13229 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13230**
13231 ELSE
13232 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13233 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13234 ELSE
13235**sr 8.4.98 (1/sqrt(x))
13236C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13237C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13238 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13239**
13240 ENDIF
13241 ENDIF
13242 XXSEA = XXSEA+XTSQI+XTSAQI
13243* check for maximum allowed sea x-value
13244 IF (XXSEA.GE.XXSEAM) THEN
13245 IXTS = IXTS-ISQ+1
13246 GOTO 110
13247 ENDIF
13248* accept this sea-quark pair
13249 IXTS = IXTS+1
13250 XTSQ(IXTS) = XTSQI
13251 XTSAQ(IXTS) = XTSAQI
13252 IFROST(IXTS) = ITT
13253 ZUOST(IXTS) = .TRUE.
13254 140 CONTINUE
13255 ENDIF
13256
13257*>>>get x-values of valence partons
13258* valence quark
13259 IF (XVTHR.GT.0.05D0) THEN
13260 XVHI = ONE-XXSEA-XDTHR
13261 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13262 ELSE
13263 160 CONTINUE
13264 XTVQI = DT_DBETAR(OHALF,UNON)
13265 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13266 & GOTO 160
13267 ENDIF
13268* valence diquark
13269 XTVDI = ONE-XTVQI-XXSEA
13270* reject according to x**1.5
13271 XDTMP = XTVDI**1.5D0
13272 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13273* accept these valence partons
13274 IXTV = IXTV+1
13275 XTVQ(IXTV) = XTVQI
13276 XTVD(IXTV) = XTVDI
13277 IFROVT(IXTV) = ITT
13278 ITOVT(ITT) = IXTV
13279 ZUOVT(IXTV) = .TRUE.
13280
13281 ENDIF
13282 170 CONTINUE
13283
13284* (4) get valence-valence chains
13285*-----------------------------------------------------------------------
13286
13287 NVV = 0
13288 DO 240 I=1,NN
13289 INTLO(I) = .TRUE.
13290 IPVAL = ITOVP(INTER1(I))
13291 ITVAL = ITOVT(INTER2(I))
13292 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13293 INTLO(I) = .FALSE.
13294 ZUOVP(IPVAL) = .FALSE.
13295 ZUOVT(ITVAL) = .FALSE.
13296 NVV = NVV+1
13297 ISKPCH(8,NVV) = 0
13298 INTVV1(NVV) = IPVAL
13299 INTVV2(NVV) = ITVAL
13300 ENDIF
13301 240 CONTINUE
13302
13303* (5) get sea-valence chains
13304*-----------------------------------------------------------------------
13305
13306 NSV = 0
13307 NDV = 0
13308 PLW = 0.5D0
13309 DO 270 I=1,NN
13310 IF (INTLO(I)) THEN
13311 IPVAL = ITOVP(INTER1(I))
13312 ITVAL = ITOVT(INTER2(I))
13313 DO 250 J=1,IXPS
13314 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13315 & ZUOVT(ITVAL)) THEN
13316 ZUOSP(J) = .FALSE.
13317 ZUOVT(ITVAL) = .FALSE.
13318 INTLO(I) = .FALSE.
13319 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13320* sample sea-diquark pair
13321 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13322 IF (IREJ1.EQ.0) GOTO 260
13323 ENDIF
13324 NSV = NSV+1
13325 ISKPCH(4,NSV) = 0
13326 INTSV1(NSV) = J
13327 INTSV2(NSV) = ITVAL
13328
13329*>>>correct chain kinematics according to minimum chain masses
13330* the actual chain masses
13331 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13332 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13333* get lower mass cuts
13334 IF (IPSQ(J).EQ.3) THEN
13335* q being s-quark
13336 AMCHK1 = AMAS
13337 AMCHK2 = AMIS
13338 ELSE
13339* q being u/d-quark
13340 AMCHK1 = AMAU
13341 AMCHK2 = AMIU
13342 ENDIF
13343* q-qq chain
13344* chain mass above minimum - resampling of sea-q x-value
13345 IF (AMSVQ1.GT.AMCHK1) THEN
13346 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13347**sr 8.4.98 (1/sqrt(x))
13348C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13349C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13350 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13351**
13352 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13353 XPSQ(J) = XPSQXX
13354* chain mass below minimum - reset sea-q x-value and correct
13355* diquark-x of the same nucleon
13356 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13357 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13358 DXPSQ = XPSQW-XPSQ(J)
13359 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13360 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13361 XPSQ(J) = XPSQW
13362 ENDIF
13363 ENDIF
13364* aq-q chain
13365* chain mass below minimum - reset sea-aq x-value and correct
13366* diquark-x of the same nucleon
13367 IF (AMSVQ2.LT.AMCHK2) THEN
13368 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13369 DXPSQ = XPSQW-XPSAQ(J)
13370 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13371 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13372 XPSAQ(J) = XPSQW
13373 ENDIF
13374 ENDIF
13375*>>>end of chain mass correction
13376
13377 GOTO 260
13378 ENDIF
13379 250 CONTINUE
13380 ENDIF
13381 260 CONTINUE
13382 270 CONTINUE
13383
13384* (6) get valence-sea chains
13385*-----------------------------------------------------------------------
13386
13387 NVS = 0
13388 NVD = 0
13389 DO 300 I=1,NN
13390 IF (INTLO(I)) THEN
13391 IPVAL = ITOVP(INTER1(I))
13392 ITVAL = ITOVT(INTER2(I))
13393 DO 280 J=1,IXTS
13394 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13395 & (IFROST(J).EQ.INTER2(I))) THEN
13396 ZUOST(J) = .FALSE.
13397 ZUOVP(IPVAL) = .FALSE.
13398 INTLO(I) = .FALSE.
13399 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13400* sample sea-diquark pair
13401 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13402 IF (IREJ1.EQ.0) GOTO 290
13403 ENDIF
13404 NVS = NVS + 1
13405 ISKPCH(6,NVS) = 0
13406 INTVS1(NVS) = IPVAL
13407 INTVS2(NVS) = J
13408
13409*>>>correct chain kinematics according to minimum chain masses
13410* the actual chain masses
13411 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13412 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13413* get lower mass cuts
13414 IF (ITSQ(J).EQ.3) THEN
13415* q being s-quark
13416 AMCHK1 = AMIS
13417 AMCHK2 = AMAS
13418 ELSE
13419* q being u/d-quark
13420 AMCHK1 = AMIU
13421 AMCHK2 = AMAU
13422 ENDIF
13423* q-aq chain
13424* chain mass below minimum - reset sea-aq x-value and correct
13425* diquark-x of the same nucleon
13426 IF (AMVSQ1.LT.AMCHK1) THEN
13427 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13428 DXTSQ = XTSQW-XTSAQ(J)
13429 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13430 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13431 XTSAQ(J) = XTSQW
13432 ENDIF
13433 ENDIF
13434* qq-q chain
13435* chain mass above minimum - resampling of sea-q x-value
13436 IF (AMVSQ2.GT.AMCHK2) THEN
13437 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13438**sr 8.4.98 (1/sqrt(x))
13439C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13440C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13441 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13442**
13443 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13444 XTSQ(J) = XTSQXX
13445* chain mass below minimum - reset sea-q x-value and correct
13446* diquark-x of the same nucleon
13447 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13448 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13449 DXTSQ = XTSQW-XTSQ(J)
13450 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13451 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13452 XTSQ(J) = XTSQW
13453 ENDIF
13454 ENDIF
13455*>>>end of chain mass correction
13456
13457 GOTO 290
13458 ENDIF
13459 280 CONTINUE
13460 ENDIF
13461 290 CONTINUE
13462 300 CONTINUE
13463
13464* (7) get sea-sea chains
13465*-----------------------------------------------------------------------
13466
13467 NSS = 0
13468 NDS = 0
13469 NSD = 0
13470 DO 420 I=1,NN
13471 IF (INTLO(I)) THEN
13472 IPVAL = ITOVP(INTER1(I))
13473 ITVAL = ITOVT(INTER2(I))
13474* loop over target partons not yet matched
13475 DO 400 J=1,IXTS
13476 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13477* loop over projectile partons not yet matched
13478 DO 390 JJ=1,IXPS
13479 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13480 ZUOSP(JJ) = .FALSE.
13481 ZUOST(J) = .FALSE.
13482 INTLO(I) = .FALSE.
13483 NSS = NSS+1
13484 ISKPCH(1,NSS) = 0
13485 INTSS1(NSS) = JJ
13486 INTSS2(NSS) = J
13487
13488*---->chain recombination option
13489 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13490 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13491 & THEN
13492* sea-sea chains may recombine with valence-valence chains
13493* only if they have the same projectile or target nucleon
13494 DO 4201 IVV=1,NVV
13495 IF (ISKPCH(8,IVV).NE.99) THEN
13496 IXVPR = INTVV1(IVV)
13497 IXVTA = INTVV2(IVV)
13498 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13499 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13500* recombination possible, drop old v-v and s-s chains
13501 ISKPCH(1,NSS) = 99
13502 ISKPCH(8,IVV) = 99
13503
13504* (a) assign new s-v chains
13505* ~~~~~~~~~~~~~~~~~~~~~~~~~
13506 IF (LSEADI.AND.
13507 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13508 & THEN
13509* sample sea-diquark pair
13510 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13511 & IREJ1)
13512 IF (IREJ1.EQ.0) GOTO 4202
13513 ENDIF
13514 NSV = NSV+1
13515 ISKPCH(4,NSV) = 0
13516 INTSV1(NSV) = JJ
13517 INTSV2(NSV) = IXVTA
13518*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13519* the actual chain masses
13520 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13521 & *ECM**2
13522 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13523 & *ECM**2
13524* get lower mass cuts
13525 IF (IPSQ(JJ).EQ.3) THEN
13526* q being s-quark
13527 AMCHK1 = AMAS
13528 AMCHK2 = AMIS
13529 ELSE
13530* q being u/d-quark
13531 AMCHK1 = AMAU
13532 AMCHK2 = AMIU
13533 ENDIF
13534* q-qq chain
13535* chain mass above minimum - resampling of sea-q x-value
13536 IF (AMSVQ1.GT.AMCHK1) THEN
13537 XPSQTH =
13538 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13539**sr 8.4.98 (1/sqrt(x))
13540 XPSQXX =
13541 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13542C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13543C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13544**
13545 XPVD(IPVAL) =
13546 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13547 XPSQ(JJ) = XPSQXX
13548* chain mass below minimum - reset sea-q x-value and correct
13549* diquark-x of the same nucleon
13550 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13551 XPSQW =
13552 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13553 DXPSQ = XPSQW-XPSQ(JJ)
13554 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13555 & THEN
13556 XPVD(IPVAL) =
13557 & XPVD(IPVAL)-DXPSQ
13558 XPSQ(JJ) = XPSQW
13559 ENDIF
13560 ENDIF
13561* aq-q chain
13562* chain mass below minimum - reset sea-aq x-value and correct
13563* diquark-x of the same nucleon
13564 IF (AMSVQ2.LT.AMCHK2) THEN
13565 XPSQW =
13566 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13567 DXPSQ = XPSQW-XPSAQ(JJ)
13568 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13569 & THEN
13570 XPVD(IPVAL) =
13571 & XPVD(IPVAL)-DXPSQ
13572 XPSAQ(JJ) = XPSQW
13573 ENDIF
13574 ENDIF
13575*>>>>>>>>>>>end of chain mass correction
13576 4202 CONTINUE
13577
13578* (b) assign new v-s chains
13579* ~~~~~~~~~~~~~~~~~~~~~~~~~
13580 IF (LSEADI.AND.(
13581 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13582 & THEN
13583* sample sea-diquark pair
13584 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13585 & IREJ1)
13586 IF (IREJ1.EQ.0) GOTO 4203
13587 ENDIF
13588 NVS = NVS+1
13589 ISKPCH(6,NVS) = 0
13590 INTVS1(NVS) = IXVPR
13591 INTVS2(NVS) = J
13592*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13593* the actual chain masses
13594 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13595 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13596* get lower mass cuts
13597 IF (ITSQ(J).EQ.3) THEN
13598* q being s-quark
13599 AMCHK1 = AMIS
13600 AMCHK2 = AMAS
13601 ELSE
13602* q being u/d-quark
13603 AMCHK1 = AMIU
13604 AMCHK2 = AMAU
13605 ENDIF
13606* q-aq chain
13607* chain mass below minimum - reset sea-aq x-value and correct
13608* diquark-x of the same nucleon
13609 IF (AMVSQ1.LT.AMCHK1) THEN
13610 XTSQW =
13611 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13612 DXTSQ = XTSQW-XTSAQ(J)
13613 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13614 & THEN
13615 XTVD(ITVAL) =
13616 & XTVD(ITVAL)-DXTSQ
13617 XTSAQ(J) = XTSQW
13618 ENDIF
13619 ENDIF
13620 IF (AMVSQ2.GT.AMCHK2) THEN
13621 XTSQTH =
13622 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13623**sr 8.4.98 (1/sqrt(x))
13624 XTSQXX =
13625 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13626C & DT_SAMSQX(XTSQTH,XTSQ(J))
13627C & DT_SAMPEX(XTSQTH,XTSQ(J))
13628**
13629 XTVD(ITVAL) =
13630 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13631 XTSQ(J) = XTSQXX
13632 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13633 XTSQW =
13634 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13635 DXTSQ = XTSQW-XTSQ(J)
13636 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13637 & THEN
13638 XTVD(ITVAL) =
13639 & XTVD(ITVAL)-DXTSQ
13640 XTSQ(J) = XTSQW
13641 ENDIF
13642 ENDIF
13643*>>>>>>>>>end of chain mass correction
13644 4203 CONTINUE
13645* jump out of s-s chain loop
13646 GOTO 420
13647 ENDIF
13648 ENDIF
13649 4201 CONTINUE
13650 ENDIF
13651*---->end of chain recombination option
13652
13653* sample sea-diquark pair (projectile)
13654 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13655 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13656 IF (IREJ1.EQ.0) THEN
13657 ISKPCH(1,NSS) = 99
13658 GOTO 410
13659 ENDIF
13660 ENDIF
13661* sample sea-diquark pair (target)
13662 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13663 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13664 IF (IREJ1.EQ.0) THEN
13665 ISKPCH(1,NSS) = 99
13666 GOTO 410
13667 ENDIF
13668 ENDIF
13669*>>>>>correct chain kinematics according to minimum chain masses
13670* the actual chain masses
13671 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13672 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13673* check for lower mass cuts
13674 IF ((SSMA1Q.LT.SSMIMQ).OR.
13675 & (SSMA2Q.LT.SSMIMQ)) THEN
13676 IPVAL = ITOVP(INTER1(I))
13677 ITVAL = ITOVT(INTER2(I))
13678 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13679 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13680* maximum allowed x values for sea quarks
13681 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13682 & 1.2D0*XSSTHR
13683 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13684 & 1.2D0*XSSTHR
13685* resampling of x values not possible - skip sea-sea chains
13686 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13687 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13688* resampling of x for projectile sea quark pair
13689 ICOUS = 0
13690 310 CONTINUE
13691 ICOUS = ICOUS+1
13692 IF (XSSTHR.GT.0.05D0) THEN
13693 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13694 & XSPMAX)
13695 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13696 & XSPMAX)
13697 ELSE
13698 320 CONTINUE
13699 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13700 IF ((XPSQI.LT.XSSTHR).OR.
13701 & (XPSQI.GT.XSPMAX)) GOTO 320
13702 330 CONTINUE
13703 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13704 IF ((XPSAQI.LT.XSSTHR).OR.
13705 & (XPSAQI.GT.XSPMAX)) GOTO 330
13706 ENDIF
13707* final test of remaining x for projectile diquark
13708 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13709 & +XPSQ(JJ)+XPSAQ(JJ)
13710 IF (XPVDCO.LE.XDTHR) THEN
13711*!!!
13712C IF (ICOUS.LT.5) GOTO 310
13713 IF (ICOUS.LT.0.5D0) GOTO 310
13714 GOTO 380
13715 ENDIF
13716* resampling of x for target sea quark pair
13717 ICOUS = 0
13718 350 CONTINUE
13719 ICOUS = ICOUS+1
13720 IF (XSSTHR.GT.0.05D0) THEN
13721 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13722 & XSTMAX)
13723 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13724 & XSTMAX)
13725 ELSE
13726 360 CONTINUE
13727 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13728 IF ((XTSQI.LT.XSSTHR).OR.
13729 & (XTSQI.GT.XSTMAX)) GOTO 360
13730 370 CONTINUE
13731 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13732 IF ((XTSAQI.LT.XSSTHR).OR.
13733 & (XTSAQI.GT.XSTMAX)) GOTO 370
13734 ENDIF
13735* final test of remaining x for target diquark
13736 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13737 & +XTSQ(J)+XTSAQ(J)
13738 IF (XTVDCO.LT.XDTHR) THEN
13739 IF (ICOUS.LT.5) GOTO 350
13740 GOTO 380
13741 ENDIF
13742 XPVD(IPVAL) = XPVDCO
13743 XTVD(ITVAL) = XTVDCO
13744 XPSQ(JJ) = XPSQI
13745 XPSAQ(JJ) = XPSAQI
13746 XTSQ(J) = XTSQI
13747 XTSAQ(J) = XTSAQI
13748*>>>>>end of chain mass correction
13749 GOTO 410
13750 ENDIF
13751* come here to discard s-s interaction
13752* resampling of x values not allowed or unsuccessful
13753 380 CONTINUE
13754 INTLO(I) = .FALSE.
13755 ZUOST(J) = .TRUE.
13756 ZUOSP(JJ) = .TRUE.
13757 NSS = NSS-1
13758 ENDIF
13759* consider next s-s interaction
13760 GOTO 410
13761 ENDIF
13762 390 CONTINUE
13763 ENDIF
13764 400 CONTINUE
13765 ENDIF
13766 410 CONTINUE
13767 420 CONTINUE
13768
13769* correct x-values of valence quarks for non-matching sea quarks
13770 DO 430 I=1,IXPS
13771 IF (ZUOSP(I)) THEN
13772 IPVAL = ITOVP(IFROSP(I))
13773 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13774 XPSQ(I) = ZERO
13775 XPSAQ(I) = ZERO
13776 ZUOSP(I) = .FALSE.
13777 ENDIF
13778 430 CONTINUE
13779 DO 440 I=1,IXTS
13780 IF (ZUOST(I)) THEN
13781 ITVAL = ITOVT(IFROST(I))
13782 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13783 XTSQ(I) = ZERO
13784 XTSAQ(I) = ZERO
13785 ZUOST(I) = .FALSE.
13786 ENDIF
13787 440 CONTINUE
13788 DO 450 I=1,IXPV
13789 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13790 450 CONTINUE
13791 DO 460 I=1,IXTV
13792 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13793 460 CONTINUE
13794
13795 RETURN
13796 END
13797
13798*$ CREATE DT_SAMSDQ.FOR
13799*COPY DT_SAMSDQ
13800*
13801*===samsdq=============================================================*
13802*
13803 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13804
13805************************************************************************
13806* SAMpling of Sea-DiQuarks *
13807* ECM cm-energy of the nucleon-nucleon system *
13808* IDX1,2 indices of x-values of the participating *
13809* partons (IDX2 is always the sea-q-pair to be *
13810* changed to sea-qq-pair) *
13811* MODE = 1 valence-q - sea-diq *
13812* = 2 sea-diq - valence-q *
13813* = 3 sea-q - sea-diq *
13814* = 4 sea-diq - sea-q *
13815* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13816* This version dated 17.10.95 is written by S. Roesler *
13817************************************************************************
13818
13819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13820 SAVE
13821
13822 PARAMETER (ZERO=0.0D0)
13823
13824* threshold values for x-sampling (DTUNUC 1.x)
13825 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13826 & SSMIMQ,VVMTHR
13827
13828* various options for treatment of partons (DTUNUC 1.x)
13829* (chain recombination, Cronin,..)
13830 LOGICAL LCO2CR,LINTPT
13831 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13832 & LCO2CR,LINTPT
13833
13834 PARAMETER ( MAXNCL = 260,
13835
13836 & MAXVQU = MAXNCL,
13837 & MAXSQU = 20*MAXVQU,
13838 & MAXINT = MAXVQU+MAXSQU)
13839
13840* x-values of partons (DTUNUC 1.x)
13841 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13842 & XTVQ(MAXVQU),XTVD(MAXVQU),
13843 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13844 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13845
13846* flavors of partons (DTUNUC 1.x)
13847 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13848 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13849 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13850 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13851 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13852 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13853 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13854
13855* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13856 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13857 & IXPV,IXPS,IXTV,IXTS,
13858 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13859 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13860 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13861 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13862 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13863 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13864 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13865 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13866
13867* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13868 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13869 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13870
13871* auxiliary common for chain system storage (DTUNUC 1.x)
13872 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13873
13874 IREJ = 0
13875* threshold-x for valence diquarks
13876 XDTHR = CDQ/ECM
13877
13878 GOTO (1,2,3,4) MODE
13879
13880*---------------------------------------------------------------------
13881* proj. valence partons - targ. sea partons
13882* get x-values and flavors for target sea-diquark pair
13883
13884 1 CONTINUE
13885 IDXVP = IDX1
13886 IDXST = IDX2
13887
13888* index of corr. val-diquark-x in target nucleon
13889 IDXVT = ITOVT(IFROST(IDXST))
13890* available x above diquark thresholds for valence- and sea-diquarks
13891 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13892
13893 IF (XXD.GE.ZERO) THEN
13894* x-values for the three diquarks of the target nucleon
13895 RR1 = DT_RNDM(XXD)
13896 RR2 = DT_RNDM(RR1)
13897 RR3 = DT_RNDM(RR2)
13898 SR123 = RR1+RR2+RR3
13899 XXTV = XDTHR+RR1*XXD/SR123
13900 XXTSQ = XDTHR+RR2*XXD/SR123
13901 XXTSAQ = XDTHR+RR3*XXD/SR123
13902 ELSE
13903 XXTV = XTVD(IDXVT)
13904 XXTSQ = XTSQ(IDXST)
13905 XXTSAQ = XTSAQ(IDXST)
13906 ENDIF
13907* flavor of the second quarks in the sea-diquark pair
13908 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13909 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13910* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13911 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13912 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13913 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13914* ss-asas pair
13915 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13916 IREJ = 1
13917 RETURN
13918 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13919* at least one strange quark
13920 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13921 IREJ = 1
13922 RETURN
13923 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13924 IREJ = 1
13925 RETURN
13926 ENDIF
13927* accept the new sea-diquark
13928 XTVD(IDXVT) = XXTV
13929 XTSQ(IDXST) = XXTSQ
13930 XTSAQ(IDXST) = XXTSAQ
13931 NVD = NVD+1
13932 INTVD1(NVD) = IDXVP
13933 INTVD2(NVD) = IDXST
13934 ISKPCH(7,NVD) = 0
13935 RETURN
13936
13937*---------------------------------------------------------------------
13938* proj. sea partons - targ. valence partons
13939* get x-values and flavors for projectile sea-diquark pair
13940
13941 2 CONTINUE
13942 IDXSP = IDX2
13943 IDXVT = IDX1
13944
13945* index of corr. val-diquark-x in projectile nucleon
13946 IDXVP = ITOVP(IFROSP(IDXSP))
13947* available x above diquark thresholds for valence- and sea-diquarks
13948 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13949
13950 IF (XXD.GE.ZERO) THEN
13951* x-values for the three diquarks of the projectile nucleon
13952 RR1 = DT_RNDM(XXD)
13953 RR2 = DT_RNDM(RR1)
13954 RR3 = DT_RNDM(RR2)
13955 SR123 = RR1+RR2+RR3
13956 XXPV = XDTHR+RR1*XXD/SR123
13957 XXPSQ = XDTHR+RR2*XXD/SR123
13958 XXPSAQ = XDTHR+RR3*XXD/SR123
13959 ELSE
13960 XXPV = XPVD(IDXVP)
13961 XXPSQ = XPSQ(IDXSP)
13962 XXPSAQ = XPSAQ(IDXSP)
13963 ENDIF
13964* flavor of the second quarks in the sea-diquark pair
13965 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13966 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13967* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13968 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13969 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13970 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13971* ss-asas pair
13972 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13973 IREJ = 1
13974 RETURN
13975 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13976* at least one strange quark
13977 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13978 IREJ = 1
13979 RETURN
13980 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13981 IREJ = 1
13982 RETURN
13983 ENDIF
13984* accept the new sea-diquark
13985 XPVD(IDXVP) = XXPV
13986 XPSQ(IDXSP) = XXPSQ
13987 XPSAQ(IDXSP) = XXPSAQ
13988 NDV = NDV+1
13989 INTDV1(NDV) = IDXSP
13990 INTDV2(NDV) = IDXVT
13991 ISKPCH(5,NDV) = 0
13992 RETURN
13993
13994*---------------------------------------------------------------------
13995* proj. sea partons - targ. sea partons
13996* get x-values and flavors for target sea-diquark pair
13997
13998 3 CONTINUE
13999 IDXSP = IDX1
14000 IDXST = IDX2
14001
14002* index of corr. val-diquark-x in target nucleon
14003 IDXVT = ITOVT(IFROST(IDXST))
14004* available x above diquark thresholds for valence- and sea-diquarks
14005 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14006
14007 IF (XXD.GE.ZERO) THEN
14008* x-values for the three diquarks of the target nucleon
14009 RR1 = DT_RNDM(XXD)
14010 RR2 = DT_RNDM(RR1)
14011 RR3 = DT_RNDM(RR2)
14012 SR123 = RR1+RR2+RR3
14013 XXTV = XDTHR+RR1*XXD/SR123
14014 XXTSQ = XDTHR+RR2*XXD/SR123
14015 XXTSAQ = XDTHR+RR3*XXD/SR123
14016 ELSE
14017 XXTV = XTVD(IDXVT)
14018 XXTSQ = XTSQ(IDXST)
14019 XXTSAQ = XTSAQ(IDXST)
14020 ENDIF
14021* flavor of the second quarks in the sea-diquark pair
14022 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14023 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14024* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14025 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14026 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14027 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14028* ss-asas pair
14029 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14030 IREJ = 1
14031 RETURN
14032 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14033* at least one strange quark
14034 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14035 IREJ = 1
14036 RETURN
14037 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14038 IREJ = 1
14039 RETURN
14040 ENDIF
14041* accept the new sea-diquark
14042 XTVD(IDXVT) = XXTV
14043 XTSQ(IDXST) = XXTSQ
14044 XTSAQ(IDXST) = XXTSAQ
14045 NSD = NSD+1
14046 INTSD1(NSD) = IDXSP
14047 INTSD2(NSD) = IDXST
14048 ISKPCH(3,NSD) = 0
14049 RETURN
14050
14051*---------------------------------------------------------------------
14052* proj. sea partons - targ. sea partons
14053* get x-values and flavors for projectile sea-diquark pair
14054
14055 4 CONTINUE
14056 IDXSP = IDX2
14057 IDXST = IDX1
14058
14059* index of corr. val-diquark-x in projectile nucleon
14060 IDXVP = ITOVP(IFROSP(IDXSP))
14061* available x above diquark thresholds for valence- and sea-diquarks
14062 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14063
14064 IF (XXD.GE.ZERO) THEN
14065* x-values for the three diquarks of the projectile nucleon
14066 RR1 = DT_RNDM(XXD)
14067 RR2 = DT_RNDM(RR1)
14068 RR3 = DT_RNDM(RR2)
14069 SR123 = RR1+RR2+RR3
14070 XXPV = XDTHR+RR1*XXD/SR123
14071 XXPSQ = XDTHR+RR2*XXD/SR123
14072 XXPSAQ = XDTHR+RR3*XXD/SR123
14073 ELSE
14074 XXPV = XPVD(IDXVP)
14075 XXPSQ = XPSQ(IDXSP)
14076 XXPSAQ = XPSAQ(IDXSP)
14077 ENDIF
14078* flavor of the second quarks in the sea-diquark pair
14079 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14080 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14081* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14082 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14083 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14084 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14085* ss-asas pair
14086 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14087 IREJ = 1
14088 RETURN
14089 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14090* at least one strange quark
14091 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14092 IREJ = 1
14093 RETURN
14094 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14095 IREJ = 1
14096 RETURN
14097 ENDIF
14098* accept the new sea-diquark
14099 XPVD(IDXVP) = XXPV
14100 XPSQ(IDXSP) = XXPSQ
14101 XPSAQ(IDXSP) = XXPSAQ
14102 NDS = NDS+1
14103 INTDS1(NDS) = IDXSP
14104 INTDS2(NDS) = IDXST
14105 ISKPCH(2,NDS) = 0
14106 RETURN
14107 END
14108*$ CREATE DT_DIFEVT.FOR
14109*COPY DT_DIFEVT
14110*
14111*===difevt=============================================================*
14112*
14113 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14114 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14115
14116************************************************************************
14117* Interface to treatment of diffractive interactions. *
14118* (input) IFP1/2 PDG-indizes of projectile partons *
14119* (baryon: IFP2 - adiquark) *
14120* PP(4) projectile 4-momentum *
14121* IFT1/2 PDG-indizes of target partons *
14122* (baryon: IFT1 - adiquark) *
14123* PT(4) target 4-momentum *
14124* (output) JDIFF = 0 no diffraction *
14125* = 1/-1 LMSD/LMDD *
14126* = 2/-2 HMSD/HMDD *
14127* NCSY counter for two-chain systems *
14128* dumped to DTEVT1 *
14129* This version dated 14.02.95 is written by S. Roesler *
14130************************************************************************
14131
14132 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14133 SAVE
14134
14135 PARAMETER ( LINP = 10 ,
14136 & LOUT = 6 ,
14137 & LDAT = 9 )
14138
14139 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14140 & OHALF=0.5D0)
14141
14142* event history
14143
14144 PARAMETER (NMXHKK=200000)
14145
14146 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14147 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14148 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14149
14150* extended event history
14151 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14152 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14153 & IHIST(2,NMXHKK)
14154
14155* flags for diffractive interactions (DTUNUC 1.x)
14156 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14157
14158 DIMENSION PP(4),PT(4)
14159
14160 LOGICAL LFIRST
14161 DATA LFIRST /.TRUE./
14162
14163 IREJ = 0
14164 JDIFF = 0
14165 IFLAGD = JDIFF
14166
14167* cm. energy
14168 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14169 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14170* identities of projectile hadron / target nucleon
14171 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14172 KTARG = IDT_ICIHAD(IDHKK(MOT))
14173
14174* single diffractive xsections
14175 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14176* double diffractive xsections
14177**!! no double diff yet
14178C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14179 DDTOT = 0.0D0
14180 DDHM = 0.0D0
14181**!!
14182* total inelastic xsection
14183C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14184 DUMZER = ZERO
14185 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14186 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14187
14188* fraction of diffractive processes
14189 FRADIF = (SDTOT+DDTOT)/SIGIN
14190
14191 IF (LFIRST) THEN
14192 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14193 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14194 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14195 & F5.1,' mb',/)
14196 LFIRST = .FALSE.
14197 ENDIF
14198
14199 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14200 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14201* diffractive interaction requested by x-section or by user
14202 FRASD = SDTOT/(SDTOT+DDTOT)
14203 FRASDH = SDHM/SDTOT
14204**sr needs to be specified!!
14205C FRADDH = DDHM/DDTOT
14206 FRADDH = 1.0D0
14207**
14208 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14209* single diffraction
14210 KDIFF = 1
14211 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14212 KP = 2
14213 KT = 0
14214 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14215 & ISINGD.NE.3) THEN
14216 KP = 0
14217 KT = 2
14218 ENDIF
14219 ELSE
14220 KP = 1
14221 KT = 0
14222 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14223 & ISINGD.NE.3) THEN
14224 KP = 0
14225 KT = 1
14226 ENDIF
14227 ENDIF
14228 ELSE
14229* double diffraction
14230 KDIFF = -1
14231 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14232 KP = 2
14233 KT = 2
14234 ELSE
14235 KP = 1
14236 KT = 1
14237 ENDIF
14238 ENDIF
14239 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14240 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14241 IF (IREJ1.EQ.0) THEN
14242 IFLAGD = 2*KDIFF
14243 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14244 ELSE
14245 GOTO 9999
14246 ENDIF
14247 ENDIF
14248 JDIFF = IFLAGD
14249
14250 RETURN
14251
14252 9999 CONTINUE
14253 IREJ = 1
14254 RETURN
14255 END
14256
14257*$ CREATE DT_DIFFKI.FOR
14258*COPY DT_DIFFKI
14259*
14260*===difkin=============================================================*
14261*
14262 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14263 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14264
14265************************************************************************
14266* Kinematics of diffractive nucleon-nucleon interaction. *
14267* IFP1/2 PDG-indizes of projectile partons *
14268* (baryon: IFP2 - adiquark) *
14269* PP(4) projectile 4-momentum *
14270* IFT1/2 PDG-indizes of target partons *
14271* (baryon: IFT1 - adiquark) *
14272* PT(4) target 4-momentum *
14273* KP = 0 projectile quasi-elastically scattered *
14274* = 1 excited to low-mass diff. state *
14275* = 2 excited to high-mass diff. state *
14276* KT = 0 target quasi-elastically scattered *
14277* = 1 excited to low-mass diff. state *
14278* = 2 excited to high-mass diff. state *
14279* This version dated 12.02.95 is written by S. Roesler *
14280************************************************************************
14281
14282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14283 SAVE
14284
14285 PARAMETER ( LINP = 10 ,
14286 & LOUT = 6 ,
14287 & LDAT = 9 )
14288
14289 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14290
14291 LOGICAL LSTART
14292
14293* particle properties (BAMJET index convention)
14294 CHARACTER*8 ANAME
14295 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14296 & IICH(210),IIBAR(210),K1(210),K2(210)
14297
14298* flags for input different options
14299 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14300 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14301 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14302
14303* rejection counter
14304 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14305 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14306 & IREXCI(3),IRDIFF(2),IRINC
14307
14308* kinematics of diffractive interactions (DTUNUC 1.x)
14309 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14310 & PPF(4),PTF(4),
14311 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14312 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14313
14314 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14315 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14316
14317 DATA LSTART /.TRUE./
14318
14319 IF (LSTART) THEN
14320 WRITE(LOUT,2000)
14321 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14322 LSTART = .FALSE.
14323 ENDIF
14324
14325 IREJ = 0
14326
14327* initialize common /DTDIKI/
14328 CALL DT_DIFINI
14329* store momenta of initial incoming particles for emc-check
14330 IF (LEMCCK) THEN
14331 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14332 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14333 ENDIF
14334
14335* masses of initial particles
14336 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14337 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14338 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14339 XMP = SQRT(XMP2)
14340 XMT = SQRT(XMT2)
14341* check quark-input (used to adjust coherence cond. for M-selection)
14342 IBP = 0
14343 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14344 IBT = 0
14345 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14346
14347* parameter for Lorentz-transformation into nucleon-nucleon cms
14348 DO 3 K=1,4
14349 PITOT(K) = PP(K)+PT(K)
14350 3 CONTINUE
14351 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14352 IF (XMTOT2.LE.ZERO) THEN
14353 WRITE(LOUT,1000) XMTOT2
14354 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14355 & 'XMTOT2 = ',E12.3)
14356 GOTO 9999
14357 ENDIF
14358 XMTOT = SQRT(XMTOT2)
14359 DO 4 K=1,4
14360 BGTOT(K) = PITOT(K)/XMTOT
14361 4 CONTINUE
14362* transformation of nucleons into cms
14363 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14364 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14365 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14366 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14367* rotation angles
14368 COD = PP1(3)/PPTOT
14369C SID = SQRT((ONE-COD)*(ONE+COD))
14370 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14371 SID = PPT/PPTOT
14372 COF = ONE
14373 SIF = ZERO
14374 IF(PPTOT*SID.GT.TINY10) THEN
14375 COF = PP1(1)/(SID*PPTOT)
14376 SIF = PP1(2)/(SID*PPTOT)
14377 ANORF = SQRT(COF*COF+SIF*SIF)
14378 COF = COF/ANORF
14379 SIF = SIF/ANORF
14380 ENDIF
14381* check consistency
14382 DO 5 K=1,4
14383 DEV1(K) = ABS(PP1(K)+PT1(K))
14384 5 CONTINUE
14385 DEV1(4) = ABS(DEV1(4)-XMTOT)
14386 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14387 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14388 WRITE(LOUT,1001) DEV1
14389 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14390 & /,8X,4E12.3)
14391 GOTO 9999
14392 ENDIF
14393
14394* select x-fractions in high-mass diff. interactions
14395 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14396
14397* select diffractive masses
14398* - projectile
14399 IF (KP.EQ.1) THEN
14400 XMPF = DT_XMLMD(XMTOT)
14401 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14402 IF (IREJ1.GT.0) GOTO 9999
14403 ELSEIF (KP.EQ.2) THEN
14404 XMPF = DT_XMHMD(XMTOT,IBP,1)
14405 ELSE
14406 XMPF = XMP
14407 ENDIF
14408* - target
14409 IF (KT.EQ.1) THEN
14410 XMTF = DT_XMLMD(XMTOT)
14411 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14412 IF (IREJ1.GT.0) GOTO 9999
14413 ELSEIF (KT.EQ.2) THEN
14414 XMTF = DT_XMHMD(XMTOT,IBT,2)
14415 ELSE
14416 XMTF = XMT
14417 ENDIF
14418
14419* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14420 XMPF2 = XMPF**2
14421 XMTF2 = XMTF**2
14422 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14423 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14424
14425* select momentum transfer (all t-values used here are <0)
14426* minimum absolute value to produce diffractive masses
14427 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14428 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14429 IF (IREJ1.GT.0) GOTO 9999
14430
14431* longitudinal momentum of excited/elastically scattered projectile
14432 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14433* total transverse momentum due to t-selection
14434 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14435 IF (PPBLT2.LT.ZERO) THEN
14436 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14437 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14438 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14439 GOTO 9999
14440 ENDIF
14441 CALL DT_DSFECF(SINPHI,COSPHI)
14442 PPBLT = SQRT(PPBLT2)
14443 PPBLOB(1) = COSPHI*PPBLT
14444 PPBLOB(2) = SINPHI*PPBLT
14445
14446* rotate excited/elastically scattered projectile into n-n cms.
14447 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14448 & XX,YY,ZZ)
14449 PPBLOB(1) = XX
14450 PPBLOB(2) = YY
14451 PPBLOB(3) = ZZ
14452
14453* 4-momentum of excited/elastically scattered target and of exchanged
14454* Pomeron
14455 DO 6 K=1,4
14456 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14457 PPOM1(K) = PP1(K)-PPBLOB(K)
14458 6 CONTINUE
14459 PTBLOB(4) = XMTOT-PPBLOB(4)
14460
14461* Lorentz-transformation back into system of initial diff. collision
14462 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14463 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14464 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14465 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14466 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14467 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14468 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14469 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14470 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14471
14472* store 4-momentum of elastically scattered particle (in single diff.
14473* events)
14474 IF (KP.EQ.0) THEN
14475 DO 7 K=1,4
14476 PSC(K) = PPF(K)
14477 7 CONTINUE
14478 ELSEIF (KT.EQ.0) THEN
14479 DO 8 K=1,4
14480 PSC(K) = PTF(K)
14481 8 CONTINUE
14482 ENDIF
14483
14484* check consistency of kinematical treatment so far
14485 IF (LEMCCK) THEN
14486 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14487 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14488 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14489 IF (IREJ1.NE.0) GOTO 9999
14490 ENDIF
14491 DO 9 K=1,4
14492 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14493 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14494 9 CONTINUE
14495 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14496 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14497 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14498 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14499 WRITE(LOUT,1003) DEV1,DEV2
14500 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14501 & 2(/,8X,4E12.3))
14502 GOTO 9999
14503 ENDIF
14504
14505* kinematical treatment for low-mass diffraction
14506 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14507 IF (IREJ1.NE.0) GOTO 9999
14508
14509* dump diffractive chains into DTEVT1
14510 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14511 IF (IREJ1.NE.0) GOTO 9999
14512
14513 RETURN
14514
14515 9999 CONTINUE
14516 IRDIFF(1) = IRDIFF(1)+1
14517 IREJ = 1
14518 RETURN
14519 END
14520
14521*$ CREATE DT_XMHMD.FOR
14522*COPY DT_XMHMD
14523*
14524*===xmhmd==============================================================*
14525*
14526 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14527
14528************************************************************************
14529* Diffractive mass in high mass single/double diffractive events. *
14530* This version dated 11.02.95 is written by S. Roesler *
14531************************************************************************
14532
14533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14534 SAVE
14535
14536 PARAMETER ( LINP = 10 ,
14537 & LOUT = 6 ,
14538 & LDAT = 9 )
14539
14540 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14541
14542* kinematics of diffractive interactions (DTUNUC 1.x)
14543 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14544 & PPF(4),PTF(4),
14545 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14546 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14547
14548C DATA XCOLOW /0.05D0/
14549 DATA XCOLOW /0.15D0/
14550
14551 DT_XMHMD = ZERO
14552 XH = XPH(2)
14553 IF (MODE.EQ.2) XH = XTH(2)
14554
14555* minimum Pomeron-x for high-mass diffraction
14556* (adjusted to get a smooth transition between HM and LM component)
14557 R = DT_RNDM(XH)
14558 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14559 IF (ECM.LE.300.0D0) THEN
14560 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14561 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14562 ENDIF
14563* maximum Pomeron-x for high-mass diffraction
14564* (coherence condition, adjusted to fit to experimental data)
14565 IF (IB.NE.0) THEN
14566* baryon-diffraction
14567 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14568 ELSE
14569* meson-diffraction
14570 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14571 ENDIF
14572* check boundaries
14573 IF (XDIMIN.GE.XDIMAX) THEN
14574 XDIMIN = OHALF*XDIMAX
14575 ENDIF
14576
14577 KLOOP = 0
14578 1 CONTINUE
14579 KLOOP = KLOOP+1
14580 IF (KLOOP.GT.20) RETURN
14581* sample Pomeron-x from 1/x-distribution (critical Pomeron)
14582 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14583* corr. diffr. mass
14584 DT_XMHMD = ECM*SQRT(XDIFF)
14585 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14586
14587 RETURN
14588 END
14589
14590*$ CREATE DT_XMLMD.FOR
14591*COPY DT_XMLMD
14592*
14593*===xmlmd==============================================================*
14594*
14595 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14596
14597************************************************************************
14598* Diffractive mass in high mass single/double diffractive events. *
14599* This version dated 11.02.95 is written by S. Roesler *
14600************************************************************************
14601
14602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14603 SAVE
14604
14605 PARAMETER ( LINP = 10 ,
14606 & LOUT = 6 ,
14607 & LDAT = 9 )
14608
14609* minimum Pomeron-x for low-mass diffraction
14610C AMO = 1.5D0
14611 AMO = 2.0D0
14612* maximum Pomeron-x for low-mass diffraction
14613* (adjusted to get a smooth transition between HM and LM component)
14614 R = DT_RNDM(AMO)
14615 SAM = 1.0D0
14616 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14617 R = DT_RNDM(AMO)*SAM
14618 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14619 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14620
14621* selection of diffractive mass
14622* (adjusted to get a smooth transition between HM and LM component)
14623 R = DT_RNDM(AMU)
14624 IF (ECM.LE.50.0D0) THEN
14625 DT_XMLMD = AMO*(AMU/AMO)**R
14626 ELSE
14627 A = 0.7D0
14628 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14629 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14630 ENDIF
14631
14632 RETURN
14633 END
14634
14635*$ CREATE DT_TDIFF.FOR
14636*COPY DT_TDIFF
14637*
14638*===tdiff==============================================================*
14639*
14640 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14641
14642************************************************************************
14643* t-selection for single/double diffractive interactions. *
14644* ECM cm. energy *
14645* TMIN minimum momentum transfer to produce diff. masses *
14646* XM1/XM2 diffractively produced masses *
14647* (for single diffraction XM2 is obsolete) *
14648* K1/K2= 0 not excited *
14649* = 1 low-mass excitation *
14650* = 2 high-mass excitation *
14651* This version dated 11.02.95 is written by S. Roesler *
14652************************************************************************
14653
14654 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14655 SAVE
14656
14657 PARAMETER ( LINP = 10 ,
14658 & LOUT = 6 ,
14659 & LDAT = 9 )
14660
14661 PARAMETER (ZERO=0.0D0)
14662
14663 PARAMETER ( BTP0 = 3.7D0,
14664 & ALPHAP = 0.24D0 )
14665
14666 IREJ = 0
14667 NCLOOP = 0
14668 DT_TDIFF = ZERO
14669
14670 IF (K1.GT.0) THEN
14671 XM1 = XM1I
14672 XM2 = XM2I
14673 ELSE
14674 XM1 = XM2I
14675 ENDIF
14676 XDI = (XM1/ECM)**2
14677 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14678* slope for single diffraction
14679 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14680 ELSE
14681* slope for double diffraction
14682 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14683 ENDIF
14684
14685 1 CONTINUE
14686 NCLOOP = NCLOOP+1
14687 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14688 Y = DT_RNDM(XDI)
14689 T = -LOG(1.0D0-Y)/SLOPE
14690 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14691 DT_TDIFF = -ABS(T)
14692
14693 RETURN
14694
14695 9999 CONTINUE
14696 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14697 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14698 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14699 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14700 IREJ = 1
14701 RETURN
14702 END
14703
14704*$ CREATE DT_XVALHM.FOR
14705*COPY DT_XVALHM
14706*
14707*===xvalhm=============================================================*
14708*
14709 SUBROUTINE DT_XVALHM(KP,KT)
14710
14711************************************************************************
14712* Sampling of parton x-values in high-mass diffractive interactions. *
14713* This version dated 12.02.95 is written by S. Roesler *
14714************************************************************************
14715
14716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14717 SAVE
14718
14719 PARAMETER ( LINP = 10 ,
14720 & LOUT = 6 ,
14721 & LDAT = 9 )
14722
14723 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14724
14725* kinematics of diffractive interactions (DTUNUC 1.x)
14726 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14727 & PPF(4),PTF(4),
14728 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14729 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14730
14731* various options for treatment of partons (DTUNUC 1.x)
14732* (chain recombination, Cronin,..)
14733 LOGICAL LCO2CR,LINTPT
14734 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14735 & LCO2CR,LINTPT
14736
14737 DATA UNON,XVQTHR /2.0D0,0.8D0/
14738
14739 IF (KP.EQ.2) THEN
14740* x-fractions of projectile valence partons
14741 1 CONTINUE
14742 XPH(1) = DT_DBETAR(OHALF,UNON)
14743 IF (XPH(1).GE.XVQTHR) GOTO 1
14744 XPH(2) = ONE-XPH(1)
14745* x-fractions of Pomeron q-aq-pair
14746 XPOLO = TINY2
14747 XPOHI = ONE-TINY2
14748 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14749 XPPO(2) = ONE-XPPO(1)
14750* flavors of Pomeron q-aq-pair
14751 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14752 IFPPO(1) = IFLAV
14753 IFPPO(2) = -IFLAV
14754 IF (DT_RNDM(UNON).GT.OHALF) THEN
14755 IFPPO(1) = -IFLAV
14756 IFPPO(2) = IFLAV
14757 ENDIF
14758 ENDIF
14759
14760 IF (KT.EQ.2) THEN
14761* x-fractions of projectile target partons
14762 2 CONTINUE
14763 XTH(1) = DT_DBETAR(OHALF,UNON)
14764 IF (XTH(1).GE.XVQTHR) GOTO 2
14765 XTH(2) = ONE-XTH(1)
14766* x-fractions of Pomeron q-aq-pair
14767 XPOLO = TINY2
14768 XPOHI = ONE-TINY2
14769 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14770 XTPO(2) = ONE-XTPO(1)
14771* flavors of Pomeron q-aq-pair
14772 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14773 IFTPO(1) = IFLAV
14774 IFTPO(2) = -IFLAV
14775 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14776 IFTPO(1) = -IFLAV
14777 IFTPO(2) = IFLAV
14778 ENDIF
14779 ENDIF
14780
14781 RETURN
14782 END
14783
14784*$ CREATE DT_LM2RES.FOR
14785*COPY DT_LM2RES
14786*
14787*===lm2res=============================================================*
14788*
14789 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14790
14791************************************************************************
14792* Check low-mass diffractive excitation for resonance mass. *
14793* (input) IF1/2 PDG-indizes of valence partons *
14794* (in/out) XM diffractive mass requested/corrected *
14795* (output) IDR/IDXR id./BAMJET-index of resonance *
14796* This version dated 12.02.95 is written by S. Roesler *
14797************************************************************************
14798
14799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14800 SAVE
14801
14802 PARAMETER ( LINP = 10 ,
14803 & LOUT = 6 ,
14804 & LDAT = 9 )
14805
14806 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14807
14808* kinematics of diffractive interactions (DTUNUC 1.x)
14809 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14810 & PPF(4),PTF(4),
14811 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14812 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14813
14814 IREJ = 0
14815 IF1B = 0
14816 IF2B = 0
14817 XMI = XM
14818
14819* BAMJET indices of partons
14820 IF1A = IDT_IPDG2B(IF1,1,2)
14821 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14822 IF2A = IDT_IPDG2B(IF2,1,2)
14823 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14824
14825* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14826 IDCH = 2
14827 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14828
14829* check for resonance mass
14830 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14831 IF (IREJ1.NE.0) GOTO 9999
14832
14833 XM = XMN
14834 RETURN
14835
14836 9999 CONTINUE
14837 IREJ = 1
14838 RETURN
14839 END
14840
14841*$ CREATE DT_LMKINE.FOR
14842*COPY DT_LMKINE
14843*
14844*===lmkine=============================================================*
14845*
14846 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14847
14848************************************************************************
14849* Kinematical treatment of low-mass excitations. *
14850* This version dated 12.02.95 is written by S. Roesler *
14851************************************************************************
14852
14853 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14854 SAVE
14855
14856 PARAMETER ( LINP = 10 ,
14857 & LOUT = 6 ,
14858 & LDAT = 9 )
14859
14860 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14861
14862* flags for input different options
14863 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14864 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14865 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14866
14867* kinematics of diffractive interactions (DTUNUC 1.x)
14868 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14869 & PPF(4),PTF(4),
14870 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14871 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14872
14873 DIMENSION P1(4),P2(4)
14874
14875 IREJ = 0
14876
14877 IF (KP.EQ.1) THEN
14878 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14879 POE = PPF(4)/PABS
14880 FAC1 = OHALF*(POE+ONE)
14881 FAC2 = -OHALF*(POE-ONE)
14882 DO 1 K=1,3
14883 PPLM1(K) = FAC1*PPF(K)
14884 PPLM2(K) = FAC2*PPF(K)
14885 1 CONTINUE
14886 PPLM1(4) = FAC1*PABS
14887 PPLM2(4) = -FAC2*PABS
14888 IF (IMSHL.EQ.1) THEN
14889
14890 XM1 = PYMASS(IFP1)
14891 XM2 = PYMASS(IFP2)
14892
14893 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14894 IF (IREJ1.NE.0) GOTO 9999
14895 DO 2 K=1,4
14896 PPLM1(K) = P1(K)
14897 PPLM2(K) = P2(K)
14898 2 CONTINUE
14899 ENDIF
14900 ENDIF
14901
14902 IF (KT.EQ.1) THEN
14903 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14904 POE = PTF(4)/PABS
14905 FAC1 = OHALF*(POE+ONE)
14906 FAC2 = -OHALF*(POE-ONE)
14907 DO 3 K=1,3
14908 PTLM2(K) = FAC1*PTF(K)
14909 PTLM1(K) = FAC2*PTF(K)
14910 3 CONTINUE
14911 PTLM2(4) = FAC1*PABS
14912 PTLM1(4) = -FAC2*PABS
14913 IF (IMSHL.EQ.1) THEN
14914
14915 XM1 = PYMASS(IFT1)
14916 XM2 = PYMASS(IFT2)
14917
14918 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14919 IF (IREJ1.NE.0) GOTO 9999
14920 DO 4 K=1,4
14921 PTLM1(K) = P1(K)
14922 PTLM2(K) = P2(K)
14923 4 CONTINUE
14924 ENDIF
14925 ENDIF
14926
14927 RETURN
14928
14929 9999 CONTINUE
14930 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14931 IREJ = 1
14932 RETURN
14933 END
14934
14935*$ CREATE DT_DIFINI.FOR
14936*COPY DT_DIFINI
14937*
14938*===difini=============================================================*
14939*
14940 SUBROUTINE DT_DIFINI
14941
14942************************************************************************
14943* Initialization of common /DTDIKI/ *
14944* This version dated 12.02.95 is written by S. Roesler *
14945************************************************************************
14946
14947 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14948 SAVE
14949
14950 PARAMETER ( LINP = 10 ,
14951 & LOUT = 6 ,
14952 & LDAT = 9 )
14953
14954 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14955
14956* kinematics of diffractive interactions (DTUNUC 1.x)
14957 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14958 & PPF(4),PTF(4),
14959 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14960 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14961
14962 DO 1 K=1,4
14963 PPOM(K) = ZERO
14964 PSC(K) = ZERO
14965 PPF(K) = ZERO
14966 PTF(K) = ZERO
14967 PPLM1(K) = ZERO
14968 PPLM2(K) = ZERO
14969 PTLM1(K) = ZERO
14970 PTLM2(K) = ZERO
14971 1 CONTINUE
14972 DO 2 K=1,2
14973 XPH(K) = ZERO
14974 XPPO(K) = ZERO
14975 XTH(K) = ZERO
14976 XTPO(K) = ZERO
14977 IFPPO(K) = 0
14978 IFTPO(K) = 0
14979 2 CONTINUE
14980 IDPR = 0
14981 IDXPR = 0
14982 IDTR = 0
14983 IDXTR = 0
14984
14985 RETURN
14986 END
14987
14988*$ CREATE DT_DIFPUT.FOR
14989*COPY DT_DIFPUT
14990*
14991*===difput=============================================================*
14992*
14993 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14994 & IREJ)
14995
14996************************************************************************
14997* Dump diffractive chains into DTEVT1 *
14998* This version dated 12.02.95 is written by S. Roesler *
14999************************************************************************
15000
15001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15002 SAVE
15003
15004 PARAMETER ( LINP = 10 ,
15005 & LOUT = 6 ,
15006 & LDAT = 9 )
15007
15008 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15009
15010 LOGICAL LCHK
15011
15012* kinematics of diffractive interactions (DTUNUC 1.x)
15013 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15014 & PPF(4),PTF(4),
15015 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15016 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15017
15018* event history
15019
15020 PARAMETER (NMXHKK=200000)
15021
15022 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15023 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15024 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15025
15026* extended event history
15027 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15028 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15029 & IHIST(2,NMXHKK)
15030
15031* rejection counter
15032 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15033 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15034 & IREXCI(3),IRDIFF(2),IRINC
15035
15036 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15037 & P1(4),P2(4),P3(4),P4(4)
15038
15039 IREJ = 0
15040
15041 IF (KP.EQ.1) THEN
15042 DO 1 K=1,4
15043 PCH(K) = PPLM1(K)+PPLM2(K)
15044 1 CONTINUE
15045 ID1 = IFP1
15046 ID2 = IFP2
15047 IF (DT_RNDM(PT).GT.OHALF) THEN
15048 ID1 = IFP2
15049 ID2 = IFP1
15050 ENDIF
15051 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15052 & PPLM1(4),0,0,0)
15053 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15054 & PPLM2(4),0,0,0)
15055 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15056 & IDPR,IDXPR,8)
15057 ELSEIF (KP.EQ.2) THEN
15058 DO 2 K=1,4
15059 PP1(K) = XPH(1)*PP(K)
15060 PP2(K) = XPH(2)*PP(K)
15061 PT1(K) = -XPPO(1)*PPOM(K)
15062 PT2(K) = -XPPO(2)*PPOM(K)
15063 2 CONTINUE
15064 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15065 XM1 = ZERO
15066 XM2 = ZERO
15067 IF (LCHK) THEN
15068 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15069 IF (IREJ1.NE.0) GOTO 9999
15070 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15071 IF (IREJ1.NE.0) GOTO 9999
15072 DO 3 K=1,4
15073 PP1(K) = P1(K)
15074 PT1(K) = P2(K)
15075 PP2(K) = P3(K)
15076 PT2(K) = P4(K)
15077 3 CONTINUE
15078 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15079 & 0,0,8)
15080 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15081 & PT1(4),0,0,8)
15082 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15083 & 0,0,8)
15084 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15085 & PT2(4),0,0,8)
15086 ELSE
15087 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15088 IF (IREJ1.NE.0) GOTO 9999
15089 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15090 IF (IREJ1.NE.0) GOTO 9999
15091 DO 4 K=1,4
15092 PP1(K) = P1(K)
15093 PT2(K) = P2(K)
15094 PP2(K) = P3(K)
15095 PT1(K) = P4(K)
15096 4 CONTINUE
15097 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15098 & 0,0,8)
15099 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15100 & PT2(4),0,0,8)
15101 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15102 & 0,0,8)
15103 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15104 & PT1(4),0,0,8)
15105 ENDIF
15106 NCSY = NCSY+1
15107 ELSE
15108 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15109 & 0,0,0)
15110 ENDIF
15111
15112 IF (KT.EQ.1) THEN
15113 DO 5 K=1,4
15114 PCH(K) = PTLM1(K)+PTLM2(K)
15115 5 CONTINUE
15116 ID1 = IFT1
15117 ID2 = IFT2
15118 IF (DT_RNDM(PT).GT.OHALF) THEN
15119 ID1 = IFT2
15120 ID2 = IFT1
15121 ENDIF
15122 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15123 & PTLM1(4),0,0,0)
15124 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15125 & PTLM2(4),0,0,0)
15126 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15127 & IDTR,IDXTR,8)
15128 ELSEIF (KT.EQ.2) THEN
15129 DO 6 K=1,4
15130 PP1(K) = XTPO(1)*PPOM(K)
15131 PP2(K) = XTPO(2)*PPOM(K)
15132 PT1(K) = XTH(2)*PT(K)
15133 PT2(K) = XTH(1)*PT(K)
15134 6 CONTINUE
15135 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15136 XM1 = ZERO
15137 XM2 = ZERO
15138 IF (LCHK) THEN
15139 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15140 IF (IREJ1.NE.0) GOTO 9999
15141 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15142 IF (IREJ1.NE.0) GOTO 9999
15143 DO 7 K=1,4
15144 PP1(K) = P1(K)
15145 PT1(K) = P2(K)
15146 PP2(K) = P3(K)
15147 PT2(K) = P4(K)
15148 7 CONTINUE
15149 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15150 & PP1(4),0,0,8)
15151 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15152 & 0,0,8)
15153 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15154 & PP2(4),0,0,8)
15155 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15156 & 0,0,8)
15157 ELSE
15158 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15159 IF (IREJ1.NE.0) GOTO 9999
15160 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15161 IF (IREJ1.NE.0) GOTO 9999
15162 DO 8 K=1,4
15163 PP1(K) = P1(K)
15164 PT2(K) = P2(K)
15165 PP2(K) = P3(K)
15166 PT1(K) = P4(K)
15167 8 CONTINUE
15168 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15169 & PP1(4),0,0,8)
15170 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15171 & 0,0,8)
15172 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15173 & PP2(4),0,0,8)
15174 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15175 & 0,0,8)
15176 ENDIF
15177 NCSY = NCSY+1
15178 ELSE
15179 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15180 & 0,0,0)
15181 ENDIF
15182
15183 RETURN
15184
15185 9999 CONTINUE
15186 IRDIFF(2) = IRDIFF(2)+1
15187 IREJ = 1
15188 RETURN
15189 END
15190*$ CREATE DT_EVTFRG.FOR
15191*COPY DT_EVTFRG
15192*
15193*===evtfrg=============================================================*
15194*
15195 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15196
15197************************************************************************
15198* Hadronization of chains in DTEVT1. *
15199* *
15200* Input: *
15201* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15202* = 2 hadronization of DTUNUC-chains (id=88xxx) *
15203* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15204* hadronized with one PYEXEC call *
15205* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15206* with one PYEXEC call *
15207* Output: *
15208* NPYMEM number of entries in JETSET-common after hadronization *
15209* IREJ rejection flag *
15210* *
15211* This version dated 17.09.00 is written by S. Roesler *
15212************************************************************************
15213
15214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15215 SAVE
15216
15217 PARAMETER ( LINP = 10 ,
15218 & LOUT = 6 ,
15219 & LDAT = 9 )
15220
15221 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15222 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15223
15224 LOGICAL LACCEP
15225
15226 PARAMETER (MXJOIN=200)
15227
15228* event history
15229
15230 PARAMETER (NMXHKK=200000)
15231
15232 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15233 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15234 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15235
15236* extended event history
15237 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15238 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15239 & IHIST(2,NMXHKK)
15240
15241* flags for input different options
15242 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15243 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15244 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15245
15246* statistics
15247 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15248 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15249 & ICEVTG(8,0:30)
15250
15251* flags for diffractive interactions (DTUNUC 1.x)
15252 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15253
15254* nucleon-nucleon event-generator
15255 CHARACTER*8 CMODEL
15256 LOGICAL LPHOIN
15257 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15258* phojet
15259
15260C model switches and parameters
15261 CHARACTER*8 MDLNA
15262 INTEGER ISWMDL,IPAMDL
15263 DOUBLE PRECISION PARMDL
15264 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15265* jetset
15266
15267 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15268 PARAMETER (MAXLND=4000)
15269 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15270
15271 INTEGER PYK
15272
15273 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15274
15275 MODE = KMODE
15276 ISTSTG = 7
15277 IF (MODE.NE.1) ISTSTG = 8
15278 IREJ = 0
15279
15280 IP = 0
15281 ISH = 0
15282 INIEMC = 1
15283 NEND = NHKK
15284 NACCEP = 0
15285 IFRG = 0
15286 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15287 DO 10 I=NPOINT(3),NEND
15288* sr 14.02.00: seems to be not necessary anymore, commented
15289C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15290C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15291 LACCEP = .TRUE.
15292* pick up chains from dtevt1
15293 IDCHK = IDHKK(I)/10000
15294 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15295 IF (IDCHK.EQ.7) THEN
15296 IPJE = IDHKK(I)-IDCHK*10000
15297 IF (IPJE.NE.IFRG) THEN
15298 IFRG = IPJE
15299 IF (IFRG.GT.NFRG) GOTO 16
15300 ENDIF
15301 ELSE
15302 IPJE = 1
15303 IFRG = IFRG+1
15304 IF (IFRG.GT.NFRG) THEN
15305 NFRG = -1
15306 GOTO 16
15307 ENDIF
15308 ENDIF
15309* statistics counter
15310c IF (IDCH(I).LE.8)
15311c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15312c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15313* special treatment for small chains already corrected to hadrons
15314 IF (IDRES(I).NE.0) THEN
15315 IF (IDRES(I).EQ.11) THEN
15316 ID = IDXRES(I)
15317 ELSE
15318 ID = IDT_IPDGHA(IDXRES(I))
15319 ENDIF
15320 IF (LEMCCK) THEN
15321 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15322 & PHKK(4,I),INIEMC,IDUM,IDUM)
15323 INIEMC = 2
15324 ENDIF
15325 IP = IP+1
15326 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15327 P(IP,1) = PHKK(1,I)
15328 P(IP,2) = PHKK(2,I)
15329 P(IP,3) = PHKK(3,I)
15330 P(IP,4) = PHKK(4,I)
15331 P(IP,5) = PHKK(5,I)
15332 K(IP,1) = 1
15333 K(IP,2) = ID
15334 K(IP,3) = 0
15335 K(IP,4) = 0
15336 K(IP,5) = 0
15337 IHIST(2,I) = 10000*IPJE+IP
15338 IF (IHIST(1,I).LE.-100) THEN
15339 ISH = ISH+1
15340 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15341 ISJOIN(ISH) = I
15342 ENDIF
15343 N = IP
15344 IHISMO(IP) = I
15345 ELSE
15346 IJ = 0
15347 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15348 IF (LEMCCK) THEN
15349 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15350 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15351 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15352 INIEMC = 2
15353 ENDIF
15354 ID = IDHKK(KK)
15355 IF (ID.EQ.0) ID = 21
15356c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15357c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15358
15359c AMRQ = PYMASS(ID)
15360
15361c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15362c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15363c & (ABS(IDIFF).EQ.0)) THEN
15364cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15365c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15366c PHKK(4,KK) = PHKK(4,KK)+DELTA
15367c PTOT1 = PTOT-DELTA
15368c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15369c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15370c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15371c PHKK(5,KK) = AMRQ
15372c ENDIF
15373 IP = IP+1
15374 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15375 P(IP,1) = PHKK(1,KK)
15376 P(IP,2) = PHKK(2,KK)
15377 P(IP,3) = PHKK(3,KK)
15378 P(IP,4) = PHKK(4,KK)
15379 P(IP,5) = PHKK(5,KK)
15380 K(IP,1) = 1
15381 K(IP,2) = ID
15382 K(IP,3) = 0
15383 K(IP,4) = 0
15384 K(IP,5) = 0
15385 IHIST(2,KK) = 10000*IPJE+IP
15386 IF (IHIST(1,KK).LE.-100) THEN
15387 ISH = ISH+1
15388 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15389 ISJOIN(ISH) = KK
15390 ENDIF
15391 IJ = IJ+1
15392 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15393 IJOIN(IJ) = IP
15394 IHISMO(IP) = I
15395 11 CONTINUE
15396 N = IP
15397* join the two-parton system
15398
15399 CALL PYJOIN(IJ,IJOIN)
15400
15401 ENDIF
15402 IDHKK(I) = 99999
15403 ENDIF
15404 10 CONTINUE
15405 16 CONTINUE
15406 N = IP
15407
15408 IF (IP.GT.0) THEN
15409
15410* final state parton shower
15411 DO 136 NPJE=1,IPJE
15412 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15413 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15414 DO 130 K1=1,ISH
15415 IF (ISJOIN(K1).EQ.0) GOTO 130
15416 I = ISJOIN(K1)
15417 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15418 & GOTO 130
15419 IH1 = IHIST(2,I)/10000
15420 IF (IH1.NE.NPJE) GOTO 130
15421 IH1 = IHIST(2,I)-IH1*10000
15422 DO 135 K2=K1+1,ISH
15423 IF (ISJOIN(K2).EQ.0) GOTO 135
15424 II = ISJOIN(K2)
15425 IH2 = IHIST(2,II)/10000
15426 IF (IH2.NE.NPJE) GOTO 135
15427 IH2 = IHIST(2,II)-IH2*10000
15428 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15429 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15430 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15431
15432 RQLUN = MIN(PT1,PT2)
15433 CALL PYSHOW(IH1,IH2,RQLUN)
15434
15435 ISJOIN(K1) = 0
15436 ISJOIN(K2) = 0
15437 GOTO 130
15438 ENDIF
15439 135 CONTINUE
15440 130 CONTINUE
15441 ENDIF
15442 ENDIF
15443 136 CONTINUE
15444
15445 CALL DT_INITJS(MODE)
15446* hadronization
15447
15448 CALL PYEXEC
15449
15450 IF (MSTU(24).NE.0) THEN
15451 WRITE(LOUT,*) ' JETSET-reject at event',
15452 & NEVHKK,MSTU(24),KMODE
15453C CALL DT_EVTOUT(4)
15454
15455C CALL PYLIST(2)
15456
15457 GOTO 9999
15458 ENDIF
15459
15460* number of entries in LUJETS
15461
15462 NLINES = PYK(0,1)
15463
15464 NPYMEM = NLINES
15465
15466 DO 12 I=1,NLINES
15467 IFLG(I) = 0
15468 12 CONTINUE
15469
15470 DO 13 II=1,NLINES
15471
15472 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15473
15474* pick up mother resonance if possible and put it together with
15475* their decay-products into the common
15476 IDXMOR = K(II,3)
15477 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15478 KFMOR = K(IDXMOR,2)
15479 ISMOR = K(IDXMOR,1)
15480 ELSE
15481 KFMOR = 91
15482 ISMOR = 1
15483 ENDIF
15484 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15485 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15486 ID = K(IDXMOR,2)
15487 MO = IHISMO(PYK(IDXMOR,15))
15488 PX = PYP(IDXMOR,1)
15489 PY = PYP(IDXMOR,2)
15490 PZ = PYP(IDXMOR,3)
15491 PE = PYP(IDXMOR,4)
15492
15493 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15494 IFLG(IDXMOR) = 1
15495 MO = NHKK
15496 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15497 IF (PYK(JDAUG,7).EQ.1) THEN
15498 ID = PYK(JDAUG,8)
15499 PX = PYP(JDAUG,1)
15500 PY = PYP(JDAUG,2)
15501 PZ = PYP(JDAUG,3)
15502 PE = PYP(JDAUG,4)
15503
15504 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15505 IF (LEMCCK) THEN
15506 PX = -PYP(JDAUG,1)
15507 PY = -PYP(JDAUG,2)
15508 PZ = -PYP(JDAUG,3)
15509 PE = -PYP(JDAUG,4)
15510
15511 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15512 ENDIF
15513 IFLG(JDAUG) = 1
15514 ENDIF
15515 15 CONTINUE
15516 ELSE
15517* there was no mother resonance
15518 MO = IHISMO(PYK(II,15))
15519 ID = PYK(II,8)
15520 PX = PYP(II,1)
15521 PY = PYP(II,2)
15522 PZ = PYP(II,3)
15523 PE = PYP(II,4)
15524
15525 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15526 IF (LEMCCK) THEN
15527 PX = -PYP(II,1)
15528 PY = -PYP(II,2)
15529 PZ = -PYP(II,3)
15530 PE = -PYP(II,4)
15531
15532 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15533 ENDIF
15534 ENDIF
15535 ENDIF
15536 13 CONTINUE
15537 IF (LEMCCK) THEN
15538 CHKLEV = TINY1
15539 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15540C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15541 ENDIF
15542
15543* global energy-momentum & flavor conservation check
15544**sr 16.5. this check is skipped in case of phojet-treatment
15545 IF (MCGENE.EQ.1)
15546 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15547
15548* update statistics-counter for diffraction
15549c IF (IFLAGD.NE.0) THEN
15550c ICDIFF(1) = ICDIFF(1)+1
15551c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15552c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15553c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15554c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15555c ENDIF
15556
15557 ENDIF
15558
15559 RETURN
15560
15561 9999 CONTINUE
15562 IREJ = 1
15563 RETURN
15564 END
15565
15566*$ CREATE DT_DECAYS.FOR
15567*COPY DT_DECAYS
15568*
15569*===decay==============================================================*
15570*
15571 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15572
15573************************************************************************
15574* Resonance-decay. *
15575* This subroutine replaces DDECAY/DECHKK. *
15576* PIN(4) 4-momentum of resonance (input) *
15577* IDXIN BAMJET-index of resonance (input) *
15578* POUT(20,4) 4-momenta of decay-products (output) *
15579* IDXOUT(20) BAMJET-indices of decay-products (output) *
15580* NSEC number of secondaries (output) *
15581* Adopted from the original version DECHKK. *
15582* This version dated 09.01.95 is written by S. Roesler *
15583************************************************************************
15584
15585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15586 SAVE
15587
15588 PARAMETER ( LINP = 10 ,
15589 & LOUT = 6 ,
15590 & LDAT = 9 )
15591
15592 PARAMETER (TINY17=1.0D-17)
15593
15594* HADRIN: decay channel information
15595 PARAMETER (IDMAX9=602)
15596 CHARACTER*8 ZKNAME
15597 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15598
15599* particle properties (BAMJET index convention)
15600 CHARACTER*8 ANAME
15601 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15602 & IICH(210),IIBAR(210),K1(210),K2(210)
15603
15604* flags for input different options
15605 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15606 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15607 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15608
15609 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15610 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15611 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15612
15613* ISTAB = 1 strong and weak decays
15614* = 2 strong decays only
15615* = 3 strong decays, weak decays for charmed particles and tau
15616* leptons only
15617 DATA ISTAB /2/
15618
15619 IREJ = 0
15620 NSEC = 0
15621* put initial resonance to stack
15622 NSTK = 1
15623 IDXSTK(NSTK) = IDXIN
15624 DO 5 I=1,4
15625 PI(NSTK,I) = PIN(I)
15626 5 CONTINUE
15627
15628* store initial configuration for energy-momentum cons. check
15629 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15630 & PI(NSTK,4),1,IDUM,IDUM)
15631
15632 100 CONTINUE
15633* get particle from stack
15634 IDXI = IDXSTK(NSTK)
15635* skip stable particles
15636 IF (ISTAB.EQ.1) THEN
15637 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15638 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15639 ELSEIF (ISTAB.EQ.2) THEN
15640 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15641 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15642 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15643 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15644 IF ( IDXI.EQ.109) GOTO 10
15645 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15646 ELSEIF (ISTAB.EQ.3) THEN
15647 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15648 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15649 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15650 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15651 ENDIF
15652
15653* calculate direction cosines and Lorentz-parameter of decaying part.
15654 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15655 PTOT = MAX(PTOT,TINY17)
15656 DO 1 I=1,3
15657 DCOS(I) = PI(NSTK,I)/PTOT
15658 1 CONTINUE
15659 GAM = PI(NSTK,4)/AAM(IDXI)
15660 BGAM = PTOT/AAM(IDXI)
15661
15662* get decay-channel
15663 KCHAN = K1(IDXI)-1
15664 2 CONTINUE
15665 KCHAN = KCHAN+1
15666 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15667
15668* identities of secondaries
15669 IDX(1) = NZK(KCHAN,1)
15670 IDX(2) = NZK(KCHAN,2)
15671 IF (IDX(2).LT.1) GOTO 9999
15672 IDX(3) = NZK(KCHAN,3)
15673
15674* handle decay in rest system of decaying particle
15675 IF (IDX(3).EQ.0) THEN
15676* two-particle decay
15677 NDEC = 2
15678 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15679 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15680 & AAM(IDX(1)),AAM(IDX(2)))
15681 ELSE
15682* three-particle decay
15683 NDEC = 3
15684 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15685 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15686 & CODF(3),COFF(3),SIFF(3),
15687 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15688 ENDIF
15689 NSTK = NSTK-1
15690
15691* transform decay products back
15692 DO 3 I=1,NDEC
15693 NSTK = NSTK+1
15694 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15695 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15696 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15697* add particle to stack
15698 IDXSTK(NSTK) = IDX(I)
15699 DO 4 J=1,3
15700 PI(NSTK,J) = DCOSF(J)*PFF(I)
15701 4 CONTINUE
15702 3 CONTINUE
15703 GOTO 100
15704
15705 10 CONTINUE
15706* stable particle, put to output-arrays
15707 NSEC = NSEC+1
15708 DO 6 I=1,4
15709 POUT(NSEC,I) = PI(NSTK,I)
15710 6 CONTINUE
15711 IDXOUT(NSEC) = IDXSTK(NSTK)
15712* store secondaries for energy-momentum conservation check
15713 IF (LEMCCK)
15714 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15715 & -POUT(NSEC,4),2,IDUM,IDUM)
15716 NSTK = NSTK-1
15717 IF (NSTK.GT.0) GOTO 100
15718
15719* check energy-momentum conservation
15720 IF (LEMCCK) THEN
15721 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15722 IF (IREJ1.NE.0) GOTO 9999
15723 ENDIF
15724
15725 RETURN
15726
15727 9999 CONTINUE
15728 IREJ = 1
15729 RETURN
15730 END
15731
15732*$ CREATE DT_DECAY1.FOR
15733*COPY DT_DECAY1
15734*
15735*===decay1=============================================================*
15736*
15737 SUBROUTINE DT_DECAY1
15738
15739************************************************************************
15740* Decay of resonances stored in DTEVT1. *
15741* This version dated 20.01.95 is written by S. Roesler *
15742************************************************************************
15743
15744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15745 SAVE
15746
15747 PARAMETER ( LINP = 10 ,
15748 & LOUT = 6 ,
15749 & LDAT = 9 )
15750
15751* event history
15752
15753 PARAMETER (NMXHKK=200000)
15754
15755 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15756 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15757 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15758
15759* extended event history
15760 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15761 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15762 & IHIST(2,NMXHKK)
15763
15764 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15765
15766 NEND = NHKK
15767C DO 1 I=NPOINT(5),NEND
15768 DO 1 I=NPOINT(4),NEND
15769 IF (ABS(ISTHKK(I)).EQ.1) THEN
15770 DO 2 K=1,4
15771 PIN(K) = PHKK(K,I)
15772 2 CONTINUE
15773 IDXIN = IDBAM(I)
15774 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15775 IF (NSEC.GT.1) THEN
15776 DO 3 N=1,NSEC
15777 IDHAD = IDT_IPDGHA(IDXOUT(N))
15778 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15779 & POUT(N,3),POUT(N,4),0,0,0)
15780 3 CONTINUE
15781 ENDIF
15782 ENDIF
15783 1 CONTINUE
15784
15785 RETURN
15786 END
15787
15788*$ CREATE DT_DECPI0.FOR
15789*COPY DT_DECPI0
15790*
15791*===decpi0=============================================================*
15792*
15793 SUBROUTINE DT_DECPI0
15794
15795************************************************************************
15796* Decay of pi0 handled with JETSET. *
15797* This version dated 18.02.96 is written by S. Roesler *
15798************************************************************************
15799
15800 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15801 SAVE
15802
15803 PARAMETER ( LINP = 10 ,
15804 & LOUT = 6 ,
15805 & LDAT = 9 )
15806
15807 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15808
15809* event history
15810
15811 PARAMETER (NMXHKK=200000)
15812
15813 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15814 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15815 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15816
15817* extended event history
15818 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15819 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15820 & IHIST(2,NMXHKK)
15821
004932dd 15822 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 15823 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15824 PARAMETER (MAXLND=4000)
15825 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15826
15827* flags for input different options
15828 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15829 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15830 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15831
15832 INTEGER PYCOMP,PYK
15833
15834 DIMENSION IHISMO(NMXHKK),P1(4)
15835
15836 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15837
15838 CALL DT_INITJS(2)
15839* allow pi0 decay
15840
15841 KC = PYCOMP(111)
15842
15843 MDCY(KC,1) = 1
15844
15845 NN = 0
15846 INI = 0
15847 DO 1 I=1,NHKK
15848 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15849 IF (INI.EQ.0) THEN
15850 INI = 1
15851 ELSE
15852 INI = 2
15853 ENDIF
15854 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15855 & PHKK(4,I),INI,IDUM,IDUM)
15856 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15857 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15858 COSTH = PHKK(3,I)/(PTOT+TINY10)
15859 IF (COSTH.GT.ONE) THEN
15860 THETA = ZERO
15861 ELSEIF (COSTH.LT.-ONE) THEN
15862 THETA = TWOPI/2.0D0
15863 ELSE
15864 THETA = ACOS(COSTH)
15865 ENDIF
15866 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15867 IF (PHKK(1,I).LT.0.0D0)
15868
15869 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15870
15871 ENER = PHKK(4,I)
15872 NN = NN+1
15873 KTEMP = MSTU(10)
15874 MSTU(10)= 1
15875 P(NN,5) = PHKK(5,I)
15876
15877 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15878
15879 MSTU(10) = KTEMP
15880 IHISMO(NN)= I
15881 ENDIF
15882 1 CONTINUE
15883 IF (NN.GT.0) THEN
15884
15885 CALL PYEXEC
15886
15887 NLINES = PYK(0,1)
15888
15889 DO 2 II=1,NLINES
15890
15891 IF (PYK(II,7).EQ.1) THEN
15892
15893 DO 3 KK=1,4
15894
15895 P1(KK) = PYP(II,KK)
15896
15897 3 CONTINUE
15898
15899 ID = PYK(II,8)
15900 MO = IHISMO(PYK(II,15))
15901
15902 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15903 IF (LEMCCK)
15904 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15905 & IDUM,IDUM)
15906*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15907 ISTHKK(MO) = -2
15908 ENDIF
15909 2 CONTINUE
15910 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15911 ENDIF
15912 MDCY(KC,1) = 0
15913
15914 RETURN
15915 END
15916
15917*$ CREATE DT_DTWOPD.FOR
15918*COPY DT_DTWOPD
15919*
15920*===dtwopd=============================================================*
15921*
15922 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15923 & COF2,SIF2,AM1,AM2)
15924
15925************************************************************************
15926* Two-particle decay. *
15927* UMO cm-energy of the decaying system (input) *
15928* AM1/AM2 masses of the decay products (input) *
15929* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15930* COD,COF,SIF direction cosines of the decay prod. (output) *
15931* Revised by S. Roesler, 20.11.95 *
15932************************************************************************
15933
15934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15935 SAVE
15936
15937 PARAMETER ( LINP = 10 ,
15938 & LOUT = 6 ,
15939 & LDAT = 9 )
15940
15941 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15942
15943 IF (UMO.LT.(AM1+AM2)) THEN
15944 WRITE(LOUT,1000) UMO,AM1,AM2
15945 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15946 & 3E12.3)
15947 STOP
15948 ENDIF
15949
15950 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15951 ECM2 = UMO-ECM1
15952 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15953 PCM2 = PCM1
15954 CALL DT_DSFECF(SIF1,COF1)
15955 COD1 = TWO*DT_RNDM(PCM2)-ONE
15956 COD2 = -COD1
15957 COF2 = -COF1
15958 SIF2 = -SIF1
15959
15960 RETURN
15961 END
15962
15963*$ CREATE DT_DTHREP.FOR
15964*COPY DT_DTHREP
15965*
15966*===dthrep=============================================================*
15967*
15968 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15969 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15970
15971************************************************************************
15972* Three-particle decay. *
15973* UMO cm-energy of the decaying system (input) *
15974* AM1/2/3 masses of the decay products (input) *
15975* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15976* COD,COF,SIF direction cosines of the decay prod. (output) *
15977* *
15978* Threpd89: slight revision by A. Ferrari *
15979* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15980* Revised by S. Roesler, 20.11.95 *
15981************************************************************************
15982
15983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15984 SAVE
15985
15986 PARAMETER ( LINP = 10 ,
15987 & LOUT = 6 ,
15988 & LDAT = 9 )
15989
15990 PARAMETER ( ANGLSQ = 2.5D-31 )
15991 PARAMETER ( AZRZRZ = 1.0D-30 )
15992 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15993 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15994 PARAMETER ( ONEONE = 1.D+00 )
15995 PARAMETER ( TWOTWO = 2.D+00 )
15996 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15997
15998 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15999
16000* flags for input different options
16001 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16002 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16003 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16004
16005 DIMENSION F(5),XX(5)
16006 DATA EPS /AZRZRZ/
16007
16008 UMOO=UMO+UMO
16009C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16010C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16011C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16012 UUMO=UMO
16013 AAM1=AM1
16014 AAM2=AM2
16015 AAM3=AM3
16016 GU=(AM2+AM3)**2
16017 GO=(UMO-AM1)**2
16018* UFAK=1.0000000000001D0
16019* IF (GU.GT.GO) UFAK=0.9999999999999D0
16020 IF (GU.GT.GO) THEN
16021 UFAK=ONEMNS
16022 ELSE
16023 UFAK=ONEPLS
16024 END IF
16025 OFAK=2.D0-UFAK
16026 GU=GU*UFAK
16027 GO=GO*OFAK
16028 DS2=(GO-GU)/99.D0
16029 AM11=AM1*AM1
16030 AM22=AM2*AM2
16031 AM33=AM3*AM3
16032 UMO2=UMO*UMO
16033 RHO2=0.D0
16034 S22=GU
16035 DO 124 I=1,100
16036 S21=S22
16037 S22=GU+(I-1.D0)*DS2
16038 RHO1=RHO2
16039 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16040 * (S22+EPS)
16041 IF(RHO2.LT.RHO1) GO TO 125
16042 124 CONTINUE
16043 125 S2SUP=(S22-S21)*.5D0+S21
16044 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16045 * (S2SUP+EPS)
16046 SUPRHO=SUPRHO*1.05D0
16047 XO=S21-DS2
16048 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16049 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16050 XX(1)=XO
16051 XX(3)=S22
16052 X1=(XO+S22)*0.5D0
16053 XX(2)=X1
16054 F(3)=RHO2
16055 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16056 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16057 DO 126 I=1,16
16058 X4=(XX(1)+XX(2))*0.5D0
16059 X5=(XX(2)+XX(3))*0.5D0
16060 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16061 * (X4+EPS)
16062 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16063 * (X5+EPS)
16064 XX(4)=X4
16065 XX(5)=X5
16066 DO 128 II=1,5
16067 IA=II
16068 DO 128 III=IA,5
16069 IF (F (II).GE.F (III)) GO TO 128
16070 FH=F(II)
16071 F(II)=F(III)
16072 F(III)=FH
16073 FH=XX(II)
16074 XX(II)=XX(III)
16075 XX(III)=FH
16076128 CONTINUE
16077 SUPRHO=F(1)
16078 S2SUP=XX(1)
16079 DO 129 II=1,3
16080 IA=II
16081 DO 129 III=IA,3
16082 IF (XX(II).GE.XX(III)) GO TO 129
16083 FH=F(II)
16084 F(II)=F(III)
16085 F(III)=FH
16086 FH=XX(II)
16087 XX(II)=XX(III)
16088 XX(III)=FH
16089129 CONTINUE
16090126 CONTINUE
16091 AM23=(AM2+AM3)**2
16092 ITH=0
16093 REDU=2.D0
16094 1 CONTINUE
16095 ITH=ITH+1
16096 IF (ITH.GT.200) REDU=-9.D0
16097 IF (ITH.GT.200) GO TO 400
16098 C=DT_RNDM(REDU)
16099* S2=AM23+C*((UMO-AM1)**2-AM23)
16100 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16101 Y=DT_RNDM(S2)
16102 Y=Y*SUPRHO
16103 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16104 IF(Y.GT.RHO) GO TO 1
16105C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16106 S1=DT_RNDM(S2)
16107 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16108 &RHO*.5D0
16109 S3=UMO2+AM11+AM22+AM33-S1-S2
16110 ECM1=(UMO2+AM11-S2)/UMOO
16111 ECM2=(UMO2+AM22-S3)/UMOO
16112 ECM3=(UMO2+AM33-S1)/UMOO
16113 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16114 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16115 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16116 CALL DT_DSFECF(SFE,CFE)
16117C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16118C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16119 PCM12 = PCM1 * PCM2
16120 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16121 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16122 GO TO 300
16123 200 CONTINUE
16124 UW=DT_RNDM(S1)
16125 COSTH=(UW-0.5D+00)*2.D+00
16126 300 CONTINUE
16127* IF(ABS(COSTH).GT.0.9999999999999999D0)
16128* &COSTH=SIGN(0.9999999999999999D0,COSTH)
16129 IF(ABS(COSTH).GT.ONEONE)
16130 &COSTH=SIGN(ONEONE,COSTH)
16131 IF (REDU.LT.1.D+00) RETURN
16132 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16133* IF(ABS(COSTH2).GT.0.9999999999999999D0)
16134* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16135 IF(ABS(COSTH2).GT.ONEONE)
16136 &COSTH2=SIGN(ONEONE,COSTH2)
16137 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16138 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16139 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16140 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16141C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16142C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16143C***THE DIRECTION OF PARTICLE 3
16144C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16145 CX11=-COSTH1
16146 CY11=SINTH1*CFE
16147 CZ11=SINTH1*SFE
16148 CX22=-COSTH2
16149 CY22=-SINTH2*CFE
16150 CZ22=-SINTH2*SFE
16151 CALL DT_DSFECF(SIF3,COF3)
16152 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16153 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16154 2 FORMAT(5F20.15)
16155 COD1=CX11*COD3+CZ11*SID3
16156 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16157 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16158 &CX11,CZ11
16159 SID1=SQRT(CHLP)
16160 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16161 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16162 COD2=CX22*COD3+CZ22*SID3
16163 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16164 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16165 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16166 400 CONTINUE
16167* === Energy conservation check: === *
16168 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16169* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16170* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16171* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16172 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16173 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16174 & + PCM3 * COF3 * SID3
16175 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16176 & + PCM3 * SIF3 * SID3
16177 EOCMPR = 1.D-12 * UMO
16178 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16179 & .GT. EOCMPR ) THEN
16180**sr 5.5.95 output-unit changed
16181 IF (IOULEV(1).GT.0) THEN
16182 WRITE(LOUT,*)
16183 & ' *** Threpd: energy/momentum conservation failure! ***',
16184 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16185 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16186 ENDIF
16187**
16188 END IF
16189 RETURN
16190 END
16191
16192*$ CREATE DT_DBKLAS.FOR
16193*COPY DT_DBKLAS
16194*
16195*===dbklas=============================================================*
16196*
16197 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16198
16199 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16200 SAVE
16201
16202 PARAMETER ( LINP = 10 ,
16203 & LOUT = 6 ,
16204 & LDAT = 9 )
16205
16206* quark-content to particle index conversion (DTUNUC 1.x)
16207 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16208 & IA08(6,21),IA10(6,21)
16209
16210 IF (I) 20,20,10
16211* baryons
16212 10 CONTINUE
16213 CALL DT_INDEXD(J,K,IND)
16214 I8 = IB08(I,IND)
16215 I10 = IB10(I,IND)
16216 IF (I8.LE.0) I8 = I10
16217 RETURN
16218* antibaryons
16219 20 CONTINUE
16220 II = IABS(I)
16221 JJ = IABS(J)
16222 KK = IABS(K)
16223 CALL DT_INDEXD(JJ,KK,IND)
16224 I8 = IA08(II,IND)
16225 I10 = IA10(II,IND)
16226 IF (I8.LE.0) I8 = I10
16227
16228 RETURN
16229 END
16230
16231*$ CREATE DT_INDEXD.FOR
16232*COPY DT_INDEXD
16233*
16234*===indexd=============================================================*
16235*
16236 SUBROUTINE DT_INDEXD(KA,KB,IND)
16237
16238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16239 SAVE
16240
16241 PARAMETER ( LINP = 10 ,
16242 & LOUT = 6 ,
16243 & LDAT = 9 )
16244
16245 KP = KA*KB
16246 KS = KA+KB
16247 IF (KP.EQ.1) IND=1
16248 IF (KP.EQ.2) IND=2
16249 IF (KP.EQ.3) IND=3
16250 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16251 IF (KP.EQ.5) IND=5
16252 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16253 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16254 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16255 IF (KP.EQ.8) IND=9
16256 IF (KP.EQ.10) IND=10
16257 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16258 IF (KP.EQ.9) IND=12
16259 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16260 IF (KP.EQ.15) IND=14
16261 IF (KP.EQ.18) IND=15
16262 IF (KP.EQ.16) IND=16
16263 IF (KP.EQ.20) IND=17
16264 IF (KP.EQ.24) IND=18
16265 IF (KP.EQ.25) IND=19
16266 IF (KP.EQ.30) IND=20
16267 IF (KP.EQ.36) IND=21
16268
16269 RETURN
16270 END
16271
16272*$ CREATE DT_DCHANT.FOR
16273*COPY DT_DCHANT
16274*
16275*===dchant=============================================================*
16276*
16277 SUBROUTINE DT_DCHANT
16278
16279 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16280 SAVE
16281
16282 PARAMETER ( LINP = 10 ,
16283 & LOUT = 6 ,
16284 & LDAT = 9 )
16285
16286 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16287
16288* HADRIN: decay channel information
16289 PARAMETER (IDMAX9=602)
16290 CHARACTER*8 ZKNAME
16291 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16292
16293* particle properties (BAMJET index convention)
16294 CHARACTER*8 ANAME
16295 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16296 & IICH(210),IIBAR(210),K1(210),K2(210)
16297
16298 DIMENSION HWT(IDMAX9)
16299
16300* change of weights wt from absolut values into the sum of wt of a dec.
16301 DO 10 J=1,IDMAX9
16302 HWT(J) = ZERO
16303 10 CONTINUE
16304C DO 999 KKK=1,210
16305C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16306C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16307C & K1(KKK),K2(KKK)
16308C 999 CONTINUE
16309C STOP
16310 DO 30 I=1,210
16311 IK1 = K1(I)
16312 IK2 = K2(I)
16313 HV = ZERO
16314 DO 20 J=IK1,IK2
16315 HV = HV+WT(J)
16316 HWT(J) = HV
16317**sr 13.1.95
16318 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16319 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16320 20 CONTINUE
16321 30 CONTINUE
16322 DO 40 J=1,IDMAX9
16323 WT(J) = HWT(J)
16324 40 CONTINUE
16325
16326 RETURN
16327 END
16328
16329*$ CREATE DT_DDATAR.FOR
16330*COPY DT_DDATAR
16331*
16332*===ddatar=============================================================*
16333*
16334 SUBROUTINE DT_DDATAR
16335
16336 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16337 SAVE
16338
16339 PARAMETER ( LINP = 10 ,
16340 & LOUT = 6 ,
16341 & LDAT = 9 )
16342
16343 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16344
16345* quark-content to particle index conversion (DTUNUC 1.x)
16346 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16347 & IA08(6,21),IA10(6,21)
16348
16349 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16350
16351 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16352 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16353 & 128,129,14*0/
16354 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16355 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16356 & 121,122,14*0/
16357 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16358 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16359 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16360 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16361 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16362 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16363 & 0, 0, 0,140,137,138,146, 0, 0,142,
16364 & 139,147, 0, 0,145,148, 50*0/
16365 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16366 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16367 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16368 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16369 & 0, 0,104,105,107,164, 0, 0,106,108,
16370 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16371 & 0, 0, 0,161,162,164,167, 0, 0,163,
16372 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16373 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16374 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16375 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16376 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16377 & 0, 0, 99,100,102,150, 0, 0,101,103,
16378 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16379 & 0, 0, 0,152,149,150,158, 0, 0,154,
16380 & 151,159, 0, 0,157,160, 50*0/
16381 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16382 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16383 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16384 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16385 & 0, 0,110,111,113,174, 0, 0,112,114,
16386 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16387 & 0, 0, 0,171,172,174,177, 0, 0,173,
16388 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16389
16390 L=0
16391 DO 2 I=1,6
16392 DO 1 J=1,6
16393 L = L+1
16394 IMPS(I,J) = IP(L)
16395 IMVE(I,J) = IV(L)
16396 1 CONTINUE
16397 2 CONTINUE
16398 L=0
16399 DO 4 I=1,6
16400 DO 3 J=1,21
16401 L = L+1
16402 IB08(I,J) = IB(L)
16403 IB10(I,J) = IBB(L)
16404 IA08(I,J) = IA(L)
16405 IA10(I,J) = IAA(L)
16406 3 CONTINUE
16407 4 CONTINUE
16408C A1 = 0.88D0
16409C B1 = 3.0D0
16410C B2 = 3.0D0
16411C B3 = 8.0D0
16412C LT = 0
16413C LB = 0
16414C BET = 12.0D0
16415C AS = 0.25D0
16416C B8 = 0.33D0
16417C AME = 0.95D0
16418C DIQ = 0.375D0
16419C ISU = 4
16420
16421 RETURN
16422 END
16423
16424*$ CREATE DT_INITJS.FOR
16425*COPY DT_INITJS
16426*
16427*===initjs=============================================================*
16428*
16429 SUBROUTINE DT_INITJS(MODE)
16430
16431************************************************************************
16432* Initialize JETSET paramters. *
16433* MODE = 0 default settings *
16434* = 1 PHOJET settings *
16435* = 2 DTUNUC settings *
16436* This version dated 16.02.96 is written by S. Roesler *
16437* *
16438* Last change 27.12.2006 by S. Roesler. *
16439************************************************************************
16440
16441 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16442 SAVE
16443
16444 PARAMETER ( LINP = 10 ,
16445 & LOUT = 6 ,
16446 & LDAT = 9 )
16447
16448 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16449
16450 LOGICAL LFIRST,LFIRDT,LFIRPH
16451
16452* INCLUDE '(DIMPAR)'
16453* DIMPAR taken from FLUKA
16454 PARAMETER ( MXXRGN =20000 )
16455 PARAMETER ( MXXMDF = 710 )
16456 PARAMETER ( MXXMDE = 702 )
16457 PARAMETER ( MFSTCK =40000 )
16458 PARAMETER ( MESTCK = 100 )
16459 PARAMETER ( MOSTCK = 2000 )
16460 PARAMETER ( MXPRSN = 100 )
16461 PARAMETER ( MXPDPM = 800 )
16462 PARAMETER ( MXPSCS =30000 )
16463 PARAMETER ( MXGLWN = 300 )
16464 PARAMETER ( MXOUTU = 50 )
16465 PARAMETER ( NALLWP = 64 )
16466 PARAMETER ( NELEMX = 80 )
16467 PARAMETER ( MPDPDX = 18 )
16468 PARAMETER ( MXHTTR = 260 )
16469 PARAMETER ( MXSEAX = 20 )
16470 PARAMETER ( MXHTNC = MXSEAX + 1 )
16471 PARAMETER ( ICOMAX = 2400 )
16472 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16473 PARAMETER ( NSTBIS = 304 )
16474 PARAMETER ( NQSTIS = 46 )
16475 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16476 PARAMETER ( MXPABL = 120 )
16477 PARAMETER ( IDMAXP = 450 )
16478 PARAMETER ( IDMXDC = 2000 )
16479 PARAMETER ( MXMCIN = 410 )
16480 PARAMETER ( IHYPMX = 4 )
16481 PARAMETER ( MKBMX1 = 11 )
16482 PARAMETER ( MKBMX2 = 11 )
16483 PARAMETER ( MXIRRD = 2500 )
16484 PARAMETER ( MXTRDC = 1500 )
16485 PARAMETER ( NKTL = 17 )
16486 PARAMETER ( NBLNMX = 40000000 )
16487
16488* INCLUDE '(PART)'
16489* PART taken from FLUKA
16490 PARAMETER ( KPETA0 = 31 )
16491 PARAMETER ( KPRHOP = 32 )
16492 PARAMETER ( KPRHO0 = 33 )
16493 PARAMETER ( KPRHOM = 34 )
16494 PARAMETER ( KPOME0 = 35 )
16495 PARAMETER ( KPPHI0 = 96 )
16496 PARAMETER ( KPDEPP = 53 )
16497 PARAMETER ( KPDELP = 54 )
16498 PARAMETER ( KPDEL0 = 55 )
16499 PARAMETER ( KPDELM = 56 )
16500 PARAMETER ( KPN14P = 91 )
16501 PARAMETER ( KPN140 = 92 )
16502* Low mass diffraction partners:
16503 PARAMETER ( KDETA0 = 0 )
16504 PARAMETER ( KDRHOP = 0 )
16505 PARAMETER ( KDRHO0 = 210 )
16506 PARAMETER ( KDRHOM = 0 )
16507 PARAMETER ( KDOME0 = 210 )
16508 PARAMETER ( KDPHI0 = 210 )
16509 PARAMETER ( KDDEPP = 0 )
16510 PARAMETER ( KDDELP = 0 )
16511 PARAMETER ( KDDEL0 = 0 )
16512 PARAMETER ( KDDELM = 0 )
16513 PARAMETER ( KDN14P = 0 )
16514 PARAMETER ( KDN140 = 0 )
16515*
16516 CHARACTER*8 ANAME
16517 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16518 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16519 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16520 & ATXN14, ATMN14, RNRN14 (-10:10),
16521 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16522 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16523 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16524 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16525 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16526 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16527
16528 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16529 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
004932dd 16530 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 16531
16532* flags for particle decays
16533 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16534 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16535 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16536
16537* flags for input different options
16538 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16539 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16540 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16541
16542 INTEGER PYCOMP
16543
16544 DIMENSION IDXSTA(40)
16545 DATA IDXSTA
16546* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16547 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16548* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16549 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16550* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16551 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16552* Ksic0 aKsic+aKsic0 sig0 asig0
16553 & 4132,-4232,-4132, 3212,-3212, 5*0/
16554
16555 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16556
16557 IF (LFIRST) THEN
16558* save default settings
16559 PDEF1 = PARJ(1)
16560 PDEF2 = PARJ(2)
16561 PDEF3 = PARJ(3)
16562 PDEF5 = PARJ(5)
16563 PDEF6 = PARJ(6)
16564 PDEF7 = PARJ(7)
16565 PDEF18 = PARJ(18)
16566 PDEF19 = PARJ(19)
16567 PDEF21 = PARJ(21)
16568 PDEF42 = PARJ(42)
16569 MDEF12 = MSTJ(12)
16570* LUJETS / PYJETS array-dimensions
16571
16572 MSTU(4) = 4000
16573
16574* increase maximum number of JETSET-error prints
16575 MSTU(22) = 50000
16576* prevent particles decaying
16577 DO 1 I=1,35
16578 IF (I.LT.34) THEN
16579
16580 KC = PYCOMP(IDXSTA(I))
16581
16582 IF (KC.GT.0) THEN
16583 IF (I.EQ.2) THEN
16584* pi0 decay
16585C MDCY(KC,1) = 1
16586 MDCY(KC,1) = 0
16587**cr mode
16588C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16589C & (I.EQ.8).OR.(I.EQ.10)) THEN
16590C ELSEIF (I.EQ.4) THEN
16591C MDCY(KC,1) = 1
16592**
16593 ELSE
16594 MDCY(KC,1) = 0
16595 ENDIF
16596 ENDIF
16597 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16598
16599 KC = PYCOMP(IDXSTA(I))
16600
16601 IF (KC.GT.0) THEN
16602 MDCY(KC,1) = 0
16603 ENDIF
16604 ENDIF
16605 1 CONTINUE
16606*
16607
16608* as Fluka event-generator: allow only paprop particles to be stable
16609* and let all other particles decay (i.e. those with strong decays)
16610 IF (ITRSPT.EQ.1) THEN
16611 DO 5 I=1,IDMAXP
16612 IF (KPTOIP(I).NE.0) THEN
16613 IDPDG = MPDGHA(I)
16614
16615 KC = PYCOMP(IDPDG)
16616
16617 IF (KC.GT.0) THEN
16618 IF (MDCY(KC,1).EQ.1) THEN
16619 WRITE(LOUT,*)
16620 & ' DT_INITJS: Decay flag for FLUKA-',
16621 & 'transport : particle should not ',
16622 & 'decay : ',IDPDG,' ',ANAME(I)
16623 MDCY(KC,1) = 0
16624 ENDIF
16625 ENDIF
16626 ENDIF
16627 5 CONTINUE
16628 DO 6 KC=1,500
16629 IDPDG = KCHG(KC,4)
16630 KP = MCIHAD(IDPDG)
16631 IF (KP.GT.0) THEN
16632 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16633 & (ANAME(KP).NE.'BLANK ').AND.
16634 & (ANAME(KP).NE.'RNDFLV ')) THEN
16635 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16636 & 'transport: particle should decay ',
16637 & ': ',IDPDG,' ',ANAME(KP)
16638 MDCY(KC,1) = 1
16639 ENDIF
16640 ENDIF
16641 6 CONTINUE
16642 ENDIF
16643
16644*
16645* popcorn:
16646 IF (PDB.LE.ZERO) THEN
16647* no popcorn-mechanism
16648 MSTJ(12) = 1
16649 ELSE
16650 MSTJ(12) = 3
16651 PARJ(5) = PDB
16652 ENDIF
16653* set JETSET-parameter requested by input cards
16654 IF (NMSTU.GT.0) THEN
16655 DO 2 I=1,NMSTU
16656 MSTU(IMSTU(I)) = MSTUX(I)
16657 2 CONTINUE
16658 ENDIF
16659 IF (NMSTJ.GT.0) THEN
16660 DO 3 I=1,NMSTJ
16661 MSTJ(IMSTJ(I)) = MSTJX(I)
16662 3 CONTINUE
16663 ENDIF
16664 IF (NPARU.GT.0) THEN
16665 DO 4 I=1,NPARU
16666 PARU(IPARU(I)) = PARUX(I)
16667 4 CONTINUE
16668 ENDIF
16669 LFIRST = .FALSE.
16670 ENDIF
16671*
16672* PARJ(1) suppression of qq-aqaq pair prod. compared to
16673* q-aq pair prod. (default: 0.1)
16674* PARJ(2) strangeness suppression (default: 0.3)
16675* PARJ(3) extra suppression of strange diquarks (default: 0.4)
16676* PARJ(6) extra suppression of sas-pair shared by B and
16677* aB in BMaB (default: 0.5)
16678* PARJ(7) extra suppression of strange meson M in BMaB
16679* configuration (default: 0.5)
16680* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16681* PARJ(21) width sigma in Gaussian p_x, p_y transverse
16682* momentum distrib. for prim. hadrons (default: 0.35)
16683* PARJ(42) b-parameter for symmetric Lund-fragmentation
16684* function (default: 0.9 GeV^-2)
16685*
16686* PHOJET settings
16687 IF (MODE.EQ.1) THEN
16688* JETSET default
16689C PARJ(1) = PDEF1
16690C PARJ(2) = PDEF2
16691C PARJ(3) = PDEF3
16692C PARJ(6) = PDEF6
16693C PARJ(7) = PDEF7
16694C PARJ(18) = PDEF18
16695C PARJ(21) = PDEF21
16696C PARJ(42) = PDEF42
16697**sr 18.11.98 parameter tuning
16698C PARJ(1) = 0.092D0
16699C PARJ(2) = 0.25D0
16700C PARJ(3) = 0.45D0
16701C PARJ(19) = 0.3D0
16702C PARJ(21) = 0.45D0
16703C PARJ(42) = 1.0D0
16704**sr 28.04.99 parameter tuning (May 99 minor modifications)
16705 PARJ(1) = 0.085D0
16706 PARJ(2) = 0.26D0
16707 PARJ(3) = 0.8D0
16708 PARJ(11) = 0.38D0
16709 PARJ(18) = 0.3D0
16710 PARJ(19) = 0.4D0
16711 PARJ(21) = 0.36D0
16712 PARJ(41) = 0.3D0
16713 PARJ(42) = 0.86D0
16714 IF (NPARJ.GT.0) THEN
16715 DO 10 I=1,NPARJ
16716 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16717 10 CONTINUE
16718 ENDIF
16719 IF (LFIRPH) THEN
16720 WRITE(LOUT,'(1X,A)')
16721 & 'DT_INITJS: JETSET-parameter for PHOJET'
16722 CALL DT_JSPARA(0)
16723 LFIRPH = .FALSE.
16724 ENDIF
16725* DTUNUC settings
16726 ELSEIF (MODE.EQ.2) THEN
16727 IF (IFRAG(2).EQ.1) THEN
16728**sr parameters before 9.3.96
16729C PARJ(2) = 0.27D0
16730C PARJ(3) = 0.6D0
16731C PARJ(6) = 0.75D0
16732C PARJ(7) = 0.75D0
16733C PARJ(21) = 0.55D0
16734C PARJ(42) = 1.3D0
16735**sr 18.11.98 parameter tuning
16736C PARJ(1) = 0.05D0
16737C PARJ(2) = 0.27D0
16738C PARJ(3) = 0.4D0
16739C PARJ(19) = 0.2D0
16740C PARJ(21) = 0.45D0
16741C PARJ(42) = 1.0D0
16742**sr 28.04.99 parameter tuning
16743 PARJ(1) = 0.11D0
16744 PARJ(2) = 0.36D0
16745 PARJ(3) = 0.8D0
16746 PARJ(19) = 0.2D0
16747 PARJ(21) = 0.3D0
16748 PARJ(41) = 0.3D0
16749 PARJ(42) = 0.58D0
16750 IF (NPARJ.GT.0) THEN
16751 DO 20 I=1,NPARJ
16752 IF (IPARJ(I).LT.0) THEN
16753 IDX = ABS(IPARJ(I))
16754 PARJ(IDX) = PARJX(I)
16755 ENDIF
16756 20 CONTINUE
16757 ENDIF
16758 IF (LFIRDT) THEN
16759 WRITE(LOUT,'(1X,A)')
16760 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16761 CALL DT_JSPARA(0)
16762 LFIRDT = .FALSE.
16763 ENDIF
16764 ELSEIF (IFRAG(2).EQ.2) THEN
16765 PARJ(1) = 0.11D0
16766 PARJ(2) = 0.27D0
16767 PARJ(3) = 0.3D0
16768 PARJ(6) = 0.35D0
16769 PARJ(7) = 0.45D0
16770 PARJ(18) = 0.66D0
16771C PARJ(21) = 0.55D0
16772C PARJ(42) = 1.0D0
16773 PARJ(21) = 0.60D0
16774 PARJ(42) = 1.3D0
16775 ELSE
16776 PARJ(1) = PDEF1
16777 PARJ(2) = PDEF2
16778 PARJ(3) = PDEF3
16779 PARJ(6) = PDEF6
16780 PARJ(7) = PDEF7
16781 PARJ(18) = PDEF18
16782 PARJ(21) = PDEF21
16783 PARJ(42) = PDEF42
16784 ENDIF
16785 ELSE
16786 PARJ(1) = PDEF1
16787 PARJ(2) = PDEF2
16788 PARJ(3) = PDEF3
16789 PARJ(5) = PDEF5
16790 PARJ(6) = PDEF6
16791 PARJ(7) = PDEF7
16792 PARJ(18) = PDEF18
16793 PARJ(19) = PDEF19
16794 PARJ(21) = PDEF21
16795 PARJ(42) = PDEF42
16796 MSTJ(12) = MDEF12
16797 ENDIF
16798
16799 RETURN
16800 END
16801
16802*$ CREATE DT_JSPARA.FOR
16803*COPY DT_JSPARA
16804*
16805*===jspara=============================================================*
16806*
16807 SUBROUTINE DT_JSPARA(MODE)
16808
16809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16810 SAVE
16811
16812 PARAMETER ( LINP = 10 ,
16813 & LOUT = 6 ,
16814 & LDAT = 9 )
16815
16816 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16817 & ONE=1.0D0,ZERO=0.0D0)
16818
16819 LOGICAL LFIRST
16820
16821 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16822
16823 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16824
16825 DATA LFIRST /.TRUE./
16826
16827* save the default JETSET-parameter on the first call
16828 IF (LFIRST) THEN
16829 DO 1 I=1,200
16830 ISTU(I) = MSTU(I)
16831 QARU(I) = PARU(I)
16832 ISTJ(I) = MSTJ(I)
16833 QARJ(I) = PARJ(I)
16834 1 CONTINUE
16835 LFIRST = .FALSE.
16836 ENDIF
16837
16838 WRITE(LOUT,1000)
16839 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16840
16841* compare the default JETSET-parameter with the present values
16842 DO 2 I=1,200
16843 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16844 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16845C ISTU(I) = MSTU(I)
16846 ENDIF
16847 DIFF = ABS(PARU(I)-QARU(I))
16848 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16849 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16850C QARU(I) = PARU(I)
16851 ENDIF
16852 IF (MSTJ(I).NE.ISTJ(I)) THEN
16853 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16854C ISTJ(I) = MSTJ(I)
16855 ENDIF
16856 DIFF = ABS(PARJ(I)-QARJ(I))
16857 IF (DIFF.GE.1.0D-5) THEN
16858 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16859C QARJ(I) = PARJ(I)
16860 ENDIF
16861 2 CONTINUE
16862 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16863 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16864
16865 RETURN
16866 END
16867*$ CREATE DT_FOZOCA.FOR
16868*COPY DT_FOZOCA
16869*
16870*===fozoca=============================================================*
16871*
16872 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16873
16874************************************************************************
16875* This subroutine treats the complete FOrmation ZOne supressed intra- *
16876* nuclear CAscade. *
16877* LFZC = .true. cascade has been treated *
16878* = .false. cascade skipped *
16879* This is a completely revised version of the original FOZOKL. *
16880* This version dated 18.11.95 is written by S. Roesler *
16881************************************************************************
16882
16883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16884 SAVE
16885
16886 PARAMETER ( LINP = 10 ,
16887 & LOUT = 6 ,
16888 & LDAT = 9 )
16889
16890 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16891 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16892
16893 LOGICAL LSTART,LCAS,LFZC
16894
16895* event history
16896
16897 PARAMETER (NMXHKK=200000)
16898
16899 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16900 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16901 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16902
16903* extended event history
16904 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16905 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16906 & IHIST(2,NMXHKK)
16907
16908* rejection counter
16909 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16910 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16911 & IREXCI(3),IRDIFF(2),IRINC
16912
16913* properties of interacting particles
16914 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16915
16916* Glauber formalism: collision properties
16917 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 16918 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16919 & NCP,NCT
7b076c76 16920
16921* flags for input different options
16922 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16923 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16924 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16925
16926* final state after intranuclear cascade step
16927 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16928
16929* parameter for intranuclear cascade
16930 LOGICAL LPAULI
16931 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16932
16933 DIMENSION NCWOUN(2)
16934
16935 DATA LSTART /.TRUE./
16936
16937 LFZC = .TRUE.
16938 IREJ = 0
16939
16940* skip cascade if hadron-hadron interaction or if supressed by user
16941 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16942* skip cascade if not all possible chains systems are hadronized
16943 DO 1 I=1,8
16944 IF (.NOT.LHADRO(I)) GOTO 9999
16945 1 CONTINUE
16946
16947 IF (LSTART) THEN
16948 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16949 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16950 & 'maximum of',I4,' generations',/,10X,'formation time ',
16951 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16952 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16953 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16954 1001 FORMAT(10X,'p_t dependent formation zone',/)
16955 1002 FORMAT(10X,'constant formation zone',/)
16956 LSTART = .FALSE.
16957 ENDIF
16958
16959* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16960* which may interact with final state particles are stored in a seperate
16961* array - here all proj./target nucleon-indices (just for simplicity)
16962 NOINC = 0
16963 DO 9 I=1,NPOINT(1)-1
16964 NOINC = NOINC+1
16965 IDXINC(NOINC) = I
16966 9 CONTINUE
16967
16968* initialize Pauli-principle treatment (find wounded nucleons)
16969 NWOUND(1) = 0
16970 NWOUND(2) = 0
16971 NCWOUN(1) = 0
16972 NCWOUN(2) = 0
16973 DO 2 J=1,NPOINT(1)
16974 DO 3 I=1,2
16975 IF (ISTHKK(J).EQ.10+I) THEN
16976 NWOUND(I) = NWOUND(I)+1
16977 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16978 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16979 ENDIF
16980 3 CONTINUE
16981 2 CONTINUE
16982
16983* modify nuclear potential for wounded nucleons
16984 IPRCL = IP -NWOUND(1)
16985 IPZRCL = IPZ-NCWOUN(1)
16986 ITRCL = IT -NWOUND(2)
16987 ITZRCL = ITZ-NCWOUN(2)
16988 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16989
16990 NSTART = NPOINT(4)
16991 NEND = NHKK
16992
16993 7 CONTINUE
16994 DO 8 I=NSTART,NEND
16995
16996 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16997* select nucleus the cascade starts first (proj. - 1, target - -1)
16998 NCAS = 1
16999* projectile/target with probab. 1/2
17000 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
17001 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17002* in the nucleus with highest mass
17003 ELSEIF (INCMOD.EQ.2) THEN
17004 IF (IP.GT.IT) THEN
17005 NCAS = -NCAS
17006 ELSEIF (IP.EQ.IT) THEN
17007 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17008 ENDIF
17009* the nucleus the cascade starts first is requested to be the one
17010* moving in the direction of the secondary
17011 ELSEIF (INCMOD.EQ.3) THEN
17012 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17013 ENDIF
17014* check that the selected "nucleus" is not a hadron
17015 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17016 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
17017
17018* treat intranuclear cascade in the nucleus selected first
17019 LCAS = .FALSE.
17020 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17021 IF (IREJ1.NE.0) GOTO 9998
17022* treat intranuclear cascade in the other nucleus if this isn't a had.
17023 NCAS = -NCAS
17024 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17025 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17026 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17027 IF (IREJ1.NE.0) GOTO 9998
17028 ENDIF
17029
17030 ENDIF
17031
17032 8 CONTINUE
17033 NSTART = NEND+1
17034 NEND = NHKK
17035 IF (NSTART.LE.NEND) GOTO 7
17036
17037 RETURN
17038
17039 9998 CONTINUE
17040* reject this event
17041 IRINC = IRINC+1
17042 IREJ = 1
17043
17044 9999 CONTINUE
17045* intranucl. cascade not treated because of interaction properties or
17046* it is supressed by user or it was rejected or...
17047 LFZC = .FALSE.
17048* reset flag characterizing direction of motion in n-n-cms
17049**sr14-11-95
17050C DO 9990 I=NPOINT(5),NHKK
17051C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17052C9990 CONTINUE
17053
17054 RETURN
17055 END
17056
17057*$ CREATE DT_INUCAS.FOR
17058*COPY DT_INUCAS
17059*
17060*===inucas=============================================================*
17061*
17062 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17063
17064************************************************************************
17065* Formation zone supressed IntraNUclear CAScade for one final state *
17066* particle. *
17067* IT, IP mass numbers of target, projectile nuclei *
17068* IDXCAS index of final state particle in DTEVT1 *
17069* NCAS = 1 intranuclear cascade in projectile *
17070* = -1 intranuclear cascade in target *
17071* This version dated 18.11.95 is written by S. Roesler *
17072************************************************************************
17073
17074 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17075 SAVE
17076
17077 PARAMETER ( LINP = 10 ,
17078 & LOUT = 6 ,
17079 & LDAT = 9 )
17080
17081 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17082 & OHALF=0.5D0,ONE=1.0D0)
17083 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17084 PARAMETER (TWOPI=6.283185307179586454D+00)
17085 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17086
17087 LOGICAL LABSOR,LCAS
17088
17089* event history
17090
17091 PARAMETER (NMXHKK=200000)
17092
17093 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17094 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17095 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17096
17097* extended event history
17098 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17099 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17100 & IHIST(2,NMXHKK)
17101
17102* final state after inc step
17103 PARAMETER (MAXFSP=10)
17104 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17105
17106* flags for input different options
17107 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17108 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17109 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17110
17111* particle properties (BAMJET index convention)
17112 CHARACTER*8 ANAME
17113 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17114 & IICH(210),IIBAR(210),K1(210),K2(210)
17115
17116* Glauber formalism: collision properties
17117 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 17118 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
17119 & NCP,NCT
7b076c76 17120* nuclear potential
17121 LOGICAL LFERMI
17122 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17123 & EBINDP(2),EBINDN(2),EPOT(2,210),
17124 & ETACOU(2),ICOUL,LFERMI
17125
17126* parameter for intranuclear cascade
17127 LOGICAL LPAULI
17128 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17129
17130* final state after intranuclear cascade step
17131 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17132
17133* nucleon-nucleon event-generator
17134 CHARACTER*8 CMODEL
17135 LOGICAL LPHOIN
17136 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17137
17138* statistics: residual nuclei
17139 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17140 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17141 & NINCST(2,4),NINCEV(2),
17142 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17143 & NRESPB(2),NRESCH(2),NRESEV(4),
17144 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17145 & NEVAFI(2,2)
17146
17147 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17148 & PCAS1(5),PNUC(5),BGTA(4),
17149 & BGCAS(2),GACAS(2),BECAS(2),
17150 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17151
17152 DATA PDIF /0.545D0/
17153
17154 IREJ = 0
17155
17156* update counter
17157 IF (NINCEV(1).NE.NEVHKK) THEN
17158 NINCEV(1) = NEVHKK
17159 NINCEV(2) = NINCEV(2)+1
17160 ENDIF
17161
17162* "BAMJET-index" of this hadron
17163 IDCAS = IDBAM(IDXCAS)
17164 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17165
17166* skip gammas, electrons, etc..
17167 IF (AAM(IDCAS).LT.TINY2) RETURN
17168
17169* Lorentz-trsf. into projectile rest system
17170 IF (IP.GT.1) THEN
17171 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17172 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17173 & PCAS(1,4),IDCAS,-2)
17174 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17175 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17176 IF (PCAS(1,5).GT.ZERO) THEN
17177 PCAS(1,5) = SQRT(PCAS(1,5))
17178 ELSE
17179 PCAS(1,5) = AAM(IDCAS)
17180 ENDIF
17181 DO 20 K=1,3
17182 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17183 20 CONTINUE
17184* Lorentz-parameters
17185* particle rest system --> projectile rest system
17186 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17187 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17188 BECAS(1) = BGCAS(1)/GACAS(1)
17189 ELSE
17190 DO 21 K=1,5
17191 PCAS(1,K) = ZERO
17192 IF (K.LE.3) COSCAS(1,K) = ZERO
17193 21 CONTINUE
17194 PTOCAS(1) = ZERO
17195 BGCAS(1) = ZERO
17196 GACAS(1) = ZERO
17197 BECAS(1) = ZERO
17198 ENDIF
17199* Lorentz-trsf. into target rest system
17200 IF (IT.GT.1) THEN
17201* LEPTO: final state particles are already in target rest frame
17202C IF (MCGENE.EQ.3) THEN
17203C PCAS(2,1) = PHKK(1,IDXCAS)
17204C PCAS(2,2) = PHKK(2,IDXCAS)
17205C PCAS(2,3) = PHKK(3,IDXCAS)
17206C PCAS(2,4) = PHKK(4,IDXCAS)
17207C ELSE
17208 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17209 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17210 & PCAS(2,4),IDCAS,-3)
17211C ENDIF
17212 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17213 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17214 IF (PCAS(2,5).GT.ZERO) THEN
17215 PCAS(2,5) = SQRT(PCAS(2,5))
17216 ELSE
17217 PCAS(2,5) = AAM(IDCAS)
17218 ENDIF
17219 DO 22 K=1,3
17220 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17221 22 CONTINUE
17222* Lorentz-parameters
17223* particle rest system --> target rest system
17224 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17225 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17226 BECAS(2) = BGCAS(2)/GACAS(2)
17227 ELSE
17228 DO 23 K=1,5
17229 PCAS(2,K) = ZERO
17230 IF (K.LE.3) COSCAS(2,K) = ZERO
17231 23 CONTINUE
17232 PTOCAS(2) = ZERO
17233 BGCAS(2) = ZERO
17234 GACAS(2) = ZERO
17235 BECAS(2) = ZERO
17236 ENDIF
17237
17238* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17239* potential (see CONUCL)
17240 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17241 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17242* impact parameter (the projectile moving along z)
17243 BIMPC(1) = ZERO
17244 BIMPC(2) = BIMPAC*FM2MM
17245
17246* get position of initial hadron in projectile/target rest-syst.
17247 DO 3 K=1,4
17248 VTXCAS(1,K) = WHKK(K,IDXCAS)
17249 VTXCAS(2,K) = VHKK(K,IDXCAS)
17250 3 CONTINUE
17251
17252 ICAS = 1
17253 I2 = 2
17254 IF (NCAS.EQ.-1) THEN
17255 ICAS = 2
17256 I2 = 1
17257 ENDIF
17258
17259 IF (PTOCAS(ICAS).LT.TINY10) THEN
17260 WRITE(LOUT,1000) PTOCAS
17261 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17262 & ' hadron ',/,20X,2E12.4)
17263 GOTO 9999
17264 ENDIF
17265
17266* reset spectator flags
17267 NSPE = 0
17268 IDXSPE(1) = 0
17269 IDXSPE(2) = 0
17270 IDSPE(1) = 0
17271 IDSPE(2) = 0
17272
17273* formation length (in fm)
17274C IF (LCAS) THEN
17275C DEL0 = ZERO
17276C ELSE
17277 DEL0 = TAUFOR*BGCAS(ICAS)
17278 IF (ITAUVE.EQ.1) THEN
17279 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17280 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17281 ENDIF
17282C ENDIF
17283* sample from exp(-del/del0)
17284 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17285* save formation time
17286 TAUSA1 = DEL1/BGCAS(ICAS)
17287 REL1 = TAUSA1*BGCAS(I2)
17288
17289 DEL = DEL1
17290 TAUSAM = DEL/BGCAS(ICAS)
17291 REL = TAUSAM*BGCAS(I2)
17292
17293* special treatment for negative particles unable to escape
17294* nuclear potential (implemented for ap, pi-, K- only)
17295 LABSOR = .FALSE.
17296 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17297* threshold energy = nuclear potential + Coulomb potential
17298* (nuclear potential for hadron-nucleus interactions only)
17299 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17300 IF (PCAS(ICAS,4).LT.ETHR) THEN
17301 DO 4 K=1,5
17302 PCAS1(K) = PCAS(ICAS,K)
17303 4 CONTINUE
17304* "absorb" negative particle in nucleus
17305 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17306 IF (IREJ1.NE.0) GOTO 9999
17307 IF (NSPE.GE.1) LABSOR = .TRUE.
17308 ENDIF
17309 ENDIF
17310
17311* if the initial particle has not been absorbed proceed with
17312* "normal" cascade
17313 IF (.NOT.LABSOR) THEN
17314
17315* calculate coordinates of hadron at the end of the formation zone
17316* transport-time and -step in the rest system where this step is
17317* treated
17318 DSTEP = DEL*FM2MM
17319 DTIME = DSTEP/BECAS(ICAS)
17320 RSTEP = REL*FM2MM
17321 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17322 RTIME = RSTEP/BECAS(I2)
17323 ELSE
17324 RTIME = ZERO
17325 ENDIF
17326* save step whithout considering the overlapping region
17327 DSTEP1 = DEL1*FM2MM
17328 DTIME1 = DSTEP1/BECAS(ICAS)
17329 RSTEP1 = REL1*FM2MM
17330 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17331 RTIME1 = RSTEP1/BECAS(I2)
17332 ELSE
17333 RTIME1 = ZERO
17334 ENDIF
17335* transport to the end of the formation zone in this system
17336 DO 5 K=1,3
17337 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17338 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17339 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17340 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17341 5 CONTINUE
17342 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17343 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17344 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17345 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17346
17347 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17348 XCAS = VTXCAS(ICAS,1)
17349 YCAS = VTXCAS(ICAS,2)
17350 XNCLTA = BIMPAC*FM2MM
17351 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17352 RNCLTA = (RTARG+RNUCLE)*FM2MM
17353C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17354C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17355C RNCLPR = (RPROJ)*FM2MM
17356C RNCLTA = (RTARG)*FM2MM
17357 RCASPR = SQRT( XCAS**2 +YCAS**2)
17358 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17359 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17360 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17361 ENDIF
17362 ENDIF
17363
17364* check if particle is already outside of the corresp. nucleus
17365 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17366 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17367 IF (RDIST.GE.RNUC(ICAS)) THEN
17368* here: IDCH is the generation of the final state part. starting
17369* with zero for hadronization products
17370* flag particles of generation 0 being outside the nuclei after
17371* formation time (to be used for excitation energy calculation)
17372 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17373 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17374 GOTO 9997
17375 ENDIF
17376 DIST = DLARGE
17377 DISTP = DLARGE
17378 DISTN = DLARGE
17379 IDXP = 0
17380 IDXN = 0
17381
17382* already here: skip particles being outside HADRIN "energy-window"
17383* to avoid wasting of time
17384 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17385 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17386 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17387C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17388C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17389C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17390C & E12.4,', above or below HADRIN-thresholds',I6)
17391 NSPE = 0
17392 GOTO 9997
17393 ENDIF
17394
17395 DO 7 IDXHKK=1,NOINC
17396 I = IDXINC(IDXHKK)
17397* scan DTEVT1 for unwounded or excited nucleons
17398 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17399 DO 8 K=1,3
17400 IF (ICAS.EQ.1) THEN
17401 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17402 ELSEIF (ICAS.EQ.2) THEN
17403 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17404 ENDIF
17405 8 CONTINUE
17406 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17407 & VTXDST(2)*COSCAS(ICAS,2)+
17408 & VTXDST(3)*COSCAS(ICAS,3)
17409* check if nucleon is situated in forward direction
17410 IF (POSNUC.GT.ZERO) THEN
17411* distance between hadron and this nucleon
17412 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17413 & VTXDST(3)**2)
17414* impact parameter
17415 BIMNU2 = DISTNU**2-POSNUC**2
17416 IF (BIMNU2.LT.ZERO) THEN
17417 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17418 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17419 & ' parameter ',/,20X,3E12.4)
17420 GOTO 7
17421 ENDIF
17422 BIMNU = SQRT(BIMNU2)
17423* maximum impact parameter to have interaction
17424 IDNUC = IDT_ICIHAD(IDHKK(I))
17425 IDNUC1 = IDT_MCHAD(IDNUC)
17426 IDCAS1 = IDT_MCHAD(IDCAS)
17427 DO 19 K=1,5
17428 PCAS1(K) = PCAS(ICAS,K)
17429 PNUC(K) = PHKK(K,I)
17430 19 CONTINUE
17431* Lorentz-parameter for trafo into rest-system of target
17432 DO 18 K=1,4
17433 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17434 18 CONTINUE
17435* transformation of projectile into rest-system of target
17436 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17437 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17438 & PPTOT,PX,PY,PZ,PE)
17439**
17440C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17441C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17442 DUMZER = ZERO
17443 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17444 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17445 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17446 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17447 SIGIN = SIGTOT-SIGEL-SIGAB
17448C SIGTOT = SIGIN+SIGEL+SIGAB
17449**
17450 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17451* check if interaction is possible
17452 IF (BIMNU.LE.BIMMAX) THEN
17453* get nucleon with smallest distance and kind of interaction
17454* (elastic/inelastic)
17455 IF (DISTNU.LT.DIST) THEN
17456 DIST = DISTNU
17457 BINT = BIMNU
17458 IF (IDNUC.NE.IDSPE(1)) THEN
17459 IDSPE(2) = IDSPE(1)
17460 IDXSPE(2) = IDXSPE(1)
17461 IDSPE(1) = IDNUC
17462 ENDIF
17463 IDXSPE(1) = I
17464 NSPE = 1
17465**sr
17466 SELA = SIGEL
17467 SABS = SIGAB
17468 STOT = SIGTOT
17469C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17470C SELA = SIGEL
17471C STOT = SIGIN+SIGEL
17472C ELSE
17473C SELA = SIGEL+0.75D0*SIGIN
17474C STOT = 0.25D0*SIGIN+SELA
17475C ENDIF
17476**
17477 ENDIF
17478 ENDIf
17479 ENDIF
17480 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17481 & VTXDST(3)**2)
17482 IDNUC = IDT_ICIHAD(IDHKK(I))
17483 IF (IDNUC.EQ.1) THEN
17484 IF (DISTNU.LT.DISTP) THEN
17485 DISTP = DISTNU
17486 IDXP = I
17487 POSP = POSNUC
17488 ENDIF
17489 ELSEIF (IDNUC.EQ.8) THEN
17490 IF (DISTNU.LT.DISTN) THEN
17491 DISTN = DISTNU
17492 IDXN = I
17493 POSN = POSNUC
17494 ENDIF
17495 ENDIF
17496 ENDIF
17497 7 CONTINUE
17498
17499* there is no nucleon for a secondary interaction
17500 IF (NSPE.EQ.0) GOTO 9997
17501
17502C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17503C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17504 IF (IDXSPE(2).EQ.0) THEN
17505 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17506C DO 80 K=1,3
17507C IF (ICAS.EQ.1) THEN
17508C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17509C ELSEIF (ICAS.EQ.2) THEN
17510C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17511C ENDIF
17512C 80 CONTINUE
17513C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17514C & VTXDST(3)**2)
17515C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17516 IDXSPE(2) = IDXN
17517 IDSPE(2) = 8
17518C ELSE
17519C STOT = STOT-SABS
17520C SABS = ZERO
17521C ENDIF
17522 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17523C DO 81 K=1,3
17524C IF (ICAS.EQ.1) THEN
17525C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17526C ELSEIF (ICAS.EQ.2) THEN
17527C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17528C ENDIF
17529C 81 CONTINUE
17530C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17531C & VTXDST(3)**2)
17532C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17533 IDXSPE(2) = IDXP
17534 IDSPE(2) = 1
17535C ELSE
17536C STOT = STOT-SABS
17537C SABS = ZERO
17538C ENDIF
17539 ELSE
17540 STOT = STOT-SABS
17541 SABS = ZERO
17542 ENDIF
17543 ENDIF
17544 RR = DT_RNDM(DIST)
17545 IF (RR.LT.SELA/STOT) THEN
17546 IPROC = 2
17547 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17548 IPROC = 3
17549 ELSE
17550 IPROC = 1
17551 ENDIF
17552
17553 DO 9 K=1,5
17554 PCAS1(K) = PCAS(ICAS,K)
17555 PNUC(K) = PHKK(K,IDXSPE(1))
17556 9 CONTINUE
17557 IF (IPROC.EQ.3) THEN
17558* 2-nucleon absorption of pion
17559 NSPE = 2
17560 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17561 IF (IREJ1.NE.0) GOTO 9999
17562 IF (NSPE.GE.1) LABSOR = .TRUE.
17563 ELSE
17564* sample secondary interaction
17565 IDNUC = IDBAM(IDXSPE(1))
17566 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17567 IF (IREJ1.EQ.1) GOTO 9999
17568 IF (IREJ1.GT.1) GOTO 9998
17569 ENDIF
17570 ENDIF
17571
17572* update arrays to include Pauli-principle
17573 DO 10 I=1,NSPE
17574 IF (NWOUND(ICAS).LE.299) THEN
17575 NWOUND(ICAS) = NWOUND(ICAS)+1
17576 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17577 ENDIF
17578 10 CONTINUE
17579
17580* dump initial hadron for energy-momentum conservation check
17581 IF (LEMCCK)
17582 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17583 & PCAS(ICAS,4),1,IDUM,IDUM)
17584
17585* dump final state particles into DTEVT1
17586
17587* check if Pauli-principle is fulfilled
17588 NPAULI = 0
17589 NWTMP(1) = NWOUND(1)
17590 NWTMP(2) = NWOUND(2)
17591 DO 111 I=1,NFSP
17592 NPAULI = 0
17593 J1 = 2
17594 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17595 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17596 DO 117 J=1,J1
17597 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17598 IF (J.EQ.1) THEN
17599 IDX = ICAS
17600 PE = PFSP(4,I)
17601 ELSE
17602 IDX = I2
17603 MODE = 1
17604 IF (IDX.EQ.1) MODE = -1
17605 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17606 ENDIF
17607* first check if cascade step is forbidden due to Pauli-principle
17608* (in case of absorpion this step is forced)
17609 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17610 & (IDFSP(I).EQ.8))) THEN
17611* get nuclear potential barrier
17612 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17613 IF (IDFSP(I).EQ.1) THEN
17614 POTLOW = POT-EBINDP(IDX)
17615 ELSE
17616 POTLOW = POT-EBINDN(IDX)
17617 ENDIF
17618* final state particle not able to escape nucleus
17619 IF (PE.LE.POTLOW) THEN
17620* check if there are wounded nucleons
17621 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17622 & EWOUND(IDX,NWOUND(IDX)))) THEN
17623 NPAULI = NPAULI+1
17624 NWOUND(IDX) = NWOUND(IDX)-1
17625 ELSE
17626* interaction prohibited by Pauli-principle
17627 NWOUND(1) = NWTMP(1)
17628 NWOUND(2) = NWTMP(2)
17629 GOTO 9997
17630 ENDIF
17631 ENDIF
17632 ENDIF
17633 117 CONTINUE
17634 111 CONTINUE
17635
17636 NPAULI = 0
17637 NWOUND(1) = NWTMP(1)
17638 NWOUND(2) = NWTMP(2)
17639
17640 DO 11 I=1,NFSP
17641
17642 IST = ISTHKK(IDXCAS)
17643
17644 NPAULI = 0
17645 J1 = 2
17646 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17647 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17648 DO 17 J=1,J1
17649 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17650 IDX = ICAS
17651 PE = PFSP(4,I)
17652 IF (J.EQ.2) THEN
17653 IDX = I2
17654 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17655 ENDIF
17656* first check if cascade step is forbidden due to Pauli-principle
17657* (in case of absorpion this step is forced)
17658 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17659 & (IDFSP(I).EQ.8))) THEN
17660* get nuclear potential barrier
17661 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17662 IF (IDFSP(I).EQ.1) THEN
17663 POTLOW = POT-EBINDP(IDX)
17664 ELSE
17665 POTLOW = POT-EBINDN(IDX)
17666 ENDIF
17667* final state particle not able to escape nucleus
17668 IF (PE.LE.POTLOW) THEN
17669* check if there are wounded nucleons
17670 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17671 & EWOUND(IDX,NWOUND(IDX)))) THEN
17672 NWOUND(IDX) = NWOUND(IDX)-1
17673 NPAULI = NPAULI+1
17674 IST = 14+IDX
17675 ELSE
17676* interaction prohibited by Pauli-principle
17677 NWOUND(1) = NWTMP(1)
17678 NWOUND(2) = NWTMP(2)
17679 GOTO 9997
17680 ENDIF
17681**sr
17682c ELSEIF (PE.LE.POT) THEN
17683cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17684cC NWOUND(IDX) = NWOUND(IDX)-1
17685c**
17686c NPAULI = NPAULI+1
17687c IST = 14+IDX
17688 ENDIF
17689 ENDIF
17690 17 CONTINUE
17691
17692* dump final state particles for energy-momentum conservation check
17693 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17694 & -PFSP(4,I),2,IDUM,IDUM)
17695
17696 PX = PFSP(1,I)
17697 PY = PFSP(2,I)
17698 PZ = PFSP(3,I)
17699 PE = PFSP(4,I)
17700 IF (ABS(IST).EQ.1) THEN
17701* transform particles back into n-n cms
17702* LEPTO: leave final state particles in target rest frame
17703C IF (MCGENE.EQ.3) THEN
17704C PFSP(1,I) = PX
17705C PFSP(2,I) = PY
17706C PFSP(3,I) = PZ
17707C PFSP(4,I) = PE
17708C ELSE
17709 IMODE = ICAS+1
17710 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17711 & PFSP(4,I),IDFSP(I),IMODE)
17712C ENDIF
17713 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17714* target cascade but fsp got stuck in proj. --> transform it into
17715* proj. 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 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17719* proj. cascade but fsp got stuck in target --> transform it into
17720* target rest system
17721 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17722 & PFSP(4,I),IDFSP(I),1)
17723 ENDIF
17724
17725* dump final state particles into DTEVT1
17726 IGEN = IDCH(IDXCAS)+1
17727 ID = IDT_IPDGHA(IDFSP(I))
17728 IXR = 0
17729 IF (LABSOR) IXR = 99
17730 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17731 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17732
17733* update the counter for particles which got stuck inside the nucleus
17734 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17735 NOINC = NOINC+1
17736 IDXINC(NOINC) = NHKK
17737 ENDIF
17738 IF (LABSOR) THEN
17739* in case of absorption the spatial treatment is an approximate
17740* solution anyway (the positions of the nucleons which "absorb" the
17741* cascade particle are not taken into consideration) therefore the
17742* particles are produced at the position of the cascade particle
17743 DO 12 K=1,4
17744 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17745 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17746 12 CONTINUE
17747 ELSE
17748* DDISTL - distance the cascade particle moves to the intera. point
17749* (the position where impact-parameter = distance to the interacting
17750* nucleon), DIST - distance to the interacting nucleon at the time of
17751* formation of the cascade particle, BINT - impact-parameter of this
17752* cascade-interaction
17753 DDISTL = SQRT(DIST**2-BINT**2)
17754 DTIME = DDISTL/BECAS(ICAS)
17755 DTIMEL = DDISTL/BGCAS(ICAS)
17756 RDISTL = DTIMEL*BGCAS(I2)
17757 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17758 RTIME = RDISTL/BECAS(I2)
17759 ELSE
17760 RTIME = ZERO
17761 ENDIF
17762* RDISTL, RTIME are this step and time in the rest system of the other
17763* nucleus
17764 DO 13 K=1,3
17765 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17766 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17767 13 CONTINUE
17768 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17769 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17770* position of particle production is half the impact-parameter to
17771* the interacting nucleon
17772 DO 14 K=1,3
17773 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17774 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17775 14 CONTINUE
17776* time of production of secondary = time of interaction
17777 WHKK(4,NHKK) = VTXCA1(1,4)
17778 VHKK(4,NHKK) = VTXCA1(2,4)
17779 ENDIF
17780
17781 11 CONTINUE
17782
17783* modify status and position of cascade particle (the latter for
17784* statistics reasons only)
17785 ISTHKK(IDXCAS) = 2
17786 IF (LABSOR) ISTHKK(IDXCAS) = 19
17787 IF (.NOT.LABSOR) THEN
17788 DO 15 K=1,4
17789 WHKK(K,IDXCAS) = VTXCA1(1,K)
17790 VHKK(K,IDXCAS) = VTXCA1(2,K)
17791 15 CONTINUE
17792 ENDIF
17793
17794 DO 16 I=1,NSPE
17795 IS = IDXSPE(I)
17796* dump interacting nucleons for energy-momentum conservation check
17797 IF (LEMCCK)
17798 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17799 & 2,IDUM,IDUM)
17800* modify entry for interacting nucleons
17801 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17802 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17803 IF (I.GE.2) THEN
17804 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17805 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17806 ENDIF
17807 16 CONTINUE
17808
17809* check energy-momentum conservation
17810 IF (LEMCCK) THEN
17811 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17812 IF (IREJ1.NE.0) GOTO 9999
17813 ENDIF
17814
17815* update counter
17816 IF (LABSOR) THEN
17817 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17818 ELSE
17819 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17820 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17821 ENDIF
17822
17823 RETURN
17824
17825 9997 CONTINUE
17826 9998 CONTINUE
17827* transport-step but no cascade step due to configuration (i.e. there
17828* is no nucleon for interaction etc.)
17829 IF (LCAS) THEN
17830 DO 100 K=1,4
17831C WHKK(K,IDXCAS) = VTXCAS(1,K)
17832C VHKK(K,IDXCAS) = VTXCAS(2,K)
17833 WHKK(K,IDXCAS) = VTXCA1(1,K)
17834 VHKK(K,IDXCAS) = VTXCA1(2,K)
17835 100 CONTINUE
17836 ENDIF
17837
17838C9998 CONTINUE
17839* no cascade-step because of configuration
17840* (i.e. hadron outside nucleus etc.)
17841 LCAS = .TRUE.
17842 RETURN
17843
17844 9999 CONTINUE
17845* rejection
17846 IREJ = 1
17847 RETURN
17848 END
17849
17850*$ CREATE DT_ABSORP.FOR
17851*COPY DT_ABSORP
17852*
17853*===absorp=============================================================*
17854*
17855 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17856
17857************************************************************************
17858* Two-nucleon absorption of antiprotons, pi-, and K-. *
17859* Antiproton absorption is handled by HADRIN. *
17860* The following channels for meson-absorption are considered: *
17861* pi- + p + p ---> n + p *
17862* pi- + p + n ---> n + n *
17863* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17864* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17865* K- + p + p ---> sigma- + n *
17866* IDCAS, PCAS identity, momentum of particle to be absorbed *
17867* NCAS = 1 intranuclear cascade in projectile *
17868* = -1 intranuclear cascade in target *
17869* NSPE number of spectator nucleons involved *
17870* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17871* Revised version of the original STOPIK written by HJM and J. Ranft. *
17872* This version dated 24.02.95 is written by S. Roesler *
17873************************************************************************
17874
17875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17876 SAVE
17877
17878 PARAMETER ( LINP = 10 ,
17879 & LOUT = 6 ,
17880 & LDAT = 9 )
17881
17882 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17883 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17884
17885* event history
17886
17887 PARAMETER (NMXHKK=200000)
17888
17889 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17890 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17891 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17892
17893* extended event history
17894 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17895 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17896 & IHIST(2,NMXHKK)
17897
17898* flags for input different options
17899 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17900 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17901 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17902
17903* final state after inc step
17904 PARAMETER (MAXFSP=10)
17905 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17906
17907* particle properties (BAMJET index convention)
17908 CHARACTER*8 ANAME
17909 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17910 & IICH(210),IIBAR(210),K1(210),K2(210)
17911
17912 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17913 & PTOT3P(4),BG3P(4),
17914 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17915
17916 IREJ = 0
17917 NFSP = 0
17918
17919* skip particles others than ap, pi-, K- for mode=0
17920 IF ((MODE.EQ.0).AND.
17921 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17922* skip particles others than pions for mode=1
17923* (2-nucleon absorption in intranuclear cascade)
17924 IF ((MODE.EQ.1).AND.
17925 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17926
17927 NUCAS = NCAS
17928 IF (NUCAS.EQ.-1) NUCAS = 2
17929
17930 IF (MODE.EQ.0) THEN
17931* scan spectator nucleons for nucleons being able to "absorb"
17932 NSPE = 0
17933 IDXSPE(1) = 0
17934 IDXSPE(2) = 0
17935 DO 1 I=1,NHKK
17936 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17937 NSPE = NSPE+1
17938 IDXSPE(NSPE) = I
17939 IDSPE(NSPE) = IDBAM(I)
17940 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17941 IF (NSPE.EQ.2) THEN
17942 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17943 & (IDSPE(2).EQ.8)) THEN
17944* there is no pi-+n+n channel
17945 NSPE = 1
17946 GOTO 1
17947 ELSE
17948 GOTO 2
17949 ENDIF
17950 ENDIF
17951 ENDIF
17952 1 CONTINUE
17953
17954 2 CONTINUE
17955 ENDIF
17956* transform excited projectile nucleons (status=15) into proj. rest s.
17957 DO 3 I=1,NSPE
17958 DO 4 K=1,5
17959 PSPE(I,K) = PHKK(K,IDXSPE(I))
17960 4 CONTINUE
17961 3 CONTINUE
17962
17963* antiproton absorption
17964 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17965 DO 5 K=1,5
17966 PSPE1(K) = PSPE(1,K)
17967 5 CONTINUE
17968 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17969 IF (IREJ1.NE.0) GOTO 9999
17970
17971* meson absorption
17972 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17973 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17974 IF (IDCAS.EQ.14) THEN
17975* pi- absorption
17976 IDFSP(1) = 8
17977 IDFSP(2) = 8
17978 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17979 ELSEIF (IDCAS.EQ.13) THEN
17980* pi+ absorption
17981 IDFSP(1) = 1
17982 IDFSP(2) = 1
17983 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17984 ELSEIF (IDCAS.EQ.23) THEN
17985* pi0 absorption
17986 IDFSP(1) = IDSPE(1)
17987 IDFSP(2) = IDSPE(2)
17988 ELSEIF (IDCAS.EQ.16) THEN
17989* K- absorption
17990 R = DT_RNDM(PCAS)
17991 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17992 IF (R.LT.ONETHI) THEN
17993 IDFSP(1) = 21
17994 IDFSP(2) = 8
17995 ELSEIF (R.LT.TWOTHI) THEN
17996 IDFSP(1) = 17
17997 IDFSP(2) = 1
17998 ELSE
17999 IDFSP(1) = 22
18000 IDFSP(2) = 1
18001 ENDIF
18002 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
18003 IDFSP(1) = 20
18004 IDFSP(2) = 8
18005 ELSE
18006 IF (R.LT.ONETHI) THEN
18007 IDFSP(1) = 20
18008 IDFSP(2) = 1
18009 ELSEIF (R.LT.TWOTHI) THEN
18010 IDFSP(1) = 17
18011 IDFSP(2) = 8
18012 ELSE
18013 IDFSP(1) = 22
18014 IDFSP(2) = 8
18015 ENDIF
18016 ENDIF
18017 ENDIF
18018* dump initial particles for energy-momentum cons. check
18019 IF (LEMCCK) THEN
18020 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18021 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18022 & IDUM,IDUM)
18023 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18024 & IDUM,IDUM)
18025 ENDIF
18026* get Lorentz-parameter of 3 particle initial state
18027 DO 6 K=1,4
18028 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18029 6 CONTINUE
18030 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18031 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18032 DO 7 K=1,4
18033 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18034 7 CONTINUE
18035* 2-particle decay of the 3-particle compound system
18036 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18037 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18038 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18039 DO 8 I=1,2
18040 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18041 PX = PCMF(I)*COFF(I)*SDF
18042 PY = PCMF(I)*SIFF(I)*SDF
18043 PZ = PCMF(I)*CODF(I)
18044 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18045 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18046 & PFSP(4,I))
18047 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18048* check consistency of kinematics
18049 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18050 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18051 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18052 & ' tree-particle kinematics',/,20X,'id: ',I3,
18053 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18054 ENDIF
18055* dump final state particles for energy-momentum cons. check
18056 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18057 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18058 8 CONTINUE
18059 NFSP = 2
18060 IF (LEMCCK) THEN
18061 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18062 IF (IREJ1.NE.0) THEN
18063 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18064 & AM3P
18065 GOTO 9999
18066 ENDIF
18067 ENDIF
18068 ELSE
18069 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18070 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18071 & ' impossible',/,20X,'too few spectators (',I2,')')
18072 NSPE = 0
18073 ENDIF
18074
18075 RETURN
18076
18077 9999 CONTINUE
18078 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18079 IREJ = 1
18080 RETURN
18081 END
18082
18083*$ CREATE DT_HADRIN.FOR
18084*COPY DT_HADRIN
18085*
18086*===hadrin=============================================================*
18087*
18088 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18089
18090************************************************************************
18091* Interface to the HADRIN-routines for inelastic and elastic *
18092* scattering. *
18093* IDPR,PPR(5) identity, momentum of projectile *
18094* IDTA,PTA(5) identity, momentum of target *
18095* MODE = 1 inelastic interaction *
18096* = 2 elastic interaction *
18097* Revised version of the original FHAD. *
18098* This version dated 27.10.95 is written by S. Roesler *
18099************************************************************************
18100
18101 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18102 SAVE
18103
18104 PARAMETER ( LINP = 10 ,
18105 & LOUT = 6 ,
18106 & LDAT = 9 )
18107
18108 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18109 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18110
18111 LOGICAL LCORR,LMSSG
18112
18113* flags for input different options
18114 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18115 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18116 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18117
18118* final state after inc step
18119 PARAMETER (MAXFSP=10)
18120 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18121
18122* particle properties (BAMJET index convention)
18123 CHARACTER*8 ANAME
18124 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18125 & IICH(210),IIBAR(210),K1(210),K2(210)
18126* output-common for DHADRI/ELHAIN
18127
18128* final state from HADRIN interaction
18129 PARAMETER (MAXFIN=10)
18130 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18131 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18132
18133 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18134 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18135
18136 DATA LMSSG /.TRUE./
18137
18138 IREJ = 0
18139 NFSP = 0
18140 KCORR = 0
18141 IMCORR(1) = 0
18142 IMCORR(2) = 0
18143 LCORR = .FALSE.
18144
18145* dump initial particles for energy-momentum cons. check
18146 IF (LEMCCK) THEN
18147 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18148 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18149 ENDIF
18150
18151 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18152 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18153 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18154 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18155 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18156 IF (LMSSG.AND.(IOULEV(3).GT.0))
18157 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18158 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18159 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18160 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18161 LMSSG = .FALSE.
18162 LCORR = .TRUE.
18163 ENDIF
18164
18165* convert initial state particles into particles which can be
18166* handled by HADRIN
18167 IDHPR = IDPR
18168 IDHTA = IDTA
18169 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18170 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18171 DO 1 K=1,4
18172 P1IN(K) = PPR(K)
18173 P2IN(K) = PTA(K)
18174 1 CONTINUE
18175 XM1 = AAM(IDHPR)
18176 XM2 = AAM(IDHTA)
18177 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18178 IF (IREJ1.GT.0) THEN
18179 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18180 GOTO 9999
18181 ENDIF
18182 DO 2 K=1,4
18183 PPR(K) = P1OUT(K)
18184 PTA(K) = P2OUT(K)
18185 2 CONTINUE
18186 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18187 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18188 ENDIF
18189
18190* Lorentz-parameter for trafo into rest-system of target
18191 DO 3 K=1,4
18192 BGTA(K) = PTA(K)/PTA(5)
18193 3 CONTINUE
18194* transformation of projectile into rest-system of target
18195 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18196 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18197 & PPR1(4))
18198
18199* direction cosines of projectile in target rest system
18200 CX = PPR1(1)/PPRTO1
18201 CY = PPR1(2)/PPRTO1
18202 CZ = PPR1(3)/PPRTO1
18203
18204* sample inelastic interaction
18205 IF (MODE.EQ.1) THEN
18206 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18207 IF (IRH.EQ.1) GOTO 9998
18208* sample elastic interaction
18209 ELSEIF (MODE.EQ.2) THEN
18210 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18211 IF (IREJ1.NE.0) THEN
18212 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18213 GOTO 9999
18214 ENDIF
18215 IF (IRH.EQ.1) GOTO 9998
18216 ELSE
18217 WRITE(LOUT,1001) MODE,INTHAD
18218 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18219 & I4,' (INTHAD =',I4,')')
18220 GOTO 9999
18221 ENDIF
18222
18223* transform final state particles back into Lab.
18224 DO 4 I=1,IRH
18225 NFSP = NFSP+1
18226 PX = CXRH(I)*PLRH(I)
18227 PY = CYRH(I)*PLRH(I)
18228 PZ = CZRH(I)*PLRH(I)
18229 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18230 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18231 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18232 IDFSP(NFSP) = ITRH(I)
18233 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18234 & PFSP(3,NFSP)**2
18235 IF (AMFSP2.LT.-TINY3) THEN
18236 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18237 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18238 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18239 & I2,') with negative mass^2',/,1X,5E12.4)
18240 GOTO 9999
18241 ELSE
18242 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18243 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18244 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18245 & PFSP(5,NFSP)
18246 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18247 & ' (id = ',I2,') with inconsistent mass',/,1X,
18248 & 2E12.4)
18249 KCORR = KCORR+1
18250 IF (KCORR.GT.2) GOTO 9999
18251 IMCORR(KCORR) = NFSP
18252 ENDIF
18253 ENDIF
18254* dump final state particles for energy-momentum cons. check
18255 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18256 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18257 4 CONTINUE
18258
18259* transform momenta on mass shell in case of inconsistencies in
18260* HADRIN
18261 IF (KCORR.GT.0) THEN
18262 IF (KCORR.EQ.2) THEN
18263 I1 = IMCORR(1)
18264 I2 = IMCORR(2)
18265 ELSE
18266 IF (IMCORR(1).EQ.1) THEN
18267 I1 = 1
18268 I2 = 2
18269 ELSE
18270 I1 = 1
18271 I2 = IMCORR(1)
18272 ENDIF
18273 ENDIF
18274 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18275 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18276 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18277 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18278 DO 5 K=1,4
18279 P1IN(K) = PFSP(K,I1)
18280 P2IN(K) = PFSP(K,I2)
18281 5 CONTINUE
18282 XM1 = AAM(IDFSP(I1))
18283 XM2 = AAM(IDFSP(I2))
18284 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18285 IF (IREJ1.GT.0) THEN
18286 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18287C GOTO 9999
18288 ENDIF
18289 DO 6 K=1,4
18290 PFSP(K,I1) = P1OUT(K)
18291 PFSP(K,I2) = P2OUT(K)
18292 6 CONTINUE
18293 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18294 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18295 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18296 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18297* dump final state particles for energy-momentum cons. check
18298 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18299 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18300 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18301 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18302 ENDIF
18303
18304* check energy-momentum conservation
18305 IF (LEMCCK) THEN
18306 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18307 IF (IREJ1.NE.0) GOTO 9999
18308 ENDIF
18309
18310 RETURN
18311
18312 9998 CONTINUE
18313 IREJ = 2
18314 RETURN
18315
18316 9999 CONTINUE
18317 IREJ = 1
18318 RETURN
18319 END
18320
18321*$ CREATE DT_HADCOL.FOR
18322*COPY DT_HADCOL
18323*
18324*===hadcol=============================================================*
18325*
18326 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18327
18328************************************************************************
18329* Interface to the HADRIN-routines for inelastic and elastic *
18330* scattering. This subroutine samples hadron-nucleus interactions *
18331* below DPM-threshold. *
18332* IDPROJ BAMJET-index of projectile hadron *
18333* PPN projectile momentum in target rest frame *
18334* IDXTAR DTEVT1-index of target nucleon undergoing *
18335* interaction with projectile hadron *
18336* This subroutine replaces HADHAD. *
18337* This version dated 5.5.95 is written by S. Roesler *
18338************************************************************************
18339
18340 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18341 SAVE
18342
18343 PARAMETER ( LINP = 10 ,
18344 & LOUT = 6 ,
18345 & LDAT = 9 )
18346
18347 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18348
18349 LOGICAL LSTART
18350
18351* event history
18352
18353 PARAMETER (NMXHKK=200000)
18354
18355 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18356 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18357 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18358
18359* extended event history
18360 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18361 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18362 & IHIST(2,NMXHKK)
18363
18364* nuclear potential
18365 LOGICAL LFERMI
18366 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18367 & EBINDP(2),EBINDN(2),EPOT(2,210),
18368 & ETACOU(2),ICOUL,LFERMI
18369
18370* interface HADRIN-DPM
18371 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18372
18373* parameter for intranuclear cascade
18374 LOGICAL LPAULI
18375 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18376
18377* final state after inc step
18378 PARAMETER (MAXFSP=10)
18379 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18380
18381* particle properties (BAMJET index convention)
18382 CHARACTER*8 ANAME
18383 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18384 & IICH(210),IIBAR(210),K1(210),K2(210)
18385
18386 DIMENSION PPROJ(5),PNUC(5)
18387
18388 DATA LSTART /.TRUE./
18389
18390 IREJ = 0
18391
18392 NPOINT(1) = NHKK+1
18393
18394 TAUSAV = TAUFOR
18395**sr 6/9/01 commented
18396C TAUFOR = TAUFOR/2.0D0
18397**
18398 IF (LSTART) THEN
18399 WRITE(LOUT,1000)
18400 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18401 WRITE(LOUT,1001) TAUFOR
18402 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18403 & F5.1,' fm/c')
18404 LSTART = .FALSE.
18405 ENDIF
18406
18407 IDNUC = IDBAM(IDXTAR)
18408 IDNUC1 = IDT_MCHAD(IDNUC)
18409 IDPRO1 = IDT_MCHAD(IDPROJ)
18410
18411 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18412 IPROC = INTHAD
18413 ELSE
18414**
18415C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18416C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18417 DUMZER = ZERO
18418 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18419 SIGIN = SIGTOT-SIGEL
18420C SIGTOT = SIGIN+SIGEL
18421**
18422 IPROC = 1
18423 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18424 ENDIF
18425
18426 PPROJ(1) = ZERO
18427 PPROJ(2) = ZERO
18428 PPROJ(3) = PPN
18429 PPROJ(5) = AAM(IDPROJ)
18430 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18431 DO 1 K=1,5
18432 PNUC(K) = PHKK(K,IDXTAR)
18433 1 CONTINUE
18434
18435 ILOOP = 0
18436 2 CONTINUE
18437 ILOOP = ILOOP+1
18438 IF (ILOOP.GT.100) GOTO 9999
18439
18440 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18441 IF (IREJ1.EQ.1) GOTO 9999
18442
18443 IF (IREJ1.GT.1) THEN
18444* no interaction possible
18445* require Pauli blocking
18446 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18447 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18448 IF ((IIBAR(IDPROJ).NE.1).AND.
18449 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18450* store incoming particle as final state particle
18451 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18452 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18453 NPOINT(4) = NHKK
18454 ELSE
18455* require Pauli blocking for final state nucleons
18456 DO 4 I=1,NFSP
18457 IF ((IDFSP(I).EQ.1).AND.
18458 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18459 IF ((IDFSP(I).EQ.8).AND.
18460 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18461 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18462 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18463 4 CONTINUE
18464* store final state particles
18465 DO 5 I=1,NFSP
18466 IST = 1
18467 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18468 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18469 IDHAD = IDT_IPDGHA(IDFSP(I))
18470 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18471 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18472 & PCMS,ECMS,0,0,0)
18473 IF (I.EQ.1) NPOINT(4) = NHKK
18474 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18475 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18476 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18477 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18478 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18479 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18480 WHKK(3,NHKK) = WHKK(3,1)
18481 WHKK(4,NHKK) = WHKK(4,1)
18482 5 CONTINUE
18483 ENDIF
18484 TAUFOR = TAUSAV
18485 RETURN
18486
18487 9999 CONTINUE
18488 IREJ = 1
18489 TAUFOR = TAUSAV
18490 RETURN
18491 END
18492*$ CREATE DT_GETEMU.FOR
18493*COPY DT_GETEMU
18494*
18495*===getemu=============================================================*
18496*
18497 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18498
18499************************************************************************
18500* Sampling of emulsion component to be considered as target-nucleus. *
18501* This version dated 6.5.95 is written by S. Roesler. *
18502************************************************************************
18503
18504 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18505 SAVE
18506
18507 PARAMETER ( LINP = 10 ,
18508 & LOUT = 6 ,
18509 & LDAT = 9 )
18510
18511 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18512
18513 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18514
18515* emulsion treatment
18516 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18517 & NCOMPO,IEMUL
18518
18519* Glauber formalism: flags and parameters for statistics
18520 LOGICAL LPROD
18521 CHARACTER*8 CGLB
18522 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18523
18524 IF (MODE.EQ.0) THEN
18525 SUMFRA = ZERO
18526 RR = DT_RNDM(SUMFRA)
18527 IT = 0
18528 ITZ = 0
18529 DO 1 ICOMP=1,NCOMPO
18530 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18531 IF (SUMFRA.GT.RR) THEN
18532 IT = IEMUMA(ICOMP)
18533 ITZ = IEMUCH(ICOMP)
18534 KKMAT = ICOMP
18535 GOTO 2
18536 ENDIF
18537 1 CONTINUE
18538 2 CONTINUE
18539 IF (IT.LE.0) THEN
18540 WRITE(LOUT,'(1X,A,E12.3)')
18541 & 'Warning! norm. failure within emulsion fractions',
18542 & SUMFRA
18543 STOP
18544 ENDIF
18545 ELSEIF (MODE.EQ.1) THEN
18546 NDIFF = 10000
18547 DO 3 I=1,NCOMPO
18548 IDIFF = ABS(IT-IEMUMA(I))
18549 IF (IDIFF.LT.NDIFF) THEN
18550 KKMAT = I
18551 NDIFF = IDIFF
18552 ENDIF
18553 3 CONTINUE
18554 ELSE
18555 STOP 'DT_GETEMU'
18556 ENDIF
18557
18558* bypass for variable projectile/target/energy runs: the correct
18559* Glauber data will be always loaded on kkmat=1
18560 IF (IOGLB.EQ.100) THEN
18561 KKMAT = 1
18562 ENDIF
18563
18564 RETURN
18565 END
18566
18567*$ CREATE DT_NCLPOT.FOR
18568*COPY DT_NCLPOT
18569*
18570*===nclpot=============================================================*
18571*
18572 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18573
18574************************************************************************
18575* Calculation of Coulomb and nuclear potential for a given configurat. *
18576* IPZ, IP charge/mass number of proj. *
18577* ITZ, IT charge/mass number of targ. *
18578* AFERP,AFERT factors modifying proj./target pot. *
18579* if =0, FERMOD is used *
18580* MODE = 0 calculation of binding energy *
18581* = 1 pre-calculated binding energy is used *
18582* This version dated 16.11.95 is written by S. Roesler. *
18583* *
18584* Last change 28.12.2006 by S. Roesler. *
18585************************************************************************
18586
18587 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18588 SAVE
18589
18590 PARAMETER ( LINP = 10 ,
18591 & LOUT = 6 ,
18592 & LDAT = 9 )
18593
18594 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18595 & TINY10=1.0D-10)
18596
18597 LOGICAL LSTART
18598
18599* particle properties (BAMJET index convention)
18600 CHARACTER*8 ANAME
18601 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18602 & IICH(210),IIBAR(210),K1(210),K2(210)
18603
18604* nuclear potential
18605 LOGICAL LFERMI
18606 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18607 & EBINDP(2),EBINDN(2),EPOT(2,210),
18608 & ETACOU(2),ICOUL,LFERMI
18609
18610 DIMENSION IDXPOT(14)
18611* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18612 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18613* asig0 asig+ atet0 atet+
18614 & 100, 101, 102, 103/
18615
18616 DATA AN /0.4D0/
18617 DATA LSTART /.TRUE./
18618
18619 IF (MODE.EQ.0) THEN
18620 EBINDP(1) = ZERO
18621 EBINDN(1) = ZERO
18622 EBINDP(2) = ZERO
18623 EBINDN(2) = ZERO
18624 ENDIF
18625 AIP = DBLE(IP)
18626 AIPZ = DBLE(IPZ)
18627 AIT = DBLE(IT)
18628 AITZ = DBLE(ITZ)
18629
18630 FERMIP = AFERP
18631 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18632 FERMIT = AFERT
18633 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18634
18635* Fermi momenta and binding energy for projectile
18636 IF ((IP.GT.1).AND.LFERMI) THEN
18637 IF (MODE.EQ.0) THEN
18638C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18639C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18640 BIP = AIP -ONE
18641 BIPZ = AIPZ-ONE
18642
18643C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18644C & -ENERGY(AIP,AIPZ))
18645 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18646 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18647 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18648
18649 IF (AIP.LE.AIPZ) THEN
18650 EBINDN(1) = EBINDP(1)
18651 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18652 ELSE
18653
18654C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18655C & -ENERGY(AIP,AIPZ))
18656 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18657 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18658 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18659
18660 ENDIF
18661 ENDIF
18662 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18663 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18664 ELSE
18665 PFERMP(1) = ZERO
18666 PFERMN(1) = ZERO
18667 ENDIF
18668* effective nuclear potential for projectile
18669C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18670C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18671 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18672 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18673
18674* Fermi momenta and binding energy for target
18675 IF ((IT.GT.1).AND.LFERMI) THEN
18676 IF (MODE.EQ.0) THEN
18677C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18678C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18679 BIT = AIT -ONE
18680 BITZ = AITZ-ONE
18681
18682C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18683C & -ENERGY(AIT,AITZ))
18684 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18685 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18686 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18687
18688 IF (AIT.LE.AITZ) THEN
18689 EBINDN(2) = EBINDP(2)
18690 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18691 ELSE
18692
18693C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18694C & -ENERGY(AIT,AITZ))
18695 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18696 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18697 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18698
18699 ENDIF
18700 ENDIF
18701 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18702 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18703 ELSE
18704 PFERMP(2) = ZERO
18705 PFERMN(2) = ZERO
18706 ENDIF
18707* effective nuclear potential for target
18708C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18709C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18710 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18711 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18712
18713 DO 2 I=1,14
18714 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18715 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18716 2 CONTINUE
18717
18718* Coulomb energy
18719 ETACOU(1) = ZERO
18720 ETACOU(2) = ZERO
18721 IF (ICOUL.EQ.1) THEN
18722 IF (IP.GT.1)
18723 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18724 IF (IT.GT.1)
18725 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18726 ENDIF
18727
18728 IF (LSTART) THEN
18729 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18730 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18731 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18732 & FERMOD,ETACOU
18733 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18734 & ,' effects',/,12X,'---------------------------',
18735 & '----------------',/,/,38X,'projectile',
18736 & ' target',/,/,1X,'Mass number / charge',
18737 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18738 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18739 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18740 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18741 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18742 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18743 LSTART = .FALSE.
18744 ENDIF
18745
18746 RETURN
18747 END
18748
18749*$ CREATE DT_RESNCL.FOR
18750*COPY DT_RESNCL
18751*
18752*===resncl=============================================================*
18753*
18754 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18755
18756************************************************************************
18757* Treatment of residual nuclei and nuclear effects. *
18758* MODE = 1 initializations *
18759* = 2 treatment of final state *
18760* This version dated 16.11.95 is written by S. Roesler. *
18761* *
18762* Last change 05.01.2007 by S. Roesler. *
18763************************************************************************
18764
18765 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18766 SAVE
18767
18768 PARAMETER ( LINP = 10 ,
18769 & LOUT = 6 ,
18770 & LDAT = 9 )
18771
18772 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18773 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18774 & ONETHI=ONE/THREE)
18775 PARAMETER (AMUAMU = 0.93149432D0,
18776 & FM2MM = 1.0D-12,
18777 & RNUCLE = 1.12D0)
18778 PARAMETER ( EMVGEV = 1.0 D-03 )
18779 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18780 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18781 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18782 PARAMETER ( AMELCT = 0.51099906 D-03 )
18783 PARAMETER ( HLFHLF = 0.5D+00 )
18784 PARAMETER ( FERTHO = 14.33 D-09 )
18785 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18786 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18787 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18788
18789* event history
18790
18791 PARAMETER (NMXHKK=200000)
18792
18793 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18794 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18795 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18796
18797* extended event history
18798 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18799 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18800 & IHIST(2,NMXHKK)
18801
18802* particle properties (BAMJET index convention)
18803 CHARACTER*8 ANAME
18804 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18805 & IICH(210),IIBAR(210),K1(210),K2(210)
18806
18807* flags for input different options
18808 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18809 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18810 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18811
18812* nuclear potential
18813 LOGICAL LFERMI
18814 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18815 & EBINDP(2),EBINDN(2),EPOT(2,210),
18816 & ETACOU(2),ICOUL,LFERMI
18817
18818* properties of interacting particles
18819 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18820
18821* properties of photon/lepton projectiles
18822 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18823
18824* Lorentz-parameters of the current interaction
18825 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18826 & UMO,PPCM,EPROJ,PPROJ
18827
18828* treatment of residual nuclei: wounded nucleons
18829 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18830
18831* treatment of residual nuclei: 4-momenta
18832 LOGICAL LRCLPR,LRCLTA
18833 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18834 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18835
18836 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18837 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18838 & IDXCOR(15000),IDXOTH(NMXHKK)
18839
18840 GOTO (1,2) MODE
18841
18842*------- initializations
18843 1 CONTINUE
18844
18845* initialize arrays for residual nuclei
18846 DO 10 K=1,5
18847 IF (K.LE.4) THEN
18848 PFSP(K) = ZERO
18849 ENDIF
18850 PINIPR(K) = ZERO
18851 PINITA(K) = ZERO
18852 PRCLPR(K) = ZERO
18853 PRCLTA(K) = ZERO
18854 TRCLPR(K) = ZERO
18855 TRCLTA(K) = ZERO
18856 10 CONTINUE
18857 SCPOT = ONE
18858 NLOOP = 0
18859
18860* correction of projectile 4-momentum for effective target pot.
18861* and Coulomb-energy (in case of hadron-nucleus interaction only)
1a043008
AM		 18862* IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18863* EPNI = EPN
7b076c76 18864* Coulomb-energy:
18865* positively charged hadron - check energy for Coloumb pot.
1a043008
AM		 18866* IF (IICH(IJPROJ).EQ.1) THEN
18867* THRESH = ETACOU(2)+AAM(IJPROJ)
18868* IF (EPNI.LE.THRESH) THEN
18869* WRITE(LOUT,1000)
18870* 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18871* & ' below Coulomb threshold - event rejected',/)
18872* ISTHKK(1) = 1
18873* RETURN
18874* ENDIF
7b076c76 18875* negatively charged hadron - increase energy by Coulomb energy
1a043008
AM		 18876* ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18877* EPNI = EPNI+ETACOU(2)
18878* ENDIF
18879* IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
7b076c76 18880* Effective target potential
18881*sr 6.6. binding energy only (to avoid negative exc. energies)
18882C EPNI = EPNI+EPOT(2,IJPROJ)
1a043008
AM		 18883* EBIPOT = EBINDP(2)
18884* IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18885* & EBIPOT = EBINDN(2)
18886* EPNI = EPNI+ABS(EBIPOT)
7b076c76 18887* re-initialization of DTLTRA
1a043008
AM		 18888* DUM1 = ZERO
18889* DUM2 = ZERO
18890* CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18891* ENDIF
18892* ENDIF
7b076c76 18893
18894* projectile in n-n cms
18895 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18896 PMASS1 = AAM(IJPROJ)
18897C* VDM assumption
18898C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18899 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18900 PMASS2 = AAM(1)
18901 PM1 = SIGN(PMASS1**2,PMASS1)
18902 PM2 = SIGN(PMASS2**2,PMASS2)
18903 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18904 PINIPR(5) = PMASS1
18905 IF (PMASS1.GT.ZERO) THEN
18906 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18907 & *(PINIPR(4)+PINIPR(5)))
18908 ELSE
18909 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18910 ENDIF
18911 AIT = DBLE(IT)
18912 AITZ = DBLE(ITZ)
18913
18914C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18915 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18916
18917 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18918 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18919 PMASS1 = AAM(1)
18920 PMASS2 = AAM(IJTARG)
18921 PM1 = SIGN(PMASS1**2,PMASS1)
18922 PM2 = SIGN(PMASS2**2,PMASS2)
18923 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18924 PINITA(5) = PMASS2
18925 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18926 & *(PINITA(4)+PINITA(5)))
18927 AIP = DBLE(IP)
18928 AIPZ = DBLE(IPZ)
18929
18930C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18931 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18932
18933 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18934 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18935 AIP = DBLE(IP)
18936 AIPZ = DBLE(IPZ)
18937
18938C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18939 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18940
18941 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18942 AIT = DBLE(IT)
18943 AITZ = DBLE(ITZ)
18944
18945C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18946 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18947
18948 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18949 ENDIF
18950
18951 RETURN
18952
18953*------- treatment of final state
18954 2 CONTINUE
18955
18956 NLOOP = NLOOP+1
18957 IF (NLOOP.GT.1) SCPOT = 0.10D0
18958C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18959
18960 JPW = NPW
18961 JPCW = NPCW
18962 JTW = NTW
18963 JTCW = NTCW
18964 DO 40 K=1,4
18965 PFSP(K) = ZERO
18966 40 CONTINUE
18967
18968 NOB = 0
18969 NOM = 0
18970 DO 900 I=NPOINT(4),NHKK
18971 IDXOTH(I) = -1
18972 IF (ISTHKK(I).EQ.1) THEN
18973 IF (IDBAM(I).EQ.7) GOTO 900
18974 IPOT = 0
18975 IOTHER = 0
18976* particle moving into forward direction
18977 IF (PHKK(3,I).GE.ZERO) THEN
18978* most likely to be effected by projectile potential
18979 IPOT = 1
18980* there is no projectile nucleus, try target
18981 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18982 IPOT = 2
18983 IF (IP.GT.1) IOTHER = 1
18984* there is no target nucleus --> skip
18985 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18986 ENDIF
18987* particle moving into backward direction
18988 ELSE
18989* most likely to be effected by target potential
18990 IPOT = 2
18991* there is no target nucleus, try projectile
18992 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18993 IPOT = 1
18994 IF (IT.GT.1) IOTHER = 1
18995* there is no projectile nucleus --> skip
18996 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18997 ENDIF
18998 ENDIF
18999 IFLG = -IPOT
19000* nobam=3: particle is in overlap-region or neither inside proj. nor target
19001* =1: particle is not in overlap-region AND is inside target (2)
19002* =2: particle is not in overlap-region AND is inside projectile (1)
19003* flag particles which are inside the nucleus ipot but not in its
19004* overlap region
19005 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19006 IF (IDBAM(I).NE.0) THEN
19007* baryons: keep all nucleons and all others where flag is set
19008 IF (IIBAR(IDBAM(I)).NE.0) THEN
19009 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19010 & THEN
19011 NOB = NOB+1
19012 PMOMB(NOB) = PHKK(3,I)
19013 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
19014 & +1000000*IOTHER+I,IFLG)
19015 ENDIF
19016* mesons: keep only those mesons where flag is set
19017 ELSE
19018 IF (IFLG.GT.0) THEN
19019 NOM = NOM+1
19020 PMOMM(NOM) = PHKK(3,I)
19021 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19022 ENDIF
19023 ENDIF
19024 ENDIF
19025 ENDIF
19026 900 CONTINUE
19027*
19028* sort particles in the arrays according to increasing long. momentum
19029 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19030 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19031*
19032* shuffle indices into one and the same array according to the later
19033* sequence of correction
19034 NCOR = 0
19035 IF (IT.GT.1) THEN
19036 DO 910 I=1,NOB
19037 IF (PMOMB(I).GT.ZERO) GOTO 911
19038 NCOR = NCOR+1
19039 IDXCOR(NCOR) = IDXB(I)
19040 910 CONTINUE
19041 911 CONTINUE
19042 IF (IP.GT.1) THEN
19043 DO 912 J=1,NOB
19044 I = NOB+1-J
19045 IF (PMOMB(I).LT.ZERO) GOTO 913
19046 NCOR = NCOR+1
19047 IDXCOR(NCOR) = IDXB(I)
19048 912 CONTINUE
19049 913 CONTINUE
19050 ELSE
19051 DO 914 I=1,NOB
19052 IF (PMOMB(I).GT.ZERO) THEN
19053 NCOR = NCOR+1
19054 IDXCOR(NCOR) = IDXB(I)
19055 ENDIF
19056 914 CONTINUE
19057 ENDIF
19058 ELSE
19059 DO 915 J=1,NOB
19060 I = NOB+1-J
19061 NCOR = NCOR+1
19062 IDXCOR(NCOR) = IDXB(I)
19063 915 CONTINUE
19064 ENDIF
19065 DO 925 I=1,NOM
19066 IF (PMOMM(I).GT.ZERO) GOTO 926
19067 NCOR = NCOR+1
19068 IDXCOR(NCOR) = IDXM(I)
19069 925 CONTINUE
19070 926 CONTINUE
19071 DO 927 J=1,NOM
19072 I = NOM+1-J
19073 IF (PMOMM(I).LT.ZERO) GOTO 928
19074 NCOR = NCOR+1
19075 IDXCOR(NCOR) = IDXM(I)
19076 927 CONTINUE
19077 928 CONTINUE
19078*
19079C IF (NEVHKK.EQ.484) THEN
19080C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19081C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19082C WRITE(LOUT,9001) NOB,NOM,NCOR
19083C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19084C WRITE(LOUT,'(/,A)') ' baryons '
19085C DO 950 I=1,NOB
19086CC J = IABS(IDXB(I))
19087CC INDEX = J-IABS(J/10000000)*10000000
19088C IPOT = IABS(IDXB(I))/10000000
19089C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19090C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19091C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19092C 950 CONTINUE
19093C WRITE(LOUT,'(/,A)') ' mesons '
19094C DO 951 I=1,NOM
19095CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19096C IPOT = IABS(IDXM(I))/10000000
19097C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19098C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19099C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19100C 951 CONTINUE
19101C 9002 FORMAT(1X,4I14,E14.5)
19102C WRITE(LOUT,'(/,A)') ' all '
19103C DO 952 I=1,NCOR
19104CC J = IABS(IDXCOR(I))
19105CC INDEX = J-IABS(J/10000000)*10000000
19106CC IPOT = IABS(IDXCOR(I))/10000000
19107C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19108C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19109C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19110C 952 CONTINUE
19111C 9003 FORMAT(1X,4I14)
19112C ENDIF
19113*
19114 DO 20 ICOR=1,NCOR
19115 IPOT = IABS(IDXCOR(ICOR))/10000000
19116 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19117 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19118 IDXOTH(I) = 1
19119
19120 IDSEC = IDBAM(I)
19121
19122* reduction of particle momentum by corresponding nuclear potential
19123* (this applies only if Fermi-momenta are requested)
19124
19125 IF (LFERMI) THEN
19126
19127* Lorentz-transformation into the rest system of the selected nucleus
19128 IMODE = -IPOT-1
19129 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19130 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19131 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19132 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19133 JPMOD = 0
19134
19135 CHKLEV = TINY3
19136 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19137 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19138 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19139 IF (IOULEV(3).GT.0)
19140 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19141 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19142 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19143 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19144 GOTO 23
19145 ENDIF
19146
19147 DO 21 K=1,4
19148 PSEC0(K) = PSEC(K)
19149 21 CONTINUE
19150
19151* the correction for nuclear potential effects is applied to as many
19152* p/n as many nucleons were wounded; the momenta of other final state
19153* particles are corrected only if they materialize inside the corresp.
19154* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19155* = 3 part. outside proj. and targ., >=10 in overlapping region)
19156 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19157 IF (IPOT.EQ.1) THEN
19158 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19159* this is most likely a wounded nucleon
19160**test
19161C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19162C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19163C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19164C RAD = RNUCLE*DBLE(IP)**ONETHI
19165C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19166C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19167**
19168 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19169 JPW = JPW-1
19170 JPMOD = 1
19171 ELSE
19172* correct only if part. was materialized inside nucleus
19173* and if it is ouside the overlapping region
19174 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19175 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19176 JPMOD = 1
19177 ENDIF
19178 ENDIF
19179 ELSEIF (IPOT.EQ.2) THEN
19180 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19181* this is most likely a wounded nucleon
19182**test
19183C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19184C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19185C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19186C RAD = RNUCLE*DBLE(IT)**ONETHI
19187C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19188C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19189**
19190 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19191 JTW = JTW-1
19192 JPMOD = 1
19193 ELSE
19194* correct only if part. was materialized inside nucleus
19195 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19196 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19197 JPMOD = 1
19198 ENDIF
19199 ENDIF
19200 ENDIF
19201 ELSE
19202 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19203 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19204 JPMOD = 1
19205 ENDIF
19206 ENDIF
19207
19208 IF (NLOOP.EQ.1) THEN
19209* Coulomb energy correction:
19210* the treatment of Coulomb potential correction is similar to the
19211* one for nuclear potential
19212 IF (IDSEC.EQ.1) THEN
19213 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19214 JPCW = JPCW-1
19215 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19216 JTCW = JTCW-1
19217 ELSE
19218 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19219 ENDIF
19220 ELSE
19221 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19222 ENDIF
19223 IF (IICH(IDSEC).EQ.1) THEN
19224* pos. particles: check if they are able to escape Coulomb potential
19225 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19226 ISTHKK(I) = 14+IPOT
19227 IF (ISTHKK(I).EQ.15) THEN
19228 DO 26 K=1,4
19229 PHKK(K,I) = PSEC0(K)
19230 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19231 26 CONTINUE
19232 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19233 IF (IDSEC.EQ.1) NPCW = NPCW-1
19234 ELSEIF (ISTHKK(I).EQ.16) THEN
19235 DO 27 K=1,4
19236 PHKK(K,I) = PSEC0(K)
19237 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19238 27 CONTINUE
19239 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19240 IF (IDSEC.EQ.1) NTCW = NTCW-1
19241 ENDIF
19242 GOTO 20
19243 ENDIF
19244 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19245* neg. particles: decrease energy by Coulomb-potential
19246 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19247 JPMOD = 1
19248 ENDIF
19249 ENDIF
19250
19251 25 CONTINUE
19252
19253 IF (PSEC(4).LT.AMSEC) THEN
19254 IF (IOULEV(6).GT.0)
19255 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19256 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19257 & ' is not allowed to escape nucleus',/,
19258 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19259 & ' mass: ',E12.3)
19260 ISTHKK(I) = 14+IPOT
19261 IF (ISTHKK(I).EQ.15) THEN
19262 DO 28 K=1,4
19263 PHKK(K,I) = PSEC0(K)
19264 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19265 28 CONTINUE
19266 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19267 IF (IDSEC.EQ.1) NPCW = NPCW-1
19268 ELSEIF (ISTHKK(I).EQ.16) THEN
19269 DO 29 K=1,4
19270 PHKK(K,I) = PSEC0(K)
19271 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19272 29 CONTINUE
19273 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19274 IF (IDSEC.EQ.1) NTCW = NTCW-1
19275 ENDIF
19276 GOTO 20
19277 ENDIF
19278
19279 IF (JPMOD.EQ.1) THEN
19280 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19281* 4-momentum after correction for nuclear potential
19282 DO 22 K=1,3
19283 PSEC(K) = PSEC(K)*PSECN/PSECO
19284 22 CONTINUE
19285
19286* store recoil momentum from particles escaping the nuclear potentials
19287 DO 30 K=1,4
19288 IF (IPOT.EQ.1) THEN
19289 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19290 ELSEIF (IPOT.EQ.2) THEN
19291 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19292 ENDIF
19293 30 CONTINUE
19294
19295* transform momentum back into n-n cms
19296 IMODE = IPOT+1
19297 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19298 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19299 & IDSEC,IMODE)
19300 ENDIF
19301
19302 ENDIF
19303
19304 23 CONTINUE
19305 DO 31 K=1,4
19306 PFSP(K) = PFSP(K)+PHKK(K,I)
19307 31 CONTINUE
19308
19309 20 CONTINUE
19310
19311 DO 33 I=NPOINT(4),NHKK
19312 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19313 PFSP(1) = PFSP(1)+PHKK(1,I)
19314 PFSP(2) = PFSP(2)+PHKK(2,I)
19315 PFSP(3) = PFSP(3)+PHKK(3,I)
19316 PFSP(4) = PFSP(4)+PHKK(4,I)
19317 ENDIF
19318 33 CONTINUE
19319
19320 DO 34 K=1,5
19321 PRCLPR(K) = TRCLPR(K)
19322 PRCLTA(K) = TRCLTA(K)
19323 34 CONTINUE
19324
19325 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19326* hadron-nucleus interactions: get residual momentum from energy-
19327* momentum conservation
19328 DO 32 K=1,4
19329 PRCLPR(K) = ZERO
19330 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19331 32 CONTINUE
19332 ELSE
19333* nucleus-hadron, nucleus-nucleus: get residual momentum from
19334* accumulated recoil momenta of particles leaving the spectators
19335* transform accumulated recoil momenta of residual nuclei into
19336* n-n cms
19337 PZI = PRCLPR(3)
19338 PEI = PRCLPR(4)
19339 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19340 PZI = PRCLTA(3)
19341 PEI = PRCLTA(4)
19342 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19343C IF (IP.GT.1) THEN
19344 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19345 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19346C ENDIF
19347 IF (IT.GT.1) THEN
19348 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19349 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19350 ENDIF
19351 ENDIF
19352
19353* check momenta of residual nuclei
19354 IF (LEMCCK) THEN
19355 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19356 & 1,IDUM,IDUM)
19357 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19358 & 2,IDUM,IDUM)
19359 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19360 & 2,IDUM,IDUM)
19361 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19362 & 2,IDUM,IDUM)
19363 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19364**sr 19.12. changed to avoid output when used with phojet
19365C CHKLEV = TINY3
19366 CHKLEV = TINY1
19367 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19368C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19369C & CALL DT_EVTOUT(4)
19370 IF (IREJ1.GT.0) RETURN
19371 ENDIF
19372
19373 RETURN
19374 END
19375
19376*$ CREATE DT_SCN4BA.FOR
19377*COPY DT_SCN4BA
19378*
19379*===scn4ba=============================================================*
19380*
19381 SUBROUTINE DT_SCN4BA
19382
19383************************************************************************
19384* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19385* This version dated 12.12.95 is written by S. Roesler. *
19386************************************************************************
19387
19388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19389 SAVE
19390
19391 PARAMETER ( LINP = 10 ,
19392 & LOUT = 6 ,
19393 & LDAT = 9 )
19394
19395 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19396 & TINY10=1.0D-10)
19397
19398* event history
19399
19400 PARAMETER (NMXHKK=200000)
19401
19402 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19403 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19404 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19405
19406* extended event history
19407 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19408 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19409 & IHIST(2,NMXHKK)
19410
19411* particle properties (BAMJET index convention)
19412 CHARACTER*8 ANAME
19413 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19414 & IICH(210),IIBAR(210),K1(210),K2(210)
19415
19416* properties of interacting particles
19417 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19418
19419* nuclear potential
19420 LOGICAL LFERMI
19421 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19422 & EBINDP(2),EBINDN(2),EPOT(2,210),
19423 & ETACOU(2),ICOUL,LFERMI
19424
19425* treatment of residual nuclei: wounded nucleons
19426 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19427
19428* treatment of residual nuclei: 4-momenta
19429 LOGICAL LRCLPR,LRCLTA
19430 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19431 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19432
19433 DIMENSION PLAB(2,5),PCMS(4)
19434
19435 IREJ = 0
19436
19437* get number of wounded nucleons
19438 NPW = 0
19439 NPW0 = 0
19440 NPCW = 0
19441 NPSTCK = 0
19442 NTW = 0
19443 NTW0 = 0
19444 NTCW = 0
19445 NTSTCK = 0
19446
19447 ISGLPR = 0
19448 ISGLTA = 0
19449 LRCLPR = .FALSE.
19450 LRCLTA = .FALSE.
19451
19452C DO 2 I=1,NHKK
19453 DO 2 I=1,NPOINT(1)
19454* projectile nucleons wounded in primary interaction and in fzc
19455 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19456 NPW = NPW+1
19457 IPW(NPW) = I
19458 NPSTCK = NPSTCK+1
19459 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19460 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19461C IF (IP.GT.1) THEN
19462 DO 5 K=1,4
19463 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19464 5 CONTINUE
19465C ENDIF
19466* target nucleons wounded in primary interaction and in fzc
19467 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19468 NTW = NTW+1
19469 ITW(NTW) = I
19470 NTSTCK = NTSTCK+1
19471 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19472 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19473 IF (IT.GT.1) THEN
19474 DO 6 K=1,4
19475 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19476 6 CONTINUE
19477 ENDIF
19478 ELSEIF (ISTHKK(I).EQ.13) THEN
19479 ISGLPR = I
19480 ELSEIF (ISTHKK(I).EQ.14) THEN
19481 ISGLTA = I
19482 ENDIF
19483 2 CONTINUE
19484
19485 DO 11 I=NPOINT(4),NHKK
19486* baryons which are unable to escape the nuclear potential of proj.
19487 IF (ISTHKK(I).EQ.15) THEN
19488 ISGLPR = I
19489 NPSTCK = NPSTCK-1
19490 IF (IIBAR(IDBAM(I)).NE.0) THEN
19491 NPW = NPW-1
19492 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19493 ENDIF
19494 DO 7 K=1,4
19495 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19496 7 CONTINUE
19497* baryons which are unable to escape the nuclear potential of targ.
19498 ELSEIF (ISTHKK(I).EQ.16) THEN
19499 ISGLTA = I
19500 NTSTCK = NTSTCK-1
19501 IF (IIBAR(IDBAM(I)).NE.0) THEN
19502 NTW = NTW-1
19503 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19504 ENDIF
19505 DO 8 K=1,4
19506 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19507 8 CONTINUE
19508 ENDIF
19509 11 CONTINUE
19510
19511* residual nuclei so far
19512 IRESP = IP-NPSTCK
19513 IREST = IT-NTSTCK
19514
19515* ckeck for "residual nuclei" consisting of one nucleon only
19516* treat it as final state particle
19517 IF (IRESP.EQ.1) THEN
19518 ID = IDBAM(ISGLPR)
19519 IST = ISTHKK(ISGLPR)
19520 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19521 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19522 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19523 IF (IST.EQ.13) THEN
19524 ISTHKK(ISGLPR) = 11
19525 ELSE
19526 ISTHKK(ISGLPR) = 2
19527 ENDIF
19528 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19529 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19530 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19531 NOBAM(NHKK) = NOBAM(ISGLPR)
19532 JDAHKK(1,ISGLPR) = NHKK
19533 DO 21 K=1,4
19534 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19535 21 CONTINUE
19536 ENDIF
19537 IF (IREST.EQ.1) THEN
19538 ID = IDBAM(ISGLTA)
19539 IST = ISTHKK(ISGLTA)
19540 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19541 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19542 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19543 IF (IST.EQ.14) THEN
19544 ISTHKK(ISGLTA) = 12
19545 ELSE
19546 ISTHKK(ISGLTA) = 2
19547 ENDIF
19548 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19549 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19550 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19551 NOBAM(NHKK) = NOBAM(ISGLTA)
19552 JDAHKK(1,ISGLTA) = NHKK
19553 DO 22 K=1,4
19554 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19555 22 CONTINUE
19556 ENDIF
19557
19558* get nuclear potential corresp. to the residual nucleus
19559 IPRCL = IP -NPW
19560 IPZRCL = IPZ-NPCW
19561 ITRCL = IT -NTW
19562 ITZRCL = ITZ-NTCW
19563 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19564
19565* baryons unable to escape the nuclear potential are treated as
19566* excited nucleons (ISTHKK=15,16)
19567 DO 3 I=NPOINT(4),NHKK
19568 IF (ISTHKK(I).EQ.1) THEN
19569 ID = IDBAM(I)
19570 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19571* final state n and p not being outside of both nuclei are considered
19572 NPOTP = 1
19573 NPOTT = 1
19574 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19575 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19576* Lorentz-trsf. into proj. rest sys. for those being inside proj.
19577 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19578 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19579 & PLAB(1,4),ID,-2)
19580 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19581 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19582 & (PLAB(1,4)+PLABT) ))
19583 EKIN = PLAB(1,4)-PLAB(1,5)
19584 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19585 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19586 ENDIF
19587 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19588 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19589* Lorentz-trsf. into targ. rest sys. for those being inside targ.
19590 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19591 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19592 & PLAB(2,4),ID,-3)
19593 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19594 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19595 & (PLAB(2,4)+PLABT) ))
19596 EKIN = PLAB(2,4)-PLAB(2,5)
19597 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19598 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19599 ENDIF
19600 IF (PHKK(3,I).GE.ZERO) THEN
19601 ISTHKK(I) = NPOTT
19602 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19603 ELSE
19604 ISTHKK(I) = NPOTP
19605 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19606 ENDIF
19607 IF (ISTHKK(I).NE.1) THEN
19608 J = ISTHKK(I)-14
19609 DO 4 K=1,5
19610 PHKK(K,I) = PLAB(J,K)
19611 4 CONTINUE
19612 IF (ISTHKK(I).EQ.15) THEN
19613 NPW = NPW-1
19614 IF (ID.EQ.1) NPCW = NPCW-1
19615 DO 9 K=1,4
19616 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19617 9 CONTINUE
19618 ELSEIF (ISTHKK(I).EQ.16) THEN
19619 NTW = NTW-1
19620 IF (ID.EQ.1) NTCW = NTCW-1
19621 DO 10 K=1,4
19622 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19623 10 CONTINUE
19624 ENDIF
19625 ENDIF
19626 ENDIF
19627 ENDIF
19628 3 CONTINUE
19629
19630* again: get nuclear potential corresp. to the residual nucleus
19631 IPRCL = IP -NPW
19632 IPZRCL = IPZ-NPCW
19633 ITRCL = IT -NTW
19634 ITZRCL = ITZ-NTCW
19635c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19636cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19637c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19638C AFERP = 0.0D0
19639c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19640cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19641c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19642C AFERT = 0.0D0
19643C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19644C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19645C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19646C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19647 AFERP = FERMOD+0.1D0
19648 AFERT = FERMOD+0.1D0
19649
19650 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19651
19652 RETURN
19653 END
19654
19655*$ CREATE DT_FICONF.FOR
19656*COPY DT_FICONF
19657*
19658*===ficonf=============================================================*
19659*
19660 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19661
19662************************************************************************
19663* Treatment of FInal CONFiguration including evaporation, fission and *
19664* Fermi-break-up (for light nuclei only). *
19665* Adopted from the original routine FINALE and extended to residual *
19666* projectile nuclei. *
19667* This version dated 12.12.95 is written by S. Roesler. *
19668* *
19669* Last change 27.12.2006 by S. Roesler. *
19670************************************************************************
19671
19672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19673 SAVE
19674
19675 PARAMETER ( LINP = 10 ,
19676 & LOUT = 6 ,
19677 & LDAT = 9 )
19678
19679 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19680 PARAMETER (ANGLGB=5.0D-16)
19681
19682* event history
19683
19684 PARAMETER (NMXHKK=200000)
19685
19686 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19687 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19688 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19689
19690* extended event history
19691 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19692 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19693 & IHIST(2,NMXHKK)
19694
19695* rejection counter
19696 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19697 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19698 & IREXCI(3),IRDIFF(2),IRINC
19699
19700* central particle production, impact parameter biasing
19701 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19702
19703* particle properties (BAMJET index convention)
19704 CHARACTER*8 ANAME
19705 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19706 & IICH(210),IIBAR(210),K1(210),K2(210)
19707
19708* treatment of residual nuclei: 4-momenta
19709 LOGICAL LRCLPR,LRCLTA
19710 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19711 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19712
19713* treatment of residual nuclei: properties of residual nuclei
19714 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19715 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19716 & NTOTFI(2),NPROFI(2)
19717
19718* statistics: residual nuclei
19719 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19720 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19721 & NINCST(2,4),NINCEV(2),
19722 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19723 & NRESPB(2),NRESCH(2),NRESEV(4),
19724 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19725 & NEVAFI(2,2)
19726
19727* flags for input different options
19728 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19729 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19730 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19731
19732* INCLUDE '(DIMPAR)'
19733* DIMPAR taken from FLUKA
19734 PARAMETER ( MXXRGN =20000 )
19735 PARAMETER ( MXXMDF = 710 )
19736 PARAMETER ( MXXMDE = 702 )
19737 PARAMETER ( MFSTCK =40000 )
19738 PARAMETER ( MESTCK = 100 )
19739 PARAMETER ( MOSTCK = 2000 )
19740 PARAMETER ( MXPRSN = 100 )
19741 PARAMETER ( MXPDPM = 800 )
19742 PARAMETER ( MXPSCS =30000 )
19743 PARAMETER ( MXGLWN = 300 )
19744 PARAMETER ( MXOUTU = 50 )
19745 PARAMETER ( NALLWP = 64 )
19746 PARAMETER ( NELEMX = 80 )
19747 PARAMETER ( MPDPDX = 18 )
19748 PARAMETER ( MXHTTR = 260 )
19749 PARAMETER ( MXSEAX = 20 )
19750 PARAMETER ( MXHTNC = MXSEAX + 1 )
19751 PARAMETER ( ICOMAX = 2400 )
19752 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19753 PARAMETER ( NSTBIS = 304 )
19754 PARAMETER ( NQSTIS = 46 )
19755 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19756 PARAMETER ( MXPABL = 120 )
19757 PARAMETER ( IDMAXP = 450 )
19758 PARAMETER ( IDMXDC = 2000 )
19759 PARAMETER ( MXMCIN = 410 )
19760 PARAMETER ( IHYPMX = 4 )
19761 PARAMETER ( MKBMX1 = 11 )
19762 PARAMETER ( MKBMX2 = 11 )
19763 PARAMETER ( MXIRRD = 2500 )
19764 PARAMETER ( MXTRDC = 1500 )
19765 PARAMETER ( NKTL = 17 )
19766 PARAMETER ( NBLNMX = 40000000 )
19767
19768* INCLUDE '(GENSTK)'
19769* GENSTK taken from FLUKA
19770 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19771 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19772 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19773 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19774 & TVRECL, TVHEAV, TVBIND,
19775 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19776
19777* INCLUDE '(RESNUC)'
19778* RESNUC from FLUKA
19779 LOGICAL LRNFSS, LFRAGM
19780 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19781 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19782 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19783 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19784 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19785 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19786 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19787 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19788 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19789 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19790 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19791 & LRNFSS, LFRAGM
19792
19793 PARAMETER ( EMVGEV = 1.0 D-03 )
19794 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19795 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19796 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19797 PARAMETER ( AMELCT = 0.51099906 D-03 )
19798 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19799 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19800 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19801 & * 1.D-09 )
19802 PARAMETER ( HLFHLF = 0.5D+00 )
19803 PARAMETER ( FERTHO = 14.33 D-09 )
19804 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19805 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19806 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19807
19808* INCLUDE '(NUCDAT)'
19809* Taken from FLUKA
19810 PARAMETER ( AMUAMU = AMUGEV )
19811 PARAMETER ( AMPROT = AMPRTN )
19812 PARAMETER ( AMNEUT = AMNTRN )
19813 PARAMETER ( AMELEC = AMELCT )
19814 PARAMETER ( R0NUCL = 1.12 D+00 )
19815 PARAMETER ( RCCOUL = 1.7 D+00 )
19816 PARAMETER ( COULPR = COUGFM )
19817 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19818 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19819 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19820 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19821 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19822* Gammin : threshold for deexcitation gammas production, set to 1 keV
19823* (this means that up to 1 keV of energy unbalancing can occur
19824* during an event)
19825 PARAMETER ( GAMMIN = 1.0D-06 )
19826 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19827* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19828 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19829*
19830 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19831 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19832 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19833 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19834 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19835 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19836 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19837 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19838 & ELBNDE (0:110)
19839
19840* INCLUDE '(PAREVT)'
19841* Taken from FLUKA
19842 PARAMETER ( FRDIFF = 0.2D+00 )
19843 PARAMETER ( ETHSEA = 1.0D+00 )
19844*
19845 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19846 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19847 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19848 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19849 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19850 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19851 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19852 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19853 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19854 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19855
19856* INCLUDE '(FHEAVY)'
19857* Taken from FLUKA
19858 PARAMETER ( MXHEAV = 100 )
19859 PARAMETER ( KXHEAV = 30 )
19860 CHARACTER*8 ANHEAV
19861 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19862 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19863 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19864 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19865 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19866 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19867 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19868 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19869 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19870 COMMON / FHEAVC / ANHEAV (KXHEAV)
19871
19872* event flag
19873 COMMON /DTEVNO/ NEVENT,ICASCA
19874
19875 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19876 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19877 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19878
19879 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19880 LOGICAL LLCPOT
19881 DATA EXC,NEXC /520*ZERO,520*0/
19882 DATA EXPNUC /4.0D-3,4.0D-3/
19883
19884 IREJ = 0
19885 LRCLPR = .FALSE.
19886 LRCLTA = .FALSE.
19887
19888* skip residual nucleus treatment if not requested or in case
19889* of central collisions
19890 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19891
19892 DO 1 K=1,2
19893 IDPAR(K) = 0
19894 IDXPAR(K)= 0
19895 NTOT(K) = 0
19896 NTOTFI(K)= 0
19897 NPRO(K) = 0
19898 NPROFI(K)= 0
19899 NN(K) = 0
19900 NH(K) = 0
19901 NHPOS(K) = 0
19902 NQ(K) = 0
19903 EEXC(K) = ZERO
19904 MO1(K) = 0
19905 MO2(K) = 0
19906 DO 2 I=1,4
19907 VRCL(K,I) = ZERO
19908 WRCL(K,I) = ZERO
19909 2 CONTINUE
19910 1 CONTINUE
19911 NFSP = 0
19912 INUC(1) = IP
19913 INUC(2) = IT
19914
19915 DO 3 I=1,NHKK
19916
19917* number of final state particles
19918 IF (ABS(ISTHKK(I)).EQ.1) THEN
19919 NFSP = NFSP+1
19920 IDFSP = IDBAM(I)
19921 ENDIF
19922
19923* properties of remaining nucleon configurations
19924 KF = 0
19925 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19926 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19927 IF (KF.GT.0) THEN
19928 IF (MO1(KF).EQ.0) MO1(KF) = I
19929 MO2(KF) = I
19930* position of residual nucleus = average position of nucleons
19931 DO 4 K=1,4
19932 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19933 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19934 4 CONTINUE
19935* total number of particles contributing to each residual nucleus
19936 NTOT(KF) = NTOT(KF)+1
19937 IDTMP = IDBAM(I)
19938 IDXTMP = I
19939* total charge of residual nuclei
19940 NQ(KF) = NQ(KF)+IICH(IDTMP)
19941* number of protons
19942 IF (IDHKK(I).EQ.2212) THEN
19943 NPRO(KF) = NPRO(KF)+1
19944* number of neutrons
19945 ELSEIF (IDHKK(I).EQ.2112) THEN
19946 NN(KF) = NN(KF)+1
19947 ELSE
19948* number of baryons other than n, p
19949 IF (IIBAR(IDTMP).EQ.1) THEN
19950 NH(KF) = NH(KF)+1
19951 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19952 ELSE
19953* any other mesons (status set to 1)
19954C WRITE(LOUT,1002) KF,IDTMP
19955C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19956C & ' containing meson ',I4,', status set to 1')
19957 ISTHKK(I) = 1
19958 IDTMP = IDPAR(KF)
19959 IDXTMP = IDXPAR(KF)
19960 NTOT(KF) = NTOT(KF)-1
19961 ENDIF
19962 ENDIF
19963 IDPAR(KF) = IDTMP
19964 IDXPAR(KF) = IDXTMP
19965 ENDIF
19966 3 CONTINUE
19967
19968* reject elastic events (def: one final state particle = projectile)
19969 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19970 IREXCI(3) = IREXCI(3)+1
19971 GOTO 9999
19972C RETURN
19973 ENDIF
19974
19975* check if one nucleus disappeared..
19976C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19977C DO 5 K=1,4
19978C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19979C PRCLPR(K) = ZERO
19980C 5 CONTINUE
19981C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19982C DO 6 K=1,4
19983C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19984C PRCLTA(K) = ZERO
19985C 6 CONTINUE
19986C ENDIF
19987
19988 ICOR = 0
19989 INORCL = 0
19990 DO 7 I=1,2
19991 DO 8 K=1,4
19992* get the average of the nucleon positions
19993 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19994 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19995 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19996 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19997 8 CONTINUE
19998* mass number and charge of residual nuclei
19999 AIF(I) = DBLE(NTOT(I))
20000 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
20001 IF (NTOT(I).GT.1) THEN
20002* masses of residual nuclei in ground state
20003
20004C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20005 AMRCL0(I) = AIF(I)*AMUC12
20006 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20007
20008* masses of residual nuclei
20009 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20010 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20011 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20012*
20013* M_res^2 < 0 : configuration not allowed
20014*
20015* a) re-calculate E_exc with scaled nuclear potential
20016* (conditional jump to label 9998)
20017* b) or reject event if N_loop(max) is exceeded
20018* (conditional jump to label 9999)
20019*
20020 IF (AMRCL(I).LE.ZERO) THEN
20021 IF (IOULEV(3).GT.0)
20022 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20023 & PRCL(I,4),NTOT
20024 1000 FORMAT(1X,'warning! negative excitation energy',/,
20025 & I4,4E15.4,2I4)
20026 AMRCL(I) = ZERO
20027 EEXC(I) = ZERO
20028 IF (NLOOP.LE.500) THEN
20029 GOTO 9998
20030 ELSE
20031 IREXCI(2) = IREXCI(2)+1
20032 GOTO 9999
20033 ENDIF
20034*
20035* 0 < M_res < M_res0 : mass below ground-state mass
20036*
20037* a) we had residual nuclei with mass N_tot and reasonable E_exc
20038* before- assign average E_exc of those configurations to this
20039* one ( Nexc(i,N_tot) > 0 )
20040* b) or (and this applies always if run in transport codes) go up
20041* one mass number and
20042* i) if mass now larger than proj/targ mass or if run in
20043* transport codes assign average E_exc per wounded nucleon
20044* x number of wounded nucleons (Inuc-Ntot)
20045* ii) or assign average E_exc of those configurations to this
20046* one ( Nexc(i,m) > 0 )
20047*
20048 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20049 & THEN
20050 M = MIN(NTOT(I),260)
20051 IF (NEXC(I,M).GT.0) THEN
20052 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20053 ELSE
20054 70 CONTINUE
20055 M = M+1
20056**sr corrected 27.12.06
20057* IF (M.GE.INUC(I)) THEN
20058* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20059 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20060 IF ( INUC (I) .GT. NTOT (I) ) THEN
20061 AMRCL(I) = AMRCL0(I)
20062 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20063 ELSE
20064 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20065 END IF
20066**
20067 ELSE
20068 IF (NEXC(I,M).GT.0) THEN
20069 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20070 ELSE
20071 GOTO 70
20072 ENDIF
20073 ENDIF
20074 ENDIF
20075 EEXC(I) = AMRCL(I)-AMRCL0(I)
20076 ICOR = ICOR+I
20077*
20078* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20079*
20080* a) re-calculate E_exc with scaled nuclear potential
20081* (conditional jump to label 9998)
20082* b) or reject event if N_loop(max) is exceeded
20083* (conditional jump to label 9999)
20084*
20085*
20086 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20087 IF (IOULEV(3).GT.0)
20088 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20089 1004 FORMAT(1X,'warning! too high excitation energy',/,
20090 & I4,1P,2E15.4,3I5)
20091 AMRCL(I) = ZERO
20092 EEXC(I) = ZERO
20093 IF (NLOOP.LE.500) THEN
20094 GOTO 9998
20095 ELSE
20096 IREXCI(2) = IREXCI(2)+1
20097 GOTO 9999
20098 ENDIF
20099*
20100* Otherwise (reasonable E_exc) :
20101* E_exc = M_res - M_res0
20102* in addition: calculate and save E_exc per wounded nucleon as
20103* well as E_exc in <E_exc> counter
20104*
20105 ELSE
20106* excitation energies of residual nuclei
20107 EEXC(I) = AMRCL(I)-AMRCL0(I)
20108**sr 27.12.06 new excitation energy correction by A.F.
20109*
20110* all parts with Ilcopt<3 commented since not used
20111*
20112* still to be done/decided:
20113* Increase Icor and put back both residual nuclei on mass shell
20114* with the exciting correction further below.
20115* For the moment the modification in the excitation energy is simply
20116* corrected by scaling the energy of the residual nucleus.
20117*
20118 LLCPOT = .TRUE.
20119 ILCOPT = 3
20120 IF ( LLCPOT ) THEN
20121 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20122 IF ( ILCOPT .LE. 2 ) THEN
20123C* Patch for Fermi momentum reduction correlated with impact parameter:
20124C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20125C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20126C AKPRHO = ONE - DLKPRH
20127C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20128C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20129C & 0.05D+00 )
20130C* REDORI = 0.75D+00
20131C* REDORI = ONE
20132C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20133 ELSE
20134 DLKPRH = ZERO
20135 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20136* Take out roughly one/half of the skin:
20137 RDCORE = RDCORE - 0.5D+00
20138 FRCFLL = RDCORE**3
20139 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20140 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20141 FRCFLL = ONE - PRSKIN
20142 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20143 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20144 END IF
20145 IF ( NNCHIT .GT. 0 ) THEN
20146C IF ( ILCOPT .EQ. 1 ) THEN
20147C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20148C DO 1220 NCH = 1, 10
20149C ETAETA = ( ONE - SKINRH**INUC(I)
20150C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20151C & * ( ONE - SKINRH ) )
20152C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20153C & * ( ONE - FRCFLL) * SKINRH )
20154C SKINRH = SKINRH * ( ONE + ETAETA )
20155C 1220 CONTINUE
20156C PRSKIN = SKINRH**(NNCHIT-1)
20157C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20158C PRSKIN = ONE - FRCFLL
20159C END IF
20160 REDCTN = ZERO
20161 DO 1230 NCH = 1, NNCHIT
20162 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20163 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20164 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20165 ELSE
20166 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20167 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20168 END IF
20169 REDCTN = REDCTN + PRFRMI**2
20170 1230 CONTINUE
20171 REDCTN = REDCTN / DBLE (NNCHIT)
20172 ELSE
20173 REDCTN = 0.5D+00
20174 END IF
20175 EEXC (I) = EEXC (I) * REDCTN / REDORI
20176 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20177 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20178 END IF
20179**
20180 IF (ICASCA.EQ.0) THEN
20181 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20182 M = MIN(NTOT(I),260)
20183 EXC(I,M) = EXC(I,M)+EEXC(I)
20184 NEXC(I,M) = NEXC(I,M)+1
20185 ENDIF
20186 ENDIF
20187 ELSEIF (NTOT(I).EQ.1) THEN
20188 WRITE(LOUT,1003) I
20189 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20190 GOTO 9999
20191 ELSE
20192 AMRCL0(I) = ZERO
20193 AMRCL(I) = ZERO
20194 EEXC(I) = ZERO
20195 INORCL = INORCL+I
20196 ENDIF
20197 7 CONTINUE
20198
20199 PRCLPR(5) = AMRCL(1)
20200 PRCLTA(5) = AMRCL(2)
20201
20202 IF (ICOR.GT.0) THEN
20203 IF (INORCL.EQ.0) THEN
20204* one or both residual nuclei consist of one nucleon only, transform
20205* this nucleon on mass shell
20206 DO 9 K=1,4
20207 P1IN(K) = PRCL(1,K)
20208 P2IN(K) = PRCL(2,K)
20209 9 CONTINUE
20210 XM1 = AMRCL(1)
20211 XM2 = AMRCL(2)
20212 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20213 IF (IREJ1.GT.0) THEN
20214 WRITE(LOUT,*) 'ficonf-mashel rejection'
20215 GOTO 9999
20216 ENDIF
20217 DO 10 K=1,4
20218 PRCL(1,K) = P1OUT(K)
20219 PRCL(2,K) = P2OUT(K)
20220 PRCLPR(K) = P1OUT(K)
20221 PRCLTA(K) = P2OUT(K)
20222 10 CONTINUE
20223 PRCLPR(5) = AMRCL(1)
20224 PRCLTA(5) = AMRCL(2)
20225 ELSE
20226 IF (IOULEV(3).GT.0)
20227 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20228 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20229 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20230 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20231 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20232 & ' correction',/,11X,'at event',I8,
20233 & ', nucleon config. 1:',2I4,' 2:',2I4,
20234 & 2(/,11X,3E12.3))
20235 IF (NLOOP.LE.500) THEN
20236 GOTO 9998
20237 ELSE
20238 IREXCI(1) = IREXCI(1)+1
20239 ENDIF
20240 ENDIF
20241 ENDIF
20242
20243* update counter
20244C IF (NRESEV(1).NE.NEVHKK) THEN
20245C NRESEV(1) = NEVHKK
20246C NRESEV(2) = NRESEV(2)+1
20247C ENDIF
20248 NRESEV(2) = NRESEV(2)+1
20249 DO 15 I=1,2
20250 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20251 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20252 NRESTO(I) = NRESTO(I)+NTOT(I)
20253 NRESPR(I) = NRESPR(I)+NPRO(I)
20254 NRESNU(I) = NRESNU(I)+NN(I)
20255 NRESBA(I) = NRESBA(I)+NH(I)
20256 NRESPB(I) = NRESPB(I)+NHPOS(I)
20257 NRESCH(I) = NRESCH(I)+NQ(I)
20258 15 CONTINUE
20259
20260* evaporation
20261 IF (LEVPRT) THEN
20262 DO 13 I=1,2
20263* initialize evaporation counter
20264 EEXCFI(I) = ZERO
20265 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20266 & (EEXC(I).GT.ZERO)) THEN
20267* put residual nuclei into DTEVT1
20268 IDRCL = 80000
20269 JMASS = INT( AIF(I))
20270 JCHAR = INT(AIZF(I))
20271* the following patch is required to transmit the correct excitation
20272* energy to Eventd
20273 IF (ITRSPT.EQ.1) THEN
20274 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20275 & (IOULEV(3).GT.0))
20276 & WRITE(LOUT,*)
20277 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20278 & AMRCL(I),AMRCL0(I),EEXC(I)
20279 PRCL0 = PRCL(I,4)
20280 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20281 & +PRCL(I,3)**2)
20282 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20283 WRITE(LOUT,*)
20284 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20285 ENDIF
20286 ENDIF
20287 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20288 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20289**sr 22.6.97
20290 NOBAM(NHKK) = I
20291**
20292 DO 14 J=1,4
20293 VHKK(J,NHKK) = VRCL(I,J)
20294 WHKK(J,NHKK) = WRCL(I,J)
20295 14 CONTINUE
20296* interface to evaporation module - fill final residual nucleus into
20297* common FKRESN
20298* fill resnuc only if code is not used as event generator in Fluka
20299 IF (ITRSPT.NE.1) THEN
20300 PXRES = PRCL(I,1)
20301 PYRES = PRCL(I,2)
20302 PZRES = PRCL(I,3)
20303 IBRES = NPRO(I)+NN(I)+NH(I)
20304 ICRES = NPRO(I)+NHPOS(I)
20305 ANOW = DBLE(IBRES)
20306 ZNOW = DBLE(ICRES)
20307 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20308* ground state mass of the residual nucleus (should be equal to AM0T)
20309
20310 AMNRES = AMRCL0(I)
20311 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20312
20313* common FKFINU
20314 TV = ZERO
20315* kinetic energy of residual nucleus
20316 TVRECL = PRCL(I,4)-AMRCL(I)
20317* excitation energy of residual nucleus
20318 TVCMS = EEXC(I)
20319 PTOLD = PTRES
20320 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20321 & 2.0D0*(AMMRES+TVCMS))))
20322 IF (PTOLD.LT.ANGLGB) THEN
20323 CALL DT_RACO(PXRES,PYRES,PZRES)
20324 PTOLD = ONE
20325 ENDIF
20326 PXRES = PXRES*PTRES/PTOLD
20327 PYRES = PYRES*PTRES/PTOLD
20328 PZRES = PZRES*PTRES/PTOLD
20329* zero counter of secondaries from evaporation
20330 NP = 0
20331* evaporation
20332 WE = ONE
20333
20334 NPHEAV = 0
20335 LRNFSS = .FALSE.
20336 LFRAGM = .FALSE.
20337 CALL EVEVAP(WE)
20338
20339* put evaporated particles and residual nuclei to DTEVT1
20340 MO = NHKK
20341 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20342 ENDIF
20343 EEXCFI(I) = EXCITF
20344 EXCEVA(I) = EXCEVA(I)+EXCITF
20345 ENDIF
20346 13 CONTINUE
20347 ENDIF
20348
20349 RETURN
20350
20351C9998 IREXCI(1) = IREXCI(1)+1
20352 9998 IREJ = IREJ+1
20353 9999 CONTINUE
20354 LRCLPR = .TRUE.
20355 LRCLTA = .TRUE.
20356 IREJ = IREJ+1
20357 RETURN
20358 END
20359
20360*$ CREATE DT_EVA2HE.FOR
20361*COPY DT_EVA2HE
20362* *
20363*====eva2he============================================================*
20364* *
20365 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20366
20367************************************************************************
20368* Interface between common's of evaporation module (FKFINU,FKFHVY) *
20369* and DTEVT1. *
20370* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20371* EEXCF exitation energy of residual nucleus after evaporation *
20372* IRCL = 1 projectile residual nucleus *
20373* = 2 target residual nucleus *
20374* This version dated 19.04.95 is written by S. Roesler. *
20375* *
20376* Last change 27.12.2006 by S. Roesler. *
20377************************************************************************
20378
20379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20380 SAVE
20381
20382 PARAMETER ( LINP = 10 ,
20383 & LOUT = 6 ,
20384 & LDAT = 9 )
20385
20386 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20387
20388* event history
20389
20390 PARAMETER (NMXHKK=200000)
20391
20392 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20393 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20394 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20395* Note: DTEVT2 - special use for heavy fragments !
20396* (IDRES(I) = mass number, IDXRES(I) = charge)
20397
20398* extended event history
20399 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20400 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20401 & IHIST(2,NMXHKK)
20402
20403* particle properties (BAMJET index convention)
20404 CHARACTER*8 ANAME
20405 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20406 & IICH(210),IIBAR(210),K1(210),K2(210)
20407
20408* flags for input different options
20409 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20410 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20411 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20412
20413* statistics: residual nuclei
20414 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20415 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20416 & NINCST(2,4),NINCEV(2),
20417 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20418 & NRESPB(2),NRESCH(2),NRESEV(4),
20419 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20420 & NEVAFI(2,2)
20421
20422* treatment of residual nuclei: properties of residual nuclei
20423 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20424 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20425 & NTOTFI(2),NPROFI(2)
20426
20427* INCLUDE '(DIMPAR)'
20428* Taken from FLUKA
20429 PARAMETER ( MXXRGN =20000 )
20430 PARAMETER ( MXXMDF = 710 )
20431 PARAMETER ( MXXMDE = 702 )
20432 PARAMETER ( MFSTCK =40000 )
20433 PARAMETER ( MESTCK = 100 )
20434 PARAMETER ( MOSTCK = 2000 )
20435 PARAMETER ( MXPRSN = 100 )
20436 PARAMETER ( MXPDPM = 800 )
20437 PARAMETER ( MXPSCS =30000 )
20438 PARAMETER ( MXGLWN = 300 )
20439 PARAMETER ( MXOUTU = 50 )
20440 PARAMETER ( NALLWP = 64 )
20441 PARAMETER ( NELEMX = 80 )
20442 PARAMETER ( MPDPDX = 18 )
20443 PARAMETER ( MXHTTR = 260 )
20444 PARAMETER ( MXSEAX = 20 )
20445 PARAMETER ( MXHTNC = MXSEAX + 1 )
20446 PARAMETER ( ICOMAX = 2400 )
20447 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20448 PARAMETER ( NSTBIS = 304 )
20449 PARAMETER ( NQSTIS = 46 )
20450 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20451 PARAMETER ( MXPABL = 120 )
20452 PARAMETER ( IDMAXP = 450 )
20453 PARAMETER ( IDMXDC = 2000 )
20454 PARAMETER ( MXMCIN = 410 )
20455 PARAMETER ( IHYPMX = 4 )
20456 PARAMETER ( MKBMX1 = 11 )
20457 PARAMETER ( MKBMX2 = 11 )
20458 PARAMETER ( MXIRRD = 2500 )
20459 PARAMETER ( MXTRDC = 1500 )
20460 PARAMETER ( NKTL = 17 )
20461 PARAMETER ( NBLNMX = 40000000 )
20462
20463* INCLUDE '(GENSTK)'
20464* Taken from FLUKA
20465 PARAMETER ( MXP = MXPSCS )
20466*
20467 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20468 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20469 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20470 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20471 & TVRECL, TVHEAV, TVBIND,
20472 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20473
20474* INCLUDE '(RESNUC)'
20475 LOGICAL LRNFSS, LFRAGM
20476 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20477 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20478 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20479 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20480 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20481 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20482 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20483 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20484 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20485 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20486 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20487 & LRNFSS, LFRAGM
20488* Taken from FLUKA
20489
20490* INCLUDE '(FHEAVY)'
20491* Taken from FLUKA
20492 PARAMETER ( MXHEAV = 100 )
20493 PARAMETER ( KXHEAV = 30 )
20494 CHARACTER*8 ANHEAV
20495 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20496 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20497 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20498 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20499 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20500 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20501 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20502 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20503 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20504 COMMON / FHEAVC / ANHEAV (KXHEAV)
20505
20506 DIMENSION IPTOKP(39)
20507 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20508 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20509 & 100, 101, 97, 102, 98, 103, 109, 115 /
20510
20511 IREJ = 0
20512
20513* skip if evaporation package is not included
20514 IF (.NOT.LEVAPO) RETURN
20515
20516* update counter
20517 IF (NRESEV(3).NE.NEVHKK) THEN
20518 NRESEV(3) = NEVHKK
20519 NRESEV(4) = NRESEV(4)+1
20520 ENDIF
20521
20522 IF (LEMCCK)
20523 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20524 & IDUM,IDUM)
20525* mass number/charge of residual nucleus before evaporation
20526 IBTOT = IDRES(MO)
20527 IZTOT = IDXRES(MO)
20528
20529* protons/neutrons/gammas
20530 DO 1 I=1,NP
20531 PX = CXR(I)*PLR(I)
20532 PY = CYR(I)*PLR(I)
20533 PZ = CZR(I)*PLR(I)
20534 ID = IPTOKP(KPART(I))
20535 IDPDG = IDT_IPDGHA(ID)
20536 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20537 & (2.0D0*MAX(TKI(I),TINY10))
20538 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20539 WRITE(LOUT,1000) ID,AM,AAM(ID)
20540 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20541 & 'particle',I3,2E10.3)
20542 ENDIF
20543 PE = TKI(I)+AM
20544 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20545 NOBAM(NHKK) = IRCL
20546 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20547 IBTOT = IBTOT-IIBAR(ID)
20548 IZTOT = IZTOT-IICH(ID)
20549 1 CONTINUE
20550
20551* heavy fragments
20552 DO 2 I=1,NPHEAV
20553 PX = CXHEAV(I)*PHEAVY(I)
20554 PY = CYHEAV(I)*PHEAVY(I)
20555 PZ = CZHEAV(I)*PHEAVY(I)
20556 IDHEAV = 80000
20557 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20558 & (2.0D0*MAX(TKHEAV(I),TINY10))
20559 PE = TKHEAV(I)+AM
20560 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20561 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20562 NOBAM(NHKK) = IRCL
20563 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20564 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20565 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20566 2 CONTINUE
20567
20568 IF (IBRES.GT.0) THEN
20569* residual nucleus after evaporation
20570 IDNUC = 80000
20571 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20572 & IBRES,ICRES,0)
20573 NOBAM(NHKK) = IRCL
20574 ENDIF
20575 EEXCF = TVCMS
20576 NTOTFI(IRCL) = IBRES
20577 NPROFI(IRCL) = ICRES
20578 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20579 IBTOT = IBTOT-IBRES
20580 IZTOT = IZTOT-ICRES
20581
20582* count events with fission
20583 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20584 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20585
20586* energy-momentum conservation check
20587 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20588C IF (IREJ.GT.0) THEN
20589C CALL DT_EVTOUT(4)
20590C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20591C ENDIF
20592* baryon-number/charge conservation check
20593 IF (IBTOT+IZTOT.NE.0) THEN
20594 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20595 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20596 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20597 ENDIF
20598
20599 RETURN
20600 END
20601
20602*$ CREATE DT_EBIND.FOR
20603*COPY DT_EBIND
20604*
20605*===ebind==============================================================*
20606*
20607 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20608
20609************************************************************************
20610* Binding energy for nuclei. *
20611* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20612* IA mass number *
20613* IZ atomic number *
20614* This version dated 5.5.95 is updated by S. Roesler. *
20615************************************************************************
20616
20617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20618 SAVE
20619
20620 PARAMETER ( LINP = 10 ,
20621 & LOUT = 6 ,
20622 & LDAT = 9 )
20623
20624 PARAMETER (ZERO=0.0D0)
20625
20626 DATA A1, A2, A3, A4, A5
20627 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20628
20629 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20630 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20631 DT_EBIND = ZERO
20632 RETURN
20633 ENDIF
20634 AA = IA
20635 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20636 & -A4*(IA-2*IZ)**2/AA
20637 IF (MOD(IA,2).EQ.1) THEN
20638 IA5 = 0
20639 ELSEIF (MOD(IZ,2).EQ.1) THEN
20640 IA5 = 1
20641 ELSE
20642 IA5 = -1
20643 ENDIF
20644 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20645
20646 RETURN
20647 END
20648
20649************************************************************************
20650* *
20651* DPMJET 3.0: cross section routines *
20652* *
20653************************************************************************
20654*
20655*
20656* SUBROUTINE DT_SHNDIF
20657* diffractive cross sections (all energies)
20658* SUBROUTINE DT_PHOXS
20659* total and inel. cross sections from PHOJET interpol. tables
20660* SUBROUTINE DT_XSHN
20661* total and el. cross sections for all energies
20662* SUBROUTINE DT_SIHNAB
20663* pion 2-nucleon absorption cross sections
20664* SUBROUTINE DT_SIGEMU
20665* cross section for target "compounds"
20666* SUBROUTINE DT_SIGGA
20667* photon nucleus cross sections
20668* SUBROUTINE DT_SIGGAT
20669* photon nucleus cross sections from tables
20670* SUBROUTINE DT_SANO
20671* anomalous hard photon-nucleon cross sections from tables
20672* SUBROUTINE DT_SIGGP
20673* photon nucleon cross sections
20674* SUBROUTINE DT_SIGVEL
20675* quasi-elastic vector meson prod. cross sections
20676* DOUBLE PRECISION FUNCTION DT_SIGVP
20677* sigma_VN(tilde)
20678* DOUBLE PRECISION FUNCTION DT_RRM2
20679* DOUBLE PRECISION FUNCTION DT_RM2
20680* DOUBLE PRECISION FUNCTION DT_SAM2
20681* SUBROUTINE DT_CKMT
20682* SUBROUTINE DT_CKMTX
20683* SUBROUTINE DT_PDF0
20684* SUBROUTINE DT_CKMTQ0
20685* SUBROUTINE DT_CKMTDE
20686* SUBROUTINE DT_CKMTPR
20687* FUNCTION DT_CKMTFF
20688*
20689* SUBROUTINE DT_FLUINI
20690* total nucleon cross section fluctuation treatment
20691*
20692* SUBROUTINE DT_SIGTBL
20693* pre-tabulation of low-energy elastic x-sec. using SIHNEL
20694* SUBROUTINE DT_XSTABL
20695* service routines
20696*
20697*
20698*$ CREATE DT_SHNDIF.FOR
20699*COPY DT_SHNDIF
20700*
20701*===shndif===============================================================*
20702*
20703 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20704
20705**********************************************************************
20706* Single diffractive hadron-nucleon cross sections *
20707* S.Roesler 14/1/93 *
20708* *
20709* The cross sections are calculated from extrapolated single *
20710* diffractive antiproton-proton cross sections (DTUJET92) using *
20711* scaling relations between total and single diffractive cross *
20712* sections. *
20713**********************************************************************
20714
20715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20716 SAVE
20717 PARAMETER (ZERO=0.0D0)
20718
20719* particle properties (BAMJET index convention)
20720 CHARACTER*8 ANAME
20721 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20722 & IICH(210),IIBAR(210),K1(210),K2(210)
20723*
20724 CSD1 = 4.201483727D0
20725 CSD4 = -0.4763103556D-02
20726 CSD5 = 0.4324148297D0
20727*
20728 CHMSD1 = 0.8519297242D0
20729 CHMSD4 = -0.1443076599D-01
20730 CHMSD5 = 0.4014954567D0
20731*
20732 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20733 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20734*
20735 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20736 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20737 FRAC = SHMSD/SDIAPP
20738*
20739 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20740 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20741 & 10, 10, 20, 20, 20) KPROJ
20742*
20743 10 CONTINUE
20744*---------------------------- p - p , n - p , sigma0+- - p ,
20745* Lambda - p
20746 CSD1 = 6.004476070D0
20747 CSD4 = -0.1257784606D-03
20748 CSD5 = 0.2447335720D0
20749 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20750 SIGDIH = FRAC*SIGDIF
20751 RETURN
20752*
20753 20 CONTINUE
20754*
20755 KPSCAL = 2
20756 KTSCAL = 1
20757C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20758 DUMZER = ZERO
20759 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20760 F = SDIAPP/SIGTO
20761 KT = 1
20762C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20763 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20764 SIGDIF = SIGTO*F
20765 SIGDIH = FRAC*SIGDIF
20766 RETURN
20767*
20768 999 CONTINUE
20769*-------------------------- leptons..
20770 SIGDIF = 1.D-10
20771 SIGDIH = 1.D-10
20772 RETURN
20773 END
20774
20775*$ CREATE DT_PHOXS.FOR
20776*COPY DT_PHOXS
20777*
20778*===phoxs================================================================*
20779*
20780 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20781
20782************************************************************************
20783* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20784* interpolation tables. *
20785* This version dated 05.11.97 is written by S. Roesler *
20786************************************************************************
20787
20788 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20789 SAVE
20790
20791 PARAMETER ( LINP = 10 ,
20792 & LOUT = 6 ,
20793 & LDAT = 9 )
20794
20795 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20796 PARAMETER (TWOPI = 6.283185307179586454D+00,
20797 & PI = TWOPI/TWO,
20798 & GEV2MB = 0.38938D0)
20799
20800 LOGICAL LFIRST
20801 DATA LFIRST /.TRUE./
20802
20803* nucleon-nucleon event-generator
20804 CHARACTER*8 CMODEL
20805 LOGICAL LPHOIN
20806 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20807
20808* particle properties (BAMJET index convention)
20809 CHARACTER*8 ANAME
20810 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20811 & IICH(210),IIBAR(210),K1(210),K2(210)
20812
20813**PHOJET105a
20814C PARAMETER (IEETAB=10)
20815C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20816**PHOJET110
20817
20818C energy-interpolation table
20819 INTEGER IEETA2
20820 PARAMETER ( IEETA2 = 20 )
20821 INTEGER ISIMAX
20822 DOUBLE PRECISION SIGTAB,SIGECM
20823 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20824**
20825
20826 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20827 WRITE(LOUT,*) MCGENE
20828 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20829 STOP
20830 ENDIF
20831
20832 IF (ECM.LE.ZERO) THEN
20833 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20834 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20835 ENDIF
20836
20837 IF (MODE.EQ.1) THEN
20838* DL
20839 DELDL = 0.0808D0
20840 EPSDL = -0.4525D0
20841 S = ECM*ECM
20842 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20843 ALPHAP= 0.25D0
20844 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20845 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20846 SINE = STOT-SIGEL
20847 SDIF1 = ZERO
20848 ELSE
20849* Phojet
20850 IP = 1
20851 IF(ECM.LE.SIGECM(IP,1)) THEN
20852 I1 = 1
20853 I2 = 1
20854 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20855 DO 1 I=2,ISIMAX
20856 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20857 1 CONTINUE
20858 2 CONTINUE
20859 I1 = I-1
20860 I2 = I
20861 ELSE
20862 IF (LFIRST) THEN
20863 WRITE(LOUT,'(/1X,A,2E12.3)')
20864 & 'PHOXS: warning! energy above initialization limit (',
20865 & ECM,SIGECM(IP,ISIMAX)
20866 LFIRST = .FALSE.
20867 ENDIF
20868 I1 = ISIMAX
20869 I2 = ISIMAX
20870 ENDIF
20871 FAC2 = ZERO
20872 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20873 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20874 FAC1 = ONE-FAC2
20875 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20876 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20877 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20878 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20879 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20880 ENDIF
20881
20882 RETURN
20883 END
20884
20885*$ CREATE DT_XSHN.FOR
20886*COPY DT_XSHN
20887*
20888*===xshn===============================================================*
20889*
20890 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20891
20892************************************************************************
20893* Total and elastic hadron-nucleon cross section. *
20894* Below 500GeV cross sections are based on the '98 data compilation *
20895* of the PDG. At higher energies PHOJET results are used (patched to *
20896* the low energy data at 500GeV). *
20897* IP projectile index (BAMJET numbering scheme) *
20898* (should be in the range 1..25) *
20899* IT target index (BAMJET numbering scheme) *
20900* (1 = proton, 8 = neutron) *
20901* PL laboratory momentum *
20902* ECM cm. energy (ignored if PL>0) *
20903* STOT total cross section *
20904* SELA elastic cross section *
20905* Last change: 24.4.99 by S. Roesler *
20906************************************************************************
20907
20908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20909 SAVE
20910
20911 PARAMETER ( LINP = 10 ,
20912 & LOUT = 6 ,
20913 & LDAT = 9 )
20914
20915 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20916
20917 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20918 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20919 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20920
20921 LOGICAL LFIRST
20922
20923* particle properties (BAMJET index convention)
20924 CHARACTER*8 ANAME
20925 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20926 & IICH(210),IIBAR(210),K1(210),K2(210)
20927
20928* nucleon-nucleon event-generator
20929 CHARACTER*8 CMODEL
20930 LOGICAL LPHOIN
20931 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20932**PHOJET105a
20933C PARAMETER (IEETAB=10)
20934C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20935**PHOJET110
20936
20937C energy-interpolation table
20938 INTEGER IEETA2
20939 PARAMETER ( IEETA2 = 20 )
20940 INTEGER ISIMAX
20941 DOUBLE PRECISION SIGTAB,SIGECM
20942 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20943
20944 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20945 DIMENSION IDXDAT(25,2)
20946*
20947 DATA APL /
20948 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20949 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20950 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20951 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20952 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20953 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20954 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20955*
20956* total cross sections:
20957* p p
20958 DATA (ASIGTO(1,K),K=1,NPOINT) /
20959 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20960 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20961 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20962 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20963 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20964 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20965 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20966* pbar p
20967 DATA (ASIGTO(2,K),K=1,NPOINT) /
20968 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20969 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20970 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20971 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20972 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20973 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20974 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20975* n p
20976 DATA (ASIGTO(3,K),K=1,NPOINT) /
20977 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20978 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20979 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20980 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20981 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20982 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20983 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20984* pi+ p
20985 DATA (ASIGTO(4,K),K=1,NPOINT) /
20986 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20987 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20988 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20989 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20990 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20991 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20992 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20993* pi- p
20994 DATA (ASIGTO(5,K),K=1,NPOINT) /
20995 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20996 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20997 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20998 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20999 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21000 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21001 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21002* K+ p
21003 DATA (ASIGTO(6,K),K=1,NPOINT) /
21004 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21005 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21006 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21007 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21008 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21009 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21010 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21011* K- p
21012 DATA (ASIGTO(7,K),K=1,NPOINT) /
21013 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21014 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21015 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21016 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21017 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21018 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21019 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21020* K+ n
21021 DATA (ASIGTO(8,K),K=1,NPOINT) /
21022 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21023 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21024 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21025 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21026 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21027 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21028 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21029* K- n
21030 DATA (ASIGTO(9,K),K=1,NPOINT) /
21031 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21032 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21033 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21034 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21035 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21036 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21037 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21038* Lambda p
21039 DATA (ASIGTO(10,K),K=1,NPOINT) /
21040 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21041 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21042 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21043 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21044 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21045 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21046 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21047*
21048* elastic cross sections:
21049* p p
21050 DATA (ASIGEL(1,K),K=1,NPOINT) /
21051 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21052 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21053 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21054 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21055 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21056 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21057 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21058* pbar p
21059 DATA (ASIGEL(2,K),K=1,NPOINT) /
21060 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21061 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21062 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21063 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21064 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21065 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21066 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21067* n p
21068 DATA (ASIGEL(3,K),K=1,NPOINT) /
21069 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21070 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21071 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21072 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21073 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21074 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21075 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21076* pi+ p
21077 DATA (ASIGEL(4,K),K=1,NPOINT) /
21078 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21079 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21080 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21081 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21082 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21083 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21084 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21085* pi- p
21086 DATA (ASIGEL(5,K),K=1,NPOINT) /
21087 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21088 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21089 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21090 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21091 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21092 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21093 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21094* K+ p
21095 DATA (ASIGEL(6,K),K=1,NPOINT) /
21096 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21097 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21098 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21099 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21100 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21101 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21102 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21103* K- p
21104 DATA (ASIGEL(7,K),K=1,NPOINT) /
21105 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21106 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21107 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21108 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21109 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21110 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21111 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21112* K+ n
21113 DATA (ASIGEL(8,K),K=1,NPOINT) /
21114 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21115 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21116 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21117 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21118 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21119 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21120 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21121* K- n
21122 DATA (ASIGEL(9,K),K=1,NPOINT) /
21123 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21124 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21125 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21126 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21127 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21128 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21129 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21130* Lambda p
21131 DATA (ASIGEL(10,K),K=1,NPOINT) /
21132 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21133 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21134 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21135 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21136 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21137 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21138 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21139
21140 DATA (IDXDAT(K,1),K=1,25) /
21141 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21142 & 1, 3,45, 8, 9/
21143 DATA (IDXDAT(K,2),K=1,25) /
21144 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21145 & 3, 1,45, 6, 7/
21146
21147 DATA LFIRST /.TRUE./
21148
21149 IF (LFIRST) THEN
21150 APLABL = LOG10(PLABLO)
21151 APLABH = LOG10(PLABHI)
21152 APTHRE = LOG10(PTHRE)
21153 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21154 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21155 DUM0 = ZERO
21156 PHOPLA = PLABHI
21157 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21158 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21159 IF (MCGENE.EQ.2) THEN
21160 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21161 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21162 ELSE
21163 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21164 ENDIF
21165 ELSE
21166 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21167 ENDIF
21168 PHOSEL = PHOSTO-PHOSIN
21169 APHOST = LOG10(PHOSTO)
21170 APHOSE = LOG10(PHOSEL)
21171 LFIRST = .FALSE.
21172 ENDIF
21173 STOT = ZERO
21174 SELA = ZERO
21175 PLAB = PL
21176 ECMS = ECM
21177 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21178 WRITE(LOUT,1000) IP,IT
21179 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21180 & 'proj/target',2I4)
21181 STOP
21182 ENDIF
21183
21184 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21185 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21186 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21187 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21188 WRITE(LOUT,1001) PLAB,ECMS
21189 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21190 STOP
21191 ENDIF
21192
21193* index of spectrum
21194 IDXP = IP
21195 IF (IP.GT.25) THEN
21196 IF (AAM(IP).GT.ZERO) THEN
21197 IF (ABS(IIBAR(IP)).GT.0) THEN
21198 IDXP = 1
21199 ELSE
21200 IDXP = 13
21201 ENDIF
21202 ELSE
21203 IDXP = 7
21204 ENDIF
21205 ENDIF
21206 IDXT = 1
21207 IF (IT.EQ.8) IDXT = 2
21208 IDXS = IDXDAT(IDXP,IDXT)
21209 IF (IDXS.EQ.0) RETURN
21210
21211* compute momentum bin indices
21212 IF (PLAB.LT.PLABLO) THEN
21213 IDX0 = 1
21214 IDX1 = 1
21215 ELSEIF (PLAB.GE.PLABHI) THEN
21216 IDX0 = NPOINT
21217 IDX1 = NPOINT
21218 ELSE
21219 APLAB = LOG10(PLAB)
21220 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21221 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21222 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21223 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21224 ENDIF
21225 IDX1 = IDX0+1
21226 ENDIF
21227
21228* interpolate cross section
21229 IF (IDXS.GT.10) THEN
21230 IDXS1 = IDXS/10
21231 IDXS2 = IDXS-10*IDXS1
21232 IF (IDX0.EQ.IDX1) THEN
21233 IF (IDX0.EQ.1) THEN
21234 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21235 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21236 ELSE
21237 DUM0 = ZERO
21238 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21239 PHOSEL = PHOSTO-PHOSIN
21240 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21241 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21242 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21243 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21244 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21245 ASELA = 0.5D0*(ASELA1+ASELA2)
21246 ENDIF
21247 ELSE
21248 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21249 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21250 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21251 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21252 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21253 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21254 ASELA1 = ASIGEL(IDXS1,IDX0)+
21255 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21256 ASELA2 = ASIGEL(IDXS2,IDX0)+
21257 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21258 ASELA = 0.5D0*(ASELA1+ASELA2)
21259 ENDIF
21260 ELSE
21261 IF (IDX0.EQ.IDX1) THEN
21262 IF (IDX0.EQ.1) THEN
21263 ASTOT = ASIGTO(IDXS,IDX0)
21264 ASELA = ASIGEL(IDXS,IDX0)
21265 ELSE
21266 DUM0 = ZERO
21267 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21268 PHOSEL = PHOSTO-PHOSIN
21269 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21270 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21271 ENDIF
21272 ELSE
21273 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21274 ASTOT = ASIGTO(IDXS,IDX0)+
21275 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21276 ASELA = ASIGEL(IDXS,IDX0)+
21277 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21278 ENDIF
21279 ENDIF
21280 STOT = 10.0D0**ASTOT
21281 SELA = 10.0D0**ASELA
21282
21283 RETURN
21284 END
21285
21286*$ CREATE DT_SIHNAB.FOR
21287*COPY DT_SIHNAB
21288*
21289*===sihnab===============================================================*
21290*
21291 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21292
21293**********************************************************************
21294* Pion 2-nucleon absorption cross sections. *
21295* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21296* taken from Ritchie PRC 28 (1983) 926 ) *
21297* This version dated 18.05.96 is written by S. Roesler *
21298**********************************************************************
21299
21300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21301 SAVE
21302 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21303 PARAMETER (AMPR = 938.0D0,
21304 & AMPI = 140.0D0,
21305 & AMDE = TWO*AMPR,
21306 & A = -1.2D0,
21307 & B = 3.5D0,
21308 & C = 7.4D0,
21309 & D = 5600.0D0,
21310 & ER = 2136.0D0)
21311
21312 SIGABS = ZERO
21313 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21314 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21315 PTOT = PLAB*1.0D3
21316 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21317 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21318 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21319 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21320* approximate 3N-abs., I=1-abs. etc.
21321 SIGABS = SIGABS/0.40D0
21322* pi0-absorption (rough approximation!!)
21323 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21324
21325 RETURN
21326 END
21327
21328*$ CREATE DT_SIGEMU.FOR
21329*COPY DT_SIGEMU
21330*
21331*===sigemu=============================================================*
21332*
21333 SUBROUTINE DT_SIGEMU
21334
21335************************************************************************
21336* Combined cross section for target compounds. *
21337* This version dated 6.4.98 is written by S. Roesler *
21338************************************************************************
21339
21340 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21341 SAVE
21342
21343 PARAMETER ( LINP = 10 ,
21344 & LOUT = 6 ,
21345 & LDAT = 9 )
21346
21347 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21348 & OHALF=0.5D0,ONE=1.0D0)
21349
21350 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21351
21352* Glauber formalism: cross sections
21353 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21354 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21355 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21356 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21357 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21358 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21359 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21360 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21361 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21362 & BSLOPE,NEBINI,NQBINI
21363
21364* emulsion treatment
21365 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21366 & NCOMPO,IEMUL
21367
21368* nucleon-nucleon event-generator
21369 CHARACTER*8 CMODEL
21370 LOGICAL LPHOIN
21371 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21372
21373 IF (MCGENE.NE.4) THEN
21374 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21375 WRITE(LOUT,'(15X,A)') '-----------------------'
21376 ENDIF
21377 DO 1 IE=1,NEBINI
21378 DO 2 IQ=1,NQBINI
21379 SIGTOT = ZERO
21380 SIGELA = ZERO
21381 SIGQEP = ZERO
21382 SIGQET = ZERO
21383 SIGQE2 = ZERO
21384 SIGPRO = ZERO
21385 SIGDEL = ZERO
21386 SIGDQE = ZERO
21387 ERRTOT = ZERO
21388 ERRELA = ZERO
21389 ERRQEP = ZERO
21390 ERRQET = ZERO
21391 ERRQE2 = ZERO
21392 ERRPRO = ZERO
21393 ERRDEL = ZERO
21394 ERRDQE = ZERO
21395 IF (NCOMPO.GT.0) THEN
21396 DO 3 IC=1,NCOMPO
21397 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21398 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21399 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21400 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21401 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21402 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21403 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21404 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21405 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21406 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21407 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21408 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21409 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21410 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21411 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21412 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21413 3 CONTINUE
21414 ERRTOT = SQRT(ERRTOT)
21415 ERRELA = SQRT(ERRELA)
21416 ERRQEP = SQRT(ERRQEP)
21417 ERRQET = SQRT(ERRQET)
21418 ERRQE2 = SQRT(ERRQE2)
21419 ERRPRO = SQRT(ERRPRO)
21420 ERRDEL = SQRT(ERRDEL)
21421 ERRDQE = SQRT(ERRDQE)
21422 ELSE
21423 SIGTOT = XSTOT(IE,IQ,1)
21424 SIGELA = XSELA(IE,IQ,1)
21425 SIGQEP = XSQEP(IE,IQ,1)
21426 SIGQET = XSQET(IE,IQ,1)
21427 SIGQE2 = XSQE2(IE,IQ,1)
21428 SIGPRO = XSPRO(IE,IQ,1)
21429 SIGDEL = XSDEL(IE,IQ,1)
21430 SIGDQE = XSDQE(IE,IQ,1)
21431 ERRTOT = XETOT(IE,IQ,1)
21432 ERRELA = XEELA(IE,IQ,1)
21433 ERRQEP = XEQEP(IE,IQ,1)
21434 ERRQET = XEQET(IE,IQ,1)
21435 ERRQE2 = XEQE2(IE,IQ,1)
21436 ERRPRO = XEPRO(IE,IQ,1)
21437 ERRDEL = XEDEL(IE,IQ,1)
21438 ERRDQE = XEDQE(IE,IQ,1)
21439 ENDIF
21440 IF (MCGENE.NE.4) THEN
21441 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21442 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21443 WRITE(LOUT,1001) SIGTOT,ERRTOT
21444 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21445 WRITE(LOUT,1002) SIGELA,ERRELA
21446 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21447 WRITE(LOUT,1003) SIGQEP,ERRQEP
21448 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21449 & F11.5,' mb')
21450 WRITE(LOUT,1004) SIGQET,ERRQET
21451 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21452 & F11.5,' mb')
21453 WRITE(LOUT,1005) SIGQE2,ERRQE2
21454 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21455 & ' +-',F11.5,' mb')
21456 WRITE(LOUT,1006) SIGPRO,ERRPRO
21457 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21458 WRITE(LOUT,1007) SIGDEL,ERRDEL
21459 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21460 WRITE(LOUT,1008) SIGDQE,ERRDQE
21461 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21462 ENDIF
21463
21464 2 CONTINUE
21465 1 CONTINUE
21466
21467 RETURN
21468 END
21469
21470*$ CREATE DT_SIGGA.FOR
21471*COPY DT_SIGGA
21472*
21473*===sigga==============================================================*
21474*
21475 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21476
21477************************************************************************
21478* Total/inelastic photon-nucleus cross sections. *
21479* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21480* production runs !!!! *
21481* This version dated 27.03.96 is written by S. Roesler *
21482************************************************************************
21483
21484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21485 SAVE
21486
21487 PARAMETER ( LINP = 10 ,
21488 & LOUT = 6 ,
21489 & LDAT = 9 )
21490
21491 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21492 & OHALF=0.5D0,ONE=1.0D0)
21493 PARAMETER (AMPROT = 0.938D0)
21494
21495 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21496
21497* Glauber formalism: cross sections
21498 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21499 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21500 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21501 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21502 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21503 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21504 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21505 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21506 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21507 & BSLOPE,NEBINI,NQBINI
21508
21509 NT = NTI
21510 X = XI
21511 Q2 = Q2I
21512 ECM = ECMI
21513 XNU = XNUI
21514 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21515 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21516 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21517 STOT = XSTOT(1,1,1)
21518 ETOT = XETOT(1,1,1)
21519 SIN = XSPRO(1,1,1)
21520 EIN = XEPRO(1,1,1)
21521
21522 RETURN
21523 END
21524
21525*$ CREATE DT_SIGGAT.FOR
21526*COPY DT_SIGGAT
21527*
21528*===siggat=============================================================*
21529*
21530 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21531
21532************************************************************************
21533* Total/inelastic photon-nucleus cross sections. *
21534* Uses pre-tabulated cross section. *
21535* This version dated 29.07.96 is written by S. Roesler *
21536************************************************************************
21537
21538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21539 SAVE
21540
21541 PARAMETER ( LINP = 10 ,
21542 & LOUT = 6 ,
21543 & LDAT = 9 )
21544
21545 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21546 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21547
21548 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21549
21550* Glauber formalism: cross sections
21551 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21552 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21553 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21554 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21555 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21556 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21557 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21558 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21559 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21560 & BSLOPE,NEBINI,NQBINI
21561
21562 NTARG = ABS(NT)
21563 I1 = 1
21564 I2 = 1
21565 RATE = ONE
21566 IF (NEBINI.GT.1) THEN
21567 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21568 I1 = NEBINI
21569 I2 = NEBINI
21570 RATE = ONE
21571 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21572 DO 1 I=2,NEBINI
21573 IF (ECMI.LT.ECMNN(I)) THEN
21574 I1 = I-1
21575 I2 = I
21576 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21577 GOTO 2
21578 ENDIF
21579 1 CONTINUE
21580 2 CONTINUE
21581 ENDIF
21582 ENDIF
21583 J1 = 1
21584 J2 = 1
21585 RATQ = ONE
21586 IF (NQBINI.GT.1) THEN
21587 IF (Q2I.GE.Q2G(NQBINI)) THEN
21588 J1 = NQBINI
21589 J2 = NQBINI
21590 RATQ = ONE
21591 ELSEIF (Q2I.GT.Q2G(1)) THEN
21592 DO 3 I=2,NQBINI
21593 IF (Q2I.LT.Q2G(I)) THEN
21594 J1 = I-1
21595 J2 = I
21596 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21597 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21598C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21599 GOTO 4
21600 ENDIF
21601 3 CONTINUE
21602 4 CONTINUE
21603 ENDIF
21604 ENDIF
21605
21606 STOT = XSTOT(I1,J1,NTARG)+
21607 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21608 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21609 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21610 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21611
21612 RETURN
21613 END
21614
21615*$ CREATE DT_SANO.FOR
21616*COPY DT_SANO
21617*
21618*===sigano=============================================================*
21619*
21620 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21621
21622************************************************************************
21623* This version dated 31.07.96 is written by S. Roesler *
21624************************************************************************
21625
21626 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21627 SAVE
21628
21629 PARAMETER ( LINP = 10 ,
21630 & LOUT = 6 ,
21631 & LDAT = 9 )
21632
21633 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21634 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21635 PARAMETER (NE = 8)
21636
21637* VDM parameter for photon-nucleus interactions
21638 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21639
21640* properties of interacting particles
21641 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21642
21643 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21644 DATA ECMANO /
21645 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21646 & 0.100D+04,0.200D+04,0.500D+04
21647 & /
21648* fixed cut (3 GeV/c)
21649 DATA FRAANO /
21650 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21651 & 0.062D+00,0.054D+00,0.042D+00
21652 & /
21653 DATA SIGHRD /
21654 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21655 & 3.3086D-01,7.6255D-01,2.1319D+00
21656 & /
21657* running cut (based on obsolete Phojet-caluclations, bugs..)
21658C DATA FRAANO /
21659C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21660C & 0.167E+00,0.150E+00,0.131E+00
21661C & /
21662C DATA SIGHRD /
21663C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21664C & 2.5736E-01,4.5593E-01,8.2550E-01
21665C & /
21666
21667 DT_SANO = ZERO
21668 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21669 J1 = 0
21670 J2 = 0
21671 RATE = ONE
21672 IF (ECM.GE.ECMANO(NE)) THEN
21673 J1 = NE
21674 J2 = NE
21675 ELSEIF (ECM.GT.ECMANO(1)) THEN
21676 DO 1 IE=2,NE
21677 IF (ECM.LT.ECMANO(IE)) THEN
21678 J1 = IE-1
21679 J2 = IE
21680 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21681 GOTO 2
21682 ENDIF
21683 1 CONTINUE
21684 2 CONTINUE
21685 ENDIF
21686 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21687 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21688 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21689 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21690 ENDIF
21691
21692 RETURN
21693 END
21694
21695*$ CREATE DT_SIGGP.FOR
21696*COPY DT_SIGGP
21697*
21698*===siggp==============================================================*
21699*
21700 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21701
21702************************************************************************
21703* Total/inelastic photon-nucleon cross sections. *
21704* This version dated 30.04.96 is written by S. Roesler *
21705************************************************************************
21706
21707 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21708 SAVE
21709
21710 PARAMETER ( LINP = 10 ,
21711 & LOUT = 6 ,
21712 & LDAT = 9 )
21713
21714 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21715 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21716 & PI = TWOPI/TWO,
21717 & GEV2MB = 0.38938D0,
21718 & ALPHEM = ONE/137.0D0)
21719
21720* particle properties (BAMJET index convention)
21721 CHARACTER*8 ANAME
21722 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21723 & IICH(210),IIBAR(210),K1(210),K2(210)
21724
21725* VDM parameter for photon-nucleus interactions
21726 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21727
21728**PHOJET105a
21729C CHARACTER*8 MDLNA
21730C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21731C PARAMETER (IEETAB=10)
21732C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21733**PHOJET110
21734
21735C model switches and parameters
21736 CHARACTER*8 MDLNA
21737 INTEGER ISWMDL,IPAMDL
21738 DOUBLE PRECISION PARMDL
21739 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21740
21741C energy-interpolation table
21742 INTEGER IEETA2
21743 PARAMETER ( IEETA2 = 20 )
21744 INTEGER ISIMAX
21745 DOUBLE PRECISION SIGTAB,SIGECM
21746 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21747**
21748
21749C PARAMETER (NPOINT=80)
21750 PARAMETER (NPOINT=16)
21751 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21752
21753 STOT = ZERO
21754 SINE = ZERO
21755 SDIR = ZERO
21756
21757 W2 = ECMI**2
21758 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21759 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21760 Q2 = Q2I
21761 X = XI
21762* photoprod.
21763 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21764 Q2 = 0.0001D0
21765 X = Q2/(W2+Q2-AAM(1)**2)
21766* DIS
21767 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21768 X = Q2/(W2+Q2-AAM(1)**2)
21769 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21770 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21771 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21772 W2 = Q2*(ONE-X)/X+AAM(1)**2
21773 ELSE
21774 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21775 STOP
21776 ENDIF
21777 ECM = SQRT(W2)
21778
21779 IF (MODEGA.EQ.1) THEN
21780 SCALE = SQRT(Q2)
21781 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21782 & IDPDF)
21783C W = SQRT(W2)
21784
21785C ALLMF2 = PHO_ALLM97(Q2,W)
21786
21787C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21788 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21789 SINE = ZERO
21790 SDIR = ZERO
21791 ELSEIF (MODEGA.EQ.2) THEN
21792 IF (INTRGE(1).EQ.1) THEN
21793 AMLO2 = (3.0D0*AAM(13))**2
21794 ELSEIF (INTRGE(1).EQ.2) THEN
21795 AMLO2 = AAM(33)**2
21796 ELSE
21797 AMLO2 = AAM(96)**2
21798 ENDIF
21799 IF (INTRGE(2).EQ.1) THEN
21800 AMHI2 = W2/TWO
21801 ELSEIF (INTRGE(2).EQ.2) THEN
21802 AMHI2 = W2/4.0D0
21803 ELSE
21804 AMHI2 = W2
21805 ENDIF
21806 AMHI20 = (ECM-AAM(1))**2
21807 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21808 XAMLO = LOG( AMLO2+Q2 )
21809 XAMHI = LOG( AMHI2+Q2 )
21810**PHOJET105a
21811C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21812**PHOJET112
21813
21814 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21815
21816**
21817 SUM = ZERO
21818 DO 1 J=1,NPOINT
21819 AM2 = EXP(ABSZX(J))-Q2
21820 IF (AM2.LT.16.0D0) THEN
21821 R = TWO
21822 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21823 R = 10.0D0/3.0D0
21824 ELSE
21825 R = 11.0D0/3.0D0
21826 ENDIF
21827C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21828 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21829 & * (ONE+EPSPOL*Q2/AM2)
21830 SUM = SUM+WEIGHT(J)*FAC
21831 1 CONTINUE
21832 SINE = SUM
21833 SDIR = DT_SIGVP(X,Q2)
21834 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21835 SDIR = SDIR/(0.588D0+RL2+Q2)
21836C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21837 ELSEIF (MODEGA.EQ.3) THEN
21838 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21839 ELSEIF (MODEGA.EQ.4) THEN
21840* load cross sections from PHOJET interpolation table
21841 IP = 1
21842 IF(ECM.LE.SIGECM(IP,1)) THEN
21843 I1 = 1
21844 I2 = 1
21845 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21846 DO 2 I=2,ISIMAX
21847 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21848 2 CONTINUE
21849 3 CONTINUE
21850 I1 = I-1
21851 I2 = I
21852 ELSE
21853 WRITE(LOUT,'(/1X,A,2E12.3)')
21854 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21855 I1 = ISIMAX
21856 I2 = ISIMAX
21857 ENDIF
21858 FAC2 = ZERO
21859 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21860 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21861 FAC1 = ONE-FAC2
21862* cross section dependence on photon virtuality
21863 FSUP1 = ZERO
21864 DO 4 I=1,3
21865 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21866 & /(1.D0+Q2/PARMDL(30+I))**2
21867 4 CONTINUE
21868 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21869 FAC1 = FAC1*FSUP1
21870 FAC2 = FAC2*FSUP1
21871 FSUP2 = 1.0D0
21872 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21873 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21874 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21875**re:
21876 STOT = STOT-SDIR
21877**
21878 SDIR = SDIR/(FSUP1*FSUP2)
21879**re:
21880 STOT = STOT+SDIR
21881**
21882 ENDIF
21883
21884 RETURN
21885 END
21886
21887*$ CREATE DT_SIGVEL.FOR
21888*COPY DT_SIGVEL
21889*
21890*===sigvel=============================================================*
21891*
21892 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21893
21894************************************************************************
21895* Cross section for elastic vector meson production *
21896* This version dated 10.05.96 is written by S. Roesler *
21897************************************************************************
21898
21899 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21900 SAVE
21901
21902 PARAMETER ( LINP = 10 ,
21903 & LOUT = 6 ,
21904 & LDAT = 9 )
21905
21906 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21907 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21908 & PI = TWOPI/TWO,
21909 & GEV2MB = 0.38938D0,
21910 & ALPHEM = ONE/137.0D0)
21911
21912* particle properties (BAMJET index convention)
21913 CHARACTER*8 ANAME
21914 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21915 & IICH(210),IIBAR(210),K1(210),K2(210)
21916
21917* VDM parameter for photon-nucleus interactions
21918 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21919
21920 W2 = ECMI**2
21921 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21922 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21923 Q2 = Q2I
21924 X = XI
21925* photoprod.
21926 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21927 Q2 = 0.0001D0
21928 X = Q2/(W2+Q2-AAM(1)**2)
21929* DIS
21930 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21931 X = Q2/(W2+Q2-AAM(1)**2)
21932 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21933 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21934 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21935 W2 = Q2*(ONE-X)/X+AAM(1)**2
21936 ELSE
21937 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21938 STOP
21939 ENDIF
21940 ECM = SQRT(W2)
21941
21942 AMV = AAM(IDXV)
21943 AMV2 = AMV**2
21944
21945 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21946 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21947 ROSH = 0.1D0
21948 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21949 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21950
21951 IF (IDXV.EQ.33) THEN
21952 COUPL = 0.00365D0
21953 ELSE
21954 STOP
21955 ENDIF
21956 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21957 SIG2 = SELVP
21958 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21959 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21960
21961 RETURN
21962 END
21963
21964*$ CREATE DT_SIGVP.FOR
21965*COPY DT_SIGVP
21966*
21967*===sigvp==============================================================*
21968*
21969 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21970
21971************************************************************************
21972* sigma_Vp *
21973************************************************************************
21974
21975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21976 SAVE
21977
21978 PARAMETER ( LINP = 10 ,
21979 & LOUT = 6 ,
21980 & LDAT = 9 )
21981
21982 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21983 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21984 & PI = TWOPI/TWO,
21985 & GEV2MB = 0.38938D0,
21986 & AMPROT = 0.938D0,
21987 & ALPHEM = ONE/137.0D0)
21988
21989* VDM parameter for photon-nucleus interactions
21990 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21991
21992 X = XI
21993 Q2 = Q2I
21994 IF (XI.LE.ZERO) X = 0.0001D0
21995 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21996
21997 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21998
21999 SCALE = SQRT(Q2)
22000 IF (MODEGA.EQ.1) THEN
22001 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22002 & IDPDF)
22003C W = ECM
22004
22005C ALLMF2 = PHO_ALLM97(Q2,W)
22006
22007C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22008C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22009C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22010 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22011 ELSEIF (MODEGA.EQ.4) THEN
22012 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22013C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22014 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22015 ELSE
22016 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22017 ENDIF
22018
22019 RETURN
22020
22021 END
22022
22023*$ CREATE DT_RRM2.FOR
22024*COPY DT_RRM2
22025*
22026*===RRM2===============================================================*
22027*
22028 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22029
22030 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22031 SAVE
22032
22033 PARAMETER ( LINP = 10 ,
22034 & LOUT = 6 ,
22035 & LDAT = 9 )
22036
22037 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22038 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22039 & PI = TWOPI/TWO,
22040 & GEV2MB = 0.38938D0)
22041
22042* particle properties (BAMJET index convention)
22043 CHARACTER*8 ANAME
22044 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22045 & IICH(210),IIBAR(210),K1(210),K2(210)
22046
22047* VDM parameter for photon-nucleus interactions
22048 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22049
22050 S = Q2*(ONE-X)/X+AAM(1)**2
22051 ECM = SQRT(S)
22052
22053 IF (INTRGE(1).EQ.1) THEN
22054 AMLO2 = (3.0D0*AAM(13))**2
22055 ELSEIF (INTRGE(1).EQ.2) THEN
22056 AMLO2 = AAM(33)**2
22057 ELSE
22058 AMLO2 = AAM(96)**2
22059 ENDIF
22060 IF (INTRGE(2).EQ.1) THEN
22061 AMHI2 = S/TWO
22062 ELSEIF (INTRGE(2).EQ.2) THEN
22063 AMHI2 = S/4.0D0
22064 ELSE
22065 AMHI2 = S
22066 ENDIF
22067 AMHI20 = (ECM-AAM(1))**2
22068 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22069
22070 AM1C2 = 16.0D0
22071 AM2C2 = 121.0D0
22072 IF (AMHI2.LE.AM1C2) THEN
22073 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22074 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22075 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22076 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22077 ELSE
22078 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22079 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22080 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22081 ENDIF
22082
22083 RETURN
22084 END
22085
22086*$ CREATE DT_RM2.FOR
22087*COPY DT_RM2
22088*
22089*===RM2================================================================*
22090*
22091 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22092
22093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22094 SAVE
22095
22096 PARAMETER ( LINP = 10 ,
22097 & LOUT = 6 ,
22098 & LDAT = 9 )
22099
22100 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22101 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22102 & PI = TWOPI/TWO,
22103 & GEV2MB = 0.38938D0)
22104
22105* VDM parameter for photon-nucleus interactions
22106 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22107
22108 IF (RL2.LE.ZERO) THEN
22109 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22110 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22111 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22112 ELSE
22113 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22114 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22115 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22116 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22117 & +EPSPOL*(
22118 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22119 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22120 ENDIF
22121
22122 RETURN
22123 END
22124
22125*$ CREATE DT_SAM2.FOR
22126*COPY DT_SAM2
22127*
22128*===SAM2===============================================================*
22129*
22130 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22131
22132 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22133 SAVE
22134
22135 PARAMETER ( LINP = 10 ,
22136 & LOUT = 6 ,
22137 & LDAT = 9 )
22138
22139 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22140 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22141 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22142 & PI = TWOPI/TWO,
22143 & GEV2MB = 0.38938D0)
22144
22145* particle properties (BAMJET index convention)
22146 CHARACTER*8 ANAME
22147 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22148 & IICH(210),IIBAR(210),K1(210),K2(210)
22149
22150* VDM parameter for photon-nucleus interactions
22151 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22152
22153 S = ECM**2
22154 IF (INTRGE(1).EQ.1) THEN
22155 AMLO2 = (3.0D0*AAM(13))**2
22156 ELSEIF (INTRGE(1).EQ.2) THEN
22157 AMLO2 = AAM(33)**2
22158 ELSE
22159 AMLO2 = AAM(96)**2
22160 ENDIF
22161 IF (INTRGE(2).EQ.1) THEN
22162 AMHI2 = S/TWO
22163 ELSEIF (INTRGE(2).EQ.2) THEN
22164 AMHI2 = S/4.0D0
22165 ELSE
22166 AMHI2 = S
22167 ENDIF
22168 AMHI20 = (ECM-AAM(1))**2
22169 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22170
22171 AM1C2 = 16.0D0
22172 AM2C2 = 121.0D0
22173 YLO = LOG(AMLO2+Q2)
22174 YC1 = LOG(AM1C2+Q2)
22175 YC2 = LOG(AM2C2+Q2)
22176 YHI = LOG(AMHI2+Q2)
22177 IF (AMHI2.LE.AM1C2) THEN
22178 FACHI = TWO
22179 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22180 FACHI = TENTRD
22181 ELSE
22182 FACHI = ELVTRD
22183 ENDIF
22184
22185 1 CONTINUE
22186 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22187 IF (YSAM2.LE.YC1) THEN
22188 FAC = TWO
22189 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22190 FAC = TENTRD
22191 ELSE
22192 FAC = ELVTRD
22193 ENDIF
22194 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22195 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22196 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22197
22198 DT_SAM2 = EXP(YSAM2)-Q2
22199
22200 RETURN
22201 END
22202
22203*$ CREATE DT_CKMT.FOR
22204*COPY DT_CKMT
22205*
22206*===ckmt===============================================================*
22207*
22208 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22209 & F2,IPAR)
22210
22211************************************************************************
22212* This version dated 31.01.96 is written by S. Roesler *
22213************************************************************************
22214
22215 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22216 SAVE
22217
22218 PARAMETER ( LINP = 10 ,
22219 & LOUT = 6 ,
22220 & LDAT = 9 )
22221
22222 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22223
22224 PARAMETER (Q02 = 2.0D0,
22225 & DQ2 = 10.05D0,
22226 & Q12 = Q02+DQ2)
22227
22228 DIMENSION PD(-6:6),SEA(3),VAL(2)
22229
22230 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22231 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22232 ADQ2 = LOG10(Q12)-LOG10(Q02)
22233 F2P = (F2Q1-F2Q0)/ADQ2
22234 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22235 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22236 F2PP = (F2PQ1-F2PQ0)/ADQ2
22237 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22238
22239 Q2 = MAX(SCALE**2.0D0,TINY10)
22240 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22241 IF (Q2.LT.Q02) THEN
22242 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22243 UPV = VAL(1)
22244 DNV = VAL(2)
22245 USEA = SEA(1)
22246 DSEA = SEA(2)
22247 STR = SEA(3)
22248 CHM = 0.0D0
22249 BOT = 0.0D0
22250 TOP = 0.0D0
22251 GL = GLU
22252 ELSE
22253 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22254 F2 = F2*SMOOTH
22255 UPV = PD(2)-PD(3)
22256 DNV = PD(1)-PD(3)
22257 USEA = PD(3)
22258 DSEA = PD(3)
22259 STR = PD(3)
22260 CHM = PD(4)
22261 BOT = PD(5)
22262 TOP = PD(6)
22263 GL = PD(0)
22264C UPV = UPV*SMOOTH
22265C DNV = DNV*SMOOTH
22266C USEA = USEA*SMOOTH
22267C DSEA = DSEA*SMOOTH
22268C STR = STR*SMOOTH
22269C CHM = CHM*SMOOTH
22270C GL = GL*SMOOTH
22271 ENDIF
22272
22273 RETURN
22274 END
22275C
22276
22277*$ CREATE DT_CKMTX.FOR
22278*COPY DT_CKMTX
22279 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22280C**********************************************************************
22281C
22282C PDF based on Regge theory, evolved with .... by ....
22283C
22284C input: IPAR 2212 proton (not installed)
22285C 45 Pomeron
22286C 100 Deuteron
22287C
22288C output: PD(-6:6) x*f(x) parton distribution functions
22289C (PDFLIB convention: d = PD(1), u = PD(2) )
22290C
22291C**********************************************************************
22292
22293 SAVE
22294 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22295
22296 PARAMETER ( LINP = 10 ,
22297 & LOUT = 6 ,
22298 & LDAT = 9 )
22299
22300 DIMENSION QQ(7)
22301C
22302 Q2=SNGL(SCALE2)
22303 Q1S=Q2
22304 XX=SNGL(X)
22305C QCD lambda for evolution
22306 OWLAM = 0.23D0
22307 OWLAM2=OWLAM**2
22308C Q0**2 for evolution
22309 Q02 = 2.D0
22310C
22311C
22312C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22313C q(6)=x*charm, q(7)=x*gluon
22314C
22315 SB=0.
22316 IF(Q2-Q02) 1,1,2
22317 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22318 1 CONTINUE
22319 IF(IPAR.EQ.2212) THEN
22320 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22321 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22322 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22323 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22324 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22325 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22326 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22327C ELSEIF (IPAR.EQ.45) THEN
22328C CALL CKMTPO(1,0,XX,SB,QQ(1))
22329C CALL CKMTPO(2,0,XX,SB,QQ(2))
22330C CALL CKMTPO(3,0,XX,SB,QQ(3))
22331C CALL CKMTPO(4,0,XX,SB,QQ(4))
22332C CALL CKMTPO(5,0,XX,SB,QQ(5))
22333C CALL CKMTPO(8,0,XX,SB,QQ(6))
22334C CALL CKMTPO(7,0,XX,SB,QQ(7))
22335 ELSEIF (IPAR.EQ.100) THEN
22336 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22337 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22338 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22339 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22340 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22341 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22342 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22343 ELSE
22344 WRITE(LOUT,'(1X,A,I4,A)')
22345 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22346 STOP
22347 ENDIF
22348C
22349 PD(-6) = 0.D0
22350 PD(-5) = 0.D0
22351 PD(-4) = DBLE(QQ(6))
22352 PD(-3) = DBLE(QQ(3))
22353 PD(-2) = DBLE(QQ(4))
22354 PD(-1) = DBLE(QQ(5))
22355 PD(0) = DBLE(QQ(7))
22356 PD(1) = DBLE(QQ(2))
22357 PD(2) = DBLE(QQ(1))
22358 PD(3) = DBLE(QQ(3))
22359 PD(4) = DBLE(QQ(6))
22360 PD(5) = 0.D0
22361 PD(6) = 0.D0
22362 IF(IPAR.EQ.45) THEN
22363 CDN = (PD(1)-PD(-1))/2.D0
22364 CUP = (PD(2)-PD(-2))/2.D0
22365 PD(-1) = PD(-1) + CDN
22366 PD(-2) = PD(-2) + CUP
22367 PD(1) = PD(-1)
22368 PD(2) = PD(-2)
22369 ENDIF
22370 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22371 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22372 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22373 END
22374C
22375
22376*$ CREATE DT_PDF0.FOR
22377*COPY DT_PDF0
22378*
22379*===pdf0===============================================================*
22380*
22381 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22382
22383************************************************************************
22384* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22385* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22386* IPAR = 2212 proton *
22387* = 100 deuteron *
22388* This version dated 31.01.96 is written by S. Roesler *
22389************************************************************************
22390
22391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22392 SAVE
22393
22394 PARAMETER ( LINP = 10 ,
22395 & LOUT = 6 ,
22396 & LDAT = 9 )
22397
22398 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22399
22400 PARAMETER (
22401 & AA = 0.1502D0,
22402 & BBDEU = 1.2D0,
22403 & BUD = 0.754D0,
22404 & BDD = 0.4495D0,
22405 & BUP = 1.2064D0,
22406 & BDP = 0.1798D0,
22407 & DELTA0 = 0.07684D0,
22408 & D = 1.117D0,
22409 & C = 3.5489D0,
22410 & A = 0.2631D0,
22411 & B = 0.6452D0,
22412 & ALPHAR = 0.415D0,
22413 & E = 0.1D0
22414 & )
22415
22416 PARAMETER (NPOINT=16)
22417C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22418 DIMENSION SEA(3),VAL(2)
22419
22420 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22421 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22422* proton, deuteron
22423 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22424 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22425 SEA(1) = 0.75D0*SEA0
22426 SEA(2) = SEA(1)
22427 SEA(3) = SEA(1)
22428 VAL(1) = 9.0D0/4.0D0*VALU0
22429 VAL(2) = 9.0D0*VALD0
22430 GLU0 = SEA(1)/(1.0D0-X)
22431 F2 = SEA0+VALU0+VALD0
22432 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22433 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22434 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22435 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22436 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22437 STOP
22438 ENDIF
22439**PHOJET105a
22440C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22441**PHOJET112
22442
22443C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22444
22445**
22446C SUMQ = ZERO
22447C SUMG = ZERO
22448C DO 1 J=1,NPOINT
22449C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22450C VALU0 = 9.0D0/4.0D0*VALU0
22451C VALD0 = 9.0D0*VALD0
22452C SEA0 = 0.75D0*SEA0
22453C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22454C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22455C 1 CONTINUE
22456C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22457 ELSE
22458 WRITE(LOUT,'(1X,A,I4,A)')
22459 & 'PDF0: IPAR =',IPAR,' not implemented!'
22460 STOP
22461 ENDIF
22462
22463 RETURN
22464 END
22465
22466*$ CREATE DT_CKMTQ0.FOR
22467*COPY DT_CKMTQ0
22468*
22469*===ckmtq0=============================================================*
22470*
22471 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22472
22473************************************************************************
22474* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22475* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22476* IPAR = 2212 proton *
22477* = 100 deuteron *
22478* This version dated 31.01.96 is written by S. Roesler *
22479************************************************************************
22480
22481 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22482 SAVE
22483
22484 PARAMETER ( LINP = 10 ,
22485 & LOUT = 6 ,
22486 & LDAT = 9 )
22487
22488 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22489
22490 PARAMETER (
22491 & AA = 0.1502D0,
22492 & BBDEU = 1.2D0,
22493 & BUD = 0.754D0,
22494 & BDD = 0.4495D0,
22495 & BUP = 1.2064D0,
22496 & BDP = 0.1798D0,
22497 & DELTA0 = 0.07684D0,
22498 & D = 1.117D0,
22499 & C = 3.5489D0,
22500 & A = 0.2631D0,
22501 & B = 0.6452D0,
22502 & ALPHAR = 0.415D0,
22503 & E = 0.1D0
22504 & )
22505
22506 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22507 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22508* proton, deuteron
22509 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22510 IF (IPAR.EQ.2212) THEN
22511 BU = BUP
22512 BD = BDP
22513 ELSE
22514 BU = BUD
22515 BD = BDD
22516 ENDIF
22517 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22518 & (Q2/(Q2+A))**(1.0D0+DELTA)
22519 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22520 & (Q2/(Q2+B))**(ALPHAR)
22521 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22522 & (Q2/(Q2+B))**(ALPHAR)
22523 ELSE
22524 WRITE(LOUT,'(1X,A,I4,A)')
22525 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22526 STOP
22527 ENDIF
22528 RETURN
22529 END
22530C
22531C
22532
22533*$ CREATE DT_CKMTDE.FOR
22534*COPY DT_CKMTDE
22535 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22536C
22537C**********************************************************************
22538C Deuteron - PDFs
22539C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22540C ANS = PDF(I)
22541C This version by S. Roesler, 30.01.96
22542C**********************************************************************
22543
22544 SAVE
22545 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22546 EQUIVALENCE (GF(1,1,1),DL(1))
22547 DATA DELTA/.13/
22548C
22549 DATA (DL(K),K= 1, 85) /
22550 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22551 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22552 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22553 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22554 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22555 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22556 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22557 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22558 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22559 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22560 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22561 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22562 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22563 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22564 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22565 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22566 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22567 DATA (DL(K),K= 86, 170) /
22568 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22569 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22570 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22571 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22572 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22573 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22574 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22581 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22582 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22583 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22584 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22585 DATA (DL(K),K= 171, 255) /
22586 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22587 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22588 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22589 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22590 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22591 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22592 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22593 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22594 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22595 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22596 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22597 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22598 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22599 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22600 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22601 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22602 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22603 DATA (DL(K),K= 256, 340) /
22604 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22605 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22606 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22607 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22608 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22615 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22616 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22617 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22618 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22619 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22620 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22621 DATA (DL(K),K= 341, 425) /
22622 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22623 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22624 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22625 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22626 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22627 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22628 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22629 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22630 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22631 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22632 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22633 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22634 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22635 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22636 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22637 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22638 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22639 DATA (DL(K),K= 426, 510) /
22640 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22641 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22642 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22647 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22649 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22650 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22651 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22652 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22653 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22654 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22655 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22656 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22657 DATA (DL(K),K= 511, 595) /
22658 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22659 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22660 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22661 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22662 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22663 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22664 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22665 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22666 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22667 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22668 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22669 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22670 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22671 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22672 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22673 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22674 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22675 DATA (DL(K),K= 596, 680) /
22676 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22681 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22683 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22684 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22685 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22686 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22687 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22688 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22689 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22690 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22691 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22692 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22693 DATA (DL(K),K= 681, 765) /
22694 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22695 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22696 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22697 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22698 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22699 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22700 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22701 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22702 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22703 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22704 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22705 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22706 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22707 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22708 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22709 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22710 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22711 DATA (DL(K),K= 766, 850) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22715 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22717 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22718 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22719 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22720 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22721 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22722 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22723 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22724 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22725 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22726 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22727 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22728 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22729 DATA (DL(K),K= 851, 935) /
22730 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22731 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22732 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22733 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22734 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22735 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22736 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22737 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22738 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22739 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22740 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22741 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22742 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22743 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+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 DATA (DL(K),K= 936, 1020) /
22748 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22749 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22751 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22752 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22753 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22754 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22755 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22756 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22757 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22758 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22759 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22760 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22761 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22762 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22763 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22764 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22765 DATA (DL(K),K= 1021, 1105) /
22766 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22767 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22768 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22769 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22770 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22771 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22772 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22773 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22774 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22775 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22776 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22777 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22778 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22783 DATA (DL(K),K= 1106, 1190) /
22784 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22785 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22786 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22787 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22788 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22789 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22790 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22791 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22792 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22793 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22794 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22795 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22796 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22797 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22798 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22799 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22800 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22801 DATA (DL(K),K= 1191, 1275) /
22802 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22803 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22804 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22805 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22806 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22807 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22808 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22809 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22810 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22811 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22815 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22817 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22818 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22819 DATA (DL(K),K= 1276, 1360) /
22820 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22821 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22822 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22823 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22824 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22825 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22826 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22827 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22828 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22829 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22830 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22831 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22832 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22833 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22834 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22835 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22836 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22837 DATA (DL(K),K= 1361, 1445) /
22838 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22839 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22840 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22841 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22842 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22843 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22844 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22845 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22850 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22851 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22852 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22853 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22854 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22855 DATA (DL(K),K= 1446, 1530) /
22856 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22857 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22858 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22859 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22860 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22861 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22862 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22863 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22864 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22865 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22866 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22867 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22868 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22869 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22870 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22871 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22872 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22873 DATA (DL(K),K= 1531, 1615) /
22874 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22875 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22876 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22877 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22878 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22879 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22886 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22887 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22888 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22889 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22890 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22891 DATA (DL(K),K= 1616, 1700) /
22892 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22893 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22894 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22895 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22896 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22897 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22898 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22899 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22900 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22901 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22902 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22903 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22904 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22905 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22906 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22907 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22908 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22909 DATA (DL(K),K= 1701, 1785) /
22910 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22911 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22912 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22913 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22922 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22923 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22924 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22925 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22926 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22927 DATA (DL(K),K= 1786, 1870) /
22928 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22929 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22930 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22931 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22932 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22933 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22934 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22935 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22936 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22937 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22938 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22939 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22940 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22941 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22942 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22943 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22944 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22945 DATA (DL(K),K= 1871, 1955) /
22946 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22947 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22956 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22957 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22958 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22959 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22960 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22961 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22962 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22963 DATA (DL(K),K= 1956, 2040) /
22964 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22965 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22966 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22967 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22968 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22969 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22970 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22971 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22972 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22973 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22974 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22975 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22976 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22977 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22978 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22979 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22980 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22981 DATA (DL(K),K= 2041, 2125) /
22982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22990 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22991 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22992 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22993 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22994 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22995 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22996 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22997 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22998 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22999 DATA (DL(K),K= 2126, 2210) /
23000 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23001 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23002 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23003 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23004 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23005 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23006 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23007 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23008 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23009 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23010 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23011 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23012 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23013 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23014 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
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 DATA (DL(K),K= 2211, 2295) /
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23024 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23025 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23026 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23027 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23028 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23029 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23030 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23031 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23032 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23033 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23034 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23035 DATA (DL(K),K= 2296, 2380) /
23036 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23037 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23038 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23039 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23040 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23041 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23042 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23043 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23044 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23045 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23046 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23047 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23048 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
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 DATA (DL(K),K= 2381, 2465) /
23054 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23058 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23059 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23060 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23061 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23062 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23063 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23064 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23065 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23066 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23067 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23068 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23069 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23070 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23071 DATA (DL(K),K= 2466, 2550) /
23072 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23073 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23074 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23075 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23076 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23077 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23078 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23079 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23080 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23081 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23082 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23084 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23089 DATA (DL(K),K= 2551, 2635) /
23090 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23092 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23093 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23094 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23095 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23096 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23097 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23098 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23099 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23100 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23101 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23102 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23103 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23104 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23105 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23106 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23107 DATA (DL(K),K= 2636, 2720) /
23108 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23109 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23110 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23111 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23112 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23113 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23114 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23115 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23116 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23124 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23125 DATA (DL(K),K= 2721, 2805) /
23126 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23127 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23128 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23129 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23130 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23131 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23132 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23133 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23134 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23135 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23136 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23137 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23138 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23139 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23140 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23141 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23142 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23143 DATA (DL(K),K= 2806, 2890) /
23144 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23145 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23146 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23147 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23148 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23149 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23150 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23159 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23160 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23161 DATA (DL(K),K= 2891, 2975) /
23162 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23163 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23164 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23165 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23166 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23167 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23168 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23169 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23170 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23171 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23172 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23173 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23174 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23175 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23176 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23177 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23178 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23179 DATA (DL(K),K= 2976, 3060) /
23180 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23181 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23182 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23183 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23184 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23193 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23194 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23195 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23196 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23197 DATA (DL(K),K= 3061, 3145) /
23198 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23199 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23200 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23201 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23202 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23203 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23204 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23205 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23206 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23207 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23208 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23209 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23210 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23211 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23212 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23213 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23214 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23215 DATA (DL(K),K= 3146, 3230) /
23216 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23217 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23218 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23227 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23228 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23229 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23230 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23231 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23232 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23233 DATA (DL(K),K= 3231, 3315) /
23234 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23235 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23236 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23237 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23238 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23239 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23240 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23241 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23242 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23243 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23244 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23245 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23246 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23247 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23248 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23249 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23250 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23251 DATA (DL(K),K= 3316, 3400) /
23252 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23261 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23262 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23263 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23264 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23265 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23266 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23267 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23268 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23269 DATA (DL(K),K= 3401, 3485) /
23270 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23271 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23272 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23273 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23274 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23275 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23276 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23277 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23278 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23279 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23280 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23281 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23282 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23283 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23284 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23285 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23286 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23287 DATA (DL(K),K= 3486, 3570) /
23288 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23295 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23296 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23297 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23298 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23299 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23300 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23301 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23302 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23303 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23304 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23305 DATA (DL(K),K= 3571, 3655) /
23306 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23307 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23308 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23309 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23310 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23311 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23312 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23313 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23314 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23315 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23316 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23317 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23318 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23319 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
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 DATA (DL(K),K= 3656, 3740) /
23324 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23329 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23330 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23331 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23332 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23333 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23334 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23335 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23336 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23337 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23338 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23339 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23340 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23341 DATA (DL(K),K= 3741, 3825) /
23342 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23343 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23344 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23345 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23346 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23347 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23348 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23349 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23350 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23351 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23352 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23353 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23354 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23355 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23359 DATA (DL(K),K= 3826, 3910) /
23360 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23363 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23364 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23365 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23366 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23367 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23368 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23369 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23370 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23371 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23372 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23373 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23374 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23375 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23376 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23377 DATA (DL(K),K= 3911, 3995) /
23378 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23379 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23380 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23381 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23382 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23383 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23384 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23385 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23386 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23387 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23394 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23395 DATA (DL(K),K= 3996, 4000) /
23396 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23397C
23398 ANS = 0.
23399 IF (X.GT.0.9985) RETURN
23400 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23401C
23402 IS = S/DELTA+1
23403 IS1 = IS+1
23404 DO 1 L=1,25
23405 KL = L+NDRV*25
23406 F1(L) = GF(I,IS,KL)
23407 F2(L) = GF(I,IS1,KL)
23408 1 CONTINUE
23409 A1 = DT_CKMTFF(X,F1)
23410 A2 = DT_CKMTFF(X,F2)
23411C A1=ALOG(A1)
23412C A2=ALOG(A2)
23413 S1 = (IS-1)*DELTA
23414 S2 = S1+DELTA
23415 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23416C ANS=EXP(ANS)
23417 RETURN
23418 END
23419C
23420C
23421
23422*$ CREATE DT_CKMTPR.FOR
23423*COPY DT_CKMTPR
23424 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23425C
23426C**********************************************************************
23427C Proton - PDFs
23428C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23429C ANS = PDF(I)
23430C This version by S. Roesler, 31.01.96
23431C**********************************************************************
23432
23433 SAVE
23434 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23435 EQUIVALENCE (GF(1,1,1),DL(1))
23436 DATA DELTA/.10/
23437C
23438 DATA (DL(K),K= 1, 85) /
23439 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23440 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23441 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23442 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23443 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23444 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23445 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23446 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23447 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23448 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23449 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23450 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23451 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23452 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23453 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23454 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23455 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23456 DATA (DL(K),K= 86, 170) /
23457 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23458 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23459 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23460 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23461 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23462 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23463 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23464 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23465 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23466 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23467 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23468 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23469 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23470 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23471 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23472 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23473 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23474 DATA (DL(K),K= 171, 255) /
23475 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23476 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23477 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23478 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23479 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23480 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23481 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23482 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23483 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23484 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23485 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23486 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23487 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23488 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23489 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23490 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23491 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23492 DATA (DL(K),K= 256, 340) /
23493 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23494 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23495 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23496 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23497 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23498 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23499 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23500 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23501 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23502 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23503 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23504 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23505 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23506 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23507 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23508 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23509 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23510 DATA (DL(K),K= 341, 425) /
23511 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23512 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23513 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23514 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23515 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23516 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23517 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23518 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23519 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23520 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23521 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23522 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23523 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23524 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23525 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23526 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23527 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23528 DATA (DL(K),K= 426, 510) /
23529 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23530 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23531 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23532 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23533 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23534 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23535 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23536 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23537 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23538 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23539 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23540 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23541 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23542 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23543 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23544 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23545 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23546 DATA (DL(K),K= 511, 595) /
23547 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23548 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23549 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23550 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23551 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23552 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23553 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23554 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23555 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23556 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23557 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23558 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23559 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23560 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23561 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23562 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23563 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23564 DATA (DL(K),K= 596, 680) /
23565 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23566 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23567 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23568 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23569 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23570 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23571 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23572 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23573 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23574 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23575 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23576 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23577 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23578 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23579 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23580 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23581 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23582 DATA (DL(K),K= 681, 765) /
23583 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23584 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23585 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23586 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23587 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23588 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23589 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23590 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23591 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23592 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23593 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23594 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23595 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23596 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23597 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23598 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23599 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23600 DATA (DL(K),K= 766, 850) /
23601 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23602 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23603 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23604 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23605 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23606 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23607 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23608 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23609 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23610 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23611 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23612 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23613 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23614 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23615 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23616 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23617 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23618 DATA (DL(K),K= 851, 935) /
23619 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23620 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23621 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23622 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23623 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23624 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23625 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23626 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23627 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23628 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23629 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23630 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23631 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23632 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23633 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23634 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23635 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23636 DATA (DL(K),K= 936, 1020) /
23637 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23638 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23639 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23640 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23641 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23642 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23643 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23644 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23645 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23646 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23647 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23648 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23649 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23650 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23651 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23652 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23653 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23654 DATA (DL(K),K= 1021, 1105) /
23655 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23656 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23657 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23658 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23659 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23660 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23661 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23662 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23663 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23664 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23665 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23666 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23667 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23668 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23669 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23670 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23671 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23672 DATA (DL(K),K= 1106, 1190) /
23673 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23674 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23675 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23676 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23677 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23678 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23679 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23680 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23681 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23682 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23683 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23684 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23685 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23686 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23687 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23688 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23689 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23690 DATA (DL(K),K= 1191, 1275) /
23691 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23692 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23693 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23694 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23695 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23696 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23697 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23698 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23699 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23700 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23701 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23702 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23703 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23704 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23705 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23706 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23707 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23708 DATA (DL(K),K= 1276, 1360) /
23709 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23710 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23711 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23712 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23713 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23714 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23715 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23716 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23717 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23718 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23719 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23720 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23721 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23722 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23723 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23724 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23725 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23726 DATA (DL(K),K= 1361, 1445) /
23727 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23728 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23729 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23730 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23731 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23732 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23733 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23734 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23735 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23736 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23737 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23738 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23739 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23740 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23741 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23742 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23743 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23744 DATA (DL(K),K= 1446, 1530) /
23745 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23746 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23747 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23748 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23749 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23750 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23751 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23752 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23753 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23754 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23755 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23756 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23757 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23758 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23759 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23760 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23761 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23762 DATA (DL(K),K= 1531, 1615) /
23763 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23764 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23765 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23766 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23767 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23768 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23769 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23770 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23771 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23772 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23773 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23774 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23775 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23776 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23777 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23778 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23779 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23780 DATA (DL(K),K= 1616, 1700) /
23781 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23782 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23783 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23784 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23785 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23786 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23787 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23788 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23789 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23790 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23791 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23792 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23793 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23794 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23795 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23796 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23797 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23798 DATA (DL(K),K= 1701, 1785) /
23799 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23800 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23801 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23802 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23803 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23804 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23805 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23806 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23807 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23808 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23809 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23810 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23811 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23812 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23813 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23814 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23815 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23816 DATA (DL(K),K= 1786, 1870) /
23817 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23818 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23819 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23820 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23821 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23822 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23823 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23824 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23825 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23826 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23827 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23828 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23829 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23830 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23831 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23832 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23833 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23834 DATA (DL(K),K= 1871, 1955) /
23835 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23836 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23837 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23838 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23839 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23840 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23841 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23842 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23843 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23844 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23845 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23846 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23847 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23848 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23849 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23850 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23851 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23852 DATA (DL(K),K= 1956, 2040) /
23853 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23854 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23855 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23856 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23857 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23858 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23859 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23860 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23861 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23862 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23863 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23864 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23865 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23866 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23867 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23868 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23869 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23870 DATA (DL(K),K= 2041, 2125) /
23871 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23872 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23873 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23874 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23875 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23876 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23877 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23879 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23880 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23881 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23882 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23883 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23884 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23885 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23886 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23887 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23888 DATA (DL(K),K= 2126, 2210) /
23889 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23890 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23891 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23892 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23893 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23894 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23895 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23896 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23897 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23898 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23899 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23900 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23901 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23902 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23903 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23904 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23905 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23906 DATA (DL(K),K= 2211, 2295) /
23907 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23908 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23909 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23910 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23911 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23913 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23914 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23915 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23916 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23917 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23918 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23919 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23920 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23921 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23922 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23923 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23924 DATA (DL(K),K= 2296, 2380) /
23925 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23926 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23927 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23928 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23929 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23930 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23931 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23932 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23933 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23934 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23935 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23936 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23937 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23938 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23939 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23940 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23941 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23942 DATA (DL(K),K= 2381, 2465) /
23943 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23944 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23945 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23947 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23948 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23949 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23950 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23951 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23952 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23953 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23954 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23955 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23956 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23957 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23958 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23959 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23960 DATA (DL(K),K= 2466, 2550) /
23961 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23962 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23963 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23964 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23965 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23966 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23967 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23968 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23969 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23970 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23971 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23972 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23973 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23974 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23975 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23976 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23977 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23978 DATA (DL(K),K= 2551, 2635) /
23979 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23981 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23982 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23983 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23984 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23985 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23986 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23987 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23988 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23989 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23990 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23991 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23992 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23993 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23994 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23995 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23996 DATA (DL(K),K= 2636, 2720) /
23997 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23998 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23999 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24000 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24001 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24002 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24003 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24004 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24005 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24006 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24007 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24008 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24009 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24010 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24011 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24012 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24014 DATA (DL(K),K= 2721, 2805) /
24015 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24016 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24017 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24018 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24019 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24020 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24021 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24022 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24023 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24024 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24025 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24026 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24027 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24028 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24029 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24030 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24031 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24032 DATA (DL(K),K= 2806, 2890) /
24033 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24034 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24035 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24036 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24037 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24038 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24039 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24040 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24041 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24042 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24043 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24044 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24045 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24046 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24047 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24048 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24049 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24050 DATA (DL(K),K= 2891, 2975) /
24051 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24052 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24053 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24054 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24055 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24056 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24057 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24058 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24059 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24060 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24061 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24062 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24063 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24064 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24065 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24066 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24067 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24068 DATA (DL(K),K= 2976, 3060) /
24069 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24070 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24071 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24072 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24073 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24074 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24075 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24076 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24077 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24078 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24079 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24080 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24081 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24082 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24083 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24084 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24085 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24086 DATA (DL(K),K= 3061, 3145) /
24087 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24088 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24089 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24090 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24091 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24092 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24093 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24094 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24095 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24096 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24097 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24098 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24099 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24100 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24101 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24102 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24103 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24104 DATA (DL(K),K= 3146, 3230) /
24105 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24106 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24107 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24108 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24109 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24110 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24111 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24112 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24113 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24114 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24116 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24117 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24118 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24119 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24120 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24121 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24122 DATA (DL(K),K= 3231, 3315) /
24123 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24124 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24125 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24126 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24127 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24128 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24129 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24130 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24131 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24132 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24133 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24134 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24135 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24136 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24137 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24138 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24139 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24140 DATA (DL(K),K= 3316, 3400) /
24141 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24142 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24143 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24144 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24145 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24146 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24147 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24148 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24150 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24151 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24152 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24153 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24154 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24155 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24156 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24157 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24158 DATA (DL(K),K= 3401, 3485) /
24159 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24160 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24161 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24162 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24163 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24164 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24165 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24166 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24167 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24168 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24169 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24170 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24171 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24172 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24173 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24174 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24175 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24176 DATA (DL(K),K= 3486, 3570) /
24177 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24178 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24179 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24180 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24181 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24182 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24184 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24185 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24186 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24187 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24188 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24189 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24190 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24191 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24192 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24193 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24194 DATA (DL(K),K= 3571, 3655) /
24195 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24196 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24197 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24198 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24199 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24200 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24201 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24202 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24203 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24204 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24205 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24206 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24207 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24208 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24209 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24210 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24211 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24212 DATA (DL(K),K= 3656, 3740) /
24213 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24214 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24215 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24216 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24218 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24219 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24220 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24221 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24222 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24223 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24224 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24225 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24226 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24227 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24228 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24229 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24230 DATA (DL(K),K= 3741, 3825) /
24231 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24232 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24233 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24234 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24235 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24236 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24237 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24238 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24239 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24240 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24241 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24242 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24243 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24244 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24245 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24246 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24247 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24248 DATA (DL(K),K= 3826, 3910) /
24249 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24250 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24252 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24253 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24254 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24255 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24256 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24257 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24258 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24259 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24260 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24261 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24262 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24263 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24264 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24265 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24266 DATA (DL(K),K= 3911, 3995) /
24267 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24268 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24269 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24270 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24271 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24272 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24273 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24274 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24275 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24276 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24277 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24278 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24279 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24280 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24281 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24282 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24283 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24284 DATA (DL(K),K= 3996, 4000) /
24285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24286C
24287 ANS = 0.
24288 IF (X.GT.0.9985) RETURN
24289 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24290C
24291 IS = S/DELTA+1
24292 IS1 = IS+1
24293 DO 1 L=1,25
24294 KL = L+NDRV*25
24295 F1(L) = GF(I,IS,KL)
24296 F2(L) = GF(I,IS1,KL)
24297 1 CONTINUE
24298 A1 = DT_CKMTFF(X,F1)
24299 A2 = DT_CKMTFF(X,F2)
24300C A1=ALOG(A1)
24301C A2=ALOG(A2)
24302 S1 = (IS-1)*DELTA
24303 S2 = S1+DELTA
24304 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24305C ANS=EXP(ANS)
24306 RETURN
24307 END
24308C
24309
24310*$ CREATE DT_CKMTFF.FOR
24311*COPY DT_CKMTFF
24312 FUNCTION DT_CKMTFF(X,FVL)
24313C**********************************************************************
24314C
24315C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24316C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24317C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24318C IN MAIN ROUTINE.
24319C
24320C**********************************************************************
24321
24322 SAVE
24323 DIMENSION FVL(25),XGRID(25)
24324 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24325 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24326C
24327 DT_CKMTFF=0.
24328 DO 1 I=1,NX
24329 IF(X.LT.XGRID(I)) GO TO 2
24330 1 CONTINUE
24331 2 I=I-1
24332 IF(I.EQ.0) THEN
24333 I=I+1
24334 ELSE IF(I.GT.23) THEN
24335 I=23
24336 ENDIF
24337 J=I+1
24338 K=J+1
24339 AXI=LOG(XGRID(I))
24340 BXI=LOG(1.-XGRID(I))
24341 AXJ=LOG(XGRID(J))
24342 BXJ=LOG(1.-XGRID(J))
24343 AXK=LOG(XGRID(K))
24344 BXK=LOG(1.-XGRID(K))
24345 FI=LOG(ABS(FVL(I)) +1.E-15)
24346 FJ=LOG(ABS(FVL(J)) +1.E-16)
24347 FK=LOG(ABS(FVL(K)) +1.E-17)
24348 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24349 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24350 $ BXI))/DET
24351 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24352 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24353 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24354 1RETURN
24355C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24356C WRITE(6,2001) X,FVL
24357C 2001 FORMAT(8E12.4)
24358C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24359C ENDIF
24360 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24361 RETURN
24362 END
24363
24364*$ CREATE DT_FLUINI.FOR
24365*COPY DT_FLUINI
24366*
24367*===fluini=============================================================*
24368*
24369 SUBROUTINE DT_FLUINI
24370
24371************************************************************************
24372* Initialisation of the nucleon-nucleon cross section fluctuation *
24373* treatment. The original version by J. Ranft. *
24374* This version dated 21.04.95 is revised by S. Roesler. *
24375************************************************************************
24376
24377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24378 SAVE
24379
24380 PARAMETER ( LINP = 10 ,
24381 & LOUT = 6 ,
24382 & LDAT = 9 )
24383
24384 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24385
24386 PARAMETER ( A = 0.1D0,
24387 & B = 0.893D0,
24388 & OM = 1.1D0,
24389 & N = 6,
24390 & DX = 0.003D0)
24391
24392* n-n cross section fluctuations
24393 PARAMETER (NBINS = 1000)
24394 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24395 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24396
24397 WRITE(LOUT,1000)
24398 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24399 & 'treated')
24400
24401 FLUSU = ZERO
24402 FLUSUU = ZERO
24403
24404 DO 1 I=1,NBINS
24405 X = DBLE(I)*DX
24406 FLUIX(I) = X
24407 FLUS = ((X-B)/(OM*B))**N
24408 IF (FLUS.LE.20.0D0) THEN
24409 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24410 ELSE
24411 FLUSI(I) = ZERO
24412 ENDIF
24413 FLUSU = FLUSU+FLUSI(I)
24414 1 CONTINUE
24415 DO 2 I=1,NBINS
24416 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24417 FLUSI(I) = FLUSUU
24418 2 CONTINUE
24419
24420C WRITE(LOUT,1001)
24421C1001 FORMAT(1X,'FLUCTUATIONS')
24422C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24423
24424 DO 3 I=1,NBINS
24425 AF = DBLE(I)*0.001D0
24426 DO 4 J=1,NBINS
24427 IF (AF.LE.FLUSI(J)) THEN
24428 FLUIXX(I) = FLUIX(J)
24429 GOTO 5
24430 ENDIF
24431 4 CONTINUE
24432 5 CONTINUE
24433 3 CONTINUE
24434 FLUIXX(1) = FLUIX(1)
24435 FLUIXX(NBINS) = FLUIX(NBINS)
24436
24437 RETURN
24438 END
24439
24440*$ CREATE DT_SIGTBL.FOR
24441*COPY DT_SIGTBL
24442*
24443*===sigtab=============================================================*
24444*
24445 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24446
24447************************************************************************
24448* This version dated 18.11.95 is written by S. Roesler *
24449************************************************************************
24450
24451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24452 SAVE
24453
24454 PARAMETER ( LINP = 10 ,
24455 & LOUT = 6 ,
24456 & LDAT = 9 )
24457
24458 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24459 & OHALF=0.5D0,ONE=1.0D0)
24460 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24461
24462 LOGICAL LINIT
24463
24464* particle properties (BAMJET index convention)
24465 CHARACTER*8 ANAME
24466 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24467 & IICH(210),IIBAR(210),K1(210),K2(210)
24468
24469 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24470 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24471 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24472 & 0, 0, 5/
24473 DATA LINIT /.FALSE./
24474
24475* precalculation and tabulation of elastic cross sections
24476 IF (ABS(MODE).EQ.1) THEN
24477 IF (MODE.EQ.1)
24478 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24479 PLABLX = LOG10(PLO)
24480 PLABHX = LOG10(PHI)
24481 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24482 DO 1 I=1,NBINS+1
24483 PLAB = PLABLX+DBLE(I-1)*DPLAB
24484 PLAB = 10**PLAB
24485 DO 2 IPROJ=1,23
24486 IDX = IDSIG(IPROJ)
24487 IF (IDX.GT.0) THEN
24488C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24489C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24490 DUMZER = ZERO
24491 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24492 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24493 ENDIF
24494 2 CONTINUE
24495 IF (MODE.EQ.1) THEN
24496 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24497 & (SIGEN(IDX,I),IDX=1,5)
24498 1000 FORMAT(F5.1,10F7.2)
24499 ENDIF
24500 1 CONTINUE
24501 IF (MODE.EQ.1) CLOSE(LDAT)
24502 LINIT = .TRUE.
24503 ELSE
24504 SIGE = -ONE
24505 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24506 & .AND.(PTOT.LE.PHI) ) THEN
24507 IDX = IDSIG(JP)
24508 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24509 PLABX = LOG10(PTOT)
24510 IF (PLABX.LE.PLABLX) THEN
24511 I1 = 1
24512 I2 = 1
24513 ELSEIF (PLABX.GE.PLABHX) THEN
24514 I1 = NBINS+1
24515 I2 = NBINS+1
24516 ELSE
24517 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24518 I2 = I1+1
24519 ENDIF
24520 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24521 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24522 PBIN = PLAB2X-PLAB1X
24523 IF (PBIN.GT.TINY10) THEN
24524 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24525 ELSE
24526 RATX = ZERO
24527 ENDIF
24528 IF (JT.EQ.1) THEN
24529 SIG1 = SIGEP(IDX,I1)
24530 SIG2 = SIGEP(IDX,I2)
24531 ELSE
24532 SIG1 = SIGEN(IDX,I1)
24533 SIG2 = SIGEN(IDX,I2)
24534 ENDIF
24535 SIGE = SIG1+RATX*(SIG2-SIG1)
24536 ENDIF
24537 ENDIF
24538 ENDIF
24539
24540 RETURN
24541 END
24542
24543*$ CREATE DT_XSTABL.FOR
24544*COPY DT_XSTABL
24545*
24546*===xstabl=============================================================*
24547*
24548 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24549
24550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24551 SAVE
24552
24553 PARAMETER ( LINP = 10 ,
24554 & LOUT = 6 ,
24555 & LDAT = 9 )
24556
24557 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24558 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24559 LOGICAL LLAB,LELOG,LQLOG
24560
24561* particle properties (BAMJET index convention)
24562 CHARACTER*8 ANAME
24563 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24564 & IICH(210),IIBAR(210),K1(210),K2(210)
24565
24566* properties of interacting particles
24567 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24568
24569 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24570
24571* Glauber formalism: cross sections
24572 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24573 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24574 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24575 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24576 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24577 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24578 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24579 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24580 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24581 & BSLOPE,NEBINI,NQBINI
24582
24583* emulsion treatment
24584 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24585 & NCOMPO,IEMUL
24586
24587 DIMENSION WHAT(6)
24588
24589 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24590 ELO = ABS(WHAT(1))
24591 EHI = ABS(WHAT(2))
24592 IF (ELO.GT.EHI) ELO = EHI
24593 LELOG = WHAT(3).LT.ZERO
24594 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24595 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24596 IF (LELOG) THEN
24597 AELO = LOG10(ELO)
24598 AEHI = LOG10(EHI)
24599 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24600 ENDIF
24601 Q2LO = WHAT(4)
24602 Q2HI = WHAT(5)
24603 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24604 LQLOG = WHAT(6).LT.ZERO
24605 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24606 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24607 IF (LQLOG) THEN
24608 AQ2LO = LOG10(Q2LO)
24609 AQ2HI = LOG10(Q2HI)
24610 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24611 ENDIF
24612
24613 IF ( ELO.EQ. EHI) NEBINS = 0
24614 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24615
24616 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24617 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24618 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24619 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24620 & ' A_p = ',I3,' A_t = ',I3,/)
24621
24622C IF (IJPROJ.NE.7) THEN
24623 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24624* normalize fractions of emulsion components
24625 IF (NCOMPO.GT.0) THEN
24626 SUMFRA = ZERO
24627 DO 10 I=1,NCOMPO
24628 SUMFRA = SUMFRA+EMUFRA(I)
24629 10 CONTINUE
24630 IF (SUMFRA.GT.ZERO) THEN
24631 DO 11 I=1,NCOMPO
24632 EMUFRA(I) = EMUFRA(I)/SUMFRA
24633 11 CONTINUE
24634 ENDIF
24635 ENDIF
24636C ELSE
24637C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24638C ENDIF
24639 DO 1 I=1,NEBINS+1
24640 IF (LELOG) THEN
24641 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24642 ELSE
24643 E = ELO+DBLE(I-1)*DEBINS
24644 ENDIF
24645 DO 2 J=1,NQBINS+1
24646 IF (LQLOG) THEN
24647 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24648 ELSE
24649 Q2 = Q2LO+DBLE(J-1)*DQBINS
24650 ENDIF
24651c IF (IJPROJ.NE.7) THEN
24652 IF (LLAB) THEN
24653 PLAB = ZERO
24654 ECM = ZERO
24655 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24656 ELSE
24657 ECM = E
24658 ENDIF
24659 XI = ZERO
24660 Q2I = ZERO
24661 IF (IJPROJ.EQ.7) Q2I = Q2
24662 IF (NCOMPO.GT.0) THEN
24663 DO 20 IC=1,NCOMPO
24664 IIT = IEMUMA(IC)
24665 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24666 20 CONTINUE
24667 ELSE
24668 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24669C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24670 ENDIF
24671 IF (NCOMPO.GT.0) THEN
24672 XTOT = ZERO
24673 ETOT = ZERO
24674 XELA = ZERO
24675 EELA = ZERO
24676 XQEP = ZERO
24677 EQEP = ZERO
24678 XQET = ZERO
24679 EQET = ZERO
24680 XQE2 = ZERO
24681 EQE2 = ZERO
24682 XPRO = ZERO
24683 EPRO = ZERO
24684 XPRO1= ZERO
24685 XDEL = ZERO
24686 EDEL = ZERO
24687 XDQE = ZERO
24688 EDQE = ZERO
24689 DO 21 IC=1,NCOMPO
24690 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24691 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24692 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24693 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24694 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24695 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24696 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24697 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24698 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24699 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24700 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24701 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24702 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24703 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24704 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24705 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24706 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24707 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24708 & -XSQE2(1,1,IC)
24709 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24710 21 CONTINUE
24711 ETOT = SQRT(ETOT)
24712 EELA = SQRT(EELA)
24713 EQEP = SQRT(EQEP)
24714 EQET = SQRT(EQET)
24715 EQE2 = SQRT(EQE2)
24716 EPRO = SQRT(EPRO)
24717 EDEL = SQRT(EDEL)
24718 EDQE = SQRT(EDQE)
24719 WRITE(LOUT,'(8E9.3)')
24720 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24721C WRITE(LOUT,'(4E9.3)')
24722C & E,XDEL,XDQE,XDEL+XDQE
24723 ELSE
24724 WRITE(LOUT,'(11E10.3)')
24725 & E,
24726 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24727 & XSQE2(1,1,1),XSPRO(1,1,1),
24728 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24729 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24730 & XSDEL(1,1,1)+XSDQE(1,1,1)
24731C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24732C & XSDEL(1,1,1)+XSDQE(1,1,1)
24733 ENDIF
24734c ELSE
24735c IF (LLAB) THEN
24736c IF (IT.GT.1) THEN
24737c IF (IXSQEL.EQ.0) THEN
24738cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24739cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24740c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24741c & STOT,ETOT,SIN,EIN,STOT0)
24742c IF (IRATIO.EQ.1) THEN
24743c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24744cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24745cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24746c*!! save cross sections
24747c STOTA = STOT
24748c ETOTA = ETOT
24749c STOTP = STGP
24750c*!!
24751c STOT = STOT/(DBLE(IT)*STGP)
24752c SIN = SIN/(DBLE(IT)*SIGP)
24753c STOT0 = STGP
24754c ETOT = ZERO
24755c EIN = ZERO
24756c ENDIF
24757c ELSE
24758c WRITE(LOUT,*)
24759c & ' XSTABL: qel. xs. not implemented for nuclei'
24760c STOP
24761c ENDIF
24762c ELSE
24763c ETOT = ZERO
24764c EIN = ZERO
24765c STOT0= ZERO
24766c IF (IXSQEL.EQ.0) THEN
24767c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24768c ELSE
24769c SIN = ZERO
24770c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24771c ENDIF
24772c ENDIF
24773c ELSE
24774c IF (IT.GT.1) THEN
24775c IF (IXSQEL.EQ.0) THEN
24776c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24777c & STOT,ETOT,SIN,EIN,STOT0)
24778c IF (IRATIO.EQ.1) THEN
24779c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24780c*!! save cross sections
24781c STOTA = STOT
24782c ETOTA = ETOT
24783c STOTP = STGP
24784c*!!
24785c STOT = STOT/(DBLE(IT)*STGP)
24786c SIN = SIN/(DBLE(IT)*SIGP)
24787c STOT0 = STGP
24788c ETOT = ZERO
24789c EIN = ZERO
24790c ENDIF
24791c ELSE
24792c WRITE(LOUT,*)
24793c & ' XSTABL: qel. xs. not implemented for nuclei'
24794c STOP
24795c ENDIF
24796c ELSE
24797c ETOT = ZERO
24798c EIN = ZERO
24799c STOT0= ZERO
24800c IF (IXSQEL.EQ.0) THEN
24801c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24802c ELSE
24803c SIN = ZERO
24804c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24805c ENDIF
24806c ENDIF
24807c ENDIF
24808cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24809cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24810cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24811c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24812c ENDIF
24813 2 CONTINUE
24814 1 CONTINUE
24815
24816 RETURN
24817 END
24818
24819*$ CREATE DT_TESTXS.FOR
24820*COPY DT_TESTXS
24821*
24822*===testxs=============================================================*
24823*
24824 SUBROUTINE DT_TESTXS
24825
24826 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24827 SAVE
24828
24829 DIMENSION XSTOT(26,2),XSELA(26,2)
24830
24831 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24832 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24833 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24834 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24835 DUMECM = 0.0D0
24836 PLABL = 0.01D0
24837 PLABH = 10000.0D0
24838 NBINS = 120
24839 APLABL = LOG10(PLABL)
24840 APLABH = LOG10(PLABH)
24841 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24842 DO 1 I=1,NBINS+1
24843 ADP = APLABL+DBLE(I-1)*ADPLAB
24844 P = 10.0D0**ADP
24845 DO 2 J=1,26
24846 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24847 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24848 2 CONTINUE
24849 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24850 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24851 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24852 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24853 1 CONTINUE
24854 1000 FORMAT(F8.3,26F9.3)
24855
24856 RETURN
24857 END
24858************************************************************************
24859* *
24860* DTUNUC 2.0: library routines *
24861* processed by S. Roesler, 6.5.95 *
24862* *
24863************************************************************************
24864*
24865* 1) Handling of parton momenta
24866* SUBROUTINE MASHEL
24867* SUBROUTINE DFERMI
24868*
24869* 2) Handling of parton flavors and particle indices
24870* INTEGER FUNCTION IPDG2B
24871* INTEGER FUNCTION IB2PDG
24872* INTEGER FUNCTION IQUARK
24873* INTEGER FUNCTION IBJQUA
24874* INTEGER FUNCTION ICIHAD
24875* INTEGER FUNCTION IPDGHA
24876* INTEGER FUNCTION MCHAD
24877* SUBROUTINE FLAHAD
24878*
24879* 3) Energy-momentum and quantum number conservation check routines
24880* SUBROUTINE EMC1
24881* SUBROUTINE EMC2
24882* SUBROUTINE EVTEMC
24883* SUBROUTINE EVTFLC
24884* SUBROUTINE EVTCHG
24885*
24886* 4) Transformations
24887* SUBROUTINE LTINI
24888* SUBROUTINE LTRANS
24889* SUBROUTINE LTNUC
24890* SUBROUTINE DALTRA
24891* SUBROUTINE DTRAFO
24892* SUBROUTINE STTRAN
24893* SUBROUTINE MYTRAN
24894* SUBROUTINE LT2LAO
24895* SUBROUTINE LT2LAB
24896*
24897* 5) Sampling from distributions
24898* INTEGER FUNCTION NPOISS
24899* DOUBLE PRECISION FUNCTION SAMPXB
24900* DOUBLE PRECISION FUNCTION SAMPEX
24901* DOUBLE PRECISION FUNCTION SAMSQX
24902* DOUBLE PRECISION FUNCTION BETREJ
24903* DOUBLE PRECISION FUNCTION DGAMRN
24904* DOUBLE PRECISION FUNCTION DBETAR
24905* SUBROUTINE RANNOR
24906* SUBROUTINE DPOLI
24907* SUBROUTINE DSFECF
24908* SUBROUTINE RACO
24909*
24910* 6) Special functions, algorithms and service routines
24911* DOUBLE PRECISION FUNCTION YLAMB
24912* SUBROUTINE SORT
24913* SUBROUTINE SORT1
24914* SUBROUTINE DT_XTIME
24915*
24916* 7) Random number generator package
24917* DOUBLE PRECISION FUNCTION DT_RNDM
24918* SUBROUTINE DT_RNDMST
24919* SUBROUTINE DT_RNDMIN
24920* SUBROUTINE DT_RNDMOU
24921* SUBROUTINE DT_RNDMTE
24922*
24923************************************************************************
24924* *
24925* 1) Handling of parton momenta *
24926* *
24927************************************************************************
24928*$ CREATE DT_MASHEL.FOR
24929*COPY DT_MASHEL
24930*
24931*===mashel=============================================================*
24932*
24933 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24934
24935************************************************************************
24936* *
24937* rescaling of momenta of two partons to put both *
24938* on mass shell *
24939* *
24940* input: PA1,PA2 input momentum vectors *
24941* XM1,2 desired masses of particles afterwards *
24942* P1,P2 changed momentum vectors *
24943* *
24944* The original version is written by R. Engel. *
24945* This version dated 12.12.94 is modified by S. Roesler. *
24946************************************************************************
24947
24948 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24949 SAVE
24950
24951 PARAMETER ( LINP = 10 ,
24952 & LOUT = 6 ,
24953 & LDAT = 9 )
24954
24955 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24956
24957 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24958
24959 IREJ = 0
24960
24961* Lorentz transformation into system CMS
24962 PX = PA1(1)+PA2(1)
24963 PY = PA1(2)+PA2(2)
24964 PZ = PA1(3)+PA2(3)
24965 EE = PA1(4)+PA2(4)
24966 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24967 XMS = (EE-XPTOT)*(EE+XPTOT)
24968 IF(XMS.LT.(XM1+XM2)**2) THEN
24969C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24970 GOTO 9999
24971 ENDIF
24972 XMS = SQRT(XMS)
24973 BGX = PX/XMS
24974 BGY = PY/XMS
24975 BGZ = PZ/XMS
24976 GAM = EE/XMS
24977 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24978 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24979* rotation angles
24980 COD = P1(3)/PTOT1
24981C SID = SQRT((ONE-COD)*(ONE+COD))
24982 PPT = SQRT(P1(1)**2+P1(2)**2)
24983 SID = PPT/PTOT1
24984 COF = ONE
24985 SIF = ZERO
24986 IF(PTOT1*SID.GT.TINY10) THEN
24987 COF = P1(1)/(SID*PTOT1)
24988 SIF = P1(2)/(SID*PTOT1)
24989 ANORF = SQRT(COF*COF+SIF*SIF)
24990 COF = COF/ANORF
24991 SIF = SIF/ANORF
24992 ENDIF
24993* new CM momentum and energies (for masses XM1,XM2)
24994 XM12 = SIGN(XM1**2,XM1)
24995 XM22 = SIGN(XM2**2,XM2)
24996 SS = XMS**2
24997 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24998 EE1 = SQRT(XM12+PCMP**2)
24999 EE2 = XMS-EE1
25000* back rotation
25001 MODE = 1
25002 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25003 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25004 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25005 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25006 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25007* check consistency
25008 DEL = XMS*0.0001D0
25009 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25010 IDEV = 1
25011 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25012 IDEV = 2
25013 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25014 IDEV = 3
25015 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25016 IDEV = 4
25017 ELSE
25018 IDEV = 0
25019 ENDIF
25020 IF (IDEV.NE.0) THEN
25021 WRITE(LOUT,'(/1X,A,I3)')
25022 & 'MASHEL: inconsistent transformation',IDEV
25023 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25024 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25025 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25026 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25027 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25028 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25029 ENDIF
25030 RETURN
25031
25032 9999 CONTINUE
25033 IREJ = 1
25034 RETURN
25035 END
25036
25037*$ CREATE DT_DFERMI.FOR
25038*COPY DT_DFERMI
25039*
25040*===dfermi=============================================================*
25041*
25042 SUBROUTINE DT_DFERMI(GPART)
25043
25044************************************************************************
25045* Find largest of three random numbers. *
25046************************************************************************
25047
25048 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25049 SAVE
25050
25051 DIMENSION G(3)
25052
25053 DO 10 I=1,3
25054 G(I)=DT_RNDM(GPART)
25055 10 CONTINUE
25056 IF (G(3).LT.G(2)) GOTO 40
25057 IF (G(3).LT.G(1)) GOTO 30
25058 GPART = G(3)
25059 20 RETURN
25060 30 GPART = G(1)
25061 GOTO 20
25062 40 IF (G(2).LT.G(1)) GOTO 30
25063 GPART = G(2)
25064 GOTO 20
25065
25066 END
25067
25068************************************************************************
25069* *
25070* 2) Handling of parton flavors and particle indices *
25071* *
25072************************************************************************
25073*$ CREATE IDT_IPDG2B.FOR
25074*COPY IDT_IPDG2B
25075*
25076*===ipdg2b=============================================================*
25077*
25078 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25079
25080************************************************************************
25081* *
25082* conversion of quark numbering scheme *
25083* *
25084* input: PDG parton numbering *
25085* for diquarks: NN number of the constituent quark *
25086* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25087* *
25088* output: BAMJET particle codes *
25089* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25090* 2 d 8 a-d -2 a-d *
25091* 3 s 9 a-s -3 a-s *
25092* 4 c 10 a-c -4 a-c *
25093* *
25094* This is a modified version of ICONV2 written by R. Engel. *
25095* This version dated 13.12.94 is written by S. Roesler. *
25096************************************************************************
25097
25098 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25099 SAVE
25100
25101 PARAMETER ( LINP = 10 ,
25102 & LOUT = 6 ,
25103 & LDAT = 9 )
25104
25105 IDA = ABS(ID)
25106* diquarks
25107 IF (IDA.GT.6) THEN
25108 KF = 3
25109 IF (IDA.GE.1000) KF = 4
25110 IDA = IDA/(10**(KF-NN))
25111 IDA = MOD(IDA,10)
25112 ENDIF
25113* exchange up and dn quarks
25114 IF (IDA.EQ.1) THEN
25115 IDA = 2
25116 ELSEIF (IDA.EQ.2) THEN
25117 IDA = 1
25118 ENDIF
25119* antiquarks
25120 IF (ID.LT.0) THEN
25121 IF (MODE.EQ.1) THEN
25122 IDA = IDA+6
25123 ELSE
25124 IDA = -IDA
25125 ENDIF
25126 ENDIF
25127 IDT_IPDG2B = IDA
25128
25129 RETURN
25130 END
25131
25132*$ CREATE IDT_IB2PDG.FOR
25133*COPY IDT_IB2PDG
25134*
25135*===ib2pdg=============================================================*
25136*
25137 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25138
25139************************************************************************
25140* *
25141* conversion of quark numbering scheme *
25142* *
25143* input: BAMJET particle codes *
25144* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25145* 2 d 8 a-d -2 a-d *
25146* 3 s 9 a-s -3 a-s *
25147* 4 c 10 a-c -4 a-c *
25148* *
25149* output: PDG parton numbering *
25150* *
25151* This version dated 13.12.94 is written by S. Roesler. *
25152************************************************************************
25153
25154 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25155 SAVE
25156
25157 PARAMETER ( LINP = 10 ,
25158 & LOUT = 6 ,
25159 & LDAT = 9 )
25160
25161 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25162 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25163 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25164 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25165 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25166
25167 IDA = ID1
25168 IDB = ID2
25169 IF (MODE.EQ.1) THEN
25170 IF (ID1.GT.6) IDA = -(ID1-6)
25171 IF (ID2.GT.6) IDB = -(ID2-6)
25172 ENDIF
25173 IF (ID2.EQ.0) THEN
25174 IDT_IB2PDG = IHKKQ(IDA)
25175 ELSE
25176 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25177 ENDIF
25178
25179 RETURN
25180 END
25181
25182*$ CREATE IDT_IQUARK.FOR
25183*COPY IDT_IQUARK
25184*
25185*===ipdgqu=============================================================*
25186*
25187 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25188
25189************************************************************************
25190* *
25191* quark contents according to PDG conventions *
25192* (random selection in case of quark mixing) *
25193* *
25194* input: IDBAMJ BAMJET particle code *
25195* K 1..3 quark number *
25196* *
25197* output: 1 d (anti --> neg.) *
25198* 2 u *
25199* 3 s *
25200* 4 c *
25201* *
25202* This version written by R. Engel. *
25203************************************************************************
25204
25205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25206 SAVE
25207
25208 IQ = IDT_IBJQUA(K,IDBAMJ)
25209* quark-antiquark
25210 IF (IQ.GT.6) THEN
25211 IQ = 6-IQ
25212 ENDIF
25213* exchange of up and down
25214 IF (ABS(IQ).EQ.1) THEN
25215 IQ = SIGN(2,IQ)
25216 ELSEIF (ABS(IQ).EQ.2) THEN
25217 IQ = SIGN(1,IQ)
25218 ENDIF
25219 IDT_IQUARK = IQ
25220
25221 RETURN
25222 END
25223
25224*$ CREATE IDT_IBJQUA.FOR
25225*COPY IDT_IBJQUA
25226*
25227*===ibamq==============================================================*
25228*
25229 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25230
25231************************************************************************
25232* *
25233* quark contents according to BAMJET conventions *
25234* (random selection in case of quark mixing) *
25235* *
25236* input: IDBAMJ BAMJET particle code *
25237* K 1..3 quark number *
25238* *
25239* output: 1 u 7 u bar *
25240* 2 d 8 d bar *
25241* 3 s 9 s bar *
25242* 4 c 10 c bar *
25243* *
25244* This version written by R. Engel. *
25245************************************************************************
25246
25247 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25248 SAVE
25249
25250 DIMENSION ITAB(3,210)
25251 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25252 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25253 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25254 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25255*sr 10.1.94
25256C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25257 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25258*
25259 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25260*sr 10.1.94
25261C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25262 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25263*sr 10.1.94
25264C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25265 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25266*
25267 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25268 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25269 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25270 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25271 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25272 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25273 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25274 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25275 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25276 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25277 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25278 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25279 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25280 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25281 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25282 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25283 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25284 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25285 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25286 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25287 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25288 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25289 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25290 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25291 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25292 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25293 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25294 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25295 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25296 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25297 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25298 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25299 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25300 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25301 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25302 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25303 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25304 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25305 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25306 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25307 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25308 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25309 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25310 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25311 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25312 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25313 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25314 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25315 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25316 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25317 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25318 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25319 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25320 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25321 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25322 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25323 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25324 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25325 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25326 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25327 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25328 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25329 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25330 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25331 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25332 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25333 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25334 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25335 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25336 DATA IDOLD /0/
25337
25338 ONE = 1.0D0
25339 IF (ITAB(1,IDBAMJ).LE.200) THEN
25340 ID = ITAB(K,IDBAMJ)
25341 ELSE
25342 IF(IDOLD.NE.IDBAMJ) THEN
25343 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25344 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25345 ELSE
25346 IDOLD = 0
25347 ENDIF
25348 ID = ITAB(K,IT)
25349 ENDIF
25350 IDOLD = IDBAMJ
25351 IDT_IBJQUA = ID
25352
25353 RETURN
25354 END
25355
25356*$ CREATE IDT_ICIHAD.FOR
25357*COPY IDT_ICIHAD
25358*
25359*===icihad=============================================================*
25360*
25361 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25362
25363************************************************************************
25364* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25365* This is a completely new version dated 25.10.95. *
25366* Renamed to be not in conflict with the modified PHOJET-version *
25367************************************************************************
25368
25369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25370 SAVE
25371
25372* hadron index conversion (BAMJET <--> PDG)
25373 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25374 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25375 & IAMCIN(210)
25376
25377 IDT_ICIHAD = 0
25378 KPDG = ABS(MCIND)
25379 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25380 IF (MCIND.LT.0) THEN
25381 JSIGN = 1
25382 ELSE
25383 JSIGN = 2
25384 ENDIF
25385 IF (KPDG.GE.10000) THEN
25386 DO 1 I=1,19
25387 IDT_ICIHAD = IBAM5(JSIGN,I)
25388 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25389 IDT_ICIHAD = 0
25390 1 CONTINUE
25391 ELSEIF (KPDG.GE.1000) THEN
25392 DO 2 I=1,29
25393 IDT_ICIHAD = IBAM4(JSIGN,I)
25394 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25395 IDT_ICIHAD = 0
25396 2 CONTINUE
25397 ELSEIF (KPDG.GE.100) THEN
25398 DO 3 I=1,22
25399 IDT_ICIHAD = IBAM3(JSIGN,I)
25400 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25401 IDT_ICIHAD = 0
25402 3 CONTINUE
25403 ELSEIF (KPDG.GE.10) THEN
25404 DO 4 I=1,7
25405 IDT_ICIHAD = IBAM2(JSIGN,I)
25406 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25407 IDT_ICIHAD = 0
25408 4 CONTINUE
25409 ENDIF
25410 5 CONTINUE
25411
25412 RETURN
25413 END
25414
25415*$ CREATE IDT_IPDGHA.FOR
25416*COPY IDT_IPDGHA
25417*
25418*===ipdgha=============================================================*
25419*
25420 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25421
25422************************************************************************
25423* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25424* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25425* Renamed to be not in conflict with the modified PHOJET-version *
25426************************************************************************
25427
25428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25429 SAVE
25430
25431* hadron index conversion (BAMJET <--> PDG)
25432 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25433 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25434 & IAMCIN(210)
25435
25436 IDT_IPDGHA = IAMCIN(MCIND)
25437
25438 RETURN
25439 END
25440
25441*$ CREATE DT_FLAHAD.FOR
25442*COPY DT_FLAHAD
25443*
25444*===flahad=============================================================*
25445*
25446 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25447
25448************************************************************************
25449* sampling of FLAvor composition for HADrons/photons *
25450* ID BAMJET-id of hadron *
25451* IF1,2,3 flavor content *
25452* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25453* Note: - u,d numbering as in BAMJET *
25454* - ID .le. 30 !! *
25455* This version dated 12.03.96 is written by S. Roesler *
25456************************************************************************
25457
25458 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25459 SAVE
25460
25461* auxiliary common for reggeon exchange (DTUNUC 1.x)
25462 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25463 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25464 & IQTCHR(-6:6),MQUARK(3,39)
25465
25466 DIMENSION JSEL(3,6)
25467 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25468
25469 ONE = 1.0D0
25470 IF (ID.EQ.7) THEN
25471* photon (charge dependent flavour sampling)
25472 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25473 IF (K.LE.4) THEN
25474 IF1 = 2
25475 IF2 = -2
25476 ELSE IF(K.EQ.5) THEN
25477 IF1 = 1
25478 IF2 = -1
25479 ELSE
25480 IF1 = 3
25481 IF2 = -3
25482 ENDIF
25483 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25484 K = IF1
25485 IF1 = IF2
25486 IF2 = K
25487 ENDIF
25488 IF3 = 0
25489 ELSE
25490* hadron
25491 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25492 IF1 = MQUARK(JSEL(1,IX),ID)
25493 IF2 = MQUARK(JSEL(2,IX),ID)
25494 IF3 = MQUARK(JSEL(3,IX),ID)
25495 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25496 IF1 = IF3
25497 IF3 = 0
25498 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25499 IF2 = IF3
25500 IF3 = 0
25501 ENDIF
25502 ENDIF
25503
25504 RETURN
25505 END
25506
25507*$ CREATE IDT_MCHAD.FOR
25508*COPY IDT_MCHAD
25509*
25510*===mchad==============================================================*
25511*
25512 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25513
25514************************************************************************
25515* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25516* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25517* *
25518* Last change 28.12.2006 by S. Roesler. *
25519************************************************************************
25520
25521 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25522 SAVE
25523
25524 DIMENSION ITRANS(210)
25525 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25526 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25527 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25528 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25529 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25530 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25531 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25532
25533 IF ( ITDTU .GT. 0 ) THEN
25534 IDT_MCHAD = ITRANS(ITDTU)
25535 ELSE
25536 IDT_MCHAD = -1
25537 END IF
25538
25539 RETURN
25540 END
25541
25542************************************************************************
25543* *
25544* 3) Energy-momentum and quantum number conservation check routines *
25545* *
25546************************************************************************
25547*$ CREATE DT_EMC1.FOR
25548*COPY DT_EMC1
25549*
25550*===emc1===============================================================*
25551*
25552 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25553
25554************************************************************************
25555* This version dated 15.12.94 is written by S. Roesler *
25556************************************************************************
25557
25558 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25559 SAVE
25560
25561 PARAMETER ( LINP = 10 ,
25562 & LOUT = 6 ,
25563 & LDAT = 9 )
25564
25565 PARAMETER (TINY10=1.0D-10)
25566
25567 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25568
25569 IREJ = 0
25570
25571 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25572 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25573
25574 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25575 IF (MODE.EQ.1) THEN
25576 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25577 ELSEIF (MODE.EQ.2) THEN
25578 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25579 ENDIF
25580 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25581 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25582 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25583 ELSEIF (MODE.LT.0) THEN
25584 IF (MODE.EQ.-1) THEN
25585 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25586 ELSEIF (MODE.EQ.-2) THEN
25587 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25588 ENDIF
25589 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25590 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25591 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25592 ENDIF
25593
25594 IF (ABS(MODE).EQ.3) THEN
25595 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25596 IF (IREJ1.NE.0) GOTO 9999
25597 ENDIF
25598 RETURN
25599
25600 9999 CONTINUE
25601 IREJ = 1
25602 RETURN
25603 END
25604
25605*$ CREATE DT_EMC2.FOR
25606*COPY DT_EMC2
25607*
25608*===emc2===============================================================*
25609*
25610 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25611 & MODE,IPOS,IREJ)
25612
25613************************************************************************
25614* MODE = 1 energy-momentum cons. check *
25615* = 2 flavor-cons. check *
25616* = 3 energy-momentum & flavor cons. check *
25617* = 4 energy-momentum & charge cons. check *
25618* = 5 energy-momentum & flavor & charge cons. check *
25619* This version dated 16.01.95 is written by S. Roesler *
25620************************************************************************
25621
25622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25623 SAVE
25624
25625 PARAMETER ( LINP = 10 ,
25626 & LOUT = 6 ,
25627 & LDAT = 9 )
25628
25629 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25630
25631* event history
25632
25633 PARAMETER (NMXHKK=200000)
25634
25635 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25636 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25637 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25638
25639* extended event history
25640 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25641 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25642 & IHIST(2,NMXHKK)
25643
25644 IREJ = 0
25645 IREJ1 = 0
25646 IREJ2 = 0
25647 IREJ3 = 0
25648
25649 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25650 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25651 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25652 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25653 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25654 DO 1 I=1,NHKK
25655 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25656 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25657 & (ISTHKK(I).EQ.IP5)) THEN
25658 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25659 & .OR.(MODE.EQ.5))
25660 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25661 & 2,IDUM,IDUM)
25662 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25663 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25664 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25665 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25666 ENDIF
25667 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25668 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25669 & (ISTHKK(I).EQ.IN5)) THEN
25670 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25671 & .OR.(MODE.EQ.5))
25672 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25673 & 2,IDUM,IDUM)
25674 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25675 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25676 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25677 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25678 ENDIF
25679 1 CONTINUE
25680 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25681 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25682 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25683 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25684 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25685 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25686
25687 RETURN
25688
25689 9999 CONTINUE
25690 IREJ = 1
25691 RETURN
25692 END
25693
25694*$ CREATE DT_EVTEMC.FOR
25695*COPY DT_EVTEMC
25696*
25697*===evtemc=============================================================*
25698*
25699 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25700
25701************************************************************************
25702* This version dated 13.12.94 is written by S. Roesler *
25703************************************************************************
25704
25705 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25706 SAVE
25707
25708 PARAMETER ( LINP = 10 ,
25709 & LOUT = 6 ,
25710 & LDAT = 9 )
25711
25712 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25713 & ZERO=0.0D0)
25714
25715* event history
25716
25717 PARAMETER (NMXHKK=200000)
25718
25719 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25720 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25721 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25722
25723* flags for input different options
25724 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25725 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25726 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25727
25728 IREJ = 0
25729
25730 MODE = IMODE
25731 CHKLEV = TINY10
25732 IF (MODE.EQ.4) THEN
25733 CHKLEV = TINY2
25734 MODE = 3
25735 ELSEIF (MODE.EQ.5) THEN
25736 CHKLEV = TINY1
25737 MODE = 3
25738 ELSEIF (MODE.EQ.-1) THEN
25739 CHKLEV = EIO
25740 MODE = 3
25741 ENDIF
25742
25743 IF (ABS(MODE).EQ.3) THEN
25744 PXDEV = PX
25745 PYDEV = PY
25746 PZDEV = PZ
25747 EDEV = E
25748 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25749 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25750 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25751 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25752 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25753 & ' event ',NEVHKK,
25754 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25755 PX = 0.0D0
25756 PY = 0.0D0
25757 PZ = 0.0D0
25758 E = 0.0D0
25759 GOTO 9999
25760 ENDIF
25761 PX = 0.0D0
25762 PY = 0.0D0
25763 PZ = 0.0D0
25764 E = 0.0D0
25765 RETURN
25766 ENDIF
25767
25768 IF (MODE.EQ.1) THEN
25769 PX = 0.0D0
25770 PY = 0.0D0
25771 PZ = 0.0D0
25772 E = 0.0D0
25773 ENDIF
25774
25775 PX = PX+PXIO
25776 PY = PY+PYIO
25777 PZ = PZ+PZIO
25778 E = E+EIO
25779
25780 RETURN
25781
25782 9999 CONTINUE
25783 IREJ = 1
25784 RETURN
25785 END
25786
25787*$ CREATE DT_EVTFLC.FOR
25788*COPY DT_EVTFLC
25789*
25790*===evtflc=============================================================*
25791*
25792 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25793
25794************************************************************************
25795* Flavor conservation check. *
25796* ID identity of particle *
25797* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25798* = 2 ID for particle/resonance in BAMJET numbering scheme *
25799* = 3 ID for particle/resonance in PDG numbering scheme *
25800* MODE = 1 initialization and add ID *
25801* =-1 initialization and subtract ID *
25802* = 2 add ID *
25803* =-2 subtract ID *
25804* = 3 check flavor cons. *
25805* IPOS flag to give position of call of EVTFLC to output *
25806* unit in case of violation *
25807* This version dated 10.01.95 is written by S. Roesler *
25808************************************************************************
25809
25810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25811 SAVE
25812
25813 PARAMETER ( LINP = 10 ,
25814 & LOUT = 6 ,
25815 & LDAT = 9 )
25816
25817 PARAMETER (TINY10=1.0D-10)
25818
25819 IREJ = 0
25820
25821 IF (MODE.EQ.3) THEN
25822 IF (IFL.NE.0) THEN
25823 WRITE(LOUT,'(1X,A,I3,A,I3)')
25824 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25825 & ' ! IFL = ',IFL
25826 IFL = 0
25827 GOTO 9999
25828 ENDIF
25829 IFL = 0
25830 RETURN
25831 ENDIF
25832
25833 IF (MODE.EQ.1) IFL = 0
25834 IF (ID.EQ.0) RETURN
25835
25836 IF (ID1.EQ.1) THEN
25837 IDD = ABS(ID)
25838 NQ = 1
25839 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25840 IF (IDD.GE.1000) NQ = 3
25841 DO 1 I=1,NQ
25842 IFBAM = IDT_IPDG2B(ID,I,2)
25843 IF (ABS(IFBAM).EQ.1) THEN
25844 IFBAM = SIGN(2,IFBAM)
25845 ELSEIF (ABS(IFBAM).EQ.2) THEN
25846 IFBAM = SIGN(1,IFBAM)
25847 ENDIF
25848 IF (MODE.GT.0) THEN
25849 IFL = IFL+IFBAM
25850 ELSE
25851 IFL = IFL-IFBAM
25852 ENDIF
25853 1 CONTINUE
25854 RETURN
25855 ENDIF
25856
25857 IDD = ID
25858 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25859 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25860 DO 2 I=1,3
25861 IF (MODE.GT.0) THEN
25862 IFL = IFL+IDT_IQUARK(I,IDD)
25863 ELSE
25864 IFL = IFL-IDT_IQUARK(I,IDD)
25865 ENDIF
25866 2 CONTINUE
25867 ENDIF
25868 RETURN
25869
25870 9999 CONTINUE
25871 IREJ = 1
25872 RETURN
25873 END
25874
25875*$ CREATE DT_EVTCHG.FOR
25876*COPY DT_EVTCHG
25877*
25878*===evtchg=============================================================*
25879*
25880 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25881
25882************************************************************************
25883* Charge conservation check. *
25884* ID identity of particle (PDG-numbering scheme) *
25885* MODE = 1 initialization *
25886* =-2 subtract ID-charge *
25887* = 2 add ID-charge *
25888* = 3 check charge cons. *
25889* IPOS flag to give position of call of EVTCHG to output *
25890* unit in case of violation *
25891* This version dated 10.01.95 is written by S. Roesler *
25892* Last change: s.r. 21.01.01 *
25893************************************************************************
25894
25895 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25896 SAVE
25897
25898 PARAMETER ( LINP = 10 ,
25899 & LOUT = 6 ,
25900 & LDAT = 9 )
25901
25902* event history
25903
25904 PARAMETER (NMXHKK=200000)
25905
25906 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25907 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25908 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25909
25910* particle properties (BAMJET index convention)
25911 CHARACTER*8 ANAME
25912 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25913 & IICH(210),IIBAR(210),K1(210),K2(210)
25914
25915 IREJ = 0
25916
25917 IF (MODE.EQ.1) THEN
25918 ICH = 0
25919 IBAR = 0
25920 RETURN
25921 ENDIF
25922
25923 IF (MODE.EQ.3) THEN
25924 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25925 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25926 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25927 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25928 ICH = 0
25929 IBAR = 0
25930 GOTO 9999
25931 ENDIF
25932 ICH = 0
25933 IBAR = 0
25934 RETURN
25935 ENDIF
25936
25937 IF (ID.EQ.0) RETURN
25938
25939 IDD = IDT_ICIHAD(ID)
25940* modification 21.1.01: use intrinsic phojet-functions to determine charge
25941* and baryon number
25942C IF (IDD.GT.0) THEN
25943C IF (MODE.EQ.2) THEN
25944C ICH = ICH+IICH(IDD)
25945C IBAR = IBAR+IIBAR(IDD)
25946C ELSEIF (MODE.EQ.-2) THEN
25947C ICH = ICH-IICH(IDD)
25948C IBAR = IBAR-IIBAR(IDD)
25949C ENDIF
25950C ELSE
25951C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25952C CALL DT_EVTOUT(4)
25953C STOP
25954C ENDIF
25955 IF (MODE.EQ.2) THEN
25956 ICH = ICH+IPHO_CHR3(ID,1)/3
25957 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25958 ELSEIF (MODE.EQ.-2) THEN
25959 ICH = ICH-IPHO_CHR3(ID,1)/3
25960 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25961 ENDIF
25962
25963 RETURN
25964
25965 9999 CONTINUE
25966 IREJ = 1
25967 RETURN
25968 END
25969
25970************************************************************************
25971* *
25972* 4) Transformations *
25973* *
25974************************************************************************
25975*$ CREATE DT_LTINI.FOR
25976*COPY DT_LTINI
25977*
25978*===ltini==============================================================*
25979*
25980 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25981
25982************************************************************************
25983* Initializations of Lorentz-transformations, calculation of Lorentz- *
25984* parameters. *
25985* This version dated 13.11.95 is written by S. Roesler. *
25986************************************************************************
25987
25988 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25989 SAVE
25990
25991 PARAMETER ( LINP = 10 ,
25992 & LOUT = 6 ,
25993 & LDAT = 9 )
25994
25995 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25996 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25997
25998* Lorentz-parameters of the current interaction
25999 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26000 & UMO,PPCM,EPROJ,PPROJ
26001
26002* properties of photon/lepton projectiles
26003 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26004
26005* particle properties (BAMJET index convention)
26006 CHARACTER*8 ANAME
26007 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26008 & IICH(210),IIBAR(210),K1(210),K2(210)
26009
26010* nucleon-nucleon event-generator
26011 CHARACTER*8 CMODEL
26012 LOGICAL LPHOIN
26013 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26014
26015 Q2 = VIRT
26016 IDP = IDPR
26017 IF (MCGENE.NE.3) THEN
26018* lepton-projectiles and PHOJET: initialize real photon instead
26019 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26020 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26021 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26022 IDP = 7
26023 Q2 = ZERO
26024 ENDIF
26025 ENDIF
26026 IDT = IDTA
26027 EPN = EPN0
26028 PPN = PPN0
26029 ECM = ECM0
26030 AMP = AAM(IDP)-SQRT(ABS(Q2))
26031 AMT = AAM(IDT)
26032 AMP2 = SIGN(AMP**2,AMP)
26033 AMT2 = AMT**2
26034 IF (ECM0.GT.ZERO) THEN
26035 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26036 IF (AMP2.GT.ZERO) THEN
26037 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26038 ELSE
26039 PPN = SQRT(EPN**2-AMP2)
26040 ENDIF
26041 ELSE
26042 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26043 IF (IDP.EQ.7) EPN = ABS(EPN)
26044 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26045 IF (AMP2.GT.ZERO) THEN
26046 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26047 ELSE
26048 PPN = SQRT(EPN**2-AMP2)
26049 ENDIF
26050 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26051 IF (AMP2.GT.ZERO) THEN
26052 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26053 ELSE
26054 EPN = SQRT(PPN**2+AMP2)
26055 ENDIF
26056 ENDIF
26057 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26058 ENDIF
26059 UMO = ECM
26060 EPROJ = EPN
26061 PPROJ = PPN
26062 IF (AMP2.GT.ZERO) THEN
26063 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26064 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26065 ELSE
26066 ETARG = TINY10
26067 PTARG = TINY10
26068 ENDIF
26069* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26070 IF (IDP.EQ.7) THEN
26071 PGAMM(1) = ZERO
26072 PGAMM(2) = ZERO
26073 AMGAM = AMP
26074 AMGAM2 = AMP2
26075 IF (ECM0.GT.ZERO) THEN
26076 S = ECM0**2
26077 ELSE
26078 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26079 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26080 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26081 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26082 ENDIF
26083 ENDIF
26084 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26085 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26086 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26087 IF (MODE.EQ.1) THEN
26088 PNUCL(1) = ZERO
26089 PNUCL(2) = ZERO
26090 PNUCL(3) = -PGAMM(3)
26091 PNUCL(4) = SQRT(S)-PGAMM(4)
26092 ENDIF
26093 ENDIF
26094 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26095 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26096 PLEPT0(1) = ZERO
26097 PLEPT0(2) = ZERO
26098* neglect lepton masses
26099C AMLPT2 = AAM(IDPR)**2
26100 AMLPT2 = ZERO
26101*
26102 IF (ECM0.GT.ZERO) THEN
26103 S = ECM0**2
26104 ELSE
26105 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26106 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26107 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26108 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26109 ENDIF
26110 ENDIF
26111 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26112 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26113 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26114 PNUCL(1) = ZERO
26115 PNUCL(2) = ZERO
26116 PNUCL(3) = -PLEPT0(3)
26117 PNUCL(4) = SQRT(S)-PLEPT0(4)
26118 ENDIF
26119* Lorentz-parameter for transformation Lab. - projectile rest system
26120 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26121 GALAB = TINY10
26122 BGLAB = TINY10
26123 BLAB = TINY10
26124 ELSE
26125 GALAB = EPROJ/AMP
26126 BGLAB = PPROJ/AMP
26127 BLAB = BGLAB/GALAB
26128 ENDIF
26129* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26130 IF (IDP.EQ.7) THEN
26131 GACMS(1) = TINY10
26132 BGCMS(1) = TINY10
26133 ELSE
26134 GACMS(1) = (ETARG+AMP)/UMO
26135 BGCMS(1) = PTARG/UMO
26136 ENDIF
26137* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26138 GACMS(2) = (EPROJ+AMT)/UMO
26139 BGCMS(2) = PPROJ/UMO
26140 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26141
26142 EPN0 = EPN
26143 PPN0 = PPN
26144 ECM0 = ECM
26145
26146 RETURN
26147 END
26148
26149*$ CREATE DT_LTRANS.FOR
26150*COPY DT_LTRANS
26151*
26152*===ltrans=============================================================*
26153*
26154 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26155
26156************************************************************************
26157* Lorentz-transformations. *
26158* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26159* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26160* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26161* This version dated 01.11.95 is written by S. Roesler. *
26162************************************************************************
26163
26164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26165 SAVE
26166
26167 PARAMETER ( LINP = 10 ,
26168 & LOUT = 6 ,
26169 & LDAT = 9 )
26170
26171 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26172
26173 PARAMETER (SQTINF=1.0D+15)
26174
26175* particle properties (BAMJET index convention)
26176 CHARACTER*8 ANAME
26177 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26178 & IICH(210),IIBAR(210),K1(210),K2(210)
26179
26180 PXO = PXI
26181 PYO = PYI
26182 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26183
26184* check particle mass for consistency (numerical rounding errors)
26185 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26186 AMO2 = (PEO-PO)*(PEO+PO)
26187 AMORQ2 = AAM(ID)**2
26188 AMDIF2 = ABS(AMO2-AMORQ2)
26189 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26190 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26191 PEO = PEO+DELTA
26192 PO1 = PO -DELTA
26193 PXO = PXO*PO1/PO
26194 PYO = PYO*PO1/PO
26195 PZO = PZO*PO1/PO
26196C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26197 ENDIF
26198
26199 RETURN
26200 END
26201
26202*$ CREATE DT_LTNUC.FOR
26203*COPY DT_LTNUC
26204*
26205*===ltnuc==============================================================*
26206*
26207 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26208
26209************************************************************************
26210* Lorentz-transformations. *
26211* PIN longitudnal momentum (input) *
26212* EIN energy (input) *
26213* POUT transformed long. momentum (output) *
26214* EOUT transformed energy (output) *
26215* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26216* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26217* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26218* This version dated 01.11.95 is written by S. Roesler. *
26219************************************************************************
26220
26221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26222 SAVE
26223
26224 PARAMETER ( LINP = 10 ,
26225 & LOUT = 6 ,
26226 & LDAT = 9 )
26227
26228 PARAMETER (ZERO=0.0D0)
26229
26230* Lorentz-parameters of the current interaction
26231 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26232 & UMO,PPCM,EPROJ,PPROJ
26233
26234 BDUM1 = ZERO
26235 BDUM2 = ZERO
26236 PDUM1 = ZERO
26237 PDUM2 = ZERO
26238 IF (ABS(MODE).EQ.1) THEN
26239 BG = -SIGN(BGLAB,DBLE(MODE))
26240 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26241 & DUM1,DUM2,DUM3,POUT,EOUT)
26242 ELSEIF (ABS(MODE).EQ.2) THEN
26243 BG = SIGN(BGCMS(1),DBLE(MODE))
26244 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26245 & DUM1,DUM2,DUM3,POUT,EOUT)
26246 ELSEIF (ABS(MODE).EQ.3) THEN
26247 BG = -SIGN(BGCMS(2),DBLE(MODE))
26248 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26249 & DUM1,DUM2,DUM3,POUT,EOUT)
26250 ELSE
26251 WRITE(LOUT,1000) MODE
26252 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26253 EOUT = EIN
26254 POUT = PIN
26255 ENDIF
26256
26257 RETURN
26258 END
26259
26260*$ CREATE DT_DALTRA.FOR
26261*COPY DT_DALTRA
26262*
26263*===daltra=============================================================*
26264*
26265 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26266
26267************************************************************************
26268* Arbitrary Lorentz-transformation. *
26269* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26270************************************************************************
26271
26272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26273 SAVE
26274 PARAMETER (ONE=1.0D0)
26275
26276 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26277 PE = EP/(GA+ONE)+EC
26278 PX = PCX+BGX*PE
26279 PY = PCY+BGY*PE
26280 PZ = PCZ+BGZ*PE
26281 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26282 E = GA*EC+EP
26283
26284 RETURN
26285 END
26286
26287*$ CREATE DT_DTRAFO.FOR
26288*COPY DT_DTRAFO
26289*
26290*====dtrafo============================================================*
26291*
26292 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26293 & PL,CXL,CYL,CZL,EL)
26294
26295C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26296
26297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26298 SAVE
26299
26300 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26301 SID = SQRT(1.D0-COD*COD)
26302 PLX = P*SID*COF
26303 PLY = P*SID*SIF
26304 PCMZ = P*COD
26305 PLZ = GAM*PCMZ+BGAM*ECM
26306 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26307 EL = GAM*ECM+BGAM*PCMZ
26308C ROTATION INTO THE ORIGINAL DIRECTION
26309 COZ = PLZ/PL
26310 SIZ = SQRT(1.D0-COZ**2)
26311 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26312
26313 RETURN
26314 END
26315
26316*$ CREATE DT_STTRAN.FOR
26317*COPY DT_STTRAN
26318*
26319*====sttran============================================================*
26320*
26321 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26322
26323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26324 SAVE
26325 DATA ANGLSQ/1.D-30/
26326************************************************************************
26327* VERSION BY J. RANFT *
26328* LEIPZIG *
26329* *
26330* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26331* *
26332* INPUT VARIABLES: *
26333* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26334* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26335* ANGLE OF "SCATTERING" *
26336* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26337* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26338* OF "SCATTERING" *
26339* *
26340* OUTPUT VARIABLES: *
26341* X,Y,Z = NEW DIRECTION COSINES *
26342* *
26343* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26344************************************************************************
26345*
26346*
26347* Changed by A. Ferrari
26348*
26349* IF (ABS(XO)-0.0001D0) 1,1,2
26350* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26351* 3 CONTINUE
26352 A = XO**2 + YO**2
26353 IF ( A .LT. ANGLSQ ) THEN
26354 X=SDE*CFE
26355 Y=SDE*SFE
26356 Z=CDE*ZO
26357 ELSE
26358 XI=SDE*CFE
26359 YI=SDE*SFE
26360 ZI=CDE
26361 A=SQRT(A)
26362 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26363 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26364 Z=A*YI+ZO*ZI
26365 ENDIF
26366
26367 RETURN
26368 END
26369
26370*$ CREATE DT_MYTRAN.FOR
26371*COPY DT_MYTRAN
26372*
26373*===mytran=============================================================*
26374*
26375 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26376
26377************************************************************************
26378* This subroutine rotates the coordinate frame *
26379* a) theta around y *
26380* b) phi around z if IMODE = 1 *
26381* *
26382* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26383* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26384* z' 0 0 1 -sin(th) 0 cos(th) z *
26385* *
26386* and vice versa if IMODE = 0. *
26387* This version dated 5.4.94 is based on the original version DTRAN *
26388* by J. Ranft and is written by S. Roesler. *
26389************************************************************************
26390
26391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26392 SAVE
26393
26394 PARAMETER ( LINP = 10 ,
26395 & LOUT = 6 ,
26396 & LDAT = 9 )
26397
26398 IF (IMODE.EQ.1) THEN
26399 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26400 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26401 Z=-SDE *XO +CDE *ZO
26402 ELSE
26403 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26404 Y= -SFE*XO+CFE*YO
26405 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26406 ENDIF
26407 RETURN
26408 END
26409
26410*$ CREATE DT_LT2LAO.FOR
26411*COPY DT_LT2LAO
26412*
26413*===lt2lab=============================================================*
26414*
26415 SUBROUTINE DT_LT2LAO
26416
26417************************************************************************
26418* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26419* for final state particles/fragments defined in nucleon-nucleon-cms *
26420* and transforms them back to the lab. *
26421* This version dated 16.11.95 is written by S. Roesler *
26422************************************************************************
26423
26424 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26425 SAVE
26426
26427 PARAMETER ( LINP = 10 ,
26428 & LOUT = 6 ,
26429 & LDAT = 9 )
26430
26431* event history
26432
26433 PARAMETER (NMXHKK=200000)
26434
26435 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26436 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26437 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26438
26439* extended event history
26440 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26441 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26442 & IHIST(2,NMXHKK)
26443
26444 NEND = NHKK
26445 NPOINT(5) = NHKK+1
26446 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26447 DO 1 I=NPOINT(4),NEND
26448C DO 1 I=1,NEND
26449 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26450 & (ISTHKK(I).EQ.1001)) THEN
26451 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26452 NOB = NOBAM(I)
26453 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26454 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26455 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26456 ISTHKK(I) = 3*ISTHKK(I)
26457 NOBAM(NHKK) = NOB
26458 ELSE
26459 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26460 ISTHKK(I) = SIGN(3,ISTHKK(I))
26461 ENDIF
26462 JDAHKK(1,I) = NHKK
26463 ENDIF
26464 1 CONTINUE
26465
26466 RETURN
26467 END
26468
26469*$ CREATE DT_LT2LAB.FOR
26470*COPY DT_LT2LAB
26471*
26472*===lt2lab=============================================================*
26473*
26474 SUBROUTINE DT_LT2LAB
26475
26476************************************************************************
26477* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26478* for final state particles/fragments defined in nucleon-nucleon-cms *
26479* and transforms them to the lab. *
26480* This version dated 07.01.96 is written by S. Roesler *
26481************************************************************************
26482
26483 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26484 SAVE
26485
26486 PARAMETER ( LINP = 10 ,
26487 & LOUT = 6 ,
26488 & LDAT = 9 )
26489
26490* event history
26491
26492 PARAMETER (NMXHKK=200000)
26493
26494 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26495 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26496 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26497
26498* extended event history
26499 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26500 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26501 & IHIST(2,NMXHKK)
26502
26503 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26504 DO 1 I=NPOINT(4),NHKK
26505 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26506 & (ISTHKK(I).EQ.1001)) THEN
26507 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26508 PHKK(3,I) = PZ
26509 PHKK(4,I) = PE
26510 ENDIF
26511 1 CONTINUE
26512
26513 RETURN
26514 END
26515
26516************************************************************************
26517* *
26518* 5) Sampling from distributions *
26519* *
26520************************************************************************
26521*$ CREATE IDT_NPOISS.FOR
26522*COPY IDT_NPOISS
26523*
26524*===npoiss=============================================================*
26525*
26526 INTEGER FUNCTION IDT_NPOISS(AVN)
26527
26528************************************************************************
26529* Sample according to Poisson distribution with Poisson parameter AVN. *
26530* The original version written by J. Ranft. *
26531* This version dated 11.1.95 is written by S. Roesler. *
26532************************************************************************
26533
26534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26535 SAVE
26536
26537 PARAMETER ( LINP = 10 ,
26538 & LOUT = 6 ,
26539 & LDAT = 9 )
26540
26541 EXPAVN = EXP(-AVN)
26542 K = 1
26543 A = 1.0D0
26544
26545 10 CONTINUE
26546 A = DT_RNDM(A)*A
26547 IF (A.GE.EXPAVN) THEN
26548 K = K+1
26549 GOTO 10
26550 ENDIF
26551 IDT_NPOISS = K-1
26552
26553 RETURN
26554 END
26555
26556*$ CREATE DT_SAMPXB.FOR
26557*COPY DT_SAMPXB
26558*
26559*===sampxb=============================================================*
26560*
26561 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26562
26563************************************************************************
26564* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26565* Processed by S. Roesler, 6.5.95 *
26566************************************************************************
26567
26568 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26569 SAVE
26570 PARAMETER (TWO=2.0D0)
26571
26572 A1 = LOG(X1+SQRT(X1**2+B**2))
26573 A2 = LOG(X2+SQRT(X2**2+B**2))
26574 AN = A2-A1
26575 A = AN*DT_RNDM(A1)+A1
26576 BB = EXP(A)
26577 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26578
26579 RETURN
26580 END
26581
26582*$ CREATE DT_SAMPEX.FOR
26583*COPY DT_SAMPEX
26584*
26585*===sampex=============================================================*
26586*
26587 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26588
26589************************************************************************
26590* Sampling from f(x)=1./x between x1 and x2. *
26591* Processed by S. Roesler, 6.5.95 *
26592************************************************************************
26593
26594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26595 SAVE
26596 PARAMETER (ONE=1.0D0)
26597
26598 R = DT_RNDM(X1)
26599 AL1 = LOG(X1)
26600 AL2 = LOG(X2)
26601 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26602
26603 RETURN
26604 END
26605
26606*$ CREATE DT_SAMSQX.FOR
26607*COPY DT_SAMSQX
26608*
26609*===samsqx=============================================================*
26610*
26611 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26612
26613************************************************************************
26614* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26615* Processed by S. Roesler, 6.5.95 *
26616************************************************************************
26617
26618 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26619 SAVE
26620 PARAMETER (ONE=1.0D0)
26621
26622 R = DT_RNDM(X1)
26623 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26624
26625 RETURN
26626 END
26627
26628*$ CREATE DT_SAMPLW.FOR
26629*COPY DT_SAMPLW
26630*
26631*===samplw=============================================================*
26632*
26633 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26634
26635************************************************************************
26636* Sampling from f(x)=1/x^b between x_min and x_max. *
26637* S. Roesler, 18.4.98 *
26638************************************************************************
26639
26640 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26641 SAVE
26642 PARAMETER (ONE=1.0D0)
26643
26644 R = DT_RNDM(B)
26645 IF (B.EQ.ONE) THEN
26646 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26647 ELSE
26648 ONEMB = ONE-B
26649 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26650 ENDIF
26651
26652 RETURN
26653 END
26654
26655*$ CREATE DT_BETREJ.FOR
26656*COPY DT_BETREJ
26657*
26658*===betrej=============================================================*
26659*
26660 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26661
26662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26663 SAVE
26664
26665 PARAMETER ( LINP = 10 ,
26666 & LOUT = 6 ,
26667 & LDAT = 9 )
26668
26669 PARAMETER (ONE=1.0D0)
26670
26671 IF (XMIN.GE.XMAX)THEN
26672 WRITE (LOUT,500) XMIN,XMAX
26673 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26674 STOP
26675 ENDIF
26676
26677 10 CONTINUE
26678 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26679 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26680 YY = BETMAX*DT_RNDM(XX)
26681 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26682 IF (YY.GT.BETXX) GOTO 10
26683 DT_BETREJ = XX
26684
26685 RETURN
26686 END
26687
26688*$ CREATE DT_DGAMRN.FOR
26689*COPY DT_DGAMRN
26690*
26691*===dgamrn=============================================================*
26692*
26693 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26694
26695************************************************************************
26696* Sampling from Gamma-distribution. *
26697* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26698* Processed by S. Roesler, 6.5.95 *
26699************************************************************************
26700
26701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26702 SAVE
26703 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26704
26705 NCOU = 0
26706 N = INT(ETA)
26707 F = ETA-DBLE(N)
26708 IF (F.EQ.ZERO) GOTO 20
26709 10 R = DT_RNDM(F)
26710 NCOU = NCOU+1
26711 IF (NCOU.GE.11) GOTO 20
26712 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26713 YYY = LOG(DT_RNDM(R)+TINY9)/F
26714 IF (ABS(YYY).GT.50.0D0) GOTO 20
26715 Y = EXP(YYY)
26716 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26717 GOTO 40
26718 20 Y = 0.0D0
26719 GOTO 50
26720 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26721 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26722 40 IF (N.EQ.0) GOTO 70
26723 50 Z = 1.0D0
26724 DO 60 I = 1,N
26725 60 Z = Z*DT_RNDM(Z)
26726 Y = Y-LOG(Z+TINY9)
26727 70 DT_DGAMRN = Y/ALAM
26728
26729 RETURN
26730 END
26731
26732*$ CREATE DT_DBETAR.FOR
26733*COPY DT_DBETAR
26734*
26735*===dbetar=============================================================*
26736*
26737 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26738
26739************************************************************************
26740* Sampling from Beta -distribution between 0.0 and 1.0 *
26741* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26742* Processed by S. Roesler, 6.5.95 *
26743************************************************************************
26744
26745 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26746 SAVE
26747
26748 Y = DT_DGAMRN(1.0D0,GAM)
26749 Z = DT_DGAMRN(1.0D0,ETA)
26750 DT_DBETAR = Y/(Y+Z)
26751
26752 RETURN
26753 END
26754
26755*$ CREATE DT_RANNOR.FOR
26756*COPY DT_RANNOR
26757*
26758*===rannor=============================================================*
26759*
26760 SUBROUTINE DT_RANNOR(X,Y)
26761
26762************************************************************************
26763* Sampling from Gaussian distribution. *
26764* Processed by S. Roesler, 6.5.95 *
26765************************************************************************
26766
26767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768 SAVE
26769 PARAMETER (TINY10=1.0D-10)
26770
26771 CALL DT_DSFECF(SFE,CFE)
26772 V = MAX(TINY10,DT_RNDM(X))
26773 A = SQRT(-2.D0*LOG(V))
26774 X = A*SFE
26775 Y = A*CFE
26776
26777 RETURN
26778 END
26779
26780*$ CREATE DT_DPOLI.FOR
26781*COPY DT_DPOLI
26782*
26783*===dpoli==============================================================*
26784*
26785 SUBROUTINE DT_DPOLI(CS,SI)
26786
26787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26788 SAVE
26789
26790 U = DT_RNDM(CS)
26791 CS = DT_RNDM(U)
26792 IF (U.LT.0.5D0) CS=-CS
26793 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26794
26795 RETURN
26796 END
26797
26798*$ CREATE DT_DSFECF.FOR
26799*COPY DT_DSFECF
26800*
26801*===dsfecf=============================================================*
26802*
26803 SUBROUTINE DT_DSFECF(SFE,CFE)
26804
26805 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26806 SAVE
26807 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26808
26809 1 CONTINUE
26810 X = DT_RNDM(SFE)
26811 Y = DT_RNDM(X)
26812 XX = X*X
26813 YY = Y*Y
26814 XY = XX+YY
26815 IF (XY.GT.ONE) GOTO 1
26816 CFE = (XX-YY)/XY
26817 SFE = TWO*X*Y/XY
26818 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26819 RETURN
26820 END
26821
26822*$ CREATE DT_RACO.FOR
26823*COPY DT_RACO
26824*
26825*===raco===============================================================*
26826*
26827 SUBROUTINE DT_RACO(WX,WY,WZ)
26828
26829************************************************************************
26830* Direction cosines of random uniform (isotropic) direction in three *
26831* dimensional space *
26832* Processed by S. Roesler, 20.11.95 *
26833************************************************************************
26834
26835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26836 SAVE
26837 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26838
26839 10 CONTINUE
26840 X = TWO*DT_RNDM(WX)-ONE
26841 Y = DT_RNDM(X)
26842 X2 = X*X
26843 Y2 = Y*Y
26844 IF (X2+Y2.GT.ONE) GOTO 10
26845
26846 CFE = (X2-Y2)/(X2+Y2)
26847 SFE = TWO*X*Y/(X2+Y2)
26848* z = 1/2 [ 1 + cos (theta) ]
26849 Z = DT_RNDM(X)
26850* 1/2 sin (theta)
26851 WZ = SQRT(Z*(ONE-Z))
26852 WX = TWO*WZ*CFE
26853 WY = TWO*WZ*SFE
26854 WZ = TWO*Z-ONE
26855
26856 RETURN
26857 END
26858
26859************************************************************************
26860* *
26861* 6) Special functions, algorithms and service routines *
26862* *
26863************************************************************************
26864*$ CREATE DT_YLAMB.FOR
26865*COPY DT_YLAMB
26866*
26867*===ylamb==============================================================*
26868*
26869 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26870
26871************************************************************************
26872* *
26873* auxiliary function for three particle decay mode *
26874* (standard LAMBDA**(1/2) function) *
26875* *
26876* Adopted from an original version written by R. Engel. *
26877* This version dated 12.12.94 is written by S. Roesler. *
26878************************************************************************
26879
26880 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26881 SAVE
26882
26883 YZ = Y-Z
26884 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26885 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26886 DT_YLAMB = SQRT(XLAM)
26887
26888 RETURN
26889 END
26890
26891*$ CREATE DT_SORT.FOR
26892*COPY DT_SORT
26893*
26894*===sort1==============================================================*
26895*
26896 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26897
26898************************************************************************
26899* This subroutine sorts entries in A in increasing/decreasing order *
26900* of A(3,i). *
26901* MODE = 1 increasing in A(3,i=1..N) *
26902* = 2 decreasing in A(3,i=1..N) *
26903* This version dated 21.04.95 is revised by S. Roesler *
26904************************************************************************
26905
26906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26907 SAVE
26908
26909 DIMENSION A(3,N)
26910
26911 M = I1
26912 10 CONTINUE
26913 M = I1-1
26914 IF (M.LE.0) RETURN
26915 L = 0
26916 DO 20 I=I0,M
26917 J = I+1
26918 IF (MODE.EQ.1) THEN
26919 IF (A(3,I).LE.A(3,J)) GOTO 20
26920 ELSE
26921 IF (A(3,I).GE.A(3,J)) GOTO 20
26922 ENDIF
26923 B = A(3,I)
26924 C = A(1,I)
26925 D = A(2,I)
26926 A(3,I) = A(3,J)
26927 A(2,I) = A(2,J)
26928 A(1,I) = A(1,J)
26929 A(3,J) = B
26930 A(1,J) = C
26931 A(2,J) = D
26932 L = 1
26933 20 CONTINUE
26934 IF (L.EQ.1) GOTO 10
26935
26936 RETURN
26937 END
26938
26939*$ CREATE DT_SORT1.FOR
26940*COPY DT_SORT1
26941*
26942*===sort1==============================================================*
26943*
26944 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26945
26946************************************************************************
26947* This subroutine sorts entries in A in increasing/decreasing order *
26948* of A(i). *
26949* MODE = 1 increasing in A(i=1..N) *
26950* = 2 decreasing in A(i=1..N) *
26951* This version dated 21.04.95 is revised by S. Roesler *
26952************************************************************************
26953
26954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26955 SAVE
26956
26957 DIMENSION A(N),IDX(N)
26958
26959 M = I1
26960 10 CONTINUE
26961 M = I1-1
26962 IF (M.LE.0) RETURN
26963 L = 0
26964 DO 20 I=I0,M
26965 J = I+1
26966 IF (MODE.EQ.1) THEN
26967 IF (A(I).LE.A(J)) GOTO 20
26968 ELSE
26969 IF (A(I).GE.A(J)) GOTO 20
26970 ENDIF
26971 B = A(I)
26972 A(I) = A(J)
26973 A(J) = B
26974 IX = IDX(I)
26975 IDX(I) = IDX(J)
26976 IDX(J) = IX
26977 L = 1
26978 20 CONTINUE
26979 IF (L.EQ.1) GOTO 10
26980
26981 RETURN
26982 END
26983
26984*$ CREATE DT_XTIME.FOR
26985*COPY DT_XTIME
26986*
26987*===xtime==============================================================*
26988*
26989 SUBROUTINE DT_XTIME
26990
26991 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26992 SAVE
26993
26994 PARAMETER ( LINP = 10 ,
26995 & LOUT = 6 ,
26996 & LDAT = 9 )
26997
26998 CHARACTER DAT*9,TIM*11
26999
27000 DAT = ' '
27001 TIM = ' '
27002C CALL GETDAT(IYEAR,IMONTH,IDAY)
27003C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27004
27005C CALL DATE(DAT)
27006C CALL TIME(TIM)
27007C WRITE(LOUT,1000) DAT,TIM
27008 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27009
27010 RETURN
27011 END
27012
27013************************************************************************
27014* *
27015* 7) Random number generator package *
27016* *
27017* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27018* SERVICE ROUTINES. *
27019* THE ALGORITHM IS FROM *
27020* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27021* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27022* IMPLEMENTATION BY K. HAHN DEC. 88, *
27023* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27024* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27025* THE PERIOD IS ABOUT 2**144, *
27026* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27027* THE PACKAGE CONTAINS *
27028* FUNCTION DT_RNDM(I) : GENERATOR *
27029* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27030* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27031* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27032* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27033*--- *
27034* FUNCTION DT_RNDM(I) *
27035* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27036* I - DUMMY VARIABLE, NOT USED *
27037* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27038* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27039* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27040* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27041* 12,34,56 ARE THE STANDARD VALUES *
27042* NB1 MUST BE IN 1..168 *
27043* 78 IS THE STANDARD VALUE *
27044* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27045* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27046* AS AFTER THE LAST DT_RNDMOU CALL ) *
27047* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27048* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27049* TAKES SEED FROM GENERATOR *
27050* U(97),C,CD,CM,I,J - SEED VALUES *
27051* SUBROUTINE DT_RNDMTE(IO) *
27052* TEST OF THE GENERATOR *
27053* IO - DEFINES OUTPUT *
27054* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27055* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27056* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27057* SAME STATUS *
27058* AS BEFORE CALL OF DT_RNDMTE *
27059************************************************************************
27060*$ CREATE DT_RNDM.FOR
27061*COPY DT_RNDM
27062*
27063*===rndm===============================================================*
27064*
27065c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27066c$$$
27067c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27068c$$$ SAVE
27069c$$$
27070c$$$* counter of calls to random number generator
27071c$$$* uncomment if needed
27072c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27073c$$$C LOGICAL LFIRST
27074c$$$C DATA LFIRST /.TRUE./
27075c$$$
27076c$$$* counter of calls to random number generator
27077c$$$* uncomment if needed
27078c$$$C IF (LFIRST) THEN
27079c$$$C IRNCT0 = 0
27080c$$$C IRNCT1 = 0
27081c$$$C LFIRST = .FALSE.
27082c$$$C ENDIF
27083c$$$
27084c$$$ DT_RNDM = FLRNDM(VDUMMY)
27085c$$$* counter of calls to random number generator
27086c$$$* uncomment if needed
27087c$$$C IRNCT1 = IRNCT1+1
27088c$$$
27089c$$$ RETURN
27090c$$$ END
27091c$$$
27092c$$$*$ CREATE DT_RNDMST.FOR
27093c$$$*COPY DT_RNDMST
27094c$$$*
27095c$$$*===rndmst=============================================================*
27096c$$$*
27097c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27098c$$$
27099c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27100c$$$ SAVE
27101c$$$
27102c$$$* random number generator
27103c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27104c$$$
27105c$$$ MA1 = NA1
27106c$$$ MA2 = NA2
27107c$$$ MA3 = NA3
27108c$$$ MB1 = NB1
27109c$$$ I = 97
27110c$$$ J = 33
27111c$$$ DO 20 II2 = 1,97
27112c$$$ S = 0
27113c$$$ T = 0.5D0
27114c$$$ DO 10 II1 = 1,24
27115c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27116c$$$ MA1 = MA2
27117c$$$ MA2 = MA3
27118c$$$ MA3 = MAT
27119c$$$ MB1 = MOD(53*MB1+1,169)
27120c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27121c$$$ 10 T = 0.5D0*T
27122c$$$ 20 U(II2) = S
27123c$$$ C = 362436.0D0/16777216.0D0
27124c$$$ CD = 7654321.0D0/16777216.0D0
27125c$$$ CM = 16777213.0D0/16777216.0D0
27126c$$$ RETURN
27127c$$$ END
27128c$$$
27129c$$$*$ CREATE DT_RNDMIN.FOR
27130c$$$*COPY DT_RNDMIN
27131c$$$*
27132c$$$*===rndmin=============================================================*
27133c$$$*
27134c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27135c$$$
27136c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27137c$$$ SAVE
27138c$$$
27139c$$$* random number generator
27140c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27141c$$$
27142c$$$ DIMENSION UIN(97)
27143c$$$
27144c$$$ DO 10 KKK = 1,97
27145c$$$ 10 U(KKK) = UIN(KKK)
27146c$$$ C = CIN
27147c$$$ CD = CDIN
27148c$$$ CM = CMIN
27149c$$$ I = IIN
27150c$$$ J = JIN
27151c$$$
27152c$$$ RETURN
27153c$$$ END
27154c$$$
27155c$$$*$ CREATE DT_RNDMOU.FOR
27156c$$$*COPY DT_RNDMOU
27157c$$$*
27158c$$$*===rndmou=============================================================*
27159c$$$*
27160c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27161c$$$
27162c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27163c$$$ SAVE
27164c$$$
27165c$$$* random number generator
27166c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27167c$$$
27168c$$$ DIMENSION UOUT(97)
27169c$$$
27170c$$$ DO 10 KKK = 1,97
27171c$$$ 10 UOUT(KKK) = U(KKK)
27172c$$$ COUT = C
27173c$$$ CDOUT = CD
27174c$$$ CMOUT = CM
27175c$$$ IOUT = I
27176c$$$ JOUT = J
27177c$$$
27178c$$$ RETURN
27179c$$$ END
27180c$$$
27181c$$$*$ CREATE DT_RNDMTE.FOR
27182c$$$*COPY DT_RNDMTE
27183c$$$*
27184c$$$*===rndmte=============================================================*
27185c$$$*
27186c$$$ SUBROUTINE DT_RNDMTE(IO)
27187c$$$
27188c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27189c$$$ SAVE
27190c$$$
27191c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27192c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27193c$$$ +8354498.D0, 10633180.D0/
27194c$$$
27195c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27196c$$$ CALL DT_RNDMST(12,34,56,78)
27197c$$$ DO 10 II1 = 1,20000
27198c$$$ 10 XX = DT_RNDM(XX)
27199c$$$ SD = 0.0D0
27200c$$$ DO 20 II2 = 1,6
27201c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27202c$$$ D(II2) = X(II2)-U(II2)
27203c$$$ 20 SD = SD+D(II2)
27204c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27205c$$$**sr 24.01.95
27206c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27207c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27208c$$$C WRITE(6,1000)
27209c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27210c$$$ & ' passed')
27211c$$$ ENDIF
27212c$$$**
27213c$$$ RETURN
27214c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27215c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27216c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27217c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27218c$$$ END
27219*
27220*$ CREATE PHO_RNDM.FOR
27221*COPY PHO_RNDM
27222*
27223*===pho_rndm===========================================================*
27224*
27225 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27226
27227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27228 SAVE
27229
27230 PHO_RNDM = DT_RNDM(DUMMY)
27231
27232 RETURN
27233 END
27234
27235*$ CREATE PYR.FOR
27236*COPY PYR
27237*
27238*===pyr================================================================*
27239*
27240 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27241
27242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27243 SAVE
27244
27245 DUMMY = DBLE(IDUMMY)
27246 PYR = DT_RNDM(DUMMY)
27247
27248 RETURN
27249 END
27250*$ CREATE DT_TITLE.FOR
27251*COPY DT_TITLE
27252*
27253*===title==============================================================*
27254*
27255 SUBROUTINE DT_TITLE
27256
27257 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27258 SAVE
27259
27260 PARAMETER ( LINP = 10 ,
27261 & LOUT = 6 ,
27262 & LDAT = 9 )
27263
27264 CHARACTER*6 CVERSI
27265 CHARACTER*11 CCHANG
27266 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27267
27268 CALL DT_XTIME
27269 WRITE(LOUT,1000) CVERSI,CCHANG
27270 1000 FORMAT(1X,'+-------------------------------------------------',
27271 & '----------------------+',/,
27272 & 1X,'|',71X,'|',/,
27273 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27274 & 1X,'|',71X,'|',/,
27275 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27276 & 1X,'|',71X,'|',/,
27277 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27278 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27279 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27280C & 1X,'|',71X,'|',/,
27281C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27282C & 17X,'|',/,
27283 & 1X,'|',71X,'|',/,
27284 & 1X,'+-------------------------------------------------',
27285 & '----------------------+',/,
27286 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27287 & 'Stefan.Roesler@cern.ch |',/,
27288 & 1X,'+-------------------------------------------------',
27289 & '----------------------+',/)
27290
27291 RETURN
27292 END
27293
27294*$ CREATE DT_EVTINI.FOR
27295*COPY DT_EVTINI
27296*
27297*===evtini=============================================================*
27298*
27299 SUBROUTINE DT_EVTINI
27300
27301************************************************************************
27302* Initialization of DTEVT1. *
27303* This version dated 15.01.94 is written by S. Roesler *
27304************************************************************************
27305
27306 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27307 SAVE
27308
27309 PARAMETER ( LINP = 10 ,
27310 & LOUT = 6 ,
27311 & LDAT = 9 )
27312
27313* event history
27314
27315 PARAMETER (NMXHKK=200000)
27316
27317 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27318 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27319 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27320
27321* extended event history
27322 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27323 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27324 & IHIST(2,NMXHKK)
27325
27326* event flag
27327 COMMON /DTEVNO/ NEVENT,ICASCA
27328
27329 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27330
27331* emulsion treatment
27332 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27333 & NCOMPO,IEMUL
27334
27335* initialization of DTEVT1/DTEVT2
27336 NEND = NHKK
27337 IF (NEVENT.EQ.1) NEND = NMXHKK
27338 NHKK = 0
27339 NEVHKK = NEVENT
27340 DO 1 I=1,NEND
27341 ISTHKK(I) = 0
27342 IDHKK(I) = 0
27343 JMOHKK(1,I) = 0
27344 JMOHKK(2,I) = 0
27345 JDAHKK(1,I) = 0
27346 JDAHKK(2,I) = 0
27347 IDRES(I) = 0
27348 IDXRES(I) = 0
27349 NOBAM(I) = 0
27350 IDCH(I) = 0
27351 IHIST(1,I) = 0
27352 IHIST(2,I) = 0
27353 DO 2 J=1,4
27354 PHKK(J,I) = 0.0D0
27355 VHKK(J,I) = 0.0D0
27356 WHKK(J,I) = 0.0D0
27357 2 CONTINUE
27358 PHKK(5,I) = 0.0D0
27359 1 CONTINUE
27360 DO 3 I=1,10
27361 NPOINT(I) = 0
27362 3 CONTINUE
27363 CALL DT_CHASTA(-1)
27364
27365C* initialization of DTLTRA
27366C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27367
27368 RETURN
27369 END
27370
27371*$ CREATE DT_STATIS.FOR
27372*COPY DT_STATIS
27373*
27374*===statis=============================================================*
27375*
27376 SUBROUTINE DT_STATIS(MODE)
27377
27378************************************************************************
27379* Initialization and output of run-statistics. *
27380* MODE = 1 initialization *
27381* = 2 output *
27382* This version dated 23.01.94 is written by S. Roesler *
27383************************************************************************
27384
27385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27386 SAVE
27387
27388 PARAMETER ( LINP = 10 ,
27389 & LOUT = 6 ,
27390 & LDAT = 9 )
27391
27392 PARAMETER (TINY3=1.0D-3)
27393
27394* statistics
27395 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27396 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27397 & ICEVTG(8,0:30)
27398
27399* rejection counter
27400 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27401 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27402 & IREXCI(3),IRDIFF(2),IRINC
27403
27404* central particle production, impact parameter biasing
27405 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27406
27407* various options for treatment of partons (DTUNUC 1.x)
27408* (chain recombination, Cronin,..)
27409 LOGICAL LCO2CR,LINTPT
27410 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27411 & LCO2CR,LINTPT
27412
27413* nucleon-nucleon event-generator
27414 CHARACTER*8 CMODEL
27415 LOGICAL LPHOIN
27416 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27417
27418* flags for particle decays
27419 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27420 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27421 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27422
27423* diquark-breaking mechanism
27424 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27425
27426 DIMENSION PP(4),PT(4)
27427
27428 GOTO (1,2) MODE
27429
27430* initialization
27431 1 CONTINUE
27432
27433* initialize statistics counter
27434 ICREQU = 0
27435 ICSAMP = 0
27436 ICCPRO = 0
27437 ICDPR = 0
27438 ICDTA = 0
27439 ICRJSS = 0
27440 ICVV2S = 0
27441 DO 10 I=1,9
27442 ICRES(I) = 0
27443 ICCHAI(1,I) = 0
27444 ICCHAI(2,I) = 0
27445 10 CONTINUE
27446* initialize rejection counter
27447 IRPT = 0
27448 IRHHA = 0
27449 LOMRES = 0
27450 LOBRES = 0
27451 IRFRAG = 0
27452 IREVT = 0
27453 IRRES(1) = 0
27454 IRRES(2) = 0
27455 IRCHKI(1) = 0
27456 IRCHKI(2) = 0
27457 IRCRON(1) = 0
27458 IRCRON(2) = 0
27459 IRCRON(3) = 0
27460 IRDIFF(1) = 0
27461 IRDIFF(2) = 0
27462 IRINC = 0
27463 DO 11 I=1,5
27464 ICDIFF(I) = 0
27465 11 CONTINUE
27466 DO 12 I=1,8
27467 DO 13 J=0,30
27468 ICEVTG(I,J) = 0
27469 13 CONTINUE
27470 12 CONTINUE
27471
27472 RETURN
27473
27474* output
27475 2 CONTINUE
27476
27477* statistics counter
27478 WRITE(LOUT,1000)
27479 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27480 & 28X,'---------------------')
004932dd 27481 IF (ICREQU.GT.0) THEN
7b076c76 27482 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27483 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27484 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27485 & 'event',11X,F9.1)
004932dd 27486 ENDIF
7b076c76 27487 IF (ICDIFF(1).NE.0) THEN
27488 WRITE(LOUT,1009) ICDIFF
27489 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27490 & 'low mass high mass',/,24X,'single diffraction',
27491 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27492 ENDIF
004932dd 27493 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
7b076c76 27494 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27495 & DBLE(ICSAMP)/DBLE(ICCPRO)
27496 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27497 & ' of sampled Glauber-events per event',9X,F9.1,/,
27498 & 2X,'fraction of production cross section',21X,F10.6)
27499 ENDIF
004932dd 27500 IF (ICSAMP.GT.0) THEN
7b076c76 27501 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27502 & DBLE(ICDTA)/DBLE(ICSAMP)
27503 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27504 & ' nucleons after x-sampling',2(4X,F6.2))
004932dd 27505 ENDIF
7b076c76 27506
27507 IF (MCGENE.EQ.1) THEN
004932dd 27508 IF (ICSAMP.GT.0) THEN
7b076c76 27509 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27510 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27511 & ' event',3X,F9.1)
27512 IF (ISICHA.EQ.1) THEN
27513 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27514 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27515 & 'of single chains per event',13X,F9.1)
27516 ENDIF
004932dd 27517 ENDIF
27518 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
7b076c76 27519 WRITE(LOUT,1006)
27520 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27521 & 23X,'mean number of chains mean number of chains',/,
27522 & 23X,'sampled hadronized having mass of a reso.')
27523 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27524 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27525 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27526 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27527 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27531 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27532 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27533 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27534 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27535 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27536 WRITE(LOUT,1008)
27537 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27538 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27539 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27540 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27541 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27542 & DBLE(IRHHA)/DBLE(ICREQU),
27543 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27544 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27545 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27546 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27547 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27548 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27549 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27550 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27551 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27552 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27553 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27554 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27555 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27556 & F7.2,/,1X,'Total no. of rej.',
27557 & ' in chain-systems treatment (GETCSY)',/,43X,
27558 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27559 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27560 & 1X,'Total no. of rej. in DPM-treatment of one event',
27561 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27562 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27563 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27564 & 'IREXCI(3) = ',I5,/)
004932dd 27565 ENDIF
7b076c76 27566 ELSEIF (MCGENE.EQ.2) THEN
27567 WRITE(LOUT,1010) ELOJET
27568 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27569 & F4.1,' GeV')
27570 WRITE(LOUT,1011)
27571 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27572 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27573 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27574 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27575 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27576 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27577 & ((ICEVTG(I,J),I=1,8),J=3,7),
27578 & ((ICEVTG(I,J),I=1,8),J=19,21),
27579 & (ICEVTG(I,8),I=1,8),
27580 & ((ICEVTG(I,J),I=1,8),J=22,24),
27581 & (ICEVTG(I,9),I=1,8),
27582 & ((ICEVTG(I,J),I=1,8),J=25,28),
27583 & ((ICEVTG(I,J),I=1,8),J=10,18)
27584 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27585 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27586 & ' no-dif.',8I8,/,
27587 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27588 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27589 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27590 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27591 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27592 & ' hi-lo ',8I8,/,
27593 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27594 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27595 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27596 WRITE(LOUT,1013)
27597 1013 FORMAT(/,1X,'2. chain system statistics -',
27598 & ' mean numbers per evt:',/,30X,'---------------------',
27599 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
004932dd 27600 IF (ICSAMP.GT.0) THEN
7b076c76 27601 WRITE(LOUT,1014)
27602 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27603 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27604 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27605 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27606 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27607 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27608 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27609 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27610 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27611 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27612 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27613 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27614 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
004932dd 27615 ENDIF
7b076c76 27616 WRITE(LOUT,1015)
27617 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
004932dd 27618 IF (ICSAMP.GT.0) THEN
7b076c76 27619 WRITE(LOUT,1016)
27620 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27621 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27622 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27623 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27624 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27625 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27626 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27627 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27628 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27629 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27630 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27631 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27632 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
004932dd 27633 ENDIF
7b076c76 27634
27635 ENDIF
27636 CALL DT_CHASTA(1)
27637
27638 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27639 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27640 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27641 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27642 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27643 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27644 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27645 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27646 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27647 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27648 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27649 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27650 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27651 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27652 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27653 & DBRKA(3,1),DBRKA(3,2),
27654 & DBRKA(3,3),DBRKA(3,4)
27655 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27656 & DBRKR(3,1),DBRKR(3,2),
27657 & DBRKR(3,3),DBRKR(3,4)
27658 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27659 & DBRKA(3,5),DBRKA(3,6),
27660 & DBRKA(3,7),DBRKA(3,8)
27661 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27662 & DBRKR(3,5),DBRKR(3,6),
27663 & DBRKR(3,7),DBRKR(3,8)
27664 ENDIF
27665
27666 FAC = 1.0D0
27667 IF (MCGENE.EQ.2) THEN
27668
27669C CALL PHO_PHIST(-2,SIGMAX)
27670 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27671
27672 ENDIF
27673
27674 CALL DT_XTIME
27675
27676 RETURN
27677 END
27678
27679*$ CREATE DT_EVTOUT.FOR
27680*COPY DT_EVTOUT
27681*
27682*===evtout=============================================================*
27683*
27684 SUBROUTINE DT_EVTOUT(MODE)
27685
27686************************************************************************
27687* MODE = 1 plot content of complete DTEVT1 to out. unit *
27688* 3 plot entries of extended DTEVT1 (DTEVT2) *
27689* 4 plot entries of DTEVT1 and DTEVT2 *
27690* This version dated 11.12.94 is written by S. Roesler *
27691************************************************************************
27692
27693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27694 SAVE
27695
27696 PARAMETER ( LINP = 10 ,
27697 & LOUT = 6 ,
27698 & LDAT = 9 )
27699
27700* event history
27701
27702 PARAMETER (NMXHKK=200000)
27703
27704 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27705 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27706 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27707
27708 DIMENSION IRANGE(NMXHKK)
27709
27710 IF (MODE.EQ.2) RETURN
27711
27712 CALL DT_EVTPLO(IRANGE,MODE)
27713
27714 RETURN
27715 END
27716
27717*$ CREATE DT_EVTPLO.FOR
27718*COPY DT_EVTPLO
27719*
27720*===evtplo=============================================================*
27721*
27722 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27723
27724************************************************************************
27725* MODE = 1 plot content of complete DTEVT1 to out. unit *
27726* 2 plot entries of DTEVT1 given by IRANGE *
27727* 3 plot entries of extended DTEVT1 (DTEVT2) *
27728* 4 plot entries of DTEVT1 and DTEVT2 *
27729* 5 plot rejection counter *
27730* This version dated 11.12.94 is written by S. Roesler *
27731************************************************************************
27732
27733 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27734 SAVE
27735
27736 PARAMETER ( LINP = 10 ,
27737 & LOUT = 6 ,
27738 & LDAT = 9 )
27739
27740 CHARACTER*16 CHAU
27741
27742* event history
27743
27744 PARAMETER (NMXHKK=200000)
27745
27746 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27747 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27748 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27749
27750* extended event history
27751 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27752 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27753 & IHIST(2,NMXHKK)
27754
27755* rejection counter
27756 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27757 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27758 & IREXCI(3),IRDIFF(2),IRINC
27759
27760 DIMENSION IRANGE(NMXHKK)
27761
27762 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27763 WRITE(LOUT,1000)
27764 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27765 & 15X,' --------------------------',/,/,
27766 & ' ST ID M1 M2 D1 D2 PX PY',
27767 & ' PZ E M',/)
27768 DO 1 I=1,NHKK
27769 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27770 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27771 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27772 & PHKK(5,I)
27773C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27774C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27775C & PHKK(3,I),PHKK(4,I)
27776C WRITE(LOUT,'(4E15.4)')
27777C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27778 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27779 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27780 1 CONTINUE
27781 WRITE(LOUT,*)
27782C DO 4 I=1,NHKK
27783C WRITE(LOUT,1006) I,ISTHKK(I),
27784C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27785C & WHKK(2,I),WHKK(3,I)
27786C1006 FORMAT(1X,I4,I6,6E10.3)
27787C 4 CONTINUE
27788 ENDIF
27789
27790 IF (MODE.EQ.2) THEN
27791 WRITE(LOUT,1000)
27792 NC = 0
27793 2 CONTINUE
27794 NC = NC+1
27795 IF (IRANGE(NC).EQ.-100) GOTO 9999
27796 I = IRANGE(NC)
27797 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27798 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27799 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27800 & PHKK(5,I)
27801 GOTO 2
27802 ENDIF
27803
27804 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27805 WRITE(LOUT,1002)
27806 1002 FORMAT(/,1X,'EVTPLO:',14X,
27807 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27808 & 15X,' -----------------------------------',/,/,
27809 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27810 & ' NOBAM IDCH M',/)
27811 DO 3 I=1,NHKK
27812C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27813 KF = IDHKK(I)
27814 IDCHK = KF/10000
27815 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27816 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27817
27818 CALL PYNAME(KF,CHAU)
27819
27820 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27821 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27822 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27823 & PHKK(5,I),CHAU
27824 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27825C ENDIF
27826 3 CONTINUE
27827 ENDIF
27828
27829 IF (MODE.EQ.5) THEN
27830 WRITE(LOUT,1004)
27831 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27832 & 15X,' --------------------------',/)
27833 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27834 & IRSEA,IRCRON
27835 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27836 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27837 & 1X,'IREMC = ',10I5,/,
27838 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27839 ENDIF
27840
27841 9999 RETURN
27842 END
27843
27844*$ CREATE DT_EVTPUT.FOR
27845*COPY DT_EVTPUT
27846*
27847*===evtput=============================================================*
27848*
27849 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27850
27851 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27852 SAVE
27853
27854 PARAMETER ( LINP = 10 ,
27855 & LOUT = 6 ,
27856 & LDAT = 9 )
27857
27858 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27859 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27860
27861* event history
27862
27863 PARAMETER (NMXHKK=200000)
27864
27865 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27866 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27867 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27868
27869* extended event history
27870 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27871 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27872 & IHIST(2,NMXHKK)
27873
27874* Lorentz-parameters of the current interaction
27875 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27876 & UMO,PPCM,EPROJ,PPROJ
27877
27878* particle properties (BAMJET index convention)
27879 CHARACTER*8 ANAME
27880 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27881 & IICH(210),IIBAR(210),K1(210),K2(210)
27882
27883C IF (MODE.GT.100) THEN
27884C WRITE(LOUT,'(1X,A,I5,A,I5)')
27885C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27886C NHKK = NHKK-MODE+100
27887C RETURN
27888C ENDIF
27889 MO1 = M1
27890 MO2 = M2
27891 NHKK = NHKK+1
27892
27893 IF (NHKK.GT.NMXHKK) THEN
27894 WRITE(LOUT,1000) NHKK
27895 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27896 & '! program execution stopped..')
27897 STOP
27898 ENDIF
27899 IF (M1.LT.0) MO1 = NHKK+M1
27900 IF (M2.LT.0) MO2 = NHKK+M2
27901 ISTHKK(NHKK) = IST
27902 IDHKK(NHKK) = ID
27903 JMOHKK(1,NHKK) = MO1
27904 JMOHKK(2,NHKK) = MO2
27905 JDAHKK(1,NHKK) = 0
27906 JDAHKK(2,NHKK) = 0
27907 IDRES(NHKK) = IDR
27908 IDXRES(NHKK) = IDXR
27909 IDCH(NHKK) = IDC
27910** here we need to do something..
27911 IF (ID.EQ.88888) THEN
27912 IDMO1 = ABS(IDHKK(MO1))
27913 IDMO2 = ABS(IDHKK(MO2))
27914 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27915 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27916 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27917 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27918 ELSE
27919 NOBAM(NHKK) = 0
27920 ENDIF
27921 IDBAM(NHKK) = IDT_ICIHAD(ID)
27922 IF (MO1.GT.0) THEN
27923 IF (JDAHKK(1,MO1).NE.0) THEN
27924 JDAHKK(2,MO1) = NHKK
27925 ELSE
27926 JDAHKK(1,MO1) = NHKK
27927 ENDIF
27928 ENDIF
27929 IF (MO2.GT.0) THEN
27930 IF (JDAHKK(1,MO2).NE.0) THEN
27931 JDAHKK(2,MO2) = NHKK
27932 ELSE
27933 JDAHKK(1,MO2) = NHKK
27934 ENDIF
27935 ENDIF
27936C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27937C PTOT = SQRT(PX**2+PY**2+PZ**2)
27938C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27939C AMRQ = AAM(IDBAM(NHKK))
27940C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27941C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27942C & (PTOT.GT.ZERO)) THEN
27943C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27944CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27945C E = E+DELTA
27946C PTOT1 = PTOT-DELTA
27947C PX = PX*PTOT1/PTOT
27948C PY = PY*PTOT1/PTOT
27949C PZ = PZ*PTOT1/PTOT
27950C ENDIF
27951C ENDIF
27952 PHKK(1,NHKK) = PX
27953 PHKK(2,NHKK) = PY
27954 PHKK(3,NHKK) = PZ
27955 PHKK(4,NHKK) = E
27956 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27957 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27958 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27959 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27960 ELSE
27961 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27962C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27963C & WRITE(LOUT,'(1X,A,G10.3)')
27964C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27965 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27966 ENDIF
27967 IDCHK = ID/10000
27968 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27969* special treatment for chains:
27970* z coordinate of chain in Lab = pos. of target nucleon
27971* time of chain-creation in Lab = time of passage of projectile
27972* nucleus at pos. of taget nucleus
27973C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27974C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27975 VHKK(1,NHKK) = VHKK(1,MO2)
27976 VHKK(2,NHKK) = VHKK(2,MO2)
27977 VHKK(3,NHKK) = VHKK(3,MO2)
27978 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27979C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27980C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27981 WHKK(1,NHKK) = WHKK(1,MO1)
27982 WHKK(2,NHKK) = WHKK(2,MO1)
27983 WHKK(3,NHKK) = WHKK(3,MO1)
27984 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27985 ELSE
27986 IF (MO1.GT.0) THEN
27987 DO 1 I=1,4
27988 VHKK(I,NHKK) = VHKK(I,MO1)
27989 WHKK(I,NHKK) = WHKK(I,MO1)
27990 1 CONTINUE
27991 ELSE
27992 DO 2 I=1,4
27993 VHKK(I,NHKK) = ZERO
27994 WHKK(I,NHKK) = ZERO
27995 2 CONTINUE
27996 ENDIF
27997 ENDIF
27998
27999 RETURN
28000 END
28001
28002*$ CREATE DT_CHASTA.FOR
28003*COPY DT_CHASTA
28004*
28005*===chasta=============================================================*
28006*
28007 SUBROUTINE DT_CHASTA(MODE)
28008
28009************************************************************************
28010* This subroutine performs CHAin STAtistics and checks sequence of *
28011* partons in dtevt1 and sorts them with projectile partons coming *
28012* first if necessary. *
28013* *
28014* This version dated 8.5.00 is written by S. Roesler. *
28015************************************************************************
28016
28017 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28018 SAVE
28019
28020 PARAMETER ( LINP = 10 ,
28021 & LOUT = 6 ,
28022 & LDAT = 9 )
28023
28024 CHARACTER*5 CCHTYP
28025
28026* event history
28027
28028 PARAMETER (NMXHKK=200000)
28029
28030 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28031 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28032 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28033
28034* extended event history
28035 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28036 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28037 & IHIST(2,NMXHKK)
28038
28039* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28040 PARAMETER (MAXCHN=10000)
28041 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28042
28043 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28044 & CCHTYP(9),ICHSTA(10),ITOT(10)
28045 DATA ICHCFG /1800*0/
28046 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28047 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28048 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28049 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28050 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28051 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28052 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28053 & 'ad aq',' d ad','ad d ',' g g '/
28054*
28055* initialization
28056*
28057 IF (MODE.EQ.-1) THEN
28058 NCHAIN = 0
28059*
28060* loop over DTEVT1 and analyse chain configurations
28061*
28062 ELSEIF (MODE.EQ.0) THEN
28063 DO 21 IDX=NPOINT(3),NHKK
28064 IDCHK = IDHKK(IDX)/10000
28065 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28066 & (IDHKK(IDX).NE.80000).AND.
28067 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28068 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28069 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28070 & ' at entry ',IDX
28071 GOTO 21
28072 ENDIF
28073*
28074 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28075 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28076 IMO1 = IST1/10
28077 IMO1 = IST1-10*IMO1
28078 IMO2 = IST2/10
28079 IMO2 = IST2-10*IMO2
28080* swop parton entries if necessary since we need projectile partons
28081* to come first in the common
28082 IF (IMO1.GT.IMO2) THEN
28083 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28084 DO 22 K=1,NPTN/2
28085 I0 = JMOHKK(1,IDX)-1+K
28086 I1 = JMOHKK(2,IDX)+1-K
28087 ITMP = ISTHKK(I0)
28088 ISTHKK(I0) = ISTHKK(I1)
28089 ISTHKK(I1) = ITMP
28090 ITMP = IDHKK(I0)
28091 IDHKK(I0) = IDHKK(I1)
28092 IDHKK(I1) = ITMP
28093 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28094 & JDAHKK(1,JMOHKK(1,I0)) = I1
28095 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28096 & JDAHKK(2,JMOHKK(1,I0)) = I1
28097 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28098 & JDAHKK(1,JMOHKK(2,I0)) = I1
28099 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28100 & JDAHKK(2,JMOHKK(2,I0)) = I1
28101 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28102 & JDAHKK(1,JMOHKK(1,I1)) = I0
28103 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28104 & JDAHKK(2,JMOHKK(1,I1)) = I0
28105 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28106 & JDAHKK(1,JMOHKK(2,I1)) = I0
28107 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28108 & JDAHKK(2,JMOHKK(2,I1)) = I0
28109 ITMP = JMOHKK(1,I0)
28110 JMOHKK(1,I0) = JMOHKK(1,I1)
28111 JMOHKK(1,I1) = ITMP
28112 ITMP = JMOHKK(2,I0)
28113 JMOHKK(2,I0) = JMOHKK(2,I1)
28114 JMOHKK(2,I1) = ITMP
28115 ITMP = JDAHKK(1,I0)
28116 JDAHKK(1,I0) = JDAHKK(1,I1)
28117 JDAHKK(1,I1) = ITMP
28118 ITMP = JDAHKK(2,I0)
28119 JDAHKK(2,I0) = JDAHKK(2,I1)
28120 JDAHKK(2,I1) = ITMP
28121 DO 23 J=1,4
28122 RTMP1 = PHKK(J,I0)
28123 RTMP2 = VHKK(J,I0)
28124 RTMP3 = WHKK(J,I0)
28125 PHKK(J,I0) = PHKK(J,I1)
28126 VHKK(J,I0) = VHKK(J,I1)
28127 WHKK(J,I0) = WHKK(J,I1)
28128 PHKK(J,I1) = RTMP1
28129 VHKK(J,I1) = RTMP2
28130 WHKK(J,I1) = RTMP3
28131 23 CONTINUE
28132 RTMP1 = PHKK(5,I0)
28133 PHKK(5,I0) = PHKK(5,I1)
28134 PHKK(5,I1) = RTMP1
28135 ITMP = IDRES(I0)
28136 IDRES(I0) = IDRES(I1)
28137 IDRES(I1) = ITMP
28138 ITMP = IDXRES(I0)
28139 IDXRES(I0) = IDXRES(I1)
28140 IDXRES(I1) = ITMP
28141 ITMP = NOBAM(I0)
28142 NOBAM(I0) = NOBAM(I1)
28143 NOBAM(I1) = ITMP
28144 ITMP = IDBAM(I0)
28145 IDBAM(I0) = IDBAM(I1)
28146 IDBAM(I1) = ITMP
28147 ITMP = IDCH(I0)
28148 IDCH(I0) = IDCH(I1)
28149 IDCH(I1) = ITMP
28150 ITMP = IHIST(1,I0)
28151 IHIST(1,I0) = IHIST(1,I1)
28152 IHIST(1,I1) = ITMP
28153 ITMP = IHIST(2,I0)
28154 IHIST(2,I0) = IHIST(2,I1)
28155 IHIST(2,I1) = ITMP
28156 22 CONTINUE
28157 ENDIF
28158 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28159 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28160*
28161* parton 1 (projectile side)
28162 IF (IST1.EQ.21) THEN
28163 IDX1 = 1
28164 ELSEIF (IST1.EQ.22) THEN
28165 IDX1 = 2
28166 ELSEIF (IST1.EQ.31) THEN
28167 IDX1 = 3
28168 ELSEIF (IST1.EQ.32) THEN
28169 IDX1 = 4
28170 ELSEIF (IST1.EQ.41) THEN
28171 IDX1 = 5
28172 ELSEIF (IST1.EQ.42) THEN
28173 IDX1 = 6
28174 ELSEIF (IST1.EQ.51) THEN
28175 IDX1 = 7
28176 ELSEIF (IST1.EQ.52) THEN
28177 IDX1 = 8
28178 ELSEIF (IST1.EQ.61) THEN
28179 IDX1 = 9
28180 ELSEIF (IST1.EQ.62) THEN
28181 IDX1 = 10
28182 ELSE
28183c WRITE(LOUT,*)
28184c & ' CHASTA: unknown parton status flag (',
28185c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28186 GOTO 21
28187 ENDIF
28188 ID = IDHKK(JMOHKK(1,IDX))
28189 IF (ABS(ID).LE.4) THEN
28190 IF (ID.GT.0) THEN
28191 ITYP1 = 1
28192 ELSE
28193 ITYP1 = 2
28194 ENDIF
28195 ELSEIF (ABS(ID).GE.1000) THEN
28196 IF (ID.GT.0) THEN
28197 ITYP1 = 3
28198 ELSE
28199 ITYP1 = 4
28200 ENDIF
28201 ELSEIF (ID.EQ.21) THEN
28202 ITYP1 = 5
28203 ELSE
28204 WRITE(LOUT,*)
28205 & ' CHASTA: inconsistent parton identity (',
28206 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28207 GOTO 21
28208 ENDIF
28209*
28210* parton 2 (target side)
28211 IF (IST2.EQ.21) THEN
28212 IDX2 = 1
28213 ELSEIF (IST2.EQ.22) THEN
28214 IDX2 = 2
28215 ELSEIF (IST2.EQ.31) THEN
28216 IDX2 = 3
28217 ELSEIF (IST2.EQ.32) THEN
28218 IDX2 = 4
28219 ELSEIF (IST2.EQ.41) THEN
28220 IDX2 = 5
28221 ELSEIF (IST2.EQ.42) THEN
28222 IDX2 = 6
28223 ELSEIF (IST2.EQ.51) THEN
28224 IDX2 = 7
28225 ELSEIF (IST2.EQ.52) THEN
28226 IDX2 = 8
28227 ELSEIF (IST2.EQ.61) THEN
28228 IDX2 = 9
28229 ELSEIF (IST2.EQ.62) THEN
28230 IDX2 = 10
28231 ELSE
28232c WRITE(LOUT,*)
28233c & ' CHASTA: unknown parton status flag (',
28234c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28235 GOTO 21
28236 ENDIF
28237 ID = IDHKK(JMOHKK(2,IDX))
28238 IF (ABS(ID).LE.4) THEN
28239 IF (ID.GT.0) THEN
28240 ITYP2 = 1
28241 ELSE
28242 ITYP2 = 2
28243 ENDIF
28244 ELSEIF (ABS(ID).GE.1000) THEN
28245 IF (ID.GT.0) THEN
28246 ITYP2 = 3
28247 ELSE
28248 ITYP2 = 4
28249 ENDIF
28250 ELSEIF (ID.EQ.21) THEN
28251 ITYP2 = 5
28252 ELSE
28253 WRITE(LOUT,*)
28254 & ' CHASTA: inconsistent parton identity (',
28255 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28256 GOTO 21
28257 ENDIF
28258*
28259* fill counter
28260 ITYPE = ICHTYP(ITYP1,ITYP2)
28261 IF (ITYPE.NE.0) THEN
28262 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28263 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28264 ICHCFG(IDX1,IDX2,ITYPE,2) =
28265 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28266
28267 NCHAIN = NCHAIN+1
28268 IF (NCHAIN.GT.MAXCHN) THEN
28269 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28270 & NCHAIN,MAXCHN
28271 STOP
28272 ENDIF
28273 IDXCHN(1,NCHAIN) = IDX
28274 IDXCHN(2,NCHAIN) = ITYPE
28275 ELSE
28276 WRITE(LOUT,*)
28277 & ' CHASTA: inconsistent chain at entry ',IDX
28278 GOTO 21
28279 ENDIF
28280 ENDIF
28281 21 CONTINUE
28282*
28283* write statistics to output unit
28284*
28285 ELSEIF (MODE.EQ.1) THEN
28286 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28287 DO 31 I=1,10
28288 WRITE(LOUT,'(/,2A)')
28289 & ' -----------------------------------------',
28290 & '------------------------------------'
28291 WRITE(LOUT,'(2A)')
28292 & ' p\\t 21 22 31 32 41',
28293 & ' 42 51 52 61 62'
28294 WRITE(LOUT,'(2A)')
28295 & ' -----------------------------------------',
28296 & '------------------------------------'
28297 DO 32 J=1,10
28298 ITOT(J) = 0
28299 DO 33 K=1,9
28300 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28301 33 CONTINUE
28302 32 CONTINUE
28303 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28304 DO 34 K=1,9
28305 ISUM = 0
28306 DO 35 J=1,10
28307 ISUM = ISUM+ICHCFG(I,J,K,1)
28308 35 CONTINUE
28309 IF (ISUM.GT.0)
28310 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28311 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28312 34 CONTINUE
28313C WRITE(LOUT,'(2A)')
28314C & ' -----------------------------------------',
28315C & '-------------------------------'
28316 31 CONTINUE
28317*
28318 ELSE
28319 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28320 STOP
28321 ENDIF
28322
28323 RETURN
28324 END
28325*$ CREATE PHO_PHIST.FOR
28326*COPY PHO_PHIST
28327*
28328*===pohist=============================================================*
28329*
28330 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28331
28332 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28333 SAVE
28334
28335 PARAMETER ( LINP = 10 ,
28336 & LOUT = 6 ,
28337 & LDAT = 9 )
28338
28339 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28340
28341* Glauber formalism: cross sections
28342 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28343 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28344 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28345 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28346 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28347 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28348 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28349 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28350 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28351 & BSLOPE,NEBINI,NQBINI
28352
28353 ILAB = 0
28354 IF (IMODE.EQ.10) THEN
28355 IMODE = 1
28356 ILAB = 1
28357 ENDIF
28358 IF (ABS(IMODE).LT.1000) THEN
28359* PHOJET-statistics
28360C CALL POHISX(IMODE,WEIGHT)
28361 IF (IMODE.EQ.-1) THEN
28362 MODE = 1
28363 XSTOT(1,1,1) = WEIGHT
28364 ENDIF
28365 IF (IMODE.EQ. 1) MODE = 2
28366 IF (IMODE.EQ.-2) MODE = 3
28367 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28368C IF (MODE.EQ.3) WRITE(LOUT,*)
28369C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28370 CALL DT_HISTOG(MODE)
28371 CALL DT_USRHIS(MODE)
28372 ELSE
28373* DTUNUC-statistics
28374 MODE = IMODE/1000
28375C IF (MODE.EQ.3) WRITE(LOUT,*)
28376C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28377 CALL DT_HISTOG(MODE)
28378 CALL DT_USRHIS(MODE)
28379 ENDIF
28380
28381 RETURN
28382 END
28383
28384*$ CREATE DT_SWPPHO.FOR
28385*COPY DT_SWPPHO
28386*
28387*===swppho=============================================================*
28388*
28389 SUBROUTINE DT_SWPPHO(ILAB)
28390
28391 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28392 SAVE
28393
28394 PARAMETER ( LINP = 10 ,
28395 & LOUT = 6 ,
28396 & LDAT = 9 )
28397
28398 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28399
28400 LOGICAL LSTART
28401
28402* event history
28403
28404 PARAMETER (NMXHKK=200000)
28405
28406 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28407 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28408 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28409
28410* extended event history
28411 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28412 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28413 & IHIST(2,NMXHKK)
28414
28415* flags for input different options
28416 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28417 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28418 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28419
28420* properties of photon/lepton projectiles
28421 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28422
28423**PHOJET105a
28424C PARAMETER (NMXHEP=2000)
28425C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28426C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28427C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28428C COMMON /PLASAV/ PLAB
28429**PHOJET110
28430C standard particle data interface
28431 INTEGER NMXHEP
28432
28433 PARAMETER (NMXHEP=4000)
28434
28435 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28436 DOUBLE PRECISION PHEP,VHEP
28437 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28438 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28439 & VHEP(4,NMXHEP)
28440C extension to standard particle data interface (PHOJET specific)
28441 INTEGER IMPART,IPHIST,ICOLOR
28442 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28443
28444C global event kinematics and particle IDs
28445 INTEGER IFPAP,IFPAB
28446 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28447 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28448**
28449 DATA ICOUNT/0/
28450
28451 DATA LSTART /.TRUE./
28452
28453C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28454 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28455 UMO = ECM
28456 ELA = ZERO
28457 PLA = ZERO
28458 IDP = IDT_ICIHAD(IFPAP(1))
28459 IDT = IDT_ICIHAD(IFPAP(2))
28460 VIRT = PVIRT(1)
28461 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28462 PLAB = PLA
28463 LSTART = .FALSE.
28464 ENDIF
28465
28466 NHKK = 0
28467 ICOUNT = ICOUNT+1
28468C NEVHKK = NEVHEP
28469 NEVHKK = ICOUNT
28470 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28471 DO 1 I=3,NHEP
28472 IF (ISTHEP(I).EQ.1) THEN
28473 NHKK = NHKK+1
28474 ISTHKK(NHKK) = 1
28475 IDHKK(NHKK) = IDHEP(I)
28476 JMOHKK(1,NHKK) = 0
28477 JMOHKK(2,NHKK) = 0
28478 JDAHKK(1,NHKK) = 0
28479 JDAHKK(2,NHKK) = 0
28480 DO 2 K=1,4
28481 PHKK(K,NHKK) = PHEP(K,I)
28482 VHKK(K,NHKK) = ZERO
28483 WHKK(K,NHKK) = ZERO
28484 2 CONTINUE
28485 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28486 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28487 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28488 PHKK(5,NHKK) = PHEP(5,I)
28489 IDRES(NHKK) = 0
28490 IDXRES(NHKK) = 0
28491 NOBAM(NHKK) = 0
28492 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28493 IDCH(NHKK) = 0
28494 ENDIF
28495 1 CONTINUE
28496
28497 RETURN
28498 END
28499
28500*$ CREATE DT_HISTOG.FOR
28501*COPY DT_HISTOG
28502*
28503*===histog=============================================================*
28504*
28505 SUBROUTINE DT_HISTOG(MODE)
28506
28507************************************************************************
28508* This version dated 25.03.96 is written by S. Roesler *
28509************************************************************************
28510
28511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28512 SAVE
28513
28514 PARAMETER ( LINP = 10 ,
28515 & LOUT = 6 ,
28516 & LDAT = 9 )
28517
28518 LOGICAL LFSP,LRNL
28519
28520* event history
28521
28522 PARAMETER (NMXHKK=200000)
28523
28524 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28525 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28526 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28527
28528* extended event history
28529 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28530 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28531 & IHIST(2,NMXHKK)
28532
28533* event flag used for histograms
28534 COMMON /DTNORM/ ICEVT,IEVHKK
28535
28536* flags for activated histograms
28537 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28538
28539 IEVHKK = NEVHKK
28540 GOTO (1,2,3) MODE
28541
28542*------------------------------------------------------------------
28543* initialization
28544 1 CONTINUE
28545 ICEVT = 0
28546 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28547 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28548
28549 RETURN
28550*------------------------------------------------------------------
28551* filling of histogram with event-record
28552 2 CONTINUE
28553 ICEVT = ICEVT+1
28554
28555 DO 20 I=1,NHKK
28556 CALL DT_SWPFSP(I,LFSP,LRNL)
28557 IF (LFSP) THEN
28558 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28559 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28560 ENDIF
28561 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28562 20 CONTINUE
28563 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28564
28565 RETURN
28566*------------------------------------------------------------------
28567* output
28568 3 CONTINUE
28569 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28570 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28571
28572 RETURN
28573 END
28574
28575*$ CREATE DT_SWPFSP.FOR
28576*COPY DT_SWPFSP
28577*
28578*===swpfsp=============================================================*
28579*
28580 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28581
28582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28583 SAVE
28584 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28585 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28586 & PI =TWOPI/TWO,
28587 & BOG =TWOPI/360.0D0)
28588
28589* event history
28590
28591 PARAMETER (NMXHKK=200000)
28592
28593 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28594 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28595 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28596
28597* extended event history
28598 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28599 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28600 & IHIST(2,NMXHKK)
28601
28602* particle properties (BAMJET index convention)
28603 CHARACTER*8 ANAME
28604 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28605 & IICH(210),IIBAR(210),K1(210),K2(210)
28606
28607* Lorentz-parameters of the current interaction
28608 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28609 & UMO,PPCM,EPROJ,PPROJ
28610
28611* flags for input different options
28612 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28613 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28614 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28615
28616* INCLUDE '(DIMPAR)'
28617* Taken from FLUKA
28618 PARAMETER ( MXXRGN =20000 )
28619 PARAMETER ( MXXMDF = 710 )
28620 PARAMETER ( MXXMDE = 702 )
28621 PARAMETER ( MFSTCK =40000 )
28622 PARAMETER ( MESTCK = 100 )
28623 PARAMETER ( MOSTCK = 2000 )
28624 PARAMETER ( MXPRSN = 100 )
28625 PARAMETER ( MXPDPM = 800 )
28626 PARAMETER ( MXPSCS =30000 )
28627 PARAMETER ( MXGLWN = 300 )
28628 PARAMETER ( MXOUTU = 50 )
28629 PARAMETER ( NALLWP = 64 )
28630 PARAMETER ( NELEMX = 80 )
28631 PARAMETER ( MPDPDX = 18 )
28632 PARAMETER ( MXHTTR = 260 )
28633 PARAMETER ( MXSEAX = 20 )
28634 PARAMETER ( MXHTNC = MXSEAX + 1 )
28635 PARAMETER ( ICOMAX = 2400 )
28636 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28637 PARAMETER ( NSTBIS = 304 )
28638 PARAMETER ( NQSTIS = 46 )
28639 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28640 PARAMETER ( MXPABL = 120 )
28641 PARAMETER ( IDMAXP = 450 )
28642 PARAMETER ( IDMXDC = 2000 )
28643 PARAMETER ( MXMCIN = 410 )
28644 PARAMETER ( IHYPMX = 4 )
28645 PARAMETER ( MKBMX1 = 11 )
28646 PARAMETER ( MKBMX2 = 11 )
28647 PARAMETER ( MXIRRD = 2500 )
28648 PARAMETER ( MXTRDC = 1500 )
28649 PARAMETER ( NKTL = 17 )
28650 PARAMETER ( NBLNMX = 40000000 )
28651
28652* INCLUDE '(PAREVT)'
28653* Taken from FLUKA
28654 PARAMETER ( FRDIFF = 0.2D+00 )
28655 PARAMETER ( ETHSEA = 1.0D+00 )
28656*
28657 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28658 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28659 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28660 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28661 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28662 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28663 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28664 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28665 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28666 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28667
28668* temporary storage for one final state particle
28669 LOGICAL LFRAG,LGREY,LBLACK
28670 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28671 & SINTHE,COSTHE,THETA,THECMS,
28672 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28673 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28674 & LFRAG,LGREY,LBLACK
28675
28676 LOGICAL LFSP,LRNL
28677
28678 LFSP = .FALSE.
28679 LRNL = .FALSE.
28680 ISTRNL = 1000
28681 MULDEF = 1
28682 IF (LEVPRT) ISTRNL = 1001
28683
28684 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28685 IST = ISTHKK(IDX)
28686 IDPDG = IDHKK(IDX)
28687 LFRAG = .FALSE.
28688 IF (IDHKK(IDX).LT.80000) THEN
28689 IDBJT = IDBAM(IDX)
28690 IBARY = IIBAR(IDBJT)
28691 ICHAR = IICH(IDBJT)
28692 AMASS = AAM(IDBJT)
28693 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28694 IDBJT = 0
28695 IBARY = IDRES(IDX)
28696 ICHAR = IDXRES(IDX)
28697 AMASS = PHKK(5,IDX)
28698 INUT = IBARY-ICHAR
28699 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28700 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28701 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28702 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28703 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28704 ELSE
28705 GOTO 9999
28706 ENDIF
28707 PE = PHKK(4,IDX)
28708 PX = PHKK(1,IDX)
28709 PY = PHKK(2,IDX)
28710 PZ = PHKK(3,IDX)
28711 PT2 = PX**2+PY**2
28712 PT = SQRT(PT2)
28713 PTOT = SQRT(PT2+PZ**2)
28714 SINTHE = PT/MAX(PTOT,TINY14)
28715 COSTHE = PZ/MAX(PTOT,TINY14)
28716 IF (COSTHE.GT.ONE) THEN
28717 THETA = ZERO
28718 ELSEIF (COSTHE.LT.-ONE) THEN
28719 THETA = TWOPI/2.0D0
28720 ELSE
28721 THETA = ACOS(COSTHE)
28722 ENDIF
28723 EKIN = PE-AMASS
28724**sr 15.4.96 new E_t-definition
28725 IF (IBARY.GT.0) THEN
28726 ET = EKIN*SINTHE
28727 ELSEIF (IBARY.LT.0) THEN
28728 ET = (EKIN+TWO*AMASS)*SINTHE
28729 ELSE
28730 ET = PE*SINTHE
28731 ENDIF
28732**
28733 XLAB = PZ/MAX(PPROJ,TINY14)
28734C XLAB = PE/MAX(EPROJ,TINY14)
28735 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28736 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28737 PPLUS = PE+PZ
28738 PMINUS = PE-PZ
28739 IF (PMINUS.GT.TINY14) THEN
28740 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28741 ELSE
28742 YY = 100.0D0
28743 ENDIF
28744 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28745 ETA = -LOG(TAN(THETA/TWO))
28746 ELSE
28747 ETA = 100.0D0
28748 ENDIF
28749 IF (IFRAME.EQ.1) THEN
28750 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28751 PPLUS = EECMS+PZCMS
28752 PMINUS = EECMS-PZCMS
28753 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28754 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28755 ELSE
28756 YYCMS = 100.0D0
28757 ENDIF
28758 PTOTCM = SQRT(PT2+PZCMS**2)
28759 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28760 IF (COSTH.GT.ONE) THEN
28761 THECMS = ZERO
28762 ELSEIF (COSTH.LT.-ONE) THEN
28763 THECMS = TWOPI/2.0D0
28764 ELSE
28765 THECMS = ACOS(COSTH)
28766 ENDIF
28767 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28768 ETACMS = -LOG(TAN(THECMS/TWO))
28769 ELSE
28770 ETACMS = 100.0D0
28771 ENDIF
28772 XF = PZCMS/MAX(PPCM,TINY14)
28773 THECMS = THECMS/BOG
28774 ELSE
28775 PZCMS = PZ
28776 EECMS = PE
28777 YYCMS = YY
28778 ETACMS = ETA
28779 XF = XLAB
28780 THECMS = THETA/BOG
28781 ENDIF
28782 THETA = THETA/BOG
28783
28784* set flag for "grey/black"
28785 LGREY = .FALSE.
28786 LBLACK = .FALSE.
28787 EK = EKIN
28788 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28789 IF (MULDEF.EQ.1) THEN
28790* EMU01-Def.
28791 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28792 & (EK.LE.375.0D-3) ).OR.
28793 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28794 & (EK.LE. 56.0D-3) ).OR.
28795 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28796 & (EK.LE. 56.0D-3) ).OR.
28797 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28798 & (EK.LE.198.0D-3) ).OR.
28799 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28800 & (EK.LE.198.0D-3) ).OR.
28801 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28802 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28803 & (IDBJT.NE.16).AND.
28804 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28805 & LGREY = .TRUE.
28806 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28807 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28808 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28809 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28810 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28811 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28812 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28813 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28814 & LBLACK = .TRUE.
28815 ELSE
28816* common Def.
28817 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28818 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28819 ENDIF
28820 LFSP = .TRUE.
28821 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28822 IST = ISTHKK(IDX)
28823 IDPDG = IDHKK(IDX)
28824 LFRAG = .TRUE.
28825 IDBJT = 0
28826 IBARY = IDRES(IDX)
28827 ICHAR = IDXRES(IDX)
28828 AMASS = PHKK(5,IDX)
28829 PE = PHKK(4,IDX)
28830 PX = PHKK(1,IDX)
28831 PY = PHKK(2,IDX)
28832 PZ = PHKK(3,IDX)
28833 PT2 = PX**2+PY**2
28834 PT = SQRT(PT2)
28835 PTOT = SQRT(PT2+PZ**2)
28836 SINTHE = PT/MAX(PTOT,TINY14)
28837 COSTHE = PZ/MAX(PTOT,TINY14)
28838 IF (COSTHE.GT.ONE) THEN
28839 THETA = ZERO
28840 ELSEIF (COSTHE.LT.-ONE) THEN
28841 THETA = TWOPI/2.0D0
28842 ELSE
28843 THETA = ACOS(COSTHE)
28844 ENDIF
28845 EKIN = PE-AMASS
28846**sr 15.4.96 new E_t-definition
28847C ET = PE*SINTHE
28848 ET = EKIN*SINTHE
28849**
28850 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28851 ETA = -LOG(TAN(THETA/TWO))
28852 ELSE
28853 ETA = 100.0D0
28854 ENDIF
28855 THETA = THETA/BOG
28856 LRNL = .TRUE.
28857 ENDIF
28858
28859 9999 CONTINUE
28860 RETURN
28861 END
28862
28863*$ CREATE DT_HIMULT.FOR
28864*COPY DT_HIMULT
28865*
28866*===himult=============================================================*
28867*
28868 SUBROUTINE DT_HIMULT(MODE)
28869
28870************************************************************************
28871* Tables of average energies/multiplicities. *
28872* This version dated 30.08.2000 is written by S. Roesler *
28873************************************************************************
28874
28875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28876 SAVE
28877
28878 PARAMETER ( LINP = 10 ,
28879 & LOUT = 6 ,
28880 & LDAT = 9 )
28881
28882 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28883
28884 PARAMETER (SWMEXP=1.7D0)
28885
28886 CHARACTER*8 ANAMEH(4)
28887
28888* particle properties (BAMJET index convention)
28889 CHARACTER*8 ANAME
28890 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28891 & IICH(210),IIBAR(210),K1(210),K2(210)
28892
28893* temporary storage for one final state particle
28894 LOGICAL LFRAG,LGREY,LBLACK
28895 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28896 & SINTHE,COSTHE,THETA,THECMS,
28897 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28898 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28899 & LFRAG,LGREY,LBLACK
28900
28901* event flag used for histograms
28902 COMMON /DTNORM/ ICEVT,IEVHKK
28903
28904* Lorentz-parameters of the current interaction
28905 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28906 & UMO,PPCM,EPROJ,PPROJ
28907
28908 PARAMETER (NOPART=210)
28909 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28910 & AVPT(4,NOPART),IAVPT(4,NOPART)
28911 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28912
28913 GOTO (1,2,3) MODE
28914
28915*------------------------------------------------------------------
28916* initialization
28917 1 CONTINUE
28918 DO 10 I=1,NOPART
28919 DO 11 J=1,4
28920 AVMULT(J,I) = ZERO
28921 AVE(J,I) = ZERO
28922 AVSWM(J,I) = ZERO
28923 AVPT(J,I) = ZERO
28924 IAVPT(J,I) = 0
28925 11 CONTINUE
28926 10 CONTINUE
28927
28928 RETURN
28929
28930*------------------------------------------------------------------
28931* filling of histogram with event-record
28932 2 CONTINUE
28933 IF (PE.LT.0.0D0) THEN
28934 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28935 RETURN
28936 ENDIF
28937 IF (.NOT.LFRAG) THEN
28938 IVEL = 2
28939 IF (LGREY) IVEL = 3
28940 IF (LBLACK) IVEL = 4
28941 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28942 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28943 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28944 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28945 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28946 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28947 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28948 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28949 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28950 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28951 IF (IDBJT.LT.116) THEN
28952* total energy, multiplicity
28953 AVE(1,30) = AVE(1,30) +PE
28954 AVE(IVEL,30) = AVE(IVEL,30)+PE
28955 AVPT(1,30) = AVPT(1,30) +PT
28956 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28957 IAVPT(1,30) = IAVPT(1,30) +1
28958 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28959 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28960 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28961 AVMULT(1,30) = AVMULT(1,30) +ONE
28962 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28963* charged energy, multiplicity
28964 IF (ICHAR.LT.0) THEN
28965 AVE(1,26) = AVE(1,26) +PE
28966 AVE(IVEL,26) = AVE(IVEL,26)+PE
28967 AVPT(1,26) = AVPT(1,26) +PT
28968 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28969 IAVPT(1,26) = IAVPT(1,26) +1
28970 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28971 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28972 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28973 AVMULT(1,26) = AVMULT(1,26) +ONE
28974 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28975 ENDIF
28976 IF (ICHAR.NE.0) THEN
28977 AVE(1,27) = AVE(1,27) +PE
28978 AVE(IVEL,27) = AVE(IVEL,27)+PE
28979 AVPT(1,27) = AVPT(1,27) +PT
28980 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28981 IAVPT(1,27) = IAVPT(1,27) +1
28982 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28983 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28984 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28985 AVMULT(1,27) = AVMULT(1,27) +ONE
28986 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28987 ENDIF
28988 ENDIF
28989 ENDIF
28990
28991 RETURN
28992
28993*------------------------------------------------------------------
28994* output
28995 3 CONTINUE
28996 WRITE(LOUT,3000)
28997 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28998 & 29X,'---------------------',/)
28999 IF (MULDEF.EQ.1) THEN
29000 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29001 ELSE
29002 BETGRE = 0.7D0
29003 BETBLC = 0.23D0
29004 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29005 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29006 & ,F4.2,' black: beta < ',F4.2,/)
29007 ENDIF
29008 WRITE(LOUT,3003) SWMEXP
29009 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29010 & 13X,'| total fast',
29011C & ' grey black K f(',F3.1,')',/,1X,
29012 & ' grey black <pt> f(',F3.1,')',/,1X,
29013 & '------------+--------------',
29014 & '-------------------------------------------------')
29015 DO 30 I=1,NOPART
29016 DO 31 J=1,4
29017 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29018 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29019 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29020 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29021 31 CONTINUE
29022 IF (I.LE.115) THEN
29023 WRITE(LOUT,3004) ANAME(I),I,
29024 & AVMULT(1,I),AVMULT(2,I),
29025 & AVMULT(3,I),AVMULT(4,I),
29026C & AVE(1,I),AVSWM(1,I)
29027 & AVPT(1,I),AVSWM(1,I)
29028 ELSEIF (I.LE.119) THEN
29029 WRITE(LOUT,3004) ANAMEH(I-115),I,
29030 & AVMULT(1,I),AVMULT(2,I),
29031 & AVMULT(3,I),AVMULT(4,I),
29032C & AVE(1,I),AVSWM(1,I)
29033 & AVPT(1,I),AVSWM(1,I)
29034 ENDIF
29035 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29036 30 CONTINUE
29037**temporary
29038C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29039C & AVMULT(3,27)+AVMULT(4,27)
29040**
29041
29042 RETURN
29043 END
29044
29045*$ CREATE DT_HISTAT.FOR
29046*COPY DT_HISTAT
29047*
29048*===histat=============================================================*
29049*
29050 SUBROUTINE DT_HISTAT(IDX,MODE)
29051
29052************************************************************************
29053* This version dated 26.02.96 is written by S. Roesler *
29054* *
29055* Last change 27.12.2006 by S. Roesler. *
29056************************************************************************
29057
29058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29059 SAVE
29060
29061 PARAMETER ( LINP = 10 ,
29062 & LOUT = 6 ,
29063 & LDAT = 9 )
29064
29065 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29066 PARAMETER (NDIM=199)
29067
29068* event history
29069
29070 PARAMETER (NMXHKK=200000)
29071
29072 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29073 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29074 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29075
29076* extended event history
29077 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29078 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29079 & IHIST(2,NMXHKK)
29080
29081* particle properties (BAMJET index convention)
29082 CHARACTER*8 ANAME
29083 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29084 & IICH(210),IIBAR(210),K1(210),K2(210)
29085
29086 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29087
29088* Glauber formalism: cross sections
29089 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29090 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29091 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29092 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29093 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29094 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29095 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29096 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29097 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29098 & BSLOPE,NEBINI,NQBINI
29099
29100* emulsion treatment
29101 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29102 & NCOMPO,IEMUL
29103
29104* properties of interacting particles
29105 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29106
29107* rejection counter
29108 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29109 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29110 & IREXCI(3),IRDIFF(2),IRINC
29111
29112* statistics: residual nuclei
29113 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29114 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29115 & NINCST(2,4),NINCEV(2),
29116 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29117 & NRESPB(2),NRESCH(2),NRESEV(4),
29118 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29119 & NEVAFI(2,2)
29120
29121* parameter for intranuclear cascade
29122 LOGICAL LPAULI
29123 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29124
29125* INCLUDE '(DIMPAR)'
29126* Taken from FLUKA
29127 PARAMETER ( MXXRGN =20000 )
29128 PARAMETER ( MXXMDF = 710 )
29129 PARAMETER ( MXXMDE = 702 )
29130 PARAMETER ( MFSTCK =40000 )
29131 PARAMETER ( MESTCK = 100 )
29132 PARAMETER ( MOSTCK = 2000 )
29133 PARAMETER ( MXPRSN = 100 )
29134 PARAMETER ( MXPDPM = 800 )
29135 PARAMETER ( MXPSCS =30000 )
29136 PARAMETER ( MXGLWN = 300 )
29137 PARAMETER ( MXOUTU = 50 )
29138 PARAMETER ( NALLWP = 64 )
29139 PARAMETER ( NELEMX = 80 )
29140 PARAMETER ( MPDPDX = 18 )
29141 PARAMETER ( MXHTTR = 260 )
29142 PARAMETER ( MXSEAX = 20 )
29143 PARAMETER ( MXHTNC = MXSEAX + 1 )
29144 PARAMETER ( ICOMAX = 2400 )
29145 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29146 PARAMETER ( NSTBIS = 304 )
29147 PARAMETER ( NQSTIS = 46 )
29148 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29149 PARAMETER ( MXPABL = 120 )
29150 PARAMETER ( IDMAXP = 450 )
29151 PARAMETER ( IDMXDC = 2000 )
29152 PARAMETER ( MXMCIN = 410 )
29153 PARAMETER ( IHYPMX = 4 )
29154 PARAMETER ( MKBMX1 = 11 )
29155 PARAMETER ( MKBMX2 = 11 )
29156 PARAMETER ( MXIRRD = 2500 )
29157 PARAMETER ( MXTRDC = 1500 )
29158 PARAMETER ( NKTL = 17 )
29159 PARAMETER ( NBLNMX = 40000000 )
29160
29161* INCLUDE '(PAREVT)'
29162* Taken from FLUKA
29163 PARAMETER ( FRDIFF = 0.2D+00 )
29164 PARAMETER ( ETHSEA = 1.0D+00 )
29165*
29166 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29167 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29168 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29169 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29170 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29171 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29172 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29173 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29174 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29175 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29176
29177* INCLUDE '(FRBKCM)'
29178* Taken from FLUKA
29179* Maximum number of fragments to be emitted:
29180 PARAMETER ( MXFFBK = 6 )
29181 PARAMETER ( MXZFBK = 10 )
29182 PARAMETER ( MXNFBK = 12 )
29183 PARAMETER ( MXAFBK = 16 )
29184 PARAMETER ( MXASST = 25 )
29185 PARAMETER ( NXAFBK = MXAFBK + 1 )
29186 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29187 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29188 PARAMETER ( MXPSST = 700 )
29189* Maximum number of pre-computed break-up combinations
29190 PARAMETER ( MXPPFB = 42500 )
29191* Maximum number of break-up combinations, including special
29192* run-time ones:
29193 PARAMETER ( MXPSFB = 43000 )
29194* Base for J multiplicity encoding:
29195 PARAMETER ( IBFRBK = 73 )
29196* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29197* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29198* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29199* --> Ibfrbk^(Jpwfbx+1) < 2100000000
29200 PARAMETER ( JPWFBX = 4 )
29201 LOGICAL LFRMBK, LNCMSS
29202 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29203 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29204 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29205 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29206 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29207 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29208 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29209 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29210 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29211 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29212
29213* INCLUDE '(EVAFLG)'
29214* Taken from FLUKA
29215 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29216 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29217 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29218 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29219 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29220 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29221 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29222 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29223 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29224 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29225 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29226 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29227
29228* temporary storage for one final state particle
29229 LOGICAL LFRAG,LGREY,LBLACK
29230 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29231 & SINTHE,COSTHE,THETA,THECMS,
29232 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29233 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29234 & LFRAG,LGREY,LBLACK
29235
29236* event flag used for histograms
29237 COMMON /DTNORM/ ICEVT,IEVHKK
29238
29239* statistics: double-Pomeron exchange
29240 COMMON /DTFLG2/ INTFLG,IPOPO
29241
29242 DIMENSION EMUSAM(NCOMPX)
29243
29244 CHARACTER*13 CMSG(3)
29245 DATA CMSG /'not requested','not requested','not requested'/
29246
29247 GOTO (1,2,3,4,5) MODE
29248
29249*------------------------------------------------------------------
29250* initialization
29251 1 CONTINUE
29252* emulsion treatment
29253 IF (NCOMPO.GT.0) THEN
29254 DO 10 I=1,NCOMPX
29255 EMUSAM(I) = ZERO
29256 10 CONTINUE
29257 ENDIF
29258* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29259 NINCGE = 0
29260 DO 11 I=1,2
29261 EXCDPM(I) = ZERO
29262 EXCDPM(I+2) = ZERO
29263 EXCEVA(I) = ZERO
29264 NINCWO(I) = 0
29265 NINCEV(I) = 0
29266 NRESTO(I) = 0
29267 NRESPR(I) = 0
29268 NRESNU(I) = 0
29269 NRESBA(I) = 0
29270 NRESPB(I) = 0
29271 NRESCH(I) = 0
29272 NRESEV(I) = 0
29273 NRESEV(I+2) = 0
29274 NEVAGA(I) = 0
29275 NEVAHT(I) = 0
29276 NEVAFI(1,I) = 0
29277 NEVAFI(2,I) = 0
29278 DO 12 J=1,6
29279 IF (J.LE.2) NINCHR(I,J) = 0
29280 IF (J.LE.3) NINCCO(I,J) = 0
29281 IF (J.LE.4) NINCST(I,J) = 0
29282 NEVA(I,J) = 0
29283 12 CONTINUE
29284 DO 13 J=1,210
29285 NEVAHY(1,I,J) = 0
29286 NEVAHY(2,I,J) = 0
29287 13 CONTINUE
29288 11 CONTINUE
29289 MAXGEN = 0
29290**dble Po statistics.
29291 KPOPO = 0
29292
29293 RETURN
29294*------------------------------------------------------------------
29295* filling of histogram with event-record
29296 2 CONTINUE
29297 IF (IST.EQ.-1) THEN
29298 IF (.NOT.LFRAG) THEN
29299 IF (IDPDG.EQ.2212) THEN
29300 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29301 ELSEIF (IDPDG.EQ.2112) THEN
29302 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29303 ELSEIF (IDPDG.EQ.22) THEN
29304 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29305 ELSEIF (IDPDG.EQ.80000) THEN
29306 IF (IDBJT.EQ.116) THEN
29307 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29308 ELSEIF (IDBJT.EQ.117) THEN
29309 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29310 ELSEIF (IDBJT.EQ.118) THEN
29311 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29312 ELSEIF (IDBJT.EQ.119) THEN
29313 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29314 ENDIF
29315 ENDIF
29316 ELSE
29317* heavy fragments (here: fission products only)
29318 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29319 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29320 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29321 ENDIF
29322 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29323 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29324 ENDIF
29325
29326 RETURN
29327*------------------------------------------------------------------
29328* output
29329 3 CONTINUE
29330
29331**dble Po statistics.
29332C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29333C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29334C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29335
29336* emulsion treatment
29337 IF (NCOMPO.GT.0) THEN
29338 WRITE(LOUT,3000)
29339 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29340 & 22X,'----------------------------',/,/,19X,
29341 & 'mass charge fraction',/,39X,
29342 & 'input treated',/)
29343 DO 30 I=1,NCOMPO
29344 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29345 & EMUSAM(I)/DBLE(ICEVT)
29346 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29347 30 CONTINUE
29348 ENDIF
29349
29350* i.n.c. statistics: output
29351 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29352 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29353 & 22X,'---------------------------------',/,/,1X,
29354 & 'no. of events for normalization: (accepted final events,',
29355 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29356 & /,1X,'no. of rejected events due to intranuclear',
29357 & ' cascade',15X,I6,/)
29358 ICEV = MAX(ICEVT,1)
29359 ICEV1 = ICEV
29360 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29361 WRITE(LOUT,3002)
29362 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29363 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29364 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29365 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29366 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29367 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29368 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29369 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29370 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29371 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29372 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29373 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29374 & /,1X,'maximum no. of generations treated (maximum allowed:'
29375 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29376 & ' interactions in proj./ target (mean per evt1)',
29377 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29378 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29379 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29380 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29381 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29382 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29383 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29384 & 'evaporation',/,22X,'-----------------------------',
29385 & '------------',/,/,1X,'no. of events for normal.: ',
29386 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29387 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29388 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29389
29390 WRITE(LOUT,3004)
29391 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29392 ICEV = MAX(NRESEV(2),1)
29393 WRITE(LOUT,3005)
29394 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29395 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29396 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29397 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29398 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29399 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29400 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29401 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29402 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29403 & 'proj. / target',/,/,8X,'total number of particles',15X,
29404 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29405 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29406 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29407 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29408 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29409
29410* evaporation / fission / fragmentation statistics: output
29411 ICEV = MAX(NRESEV(2),1)
29412 ICEV1 = MAX(NRESEV(4),1)
29413 NTEVA1 =
29414 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29415 NTEVA2 =
29416 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29417 IF (LEVPRT) THEN
29418
29419 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29420
29421 IF (LFRMBK) CMSG(2) = 'requested '
29422 IF (LDEEXG) CMSG(3) = 'requested '
29423 WRITE(LOUT,3006)
29424 & CMSG,
29425 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29426 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29427 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29428 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29429 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29430 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29431 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29432 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29433 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29434 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29435 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29436 & 'deexcitation:',2X,A13,/,/,
29437 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29438 & 'proj. / target',/,/,8X,'total number of evap. particles',
29439 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29440 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29441 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29442 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29443 & 'heavy fragments',25X,2F9.3,/)
29444
29445 IF (IEVFSS.EQ.1) THEN
29446
29447 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29448 & NEVAFI(2,1),NEVAFI(2,2),
29449 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29450 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29451 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29452 & 12X,'out of which fission occured',8X,2I9,/,
29453 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29454 ENDIF
29455
29456C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29457
29458C WRITE(LOUT,3008)
29459C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29460C & ' proj. / target',/)
29461C DO 31 I=1,210
29462C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29463C WRITE(LOUT,3009) I,
29464C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29465C3009 FORMAT(38X,I3,3X,2E12.3)
29466C ENDIF
29467C 31 CONTINUE
29468C WRITE(LOUT,3010)
29469C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29470C & ' proj. / target',/)
29471C DO 32 I=1,210
29472C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29473C WRITE(LOUT,3011) I,
29474C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29475C3011 FORMAT(38X,I3,3X,2E12.3)
29476C ENDIF
29477C 32 CONTINUE
29478C WRITE(LOUT,*)
29479C ENDIF
29480 ELSE
29481 WRITE(LOUT,3012)
29482 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29483 & 'Evaporation: not requested',/)
29484 ENDIF
29485
29486 RETURN
29487*------------------------------------------------------------------
29488* filling of histogram with event-record
29489 4 CONTINUE
29490* emulsion treatment
29491 IF (NCOMPO.GT.0) THEN
29492 DO 40 I=1,NCOMPO
29493 IF (IT.EQ.IEMUMA(I)) THEN
29494 EMUSAM(I) = EMUSAM(I)+ONE
29495 ENDIF
29496 40 CONTINUE
29497 ENDIF
29498 NINCGE = NINCGE+MAXGEN
29499 MAXGEN = 0
29500**dble Po statistics.
29501 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29502
29503 RETURN
29504*------------------------------------------------------------------
29505* filling of histogram with event-record
29506 5 CONTINUE
29507 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29508 IB = IIBAR(IDBAM(IDX))
29509 IC = IICH(IDBAM(IDX))
29510 J = ISTHKK(IDX)-14
29511 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29512 NINCST(J,1) = NINCST(J,1)+1
29513 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29514 NINCST(J,2) = NINCST(J,2)+1
29515 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29516 NINCST(J,3) = NINCST(J,3)+1
29517 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29518 NINCST(J,4) = NINCST(J,4)+1
29519 ENDIF
29520 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29521 NINCWO(1) = NINCWO(1)+1
29522 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29523 NINCWO(2) = NINCWO(2)+1
29524 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29525 IB = IDRES(IDX)
29526 IC = IDXRES(IDX)
29527 IF (IC.GT.0) THEN
29528 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29529 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29530 ENDIF
29531 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29532 ENDIF
29533
29534 RETURN
29535 END
29536*$ CREATE DT_NEWHGR.FOR
29537*COPY DT_NEWHGR
29538*
29539*===newhgr=============================================================*
29540*
29541 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29542
29543************************************************************************
29544* *
29545* Histogram initialization. *
29546* *
29547* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29548* XLIM3 bin size *
29549* IBIN > 0 number of bins in equidistant lin. binning *
29550* = -1 reset histograms *
29551* < -1 |IBIN| number of bins in equidistant log. *
29552* binning or log. binning in user def. struc. *
29553* XLIMB(*) user defined bin structure *
29554* *
29555* The bin structure is sensitive to *
29556* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29557* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29558* XLIMB, IBIN if XLIM3 < 0 *
29559* *
29560* *
29561* output: IREFN histogram index *
29562* (= -1 for inconsistent histogr. request) *
29563* *
29564* This subroutine is based on a original version by R. Engel. *
29565* This version dated 22.4.95 is written by S. Roesler. *
29566************************************************************************
29567
29568 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29569 SAVE
29570
29571 PARAMETER ( LINP = 10 ,
29572 & LOUT = 6 ,
29573 & LDAT = 9 )
29574
29575 LOGICAL LSTART
29576
29577 PARAMETER (ZERO = 0.0D0,
29578 & TINY = 1.0D-10)
29579
29580 DIMENSION XLIMB(*)
29581
29582* histograms
29583
29584 PARAMETER (NHIS=150, NDIM=250)
29585
29586 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29587 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29588
29589* auxiliary common for histograms
29590 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29591
29592 DATA LSTART /.TRUE./
29593
29594* reset histogram counter
29595 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29596 IHISL = 0
29597 IF (IBIN.EQ.-1) RETURN
29598 LSTART = .FALSE.
29599 ENDIF
29600
29601 IHIS = IHISL+1
29602* check for maximum number of allowed histograms
29603 IF (IHIS.GT.NHIS) THEN
29604 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29605 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29606 & I4,') exceeds array size (',I4,')',/,21X,
29607 & 'histogram',I3,' skipped!')
29608 GOTO 9999
29609 ENDIF
29610
29611 IREFN = IHIS
29612 IBINS(IHIS) = ABS(IBIN)
29613* check requested number of bins
29614 IF (IBINS(IHIS).GE.NDIM) THEN
29615 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29616 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29617 & I3,') exceeds array size (',I3,')',/,21X,
29618 & 'and will be reset to ',I3)
29619 IBINS(IHIS) = NDIM
29620 ENDIF
29621 IF (IBINS(IHIS).EQ.0) THEN
29622 WRITE(LOUT,1001) IBIN,IHIS
29623 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29624 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29625 GOTO 9999
29626 ENDIF
29627
29628* initialize arrays
29629 DO 1 I=1,NDIM
29630 DO 2 K=1,3
29631 HIST(K,IHIS,I) = ZERO
29632 HIST(K+3,IHIS,I) = ZERO
29633 TMPHIS(K,IHIS,I) = ZERO
29634 2 CONTINUE
29635 HIST(7,IHIS,I) = ZERO
29636 1 CONTINUE
29637 DENTRY(1,IHIS)= ZERO
29638 DENTRY(2,IHIS)= ZERO
29639 OVERF(IHIS) = ZERO
29640 UNDERF(IHIS) = ZERO
29641 TMPUFL(IHIS) = ZERO
29642 TMPOFL(IHIS) = ZERO
29643
29644* bin str. sensitive to lower edge, bin size, and numb. of bins
29645 IF (XLIM3.GT.ZERO) THEN
29646 DO 3 K=1,IBINS(IHIS)+1
29647 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29648 3 CONTINUE
29649 ISWI(IHIS) = 1
29650* bin str. sensitive to lower/upper edge and numb. of bins
29651 ELSEIF (XLIM3.EQ.ZERO) THEN
29652* linear binning
29653 IF (IBIN.GT.0) THEN
29654 XLOW = XLIM1
29655 XHI = XLIM2
29656 IF (XLIM2.LE.XLIM1) THEN
29657 WRITE(LOUT,1002) XLIM1,XLIM2
29658 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29659 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29660 GOTO 9999
29661 ENDIF
29662 ISWI(IHIS) = 1
29663 ELSEIF (IBIN.LT.-1) THEN
29664* logarithmic binning
29665 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29666 WRITE(LOUT,1004) XLIM1,XLIM2
29667 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29668 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29669 GOTO 9999
29670 ENDIF
29671 IF (XLIM2.LE.XLIM1) THEN
29672 WRITE(LOUT,1005) XLIM1,XLIM2
29673 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29674 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29675 GOTO 9999
29676 ENDIF
29677 XLOW = LOG10(XLIM1)
29678 XHI = LOG10(XLIM2)
29679 ISWI(IHIS) = 3
29680 ENDIF
29681 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29682 DO 4 K=1,IBINS(IHIS)+1
29683 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29684 4 CONTINUE
29685 ELSE
29686* user defined bin structure
29687 DO 5 K=1,IBINS(IHIS)+1
29688 IF (IBIN.GT.0) THEN
29689 HIST(1,IHIS,K) = XLIMB(K)
29690 ISWI(IHIS) = 2
29691 ELSEIF (IBIN.LT.-1) THEN
29692 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29693 ISWI(IHIS) = 4
29694 ENDIF
29695 5 CONTINUE
29696 ENDIF
29697
29698* histogram accepted
29699 IHISL = IHIS
29700
29701 RETURN
29702
29703 9999 CONTINUE
29704 IREFN = -1
29705 RETURN
29706 END
29707
29708*$ CREATE DT_FILHGR.FOR
29709*COPY DT_FILHGR
29710*
29711*===filhgr=============================================================*
29712*
29713 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29714
29715************************************************************************
29716* *
29717* Scoring for histogram IHIS. *
29718* *
29719* This subroutine is based on a original version by R. Engel. *
29720* This version dated 23.4.95 is written by S. Roesler. *
29721************************************************************************
29722
29723 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29724 SAVE
29725
29726 PARAMETER ( LINP = 10 ,
29727 & LOUT = 6 ,
29728 & LDAT = 9 )
29729
29730 PARAMETER (ZERO = 0.0D0,
29731 & ONE = 1.0D0,
29732 & TINY = 1.0D-10)
29733
29734* histograms
29735
29736 PARAMETER (NHIS=150, NDIM=250)
29737
29738 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29739 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29740
29741* auxiliary common for histograms
29742 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29743
29744 DATA NCEVT /1/
29745
29746 X = XI
29747 Y = YI
29748
29749* dump content of temorary arrays into histograms
29750 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29751 CALL DT_EVTHIS(IDUM)
29752 NCEVT = NEVT
29753 ENDIF
29754
29755* check histogram index
29756 IF (IHIS.EQ.-1) RETURN
29757 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29758C WRITE(LOUT,1000) IHIS,IHISL
29759 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29760 & ' out of range (1..',I3,')')
29761 RETURN
29762 ENDIF
29763
29764 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29765* bin structure not explicitly given
29766 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29767 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29768 IF (X.LT.HIST(1,IHIS,1)) THEN
29769 I1 = 0
29770 ELSE
29771 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29772 ENDIF
29773
29774 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29775* user defined bin structure
29776 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29777 IF (X.LT.HIST(1,IHIS,1)) THEN
29778 I1 = 0
29779 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29780 I1 = IBINS(IHIS)+1
29781 ELSE
29782* binary sort algorithm
29783 KMIN = 0
29784 KMAX = IBINS(IHIS)+1
29785 1 CONTINUE
29786 IF ((KMAX-KMIN).EQ.1) GOTO 2
29787 KK = (KMAX+KMIN)/2
29788 IF (X.LE.HIST(1,IHIS,KK)) THEN
29789 KMAX=KK
29790 ELSE
29791 KMIN=KK
29792 ENDIF
29793 GOTO 1
29794 2 CONTINUE
29795 I1 = KMIN
29796 ENDIF
29797
29798 ELSE
29799 WRITE(LOUT,1001)
29800 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29801 RETURN
29802 ENDIF
29803
29804* scoring
29805 IF (I1.LE.0) THEN
29806 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29807 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29808 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29809 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29810 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29811 ELSE
29812 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29813 ENDIF
29814 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29815 ELSE
29816 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29817 ENDIF
29818
29819 RETURN
29820 END
29821
29822*$ CREATE DT_EVTHIS.FOR
29823*COPY DT_EVTHIS
29824*
29825*===evthis=============================================================*
29826*
29827 SUBROUTINE DT_EVTHIS(NEVT)
29828
29829************************************************************************
29830* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29831* is called after each event and for the last event before any call *
29832* to OUTHGR. *
29833* NEVT number of events dumped, this is only needed to *
29834* get the normalization after the last event *
29835* This version dated 23.4.95 is written by S. Roesler. *
29836************************************************************************
29837
29838 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29839 SAVE
29840
29841 PARAMETER ( LINP = 10 ,
29842 & LOUT = 6 ,
29843 & LDAT = 9 )
29844
29845 LOGICAL LNOETY
29846
29847 PARAMETER (ZERO = 0.0D0,
29848 & ONE = 1.0D0,
29849 & TINY = 1.0D-10)
29850
29851* histograms
29852
29853 PARAMETER (NHIS=150, NDIM=250)
29854
29855 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29856 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29857
29858* auxiliary common for histograms
29859 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29860
29861 DATA NCEVT /0/
29862
29863 NCEVT = NCEVT+1
29864 NEVT = NCEVT
29865
29866 DO 1 I=1,IHISL
29867 LNOETY = .TRUE.
29868 DO 2 J=1,IBINS(I)
29869 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29870 LNOETY = .FALSE.
29871 HIST(2,I,J) = HIST(2,I,J)+ONE
29872 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29873 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29874 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29875 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29876 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29877 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29878 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29879 TMPHIS(1,I,J) = ZERO
29880 TMPHIS(2,I,J) = ZERO
29881 TMPHIS(3,I,J) = ZERO
29882 ENDIF
29883 2 CONTINUE
29884 IF (LNOETY) THEN
29885 IF (TMPUFL(I).GT.ZERO) THEN
29886 UNDERF(I) = UNDERF(I)+ONE
29887 TMPUFL(I) = ZERO
29888 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29889 OVERF(I) = OVERF(I)+ONE
29890 TMPOFL(I) = ZERO
29891 ENDIF
29892 ELSE
29893 DENTRY(1,I) = DENTRY(1,I)+ONE
29894 ENDIF
29895 1 CONTINUE
29896
29897 RETURN
29898 END
29899
29900*$ CREATE DT_OUTHGR.FOR
29901*COPY DT_OUTHGR
29902*
29903*===outhgr=============================================================*
29904*
29905 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29906 & ILOGY,INORM,NMODE)
29907
29908************************************************************************
29909* *
29910* Plot histogram(s) to standard output unit *
29911* *
29912* I1..6 indices of histograms to be plotted *
29913* CHEAD,IHEAD header string,integer *
29914* NEVTS number of events *
29915* FAC scaling factor *
29916* ILOGY = 1 logarithmic y-axis *
29917* INORM normalization *
29918* = 0 no further normalization (FAC is obsolete) *
29919* = 1 per event and bin width *
29920* = 2 per entry and bin width *
29921* = 3 per bin entry *
29922* = 4 per event and "bin width" x1^2...x2^2 *
29923* = 5 per event and "log. bin width" ln x1..ln x2 *
29924* = 6 per event *
29925* MODE = 0 no output but normalization applied *
29926* = 1 all valid histograms separately (small frame) *
29927* all valid histograms separately (small frame) *
29928* = -1 and tables as histograms *
29929* = 2 all valid histograms (one plot, wide frame) *
29930* all valid histograms (one plot, wide frame) *
29931* = -2 and tables as histograms *
29932* *
29933* *
29934* Note: All histograms to be plotted with one call to this *
29935* subroutine and |MODE|=2 must have the same bin structure! *
29936* There is no test included ensuring this fact. *
29937* *
29938* This version dated 23.4.95 is written by S. Roesler. *
29939************************************************************************
29940
29941 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29942 SAVE
29943
29944 PARAMETER ( LINP = 10 ,
29945 & LOUT = 6 ,
29946 & LDAT = 9 )
29947
29948 CHARACTER*72 CHEAD
29949
29950 PARAMETER (ZERO = 0.0D0,
29951 & IZERO = 0,
29952 & ONE = 1.0D0,
29953 & TWO = 2.0D0,
29954 & OHALF = 0.5D0,
29955 & EPS = 1.0D-5,
29956 & TINY = 1.0D-8,
29957 & SMALL = -1.0D8,
29958 & RLARGE = 1.0D8 )
29959
29960* histograms
29961
29962 PARAMETER (NHIS=150, NDIM=250)
29963
29964 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29965 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29966
29967 PARAMETER (NDIM2 = 2*NDIM)
29968 DIMENSION XX(NDIM2),YY(NDIM2)
29969
29970 PARAMETER (NHISTO = 6)
29971 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29972 & IDX(NHISTO)
29973
29974 CHARACTER*43 CNORM(0:8)
29975 DATA CNORM /'no further normalization ',
29976 & 'per event and bin width ',
29977 & 'per entry1 and bin width ',
29978 & 'per bin entry ',
29979 & 'per event and "bin width" x1^2...x2^2 ',
29980 & 'per event and "log. bin width" ln x1..ln x2',
29981 & 'per event ',
29982 & 'per bin entry1 ',
29983 & 'per entry2 and bin width '/
29984
29985 IDX1(1) = I1
29986 IDX1(2) = I2
29987 IDX1(3) = I3
29988 IDX1(4) = I4
29989 IDX1(5) = I5
29990 IDX1(6) = I6
29991
29992 MODE = NMODE
29993
29994* initialization if "wide frame" is requested
29995 IF (ABS(MODE).EQ.2) THEN
29996 DO 1 I=1,NHISTO
29997 DO 2 J=1,NDIM
29998 XX1(J,I) = ZERO
29999 YY1(J,I) = ZERO
30000 2 CONTINUE
30001 1 CONTINUE
30002 ENDIF
30003
30004* plot header
30005 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30006
30007* check histogram indices
30008 NHI = 0
30009 DO 3 I=1,NHISTO
30010 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30011 IF (ISWI(IDX1(I)).NE.0) THEN
30012 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30013 WRITE(LOUT,1000)
30014 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30015 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30016 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30017 & ' overflows: ',F10.0)
30018 ELSE
30019 NHI = NHI+1
30020 IDX(NHI) = IDX1(I)
30021 ENDIF
30022 ENDIF
30023 ENDIF
30024 3 CONTINUE
30025 IF (NHI.EQ.0) THEN
30026 WRITE(LOUT,1001)
30027 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30028 RETURN
30029 ENDIF
30030
30031* check normalization request
30032 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30033 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30034 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30035 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30036 WRITE(LOUT,1002) NEVTS,INORM,FAC
30037 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30038 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30039 & 'FAC = ',E11.4)
30040 RETURN
30041 ENDIF
30042
30043 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30044
30045* apply normalization
30046 DO 4 N=1,NHI
30047
30048 I = IDX(N)
30049
30050 IF (ISWI(I).EQ.1) THEN
30051 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30052 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30053 & ' to',2X,E10.4,',',2X,I3,' bins')
30054 ELSEIF (ISWI(I).EQ.2) THEN
30055 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30056 WRITE(LOUT,1007)
30057 1007 FORMAT(1X,'user defined bin structure')
30058 ELSEIF (ISWI(I).EQ.3) THEN
30059 WRITE(LOUT,1004)
30060 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30061 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30062 & ' to',2X,E10.4,',',2X,I3,' bins')
30063 ELSEIF (ISWI(I).EQ.4) THEN
30064 WRITE(LOUT,1004)
30065 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30066 WRITE(LOUT,1007)
30067 ELSE
30068 WRITE(LOUT,1008) ISWI(I)
30069 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30070 ENDIF
30071 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30072 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30073 & ' overfl.:',F8.0)
30074 WRITE(LOUT,1009) CNORM(INORM)
30075 1009 FORMAT(1X,'normalization: ',A,/)
30076
30077 DO 5 K=1,IBINS(I)
30078 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30079 YMEAN = FAC*YMEAN
30080 YERR = FAC*YERR
30081 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30082 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30083 1006 FORMAT(1X,5E11.3)
30084* small frame
30085 II = 2*K
30086 XX(II-1) = HIST(1,I,K)
30087 XX(II) = HIST(1,I,K+1)
30088 YY(II-1) = YMEAN
30089 YY(II) = YMEAN
30090* wide frame
30091 XX1(K,N) = XMEAN
30092 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30093 & XX1(K,N) = LOG10(XMEAN)
30094 YY1(K,N) = YMEAN
30095 5 CONTINUE
30096
30097* plot small frame
30098 IF (ABS(MODE).EQ.1) THEN
30099 IBIN2 = 2*IBINS(I)
30100 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30101 IF(ILOGY.EQ.1) THEN
30102 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30103 ELSE
30104 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30105 ENDIF
30106 ENDIF
30107
30108 4 CONTINUE
30109
30110* plot wide frame
30111 IF (ABS(MODE).EQ.2) THEN
30112 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30113 NSIZE = NDIM*NHISTO
30114 DXLOW = HIST(1,IDX(1),1)
30115 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30116 YLOW = RLARGE
30117 YHI = SMALL
30118 DO 6 I=1,NHISTO
30119 DO 7 J=1,NDIM
30120 IF (YY1(J,I).LT.YLOW) THEN
30121 IF (ILOGY.EQ.1) THEN
30122 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30123 ELSE
30124 YLOW = YY1(J,I)
30125 ENDIF
30126 ENDIF
30127 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30128 7 CONTINUE
30129 6 CONTINUE
30130 DY = (YHI-YLOW)/DBLE(NDIM)
30131 IF (DY.LE.ZERO) THEN
30132 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30133 & 'OUTHGR: warning! zero bin width for histograms ',
30134 & IDX,': ',YLOW,YHI
30135 RETURN
30136 ENDIF
30137 IF (ILOGY.EQ.1) THEN
30138 YLOW = LOG10(YLOW)
30139 DY = (LOG10(YHI)-YLOW)/100.0D0
30140 DO 8 I=1,NHISTO
30141 DO 9 J=1,NDIM
30142 IF (YY1(J,I).LE.ZERO) THEN
30143 YY1(J,I) = YLOW
30144 ELSE
30145 YY1(J,I) = LOG10(YY1(J,I))
30146 ENDIF
30147 9 CONTINUE
30148 8 CONTINUE
30149 ENDIF
30150 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30151 ENDIF
30152
30153 RETURN
30154 END
30155
30156*$ CREATE DT_GETBIN.FOR
30157*COPY DT_GETBIN
30158*
30159*===getbin=============================================================*
30160*
30161 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30162 & XMEAN,YMEAN,YERR)
30163
30164************************************************************************
30165* This version dated 23.4.95 is written by S. Roesler. *
30166************************************************************************
30167
30168 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30169 SAVE
30170
30171 PARAMETER ( LINP = 10 ,
30172 & LOUT = 6 ,
30173 & LDAT = 9 )
30174
30175 PARAMETER (ZERO = 0.0D0,
30176 & ONE = 1.0D0,
30177 & TINY35 = 1.0D-35)
30178
30179* histograms
30180
30181 PARAMETER (NHIS=150, NDIM=250)
30182
30183 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30184 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30185
30186 XLOW = HIST(1,IHIS,IBIN)
30187 XHI = HIST(1,IHIS,IBIN+1)
30188 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30189 XLOW = 10**XLOW
30190 XHI = 10**XHI
30191 ENDIF
30192 IF (NORM.EQ.2) THEN
30193 DX = XHI-XLOW
30194 NEVT = INT(DENTRY(1,IHIS))
30195 ELSEIF (NORM.EQ.3) THEN
30196 DX = ONE
30197 NEVT = INT(HIST(2,IHIS,IBIN))
30198 ELSEIF (NORM.EQ.4) THEN
30199 DX = XHI**2-XLOW**2
30200 NEVT = KEVT
30201 ELSEIF (NORM.EQ.5) THEN
30202 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30203 NEVT = KEVT
30204 ELSEIF (NORM.EQ.6) THEN
30205 DX = ONE
30206 NEVT = KEVT
30207 ELSEIF (NORM.EQ.7) THEN
30208 DX = ONE
30209 NEVT = INT(HIST(7,IHIS,IBIN))
30210 ELSEIF (NORM.EQ.8) THEN
30211 DX = XHI-XLOW
30212 NEVT = INT(DENTRY(2,IHIS))
30213 ELSE
30214 DX = ABS(XHI-XLOW)
30215 NEVT = KEVT
30216 ENDIF
30217 IF (ABS(DX).LT.TINY35) DX = ONE
30218 NEVT = MAX(NEVT,1)
30219 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30220 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30221 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30222 YSUM = HIST(5,IHIS,IBIN)
30223 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30224C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30225 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30226 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30227
30228 RETURN
30229 END
30230
30231*$ CREATE DT_JOIHIS.FOR
30232*COPY DT_JOIHIS
30233*
30234*===joihis=============================================================*
30235*
30236 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30237
30238************************************************************************
30239* *
30240* Operation on histograms. *
30241* *
30242* input: IH1,IH2 histogram indices to be joined *
30243* COPER character defining the requested operation, *
30244* i.e. '+', '-', '*', '/' *
30245* FAC1,FAC2 factors for joining, i.e. *
30246* FAC1*histo1 COPER FAC2*histo2 *
30247* *
30248* This version dated 23.4.95 is written by S. Roesler. *
30249************************************************************************
30250
30251 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30252 SAVE
30253
30254 PARAMETER ( LINP = 10 ,
30255 & LOUT = 6 ,
30256 & LDAT = 9 )
30257
30258 CHARACTER COPER*1
30259
30260 PARAMETER (ZERO = 0.0D0,
30261 & ONE = 1.0D0,
30262 & OHALF = 0.5D0,
30263 & TINY8 = 1.0D-8,
30264 & SMALL = -1.0D8,
30265 & RLARGE = 1.0D8 )
30266
30267* histograms
30268
30269 PARAMETER (NHIS=150, NDIM=250)
30270
30271 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30272 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30273
30274 PARAMETER (NDIM2 = 2*NDIM)
30275 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30276
30277 CHARACTER*43 CNORM(0:6)
30278 DATA CNORM /'no further normalization ',
30279 & 'per event and bin width ',
30280 & 'per entry and bin width ',
30281 & 'per bin entry ',
30282 & 'per event and "bin width" x1^2...x2^2 ',
30283 & 'per event and "log. bin width" ln x1..ln x2',
30284 & 'per event '/
30285
30286* check histogram indices
30287 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30288 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30289 WRITE(LOUT,1000) IH1,IH2,IHISL
30290 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30291 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30292 GOTO 9999
30293 ENDIF
30294
30295* check bin structure of histograms to be joined
30296 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30297 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30298 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30299 & ' and ',I3,' failed',/,21X,
30300 & 'due to different numbers of bins (',I3,',',I3,')')
30301 GOTO 9999
30302 ENDIF
30303 DO 1 K=1,IBINS(IH1)+1
30304 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30305 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30306 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30307 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30308 & 'X1,X2 = ',2E11.4)
30309 GOTO 9999
30310 ENDIF
30311 1 CONTINUE
30312
30313 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30314 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30315 & 'operation ',A,/,11X,'and factors ',2E11.4)
30316 WRITE(LOUT,1004) CNORM(NORM)
30317 1004 FORMAT(1X,'normalization: ',A,/)
30318
30319 DO 2 K=1,IBINS(IH1)
30320 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30321 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30322 XLOW = XLOW1
30323 XHI = XHI1
30324 XMEAN = OHALF*(XMEAN1+XMEAN2)
30325 IF (COPER.EQ.'+') THEN
30326 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30327 ELSEIF (COPER.EQ.'*') THEN
30328 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30329 ELSEIF (COPER.EQ.'/') THEN
30330 IF (YMEAN2.EQ.ZERO) THEN
30331 YMEAN = ZERO
30332 ELSE
30333 IF (FAC2.EQ.ZERO) FAC2 = ONE
30334 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30335 ENDIF
30336 ELSE
30337 GOTO 9998
30338 ENDIF
30339 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30340 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30341 1006 FORMAT(1X,5E11.3)
30342* small frame
30343 II = 2*K
30344 XX(II-1) = HIST(1,IH1,K)
30345 XX(II) = HIST(1,IH1,K+1)
30346 YY(II-1) = YMEAN
30347 YY(II) = YMEAN
30348* wide frame
30349 XX1(K) = XMEAN
30350 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30351 YY1(K) = YMEAN
30352 2 CONTINUE
30353
30354* plot small frame
30355 IF (ABS(MODE).EQ.1) THEN
30356 IBIN2 = 2*IBINS(IH1)
30357 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30358 IF(ILOGY.EQ.1) THEN
30359 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30360 ELSE
30361 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30362 ENDIF
30363 ENDIF
30364
30365* plot wide frame
30366 IF (ABS(MODE).EQ.2) THEN
30367 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30368 NSIZE = NDIM
30369 DXLOW = HIST(1,IH1,1)
30370 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30371 YLOW = RLARGE
30372 YHI = SMALL
30373 DO 3 I=1,NDIM
30374 IF (YY1(I).LT.YLOW) THEN
30375 IF (ILOGY.EQ.1) THEN
30376 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30377 ELSE
30378 YLOW = YY1(I)
30379 ENDIF
30380 ENDIF
30381 IF (YY1(I).GT.YHI) YHI = YY1(I)
30382 3 CONTINUE
30383 DY = (YHI-YLOW)/DBLE(NDIM)
30384 IF (DY.LE.ZERO) THEN
30385 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30386 & 'JOIHIS: warning! zero bin width for histograms ',
30387 & IH1,IH2,': ',YLOW,YHI
30388 RETURN
30389 ENDIF
30390 IF (ILOGY.EQ.1) THEN
30391 YLOW = LOG10(YLOW)
30392 DY = (LOG10(YHI)-YLOW)/100.0D0
30393 DO 4 I=1,NDIM
30394 IF (YY1(I).LE.ZERO) THEN
30395 YY1(I) = YLOW
30396 ELSE
30397 YY1(I) = LOG10(YY1(I))
30398 ENDIF
30399 4 CONTINUE
30400 ENDIF
30401 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30402 ENDIF
30403
30404 RETURN
30405
30406 9998 CONTINUE
30407 WRITE(LOUT,1005) COPER
30408 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30409
30410 9999 CONTINUE
30411 RETURN
30412 END
30413
30414*$ CREATE DT_XGRAPH.FOR
30415*COPY DT_XGRAPH
30416*
30417*===qgraph=============================================================*
30418*
30419 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30420C***********************************************************************
30421C
30422C calculate quasi graphic picture with 25 lines and 79 columns
30423C ranges will be chosen automatically
30424C
30425C input N dimension of input fields
30426C IARG number of curves (fields) to plot
30427C X field of X
30428C Y1 field of Y1
30429C Y2 field of Y2
30430C
30431C This subroutine is written by R. Engel.
30432C***********************************************************************
30433 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30434 SAVE
30435
30436 PARAMETER ( LINP = 10 ,
30437 & LOUT = 6 ,
30438 & LDAT = 9 )
30439
30440C
30441 DIMENSION X(N),Y1(N),Y2(N)
30442 PARAMETER (EPS=1.D-30)
30443 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30444 CHARACTER SYMB(5)
30445 CHARACTER COL(0:149,0:49)
30446C
30447 DATA SYMB /'0','e','z','#','x'/
30448C
30449 ISPALT=IBREIT-10
30450C
30451C*** automatic range fitting
30452C
30453 XMAX=X(1)
30454 XMIN=X(1)
30455 DO 600 I=1,N
30456 XMAX=MAX(X(I),XMAX)
30457 XMIN=MIN(X(I),XMIN)
30458 600 CONTINUE
30459 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30460C
30461 ITEST=0
30462 DO 1100 K=0,IZEIL-1
30463 ITEST=ITEST+1
30464 IF (ITEST.EQ.IYRAST) THEN
30465 DO 1010 L=1,ISPALT-1
30466 COL(L,K)='-'
304671010 CONTINUE
30468 COL(ISPALT,K)='+'
30469 ITEST=0
30470 DO 1020 L=0,ISPALT-1,IXRAST
30471 COL(L,K)='+'
304721020 CONTINUE
30473 ELSE
30474 DO 1030 L=1,ISPALT-1
30475 COL(L,K)=' '
304761030 CONTINUE
30477 DO 1040 L=0,ISPALT-1,IXRAST
30478 COL(L,K)='|'
304791040 CONTINUE
30480 COL(ISPALT,K)='|'
30481 ENDIF
304821100 CONTINUE
30483C
30484C*** plot curve Y1
30485C
30486 YMAX=Y1(1)
30487 YMIN=Y1(1)
30488 DO 500 I=1,N
30489 YMAX=MAX(Y1(I),YMAX)
30490 YMIN=MIN(Y1(I),YMIN)
30491500 CONTINUE
30492 IF(IARG.GT.1) THEN
30493 DO 550 I=1,N
30494 YMAX=MAX(Y2(I),YMAX)
30495 YMIN=MIN(Y2(I),YMIN)
30496550 CONTINUE
30497 ENDIF
30498 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30499 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30500 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30501 IF(YZOOM.LT.EPS) THEN
30502 WRITE(LOUT,'(1X,A)')
30503 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30504 RETURN
30505 ENDIF
30506C
30507C*** plot curve Y1
30508C
30509 ILAST=-1
30510 LLAST=-1
30511 DO 1200 K=1,N
30512 L=NINT((X(K)-XMIN)/XZOOM)
30513 I=NINT((YMAX-Y1(K))/YZOOM)
30514 IF(ILAST.GE.0) THEN
30515 LD = L-LLAST
30516 ID = I-ILAST
30517 DO 55 II=0,LD,SIGN(1,LD)
30518 DO 66 KK=0,ID,SIGN(1,ID)
30519 COL(II+LLAST,KK+ILAST)=SYMB(1)
30520 66 CONTINUE
30521 55 CONTINUE
30522 ELSE
30523 COL(L,I)=SYMB(1)
30524 ENDIF
30525 ILAST = I
30526 LLAST = L
305271200 CONTINUE
30528C
30529 IF(IARG.GT.1) THEN
30530C
30531C*** plot curve Y2
30532C
30533 DO 1250 K=1,N
30534 L=NINT((X(K)-XMIN)/XZOOM)
30535 I=NINT((YMAX-Y2(K))/YZOOM)
30536 COL(L,I)=SYMB(2)
305371250 CONTINUE
30538 ENDIF
30539C
30540C*** write it
30541C
30542 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30543C
30544C*** write range of X
30545C
30546 XZOOM = (XMAX-XMIN)/DBLE(7)
30547 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30548C
30549 DO 1300 K=0,IZEIL-1
30550 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30551 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30552 110 FORMAT(1X,1PE9.2,70A1)
305531300 CONTINUE
30554C
30555C*** write range of X
30556C
30557 XZOOM = (XMAX-XMIN)/DBLE(7)
30558 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30559 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30560 120 FORMAT(6X,7(1PE10.3))
30561 END
30562
30563*$ CREATE DT_XGLOGY.FOR
30564*COPY DT_XGLOGY
30565*
30566*===qglogy=============================================================*
30567*
30568 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30569C***********************************************************************
30570C
30571C calculate quasi graphic picture with 25 lines and 79 columns
30572C logarithmic y axis
30573C ranges will be chosen automatically
30574C
30575C input N dimension of input fields
30576C IARG number of curves (fields) to plot
30577C X field of X
30578C Y1 field of Y1
30579C Y2 field of Y2
30580C
30581C This subroutine is written by R. Engel.
30582C***********************************************************************
30583C
30584 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30585 SAVE
30586
30587 PARAMETER ( LINP = 10 ,
30588 & LOUT = 6 ,
30589 & LDAT = 9 )
30590
30591 DIMENSION X(N),Y1(N),Y2(N)
30592 PARAMETER (EPS=1.D-30)
30593 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30594 CHARACTER SYMB(5)
30595 CHARACTER COL(0:149,0:49)
30596 PARAMETER (DEPS = 1.D-10)
30597C
30598 DATA SYMB /'0','e','z','#','x'/
30599C
30600 ISPALT=IBREIT-10
30601C
30602C*** automatic range fitting
30603C
30604 XMAX=X(1)
30605 XMIN=X(1)
30606 DO 600 I=1,N
30607 XMAX=MAX(X(I),XMAX)
30608 XMIN=MIN(X(I),XMIN)
30609 600 CONTINUE
30610 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30611C
30612 ITEST=0
30613 DO 1100 K=0,IZEIL-1
30614 ITEST=ITEST+1
30615 IF (ITEST.EQ.IYRAST) THEN
30616 DO 1010 L=1,ISPALT-1
30617 COL(L,K)='-'
306181010 CONTINUE
30619 COL(ISPALT,K)='+'
30620 ITEST=0
30621 DO 1020 L=0,ISPALT-1,IXRAST
30622 COL(L,K)='+'
306231020 CONTINUE
30624 ELSE
30625 DO 1030 L=1,ISPALT-1
30626 COL(L,K)=' '
306271030 CONTINUE
30628 DO 1040 L=0,ISPALT-1,IXRAST
30629 COL(L,K)='|'
306301040 CONTINUE
30631 COL(ISPALT,K)='|'
30632 ENDIF
306331100 CONTINUE
30634C
30635C*** plot curve Y1
30636C
30637 YMAX=Y1(1)
30638 YMIN=MAX(Y1(1),EPS)
30639 DO 500 I=1,N
30640 YMAX =MAX(Y1(I),YMAX)
30641 IF(Y1(I).GT.EPS) THEN
30642 IF(YMIN.EQ.EPS) THEN
30643 YMIN = Y1(I)/10.D0
30644 ELSE
30645 YMIN = MIN(Y1(I),YMIN)
30646 ENDIF
30647 ENDIF
30648500 CONTINUE
30649 IF(IARG.GT.1) THEN
30650 DO 550 I=1,N
30651 YMAX=MAX(Y2(I),YMAX)
30652 IF(Y2(I).GT.EPS) THEN
30653 IF(YMIN.EQ.EPS) THEN
30654 YMIN = Y2(I)
30655 ELSE
30656 YMIN = MIN(Y2(I),YMIN)
30657 ENDIF
30658 ENDIF
30659550 CONTINUE
30660 ENDIF
30661C
30662 DO 560 I=1,N
30663 Y1(I) = MAX(Y1(I),YMIN)
30664 560 CONTINUE
30665 IF(IARG.GT.1) THEN
30666 DO 570 I=1,N
30667 Y2(I) = MAX(Y2(I),YMIN)
30668 570 CONTINUE
30669 ENDIF
30670C
30671 IF(YMAX.LE.YMIN) THEN
30672 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30673 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30674 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30675 RETURN
30676 ENDIF
30677C
30678 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30679 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30680 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30681 IF(YZOOM.LT.EPS) THEN
30682 WRITE(LOUT,'(1X,A)')
30683 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30684 RETURN
30685 ENDIF
30686C
30687C*** plot curve Y1
30688C
30689 ILAST=-1
30690 LLAST=-1
30691 DO 1200 K=1,N
30692 L=NINT((X(K)-XMIN)/XZOOM)
30693 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30694 IF(ILAST.GE.0) THEN
30695 LD = L-LLAST
30696 ID = I-ILAST
30697 DO 55 II=0,LD,SIGN(1,LD)
30698 DO 66 KK=0,ID,SIGN(1,ID)
30699 COL(II+LLAST,KK+ILAST)=SYMB(1)
30700 66 CONTINUE
30701 55 CONTINUE
30702 ELSE
30703 COL(L,I)=SYMB(1)
30704 ENDIF
30705 ILAST = I
30706 LLAST = L
307071200 CONTINUE
30708C
30709 IF(IARG.GT.1) THEN
30710C
30711C*** plot curve Y2
30712C
30713 DO 1250 K=1,N
30714 L=NINT((X(K)-XMIN)/XZOOM)
30715 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30716 COL(L,I)=SYMB(2)
307171250 CONTINUE
30718 ENDIF
30719C
30720C*** write it
30721C
30722 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30723 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30724C
30725C*** write range of X
30726C
30727 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30728 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30729C
30730 DO 1300 K=0,IZEIL-1
30731 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30732 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30733 110 FORMAT(1X,1PE9.2,70A1)
307341300 CONTINUE
30735C
30736C*** write range of X
30737C
30738 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30739 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30740 120 FORMAT(6X,7(1PE10.3))
30741C
30742 END
30743
30744*$ CREATE DT_SRPLOT.FOR
30745*COPY DT_SRPLOT
30746*
30747*===plot===============================================================*
30748*
30749 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30750
30751 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30752 SAVE
30753
30754 PARAMETER ( LINP = 10 ,
30755 & LOUT = 6 ,
30756 & LDAT = 9 )
30757
30758*
30759* initial version
30760* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30761* This is a subroutine of fluka to plot Y across the page
30762* as a function of X down the page. Up to 37 curves can be
30763* plotted in the same picture with different plotting characters.
30764* Output of first 10 overprinted characters addad by FB 88
30765* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30766*
30767* Input Variables:
30768* X = array containing the values of X
30769* Y = array containing the values of Y
30770* N = number of values in X and in Y
30771* can exceed the fixed number of lines
30772* M = number of different curves X,Y are containing
30773* MM = number of points in each curve i.e. N=M*MM
30774* XO = smallest value of X to be plotted
30775* DX = increment of X between subsequent lines
30776* YO = smallest value of Y to be plotted
30777* DY = increment of Y between subsequent character spaces
30778*
30779* other variables used inside:
30780* XX = numbers along the X-coordinate axis
30781* YY = numbers along the Y-coordinate axis
30782* LL = ten lines temporary storage for the plot
30783* L = character set used to plot different curves
30784* LOV = memorizes overprinted symbols
30785* the first 10 overprinted symbols are printed on
30786* the end of the line to avoid ambiguities
30787* (added by FB as considered quite helpful)
30788*
30789*********************************************************************
30790*
30791 DIMENSION XX(61),YY(61),LL(101,10)
30792 DIMENSION X(N),Y(N),L(40),LOV(40,10)
004932dd 30793 INTEGER*4 LL, L, LOV
7b076c76 30794 DATA L/
30795 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30796 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30797 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30798 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30799*
30800*
30801 MN=51
30802 DO 10 I=1,MN
30803 AI=I-1
30804 10 XX(I)=XO+AI*DX
30805 DO 20 I=1,11
30806 AI=I-1
30807 20 YY(I)=YO+10.0D0*AI*DY
30808 WRITE(LOUT, 500) (YY(I),I=1,11)
30809 MMN=MN-1
30810*
30811*
30812 DO 90 JJ=1,MMN,10
30813 JJJ=JJ-1
30814 DO 30 I=1,101
30815 DO 30 J=1,10
30816 30 LL(I,J)=L(40)
30817 DO 40 I=1,101
30818 40 LL(I,1)=L(39)
30819 DO 50 I=1,101,10
30820 DO 50 J=1,10
30821 50 LL(I,J)=L(38)
30822 DO 60 I=1,40
30823 DO 60 J=1,10
30824 60 LOV(I,J)=L(40)
30825*
30826*
30827 DO 70 I=1,M
30828 DO 70 J=1,MM
30829 II=J+(I-1)*MM
30830 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30831 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30832 AIX=AIX-DBLE(JJJ)
30833* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30834 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30835 + . AIY .LT. 102.D0) THEN
30836 IX=INT(AIX)
30837 IY=INT(AIY)
30838 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30839 + THEN
30840 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30841 + =LL(IY,IX)
30842 LL(IY,IX)=L(I)
30843 ENDIF
30844 ENDIF
30845 70 CONTINUE
30846*
30847*
30848 DO 80 I=1,10
30849 II=I+JJJ
30850 III=II+1
30851 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30852 & (LOV(J,I),J=1,10)
30853 80 CONTINUE
30854 90 CONTINUE
30855*
30856*
30857 WRITE(LOUT, 520)
30858 WRITE(LOUT, 500) (YY(I),I=1,11)
30859 RETURN
30860*
30861 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30862 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30863 520 FORMAT(20X,10('1---------'),'1')
30864 END
30865*$ CREATE DT_DEFSET.FOR
30866*COPY DT_DEFSET
30867*
30868*===defset=============================================================*
30869*
30870 BLOCK DATA DT_DEFSET
30871
30872 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30873 SAVE
30874
30875* flags for input different options
30876 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30877 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30878 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30879
30880 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30881
30882* emulsion treatment
30883 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30884 & NCOMPO,IEMUL
30885
30886* / DTFLG1 /
30887 DATA IFRAG / 2, 1 /
30888 DATA IRESCO / 1 /
30889 DATA IMSHL / 1 /
30890 DATA IRESRJ / 0 /
30891 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30892 DATA LEMCCK / .FALSE. /
30893 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30894 & .TRUE.,.TRUE.,.TRUE./
30895 DATA LSEADI / .TRUE. /
30896 DATA LEVAPO / .TRUE. /
30897 DATA IFRAME / 1 /
30898 DATA ITRSPT / 0 /
30899
30900* / DTCOMP /
30901 DATA EMUFRA / NCOMPX*0.0D0 /
30902 DATA IEMUMA / NCOMPX*1 /
30903 DATA IEMUCH / NCOMPX*1 /
30904 DATA NCOMPO / 0 /
30905 DATA IEMUL / 0 /
30906
30907 END
30908
30909*$ CREATE DT_HADPRP.FOR
30910*COPY DT_HADPRP
30911*
30912*===hadprp=============================================================*
30913*
30914 BLOCK DATA DT_HADPRP
30915
30916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30917 SAVE
30918
30919* auxiliary common for reggeon exchange (DTUNUC 1.x)
30920 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30921 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30922 & IQTCHR(-6:6),MQUARK(3,39)
30923
30924* hadron index conversion (BAMJET <--> PDG)
30925 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30926 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30927 & IAMCIN(210)
30928
30929* names of hadrons used in input-cards
30930 CHARACTER*8 BTYPE
30931 COMMON /DTPAIN/ BTYPE(30)
30932
30933* / DTQUAR /
30934*----------------------------------------------------------------------*
30935* *
30936* Quark content of particles: *
30937* index quark el. charge bar. charge isospin isospin3 *
30938* 1 = u 2/3 1/3 1/2 1/2 *
30939* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30940* 2 = d -1/3 1/3 1/2 -1/2 *
30941* -2 = dbar 1/3 -1/3 1/2 1/2 *
30942* 3 = s -1/3 1/3 0 0 *
30943* -3 = sbar 1/3 -1/3 0 0 *
30944* 4 = c 2/3 1/3 0 0 *
30945* -4 = cbar -2/3 -1/3 0 0 *
30946* 5 = b -1/3 1/3 0 0 *
30947* -5 = bbar 1/3 -1/3 0 0 *
30948* 6 = t 2/3 1/3 0 0 *
30949* -6 = tbar -2/3 -1/3 0 0 *
30950* *
30951* Mquark = particle quark composition (Paprop numbering) *
30952* Iqechr = electric charge ( in 1/3 unit ) *
30953* Iqbchr = baryonic charge ( in 1/3 unit ) *
30954* Iqichr = isospin ( in 1/2 unit ), z component *
30955* Iqschr = strangeness *
30956* Iqcchr = charm *
30957* Iquchr = beauty *
30958* Iqtchr = ...... *
30959* *
30960*----------------------------------------------------------------------*
30961 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30962 DATA IQBCHR / 6*-1, 0, 6*1 /
30963 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30964 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30965 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30966 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30967 DATA IQTCHR / -1, 11*0, 1 /
30968 DATA MQUARK /
30969 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30970 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30971 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30972 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30973 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30974 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30975 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30976 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30977
30978* / DTHAIC /
30979* (renamed) (HAdron InDex COnversion)
30980* translation table version filled up by r.e. 25.01.94 *
30981 DATA IAMCIN /
30982 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30983 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30984 &3222,3212,111,311,-311, 0,0,0,0,0,
30985 &221,213,113,-213,223, 323,313,-323,-313,10323,
30986 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30987 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30988 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30989 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30990 &5*99999, 5*99999,
30991 &4*99999,331, 333,3322,3312,-3222,-3212,
30992 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30993 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30994 &-431,441,423,413,-413, -423,433,-433,20443,443,
30995 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30996 &4212,4112,3*99999, 3*99999,-4122,-4232,
30997 &-4132,-4222,-4212,-4112,99999, 5*99999,
30998 &5*99999, 5*99999,
30999 &10*99999,
31000 &5*99999 , 20211,20111,-20211,99999,20321,
31001 &-20321,20311,-20311,7*99999 ,
31002 &7*99999,12212,12112,99999/
31003
31004* / DTHAIC /
31005* (HAdron InDex COnversion)
31006 DATA (IPDG2(1,K),K=1,7)
31007 & / -11, -12, -13, -15, -16, -14, 0/
31008 DATA (IBAM2(1,K),K=1,7)
31009 & / 4, 6, 10, 131, 134, 136, 0/
31010 DATA (IPDG2(2,K),K=1,7)
31011 & / 11, 12, 22, 13, 15, 16, 14/
31012 DATA (IBAM2(2,K),K=1,7)
31013 & / 3, 5, 7, 11, 132, 133, 135/
31014 DATA (IPDG3(1,K),K=1,22)
31015 & / -211, -321, -311, -213, -323, -313, -411, -421,
31016 & -431, -413, -423, -433, 0, 0, 0, 0,
31017 & 0, 0, 0, 0, 0, 0/
31018 DATA (IBAM3(1,K),K=1,22)
31019 & / 14, 16, 25, 34, 38, 39, 118, 119,
31020 & 121, 125, 126, 128, 0, 0, 0, 0,
31021 & 0, 0, 0, 0, 0, 0/
31022 DATA (IPDG3(2,K),K=1,22)
31023 & / 130, 211, 321, 310, 111, 311, 221, 213,
31024 & 113, 223, 323, 313, 331, 333, 421, 411,
31025 & 431, 441, 423, 413, 433, 443/
31026 DATA (IBAM3(2,K),K=1,22)
31027 & / 12, 13, 15, 19, 23, 24, 31, 32,
31028 & 33, 35, 36, 37, 95, 96, 116, 117,
31029 & 120, 122, 123, 124, 127, 130/
31030 DATA (IPDG4(1,K),K=1,29)
31031 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31032 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31033 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31034 & -4212, -4112, 0, 0, 0/
31035 DATA (IBAM4(1,K),K=1,29)
31036 & / 2, 9, 18, 67, 68, 69, 70, 75,
31037 & 76, 99, 100, 101, 102, 103, 110, 111,
31038 & 112, 113, 114, 115, 149, 150, 151, 152,
31039 & 153, 154, 0, 0, 0/
31040 DATA (IPDG4(2,K),K=1,29)
31041 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31042 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31043 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31044 & 4232, 4132, 4222, 4212, 4112/
31045 DATA (IBAM4(2,K),K=1,29)
31046 & / 1, 8, 17, 20, 21, 22, 48, 49,
31047 & 50, 51, 52, 53, 54, 55, 56, 97,
31048 & 98, 104, 105, 106, 107, 108, 109, 137,
31049 & 138, 139, 140, 141, 142/
31050 DATA (IPDG5(1,K),K=1,19)
31051 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31052 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31053 & 0, 0, 0/
31054 DATA (IBAM5(1,K),K=1,19)
31055 & / 42, 43, 46, 47, 71, 72, 73, 74,
31056 & 188, 191, 193, 0, 0, 0, 0, 0,
31057 & 0, 0, 0/
31058 DATA (IPDG5(2,K),K=1,19)
31059 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31060 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31061 & 20311, 12212, 12112/
31062 DATA (IBAM5(2,K),K=1,19)
31063 & / 40, 41, 44, 45, 57, 58, 59, 60,
31064 & 63, 64, 65, 66, 129, 186, 187, 190,
31065 & 192, 208, 209/
31066
31067* / DTPAIN /
31068* internal particle names
31069 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31070 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31071 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31072 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31073 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31074 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31075 &'BLANK ' /
31076
31077 END
31078
31079*$ CREATE DT_BLKD46.FOR
31080*COPY DT_BLKD46
31081*
31082*===blkd46=============================================================*
31083*
31084 BLOCK DATA DT_BLKD46
31085
31086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31087 SAVE
31088
31089 PARAMETER ( AMELCT = 0.51099906 D-03 )
31090 PARAMETER ( AMMUON = 0.105658389 D+00 )
31091
31092* particle properties (BAMJET index convention)
31093 CHARACTER*8 ANAME
31094 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31095 & IICH(210),IIBAR(210),K1(210),K2(210)
31096
31097* / DTPART /
31098* Particle masses Engel version JETSET compatible
31099C DATA (AAM(K),K=1,85) /
31100C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31101C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31102C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31103C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31104C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31105C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31106C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31107C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31108C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31109C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31110C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31111C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31112C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31113C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31114C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31115C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31116C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31117C DATA (AAM(K),K=86,183) /
31118C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31119C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31120C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31121C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31122C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31123C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31124C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31125C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31126C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31127C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31128C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31129C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31130C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31131C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31132C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31133C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31134C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31135C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31136C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31137C & .1250D+01, .1250D+01, .1250D+01 /
31138C DATA (AAM ( I ), I = 184,210 ) /
31139C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31140C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31141C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31142C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31143C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31144C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31145C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31146C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31147C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31148* sr 25.1.06: particle masses adjusted to Pythia
31149 DATA (AAM(K),K=1,85) /
31150 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31151 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31152 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31153 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31154 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31155 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31156 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31157 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31158 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31159 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31160 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31161 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31162 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31163 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31164 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31165 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31166 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31167 DATA (AAM(K),K=86,183) /
31168 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31169 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31170 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31171 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31172 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31173 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31174 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31175 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31176 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31177 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31178 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31179 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31180 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31181 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31182 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31183 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31184 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31185 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31186 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31187 & .1250D+01, .1250D+01, .1250D+01 /
31188 DATA (AAM ( I ), I = 184,210 ) /
31189 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31190 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31191 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31192 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31193 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31194 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31195 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31196 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31197 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31198* Particle mean lives
31199 DATA (TAU(K),K=1,183) /
31200 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31201 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31202 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31203 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31204 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31205 & 70*.0000D+00,
31206 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31207 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31208 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31209 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31210 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31211 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31213 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31214 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31215 & 40*.0000D+00,
31216 & .0000D+00, .0000D+00, .0000D+00 /
31217 DATA ( TAU ( I ), I = 184,210 ) /
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 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31223 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31224 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31225 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31226 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31227* Resonance width Gamma in GeV
31228 DATA (GA(K),K= 1,85) /
31229 & 30*.0000D+00,
31230 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31231 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31232 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31233 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31234 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31235 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31236 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31237 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31238 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31239 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31240 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31241 DATA (GA(K),K= 86,183) /
31242 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31243 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31244 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31245 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31246 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31247 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31248 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31249 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31250 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31251 & 50*.0000D+00,
31252 & .3000D+00, .3000D+00, .3000D+00 /
31253 DATA ( GA ( I ), I = 184,210 ) /
31254 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31255 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31256 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31257 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31258 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31259 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31260 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31261 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31262 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31263* Particle names
31264* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31265* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31266* designation N*@@ means N*@1(@2)
31267 DATA (ANAME(K),K=1,85) /
31268 & 'P ','AP ','E- ','E+ ','NUE ',
31269 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31270 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31271 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31272 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31273 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31274 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31275 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31276 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31277 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31278 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31279 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31280 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31281 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31282 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31283 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31284 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31285 DATA (ANAME(K),K=86,183) /
31286 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31287 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31288 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31289 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31290 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31291 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31292 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31293 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31294 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31295 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31296 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31297 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31298 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31299 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31300 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31301 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31302 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31303 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31304 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31305 & 'RO ','R+ ','R- ' /
31306 DATA ( ANAME ( I ), I = 184,210 ) /
31307 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31308 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31309 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31310 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31311 &'N*+14 ','N*014 ','BLANK '/
31312* Charge of particles and resonances
31313 DATA (IICH ( I ), I = 1,210 ) /
31314 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31315 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31316 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31317 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31318 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31319 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31320 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31321 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31322 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31323 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31324 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31325 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31326 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31327 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31328* Particle baryonic charges
31329 DATA (IIBAR ( I ), I = 1,210 ) /
31330 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31331 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31332 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31333 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31334 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31335 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31336 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31337 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31338 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31339 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31340 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31341 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31342 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31343 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31344* First number of decay channels used for resonances
31345* and decaying particles
31346 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31347 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31348 & 2*330, 46, 51, 52, 54, 55, 58,
31349* 50
31350 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31351 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31352 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31353* 85
31354 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31355 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31356 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31357 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31358 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31359 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31360 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31361 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31362 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31363 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31364 & 590, 596, 602 /
31365* Last number of decay channels used for resonances
31366* and decaying particles
31367 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31368 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31369 & 2* 330, 50, 51, 53, 54, 57,
31370* 50
31371 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31372 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31373 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31374* 85
31375 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31376 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31377 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31378 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31379 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31380 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31381 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31382 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31383 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31384 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31385 & 589, 595, 601, 602 /
31386
31387 END
31388
31389*$ CREATE DT_BLKD47.FOR
31390*COPY DT_BLKD47
31391*
31392*===blkd47=============================================================*
31393*
31394 BLOCK DATA DT_BLKD47
31395
31396 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31397 SAVE
31398
31399* HADRIN: decay channel information
31400 PARAMETER (IDMAX9=602)
31401 CHARACTER*8 ZKNAME
31402 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31403
31404* Name of decay channel
31405* Designation N*@ means N*@1(1236)
31406* @1=# means ++, @1 = = means --
31407* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31408 DATA (ZKNAME(K),K= 1, 85) /
31409 & 'P ','AP ','E- ','E+ ','NUE ',
31410 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31411 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31412 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31413 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31414 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31415 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31416 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31417 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31418 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31419 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31420 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31421 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31422 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31423 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31424 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31425 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31426 DATA (ZKNAME(K),K= 86,170) /
31427 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31428 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31429 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31430 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31431 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31432 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31433 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31434 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31435 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31436 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31437 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31438 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31439 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31440 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31441 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31442 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31443 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31444 DATA (ZKNAME(K),K=171,255) /
31445 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31446 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31447 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31448 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31449 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31450 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31451 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31452 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31453 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31454 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31455 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31456 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31457 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31458 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31459 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31460 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31461 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31462 DATA (ZKNAME(K),K=256,340) /
31463 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31464 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31465 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31466 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31467 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31468 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31469 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31470 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31471 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31472 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31473 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31474 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31475 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31476 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31477 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31478 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31479 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31480 DATA (ZKNAME(K),K=341,425) /
31481 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31482 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31483 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31484 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31485 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31486 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31487 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31488 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31489 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31490 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31491 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31492 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31493 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31494 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31495 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31496 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31497 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31498 DATA (ZKNAME(K),K=426,510) /
31499 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31500 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31501 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31502 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31503 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31504 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31505 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31506 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31507 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31508 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31509 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31510 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31511 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31512 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31513 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31514 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31515 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31516 DATA (ZKNAME(K),K=511,540) /
31517 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31518 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31519 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31520 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31521 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31522 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31523 DATA (ZKNAME(I),I=541,602)/
31524 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31525 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31526 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31527 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31528 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31529 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31530 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31531 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31532 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31533* Weight of decay channel
31534 DATA (WT(K),K= 1, 85) /
31535 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31536 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31537 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31538 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31539 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31540 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31541 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31542 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31543 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31544 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31545 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31546 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31547 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31548 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31549 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31550 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31551 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31552 DATA (WT(K),K= 86,170) /
31553 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31554 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31555 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31556 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31557 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31558 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31559 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31560 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31561 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31562 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31563 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31564 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31565 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31566 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31567 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31568 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31569 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31570 DATA (WT(K),K=171,255) /
31571 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31572 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31573 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31574 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31575 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31576 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31577 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31578 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31579 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31580 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31581 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31582 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31583 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31584 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31585 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31586 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31587 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31588 DATA (WT(K),K=256,340) /
31589 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31590 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31591 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31592 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31593 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31594 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31595 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31596 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31597 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31598 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31599 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31600 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31601 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31602 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31603 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31604 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31605 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31606 DATA (WT(K),K=341,425) /
31607 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31608 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31609 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31610 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31611 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31612 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31613 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31614 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31615 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31616 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31617 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31618 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31619 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31620 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31621 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31622 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31623 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31624 DATA (WT(K),K=426,510) /
31625 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31626 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31627 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31628 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31629 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31630 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31631 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31632 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31633 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31634 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31635 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31636 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31637 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31638 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31639 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31640 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31641 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31642 DATA (WT(K),K=511,540) /
31643 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31644 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31645 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31646 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31647 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31648 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31649C
31650 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31651 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31652 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31653 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31654 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31655 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31656 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31657* Particle numbers in decay channel
31658 DATA (NZK(K,1),K= 1,170) /
31659 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31660 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31661 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31662 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31663 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31664 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31665 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31666 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31667 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31668 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31669 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31670 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31671 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31672 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31673 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31674 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31675 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31676 DATA (NZK(K,1),K=171,340) /
31677 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31678 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31679 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31680 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31681 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31682 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31683 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31684 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31685 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31686 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31687 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31688 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31689 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31690 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31691 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31692 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31693 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31694 DATA (NZK(K,1),K=341,510) /
31695 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31696 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31697 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31698 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31699 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31700 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31701 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31702 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31703 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31704 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31705 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31706 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31707 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31708 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31709 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31710 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31711 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31712 DATA (NZK(K,1),K=511,540) /
31713 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31714 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31715 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31716 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31717 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31718 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31719 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31720 & 55, 8, 1, 8, 8, 54, 55, 210/
31721 DATA (NZK(K,2),K= 1,170) /
31722 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31723 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31724 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31725 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31726 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31727 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31728 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31729 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31730 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31731 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31732 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31733 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31734 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31735 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31736 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31737 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31738 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31739 DATA (NZK(K,2),K=171,340) /
31740 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31741 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31742 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31743 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31744 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31745 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31746 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31747 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31748 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31749 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31750 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31751 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31752 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31753 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31754 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31755 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31756 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31757 DATA (NZK(K,2),K=341,510) /
31758 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31759 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31760 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31761 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31762 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31763 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31764 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31765 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31766 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31767 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31768 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31769 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31770 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31771 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31772 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31773 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31774 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31775 DATA (NZK(K,2),K=511,540) /
31776 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31777 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31778 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31779 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31780 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31781 & 14, 14, 23, 14, 16, 25,
31782 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31783 & 23, 13, 14, 23, 0 /
31784 DATA (NZK(K,3),K= 1,170) /
31785 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31786 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31787 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31788 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31789 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31790 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31791 & 110*0 /
31792 DATA (NZK(K,3),K=171,340) /
31793 & 80*0,
31794 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31795 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31796 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31797 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31798 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31799 & 30*0,
31800 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31801 DATA (NZK(K,3),K=341,510) /
31802 & 30*0,
31803 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31804 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31805 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31806 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31807 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31808 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31809 & 80*0 /
31810 DATA (NZK(K,3),K=511,540) /
31811 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31812 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31813 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31814 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31815 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31816
31817 END
31818
31819*$ CREATE DT_XHOINI.FOR
31820*COPY DT_XHOINI
31821*
31822*====phoini============================================================*
31823*
31824 SUBROUTINE DT_XHOINI
31825C SUBROUTINE DT_PHOINI
31826
31827 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31828 SAVE
31829
31830 PARAMETER ( LINP = 10 ,
31831 & LOUT = 6 ,
31832 & LDAT = 9 )
31833
31834 RETURN
31835 END
31836
31837*$ CREATE DT_XVENTB.FOR
31838*COPY DT_XVENTB
31839*
31840*====eventb============================================================*
31841*
31842 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31843C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31844
31845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31846 SAVE
31847
31848 PARAMETER ( LINP = 10 ,
31849 & LOUT = 6 ,
31850 & LDAT = 9 )
31851
31852 WRITE(LOUT,1000)
31853 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31854 STOP
31855
31856 END
31857
31858*$ CREATE DT_XVENT.FOR
31859*COPY DT_XVENT
31860*
31861*===event==============================================================*
31862*
31863 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31864C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31865
31866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31867 SAVE
31868
31869 DIMENSION PP(4),PT(4)
31870
31871 RETURN
31872 END
31873
31874*$ CREATE DT_XOHISX.FOR
31875*COPY DT_XOHISX
31876*
31877*===pohisx=============================================================*
31878*
31879 SUBROUTINE DT_XOHISX(I,X)
31880C SUBROUTINE POHISX(I,X)
31881
31882 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31883 SAVE
31884
31885 RETURN
31886 END
31887
31888*$ CREATE PHO_LHIST.FOR
31889*COPY PHO_LHIST
31890*
31891*===poluhi=============================================================*
31892*
31893 SUBROUTINE PHO_LHIST(I,X)
31894
31895**
31896
31897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31898 SAVE
31899
31900 RETURN
31901 END
31902
31903*$ CREATE PDFSET.FOR
31904*COPY PDFSET
31905*
31906C**********************************************************************
31907C
31908C dummy subroutines, remove to link PDFLIB
31909C
31910C**********************************************************************
31911 SUBROUTINE PDFSET(PARAM,VALUE)
31912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31913 DIMENSION PARAM(20),VALUE(20)
31914 CHARACTER*20 PARAM
31915 END
31916
31917*$ CREATE STRUCTM.FOR
31918*COPY STRUCTM
31919*
31920 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31921 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31922 END
31923
31924*$ CREATE STRUCTP.FOR
31925*COPY STRUCTP
31926*
31927 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31928 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31929 END
31930
31931*$ CREATE DT_DIQBRK.FOR
31932*COPY DT_DIQBRK
31933*
31934*===diqbrk=============================================================*
31935*
31936 SUBROUTINE DT_XIQBRK
31937C SUBROUTINE DT_DIQBRK
31938
31939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31940 SAVE
31941
31942 STOP 'diquark-breaking not implemeted !'
31943
31944 RETURN
31945 END
31946*$ CREATE DT_ELHAIN.FOR
31947*COPY DT_ELHAIN
31948*
31949*===elhain=============================================================*
31950*
31951 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31952
31953************************************************************************
31954* Elastic hadron-hadron scattering. *
31955* This is a revised version of the original. *
31956* This version dated 03.04.98 is written by S. Roesler *
31957************************************************************************
31958
31959 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31960 SAVE
31961
31962 PARAMETER ( LINP = 10 ,
31963 & LOUT = 6 ,
31964 & LDAT = 9 )
31965
31966 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31967 & TINY10=1.0D-10)
31968
31969 PARAMETER (ENNTHR = 3.5D0)
31970 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31971 & BLOWB=0.05D0,BHIB=0.2D0,
31972 & BLOWM=0.1D0, BHIM=2.0D0)
31973
31974* particle properties (BAMJET index convention)
31975 CHARACTER*8 ANAME
31976 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31977 & IICH(210),IIBAR(210),K1(210),K2(210)
31978
31979* final state from HADRIN interaction
31980 PARAMETER (MAXFIN=10)
31981 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31982 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31983
31984C DATA TSLOPE /10.0D0/
31985
31986 IREJ = 0
31987
31988 1 CONTINUE
31989
31990 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31991 EKIN = ELAB-AAM(IP)
31992* kinematical quantities in cms of the hadrons
31993 AMP2 = AAM(IP)**2
31994 AMT2 = AAM(IT)**2
31995 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31996 ECM = SQRT(S)
31997 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31998 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31999
32000* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
32001 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
32002 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
32003* TSAMCS treats pp and np only, therefore change pn into np and
32004* nn into pp
32005 IF (IT.EQ.1) THEN
32006 KPROJ = IP
32007 ELSE
32008 KPROJ = 8
32009 IF (IP.EQ.8) KPROJ = 1
32010 ENDIF
32011 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32012 T = TWO*PCM**2*(CTCMS-ONE)
32013
32014* very crude treatment otherwise: sample t from exponential dist.
32015 ELSE
32016* momentum transfer t
32017 TMAX = TWO*TWO*PCM**2
32018 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32019 IF (IIBAR(IP).NE.0) THEN
32020 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32021 ELSE
32022 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32023 ENDIF
32024 FMAX = EXP(-TSLOPE*TMAX)-ONE
32025 R = DT_RNDM(RR)
32026 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32027 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32028 ENDIF
32029
32030* target hadron in Lab after scattering
32031 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32032 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32033 IF (PLRH(2).LE.TINY10) THEN
32034C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32035 GOTO 1
32036 ENDIF
32037* projectile hadron in Lab after scattering
32038 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32039 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32040* scattering angle of projectile in Lab
32041 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32042 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32043 CALL DT_DSFECF(SPLABP,CPLABP)
32044* direction cosines of projectile in Lab
32045 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32046 & CXRH(1),CYRH(1),CZRH(1))
32047* scattering angle of target in Lab
32048 PLLABT = PLAB-CTLABP*PLRH(1)
32049 CTLABT = PLLABT/PLRH(2)
32050 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32051* direction cosines of target in Lab
32052 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32053 & CXRH(2),CYRH(2),CZRH(2))
32054* fill /HNFSPA/
32055 IRH = 2
32056 ITRH(1) = IP
32057 ITRH(2) = IT
32058
32059 RETURN
32060 END
32061
32062*$ CREATE DT_TSAMCS.FOR
32063*COPY DT_TSAMCS
32064*
32065*===tsamcs=============================================================*
32066*
32067 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32068
32069************************************************************************
32070* Sampling of cos(theta) for nucleon-proton scattering according to *
32071* hetkfa2/bertini parametrization. *
32072* This is a revised version of the original (HJM 24/10/88) *
32073* This version dated 28.10.95 is written by S. Roesler *
32074************************************************************************
32075
32076 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32077 SAVE
32078
32079 PARAMETER ( LINP = 10 ,
32080 & LOUT = 6 ,
32081 & LDAT = 9 )
32082
32083 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32084 & TINY10=1.0D-10)
32085
32086 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32087 DIMENSION PDCI(60),PDCH(55)
32088
32089 DATA (DCLIN(I),I=1,80) /
32090 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32091 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32092 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32093 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32094 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32095 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32096 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32097 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32098 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32099 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32100 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32101 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32102 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32103 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32104 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32105 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32106 DATA (DCLIN(I),I=81,160) /
32107 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32108 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32109 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32110 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32111 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32112 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32113 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32114 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32115 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32116 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32117 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32118 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32119 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32120 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32121 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32122 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32123 DATA (DCLIN(I),I=161,195) /
32124 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32125 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32126 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32127 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32128 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32129 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32130 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32131
32132 DATA PDCI /
32133 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32134 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32135 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32136 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32137 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32138 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32139 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32140 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32141 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32142 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32143 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32144 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32145
32146 DATA PDCH /
32147 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32148 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32149 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32150 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32151 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32152 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32153 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32154 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32155 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32156 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32157 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32158
32159 DATA (DCHN(I),I=1,90) /
32160 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32161 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32162 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32163 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32164 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32165 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32166 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32167 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32168 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32169 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32170 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32171 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32172 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32173 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32174 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32175 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32176 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32177 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32178 DATA (DCHN(I),I=91,143) /
32179 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32180 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32181 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32182 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32183 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32184 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32185 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32186 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32187 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32188 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32189 & 6.488D-02, 6.485D-02, 6.480D-02/
32190
32191 DATA DCHNA /
32192 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32193 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32194 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32195 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32196 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32197 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32198 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32199 & 1.000D+00/
32200
32201 DATA DCHNB /
32202 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32203 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32204 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32205 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32206 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32207 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32208 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32209 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32210 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32211 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32212 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32213 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32214
32215 CST = ONE
32216 IF (EKIN.GT.3.5D0) RETURN
32217C
32218 IF(KPROJ.EQ.8) GOTO 101
32219 IF(KPROJ.EQ.1) GOTO 102
32220C* INVALID REACTION
32221 WRITE(LOUT,'(A,I5/A)')
32222 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32223 & ' COS(THETA) = 1D0 RETURNED'
32224 RETURN
32225C-------------------------------- NP ELASTIC SCATTERING----------
32226101 CONTINUE
32227 IF (EKIN.GT.0.740D0)GOTO 1000
32228 IF (EKIN.LT.0.300D0)THEN
32229C EKIN .LT. 300 MEV
32230 IDAT=1
32231 ELSE
32232C 300 MEV < EKIN < 740 MEV
32233 IDAT=6
32234 END IF
32235C
32236 ENER=EKIN
32237 IE=INT(ABS(ENER/0.020D0))
32238 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32239C FORWARD/BACKWARD DECISION
32240 K=IDAT+5*IE
32241 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32242 IF (DT_RNDM(CST).LT.BWFW)THEN
32243 VALUE2=-1D0
32244 K=K+1
32245 ELSE
32246 VALUE2=1D0
32247 K=K+3
32248 END IF
32249C
32250 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32251 RND=DT_RNDM(COEF)
32252C
32253 IF(RND.LT.COEF)THEN
32254 CST=DT_RNDM(RND)
32255 CST=CST*VALUE2
32256 ELSE
32257 R1=DT_RNDM(CST)
32258 R2=DT_RNDM(R1)
32259 R3=DT_RNDM(R2)
32260 R4=DT_RNDM(R3)
32261C
32262 IF(VALUE2.GT.0.0)THEN
32263 CST=MAX(R1,R2,R3,R4)
32264 GOTO 1500
32265 ELSE
32266 R5=DT_RNDM(R4)
32267C
32268 IF (IDAT.EQ.1)THEN
32269 CST=-MAX(R1,R2,R3,R4,R5)
32270 ELSE
32271 R6=DT_RNDM(R5)
32272 R7=DT_RNDM(R6)
32273 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32274 END IF
32275C
32276 END IF
32277C
32278 END IF
32279C
32280 GOTO 1500
32281C
32282C******** EKIN .GT. 0.74 GEV
32283C
322841000 ENER=EKIN - 0.66D0
32285C IE=ABS(ENER/0.02)
32286 IE=INT(ENER/0.02D0)
32287 EMEV=EKIN*1D3
32288C
32289 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32290 K=IE
32291 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32292 RND=DT_RNDM(BWFW)
32293C FORWARD NEUTRON
32294 IF (RND.GE.BWFW)THEN
32295 DO 1200 K=10,36,9
32296 IF (DCHNA(K).GT.EMEV) THEN
32297 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32298 UNIV=DT_RNDM(UNIVE)
32299 DO 1100 I=1,8
32300 II=K+I
32301 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32302C
32303 IF (P.GT.UNIV)THEN
32304 UNIV=DT_RNDM(UNIVE)
32305 FLTI=DBLE(I)-UNIV
32306 GOTO(290,290,290,290,330,340,350,360) I
32307 END IF
32308 1100 CONTINUE
32309 END IF
32310 1200 CONTINUE
32311C
32312 ELSE
32313C BACKWARD NEUTRON
32314 DO 1400 K=13,60,12
32315 IF (DCHNB(K).GT.EMEV) THEN
32316 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32317 UNIV=DT_RNDM(UNIVE)
32318 DO 1300 I=1,11
32319 II=K+I
32320 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32321C
32322 IF (P.GT.UNIV)THEN
32323 UNIV=DT_RNDM(P)
32324 FLTI=DBLE(I)-UNIV
32325 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32326 END IF
32327 1300 CONTINUE
32328 END IF
32329 1400 CONTINUE
32330 END IF
32331C
32332120 CST=1.0D-2*FLTI-1.0D0
32333 GOTO 1500
32334140 CST=2.0D-2*UNIV-0.98D0
32335 GOTO 1500
32336150 CST=4.0D-2*UNIV-0.96D0
32337 GOTO 1500
32338160 CST=6.0D-2*FLTI-1.16D0
32339 GOTO 1500
32340180 CST=8.0D-2*UNIV-0.80D0
32341 GOTO 1500
32342190 CST=1.0D-1*UNIV-0.72D0
32343 GOTO 1500
32344200 CST=1.2D-1*UNIV-0.62D0
32345 GOTO 1500
32346210 CST=2.0D-1*UNIV-0.50D0
32347 GOTO 1500
32348220 CST=3.0D-1*(UNIV-1.0D0)
32349 GOTO 1500
32350C
32351290 CST=1.0D0-2.5d-2*FLTI
32352 GOTO 1500
32353330 CST=0.85D0+0.5D-1*UNIV
32354 GOTO 1500
32355340 CST=0.70D0+1.5D-1*UNIV
32356 GOTO 1500
32357350 CST=0.50D0+2.0D-1*UNIV
32358 GOTO 1500
32359360 CST=0.50D0*UNIV
32360C
323611500 RETURN
32362C
32363C----------------------------------- PP ELASTIC SCATTERING -------
32364C
32365 102 CONTINUE
32366 EMEV=EKIN*1D3
32367C
32368 IF (EKIN.LE.0.500D0) THEN
32369 RND=DT_RNDM(EMEV)
32370 CST=2.0D0*RND-1.0D0
32371 RETURN
32372C
32373 ELSEIF (EKIN.LT.1.0D0) THEN
32374 DO 2200 K=13,60,12
32375 IF (PDCI(K).GT.EMEV) THEN
32376 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32377 UNIV=DT_RNDM(UNIVE)
32378 SUM=0
32379 DO 2100 I=1,11
32380 II=K+I
32381 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32382C
32383 IF (UNIV.LT.SUM)THEN
32384 UNIV=DT_RNDM(SUM)
32385 FLTI=DBLE(I)-UNIV
32386 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32387 END IF
32388 2100 CONTINUE
32389 END IF
32390 2200 CONTINUE
32391 ELSE
32392 DO 2400 K=12,55,11
32393 IF (PDCH(K).GT.EMEV) THEN
32394 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32395 UNIV=DT_RNDM(UNIVE)
32396 SUM=0.0D0
32397 DO 2300 I=1,10
32398 II=K+I
32399 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32400C
32401 IF (UNIV.LT.SUM)THEN
32402 UNIV=DT_RNDM(SUM)
32403 FLTI=UNIV+DBLE(I)
32404 GOTO(50,55,60,60,65,65,65,65,70,70) I
32405 END IF
32406 2300 CONTINUE
32407 END IF
32408 2400 CONTINUE
32409 END IF
32410C
3241150 CST=0.4D0*UNIV
32412 GOTO 2500
3241355 CST=0.2D0*FLTI
32414 GOTO 2500
3241560 CST=0.3D0+0.1D0*FLTI
32416 GOTO 2500
3241765 CST=0.6D0+0.04D0*FLTI
32418 GOTO 2500
3241970 CST=0.78D0+0.02D0*FLTI
32420C
324212500 CONTINUE
32422 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32423C
32424 RETURN
32425 END
32426
32427*$ CREATE DT_DHADRI.FOR
32428*COPY DT_DHADRI
32429*
32430*===dhadri=============================================================*
32431*
32432 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32433
32434 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32435 SAVE
32436
32437 PARAMETER ( LINP = 10 ,
32438 & LOUT = 6 ,
32439 & LDAT = 9 )
32440
32441C
32442C-----------------------------
32443C*** INPUT VARIABLES LIST:
32444C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32445C*** GEV/C LABORATORY MOMENTUM REGION
32446C*** N - PROJECTILE HADRON INDEX
32447C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32448C*** ELAB - LABORATORY ENERGY OF N (GEV)
32449C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32450C*** ITTA - TARGET NUCLEON INDEX
32451C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32452C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32453C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32454C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32455C*** RESPECT., UNITS (GEV/C AND GEV)
32456C----------------------------
32457
32458 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32459
32460 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32461
32462 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32463 & NRK(2,268),NURE(30,2)
32464
32465* particle properties (BAMJET index convention),
32466* (dublicate of DTPART for HADRIN)
32467 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32468 & K1H(110),K2H(110)
32469
32470 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32471
32472 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32473 & ITS(149),IS
32474
32475 COMMON /HNDRUN/ RUNTES,EFTES
32476
32477* particle properties (BAMJET index convention)
32478 CHARACTER*8 ANAME
32479 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32480 & IICH(210),IIBAR(210),K1(210),K2(210)
32481
32482* final state from HADRIN interaction
32483 PARAMETER (MAXFIN=10)
32484 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32485 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32486
32487 DIMENSION ITPRF(110)
32488 DATA NNN/0/
32489 DATA UMODA/0./
32490 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32491 LOWP=0
32492 IF (N.LE.0.OR.N.GE.111)N=1
32493 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32494 GOTO 280
32495* WRITE (6,1000)
32496* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32497* STOP
32498*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32499* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32500 ENDIF
32501 IATMPT=0
32502 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32503C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32504C STOP
32505 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32506 + ALLOWED REGION, PLAB=',1E15.5)
32507
32508 20 CONTINUE
32509 UMODAT=N*1.11111D0+ITTA*2.19291D0
32510 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32511 UMODA=UMODAT
32512 30 IATMPT=0
32513 LOWP=LOWP+1
32514 40 CONTINUE
32515 IMACH=0
32516 REDU=2.0D0
32517 IF (LOWP.GT.20) THEN
32518C WRITE(LOUT,*) ' jump 1'
32519 GO TO 280
32520 ENDIF
32521 NNN=N
32522 IF (NNN.EQ.N) GO TO 50
32523 RUNTES=0.0D0
32524 EFTES=0.0D0
32525 50 CONTINUE
32526 IS=1
32527 IRH=0
32528 IST=1
32529 NSTAB=23
32530 IRE=NURE(N,1)
32531 IF(ITTA.GT.1) IRE=NURE(N,2)
32532C
32533C-----------------------------
32534C*** IE,AMT,ECM,SI DETERMINATION
32535C----------------------------
32536 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32537 IANTH=-1
32538**sr
32539C IF (AMH(1).NE.0.93828D0) IANTH=1
32540 IF (AMH(1).NE.0.9383D0) IANTH=1
32541**
32542 IF (IANTH.GE.0) SI=1.0D0
32543 ECMMH=ECM
32544C
32545C-----------------------------
32546C ENERGY INDEX
32547C IRE CHARACTERIZES THE REACTION
32548C IE IS THE ENERGY INDEX
32549C----------------------------
32550 IF (SI.LT.1.D-6) THEN
32551C WRITE(LOUT,*) ' jump 2'
32552 GO TO 280
32553 ENDIF
32554 IF (N.LE.NSTAB) GO TO 60
32555 RUNTES=RUNTES+1.0D0
32556 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32557 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32558 IF(IBARH(N).EQ.1) N=8
32559 IF(IBARH(N).EQ.-1) N=9
32560 60 CONTINUE
32561 IMACH=IMACH+1
32562**sr 19.2.97: loop for direct channel suppression
32563C IF (IMACH.GT.10) THEN
32564 IF (IMACH.GT.1000) THEN
32565**
32566C WRITE(LOUT,*) ' jump 3'
32567 GO TO 280
32568 ENDIF
32569 ECM =ECMMH
32570 AMN2=AMN**2
32571 AMT2=AMT**2
32572 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32573 IF(ECMN.LE.AMN) ECMN=AMN
32574 PCMN=SQRT(ECMN**2-AMN2)
32575 GAM=(ELAB+AMT)/ECM
32576 BGAM=PLAB/ECM
32577 IF (IANTH.GE.0) ECM=2.1D0
32578C
32579C-----------------------------
32580C*** RANDOM CHOICE OF REACTION CHANNEL
32581C----------------------------
32582 IST=0
32583 VV=DT_RNDM(AMN2)
32584 VV=VV-1.D-17
32585C
32586C-----------------------------
32587C*** PLACE REDUCED VERSION
32588C----------------------------
32589 IIEI=IEII(IRE)
32590 IDWK=IEII(IRE+1)-IIEI
32591 IIWK=IRII(IRE)
32592 IIKI=IKII(IRE)
32593C
32594C-----------------------------
32595C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32596C----------------------------
32597 HECM=ECM
32598 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32599 IF (HUMO.LT.ECM) ECM=HUMO
32600C
32601C-----------------------------
32602C*** INTERPOLATION PREPARATION
32603C----------------------------
32604 ECMO=UMO(IE)
32605 ECM1=UMO(IE-1)
32606 DECM=ECMO-ECM1
32607 DEC=ECMO-ECM
32608C
32609C-----------------------------
32610C*** RANDOM LOOP
32611C----------------------------
32612 IK=0
32613 WKK=0.0D0
32614 WICOR=0.0D0
32615 70 IK=IK+1
32616 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32617 WOK=WK(IWK)
32618 WDK=WOK-WK(IWK-1)
32619C
32620C-----------------------------
32621C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32622C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32623C CONTRIBUTE
32624C----------------------------
32625 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32626 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32627 IF (WICO.EQ.WICOR) GO TO 70
32628 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32629 WICOR=WICO
32630C
32631C-----------------------------
32632C*** INTERPOLATION IN CHANNEL WEIGHTS
32633C----------------------------
32634 EKLIM=-THRESH(IIKI+IK)
32635 IELIM=IDT_IEFUND(EKLIM,IRE)
32636 DELIM=UMO(IELIM)+EKLIM
32637 *+1.D-16
32638 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32639 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32640 80 DECC=DELIM
32641 GO TO 100
32642 90 DECC=DECM
32643 100 CONTINUE
32644 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32645C
32646C-----------------------------
32647C*** RANDOM CHOICE
32648C----------------------------
32649C
32650 IF (VV.GT.WKK) GO TO 70
32651C
32652C***IK IS THE REACTION CHANNEL
32653C----------------------------
32654 INRK=IKII(IRE)+IK
32655 ECM=HECM
32656 I1001 =0
32657C
32658 110 CONTINUE
32659 IT1=NRK(1,INRK)
32660 AM1=DT_DAMG(IT1)
32661 IT2=NRK(2,INRK)
32662 AM2=DT_DAMG(IT2)
32663 AMS=AM1+AM2
32664 I1001=I1001+1
32665 IF (I1001.GT.50) GO TO 60
32666C
32667 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32668 IT11=IT1
32669 IT22=IT2
32670 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32671 AM11=AM1
32672 AM22=AM2
32673 IF (IT2.GT.0) GO TO 120
32674**sr 19.2.97: supress direct channel for pp-collisions
32675 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32676 RR = DT_RNDM(AM11)
32677 IF (RR.LE.0.75D0) GOTO 60
32678 ENDIF
32679**
32680C
32681C-----------------------------
32682C INCLUSION OF DIRECT RESONANCES
32683C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32684C------------------------
32685 KZ1=K1H(IT1)
32686 IST=IST+1
32687 IECO=0
32688 ECO=ECM
32689 GAM=(ELAB+AMT)/ECO
32690 BGAM=PLAB/ECO
32691 CXS(1)=CX
32692 CYS(1)=CY
32693 CZS(1)=CZ
32694 GO TO 170
32695 120 CONTINUE
32696 WW=DT_RNDM(ECO)
32697 IF(WW.LT. 0.5D0) GO TO 130
32698 IT1=IT22
32699 IT2=IT11
32700 AM1=AM22
32701 AM2=AM11
32702 130 CONTINUE
32703C
32704C-----------------------------
32705C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32706 IBN=IBARH(N)
32707 IB1=IBARH(IT1)
32708 IT11=IT1
32709 IT22=IT2
32710 AM11=AM1
32711 AM22=AM2
32712 IF(IB1.EQ.IBN) GO TO 140
32713 IT1=IT22
32714 IT2=IT11
32715 AM1=AM22
32716 AM2=AM11
32717 140 CONTINUE
32718C-----------------------------
32719C***IT1,IT2 ARE THE CREATED PARTICLES
32720C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32721C------------------------
32722 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32723 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32724 IST=IST+1
32725 ITS(IST)=IT1
32726 AMM(IST)=AM1
32727C
32728C-----------------------------
32729C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32730C----------------------------
32731 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32732 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32733 IST=IST+1
32734 ITS(IST)=IT2
32735 AMM(IST)=AM2
32736 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32737 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32738 150 CONTINUE
32739C
32740C-----------------------------
32741C***TEST STABLE OR UNSTABLE
32742C----------------------------
32743 IF(ITS(IST).GT.NSTAB) GO TO 160
32744 IRH=IRH+1
32745C
32746C-----------------------------
32747C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32748C----------------------------
32749C* IF (REDU.LT.0.D0) GO TO 1009
32750 ITRH(IRH)=ITS(IST)
32751 PLRH(IRH)=PLS(IST)
32752 CXRH(IRH)=CXS(IST)
32753 CYRH(IRH)=CYS(IST)
32754 CZRH(IRH)=CZS(IST)
32755 ELRH(IRH)=ELS(IST)
32756 IST=IST-1
32757 IF(IST.GE.1) GO TO 150
32758 GO TO 260
32759 160 CONTINUE
32760C
32761C RANDOM CHOICE OF DECAY CHANNELS
32762C----------------------------
32763C
32764 IT=ITS(IST)
32765 ECO=AMM(IST)
32766 GAM=ELS(IST)/ECO
32767 BGAM=PLS(IST)/ECO
32768 IECO=0
32769 KZ1=K1H(IT)
32770 170 CONTINUE
32771 IECO=IECO+1
32772 VV=DT_RNDM(GAM)
32773 VV=VV-1.D-17
32774 IIK=KZ1-1
32775 180 IIK=IIK+1
32776 IF (VV.GT.WTI(IIK)) GO TO 180
32777C
32778C IIK IS THE DECAY CHANNEL
32779C----------------------------
32780 IT1=NZKI(IIK,1)
32781 I310=0
32782 190 CONTINUE
32783 I310=I310+1
32784 AM1=DT_DAMG(IT1)
32785 IT2=NZKI(IIK,2)
32786 AM2=DT_DAMG(IT2)
32787 IF (IT2-1.LT.0) GO TO 240
32788 IT3=NZKI(IIK,3)
32789 AM3=DT_DAMG(IT3)
32790 AMS=AM1+AM2+AM3
32791C
32792C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32793C----------------------------
32794 IF (IECO.LE.10) GO TO 200
32795 IATMPT=IATMPT+1
32796 IF(IATMPT.GT.3) THEN
32797C WRITE(LOUT,*) ' jump 4'
32798 GO TO 280
32799 ENDIF
32800 GO TO 40
32801 200 CONTINUE
32802 IF (I310.GT.50) GO TO 170
32803 IF (AMS.GT.ECO) GO TO 190
32804C
32805C FOR THE DECAY CHANNEL
32806C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32807C----------------------------
32808 IF (REDU.LT.0.D0) GO TO 30
32809 ITWTHC=0
32810 REDU=2.0D0
32811 IF(IT3.EQ.0) GO TO 220
32812 210 CONTINUE
32813 ITWTH=1
32814 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32815 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32816 GO TO 230
32817 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32818 &COD2,COF2,SIF2,AM1,AM2)
32819 ITWTH=-1
32820 IT3=0
32821 230 CONTINUE
32822 ITWTHC=ITWTHC+1
32823 IF (REDU.GT.0.D0) GO TO 240
32824 REDU=2.0D0
32825 IF (ITWTHC.GT.100) GO TO 30
32826 IF (ITWTH) 220,220,210
32827 240 CONTINUE
32828 ITS(IST )=IT1
32829 IF (IT2-1.LT.0) GO TO 250
32830 ITS(IST+1) =IT2
32831 ITS(IST+2)=IT3
32832 RX=CXS(IST)
32833 RY=CYS(IST)
32834 RZ=CZS(IST)
32835 AMM(IST)=AM1
32836 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32837 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32838 IST=IST+1
32839 AMM(IST)=AM2
32840 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32841 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32842 IF (IT3.LE.0) GO TO 250
32843 IST=IST+1
32844 AMM(IST)=AM3
32845 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32846 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32847 250 CONTINUE
32848 GO TO 150
32849 260 CONTINUE
32850 270 CONTINUE
32851 RETURN
32852 280 CONTINUE
32853C
32854C----------------------------
32855C
32856C ZERO CROSS SECTION CASE
32857C----------------------------
32858C
32859 IRH=1
32860 ITRH(1)=N
32861 CXRH(1)=CX
32862 CYRH(1)=CY
32863 CZRH(1)=CZ
32864 ELRH(1)=ELAB
32865 PLRH(1)=PLAB
32866 RETURN
32867 END
32868
32869*$ CREATE DT_RUNTT.FOR
32870*COPY DT_RUNTT
32871*
32872*===runtt==============================================================*
32873*
32874 BLOCK DATA DT_RUNTT
32875
32876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32877 SAVE
32878
32879 COMMON /HNDRUN/ RUNTES,EFTES
32880
32881 DATA RUNTES,EFTES /100.D0,100.D0/
32882
32883 END
32884
32885*$ CREATE DT_NONAME.FOR
32886*COPY DT_NONAME
32887*
32888*===noname=============================================================*
32889*
32890 BLOCK DATA DT_NONAME
32891
32892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32893 SAVE
32894
32895* slope parameters for HADRIN interactions
32896 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32897
32898 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32899
32900C DATAS DATAS DATAS DATAS DATAS
32901C****** *********
32902 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32903 & 207, 224, 241, 252, 268 /
32904 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32905 & 220, 241, 262, 279, 296 /
32906 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32907 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32908
32909C
32910C MASSES FOR THE SLOPE B(M) IN GEV
32911C SLOPE B(M) FOR AN MESONIC SYSTEM
32912C SLOPE B(M) FOR A BARYONIC SYSTEM
32913
32914*
32915 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32916 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32917 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32918 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32919 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32920 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32921 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32922 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32923 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32924 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32925 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32926 & 14.2D0, 13.4D0, 12.6D0,
32927 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32928 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32929*
32930 END
32931
32932*$ CREATE DT_DAMG.FOR
32933*COPY DT_DAMG
32934*
32935*===damg===============================================================*
32936*
32937 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32938
32939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32940 SAVE
32941
32942* particle properties (BAMJET index convention),
32943* (dublicate of DTPART for HADRIN)
32944 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32945 & K1H(110),K2H(110)
32946
32947 DIMENSION GASUNI(14)
32948 DATA GASUNI/
32949 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32950 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32951 DATA GAUNO/2.352D0/
32952 DATA GAUNON/2.4D0/
32953 DATA IO/14/
32954 DATA NSTAB/23/
32955
32956 I=1
32957 IF (IT.LE.0) GO TO 30
32958 IF (IT.LE.NSTAB) GO TO 20
32959 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32960 VV=DT_RNDM(DGAUNI)
32961 VV=VV*2.0D0-1.0D0+1.D-16
32962 10 CONTINUE
32963 VO=GASUNI(I)
32964 I=I+1
32965 V1=GASUNI(I)
32966 IF (VV.GT.V1) GO TO 10
32967 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32968 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32969 DAM=GAH(IT)*UNIGA/GAUNO
32970 AAM=AMH(IT)+DAM
32971 DT_DAMG=AAM
32972 RETURN
32973 20 CONTINUE
32974 DT_DAMG=AMH(IT)
32975 RETURN
32976 30 CONTINUE
32977 DT_DAMG=0.0D0
32978 RETURN
32979 END
32980
32981*$ CREATE DT_DCALUM.FOR
32982*COPY DT_DCALUM
32983*
32984*===dcalum=============================================================*
32985*
32986 SUBROUTINE DT_DCALUM(N,ITTA)
32987
32988 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32989 SAVE
32990
32991C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32992
32993* particle properties (BAMJET index convention),
32994* (dublicate of DTPART for HADRIN)
32995 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32996 & K1H(110),K2H(110)
32997
32998 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32999
33000 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33001
33002 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33003 & NRK(2,268),NURE(30,2)
33004
33005 IRE=NURE(N,ITTA/8+1)
33006 IEO=IEII(IRE)+1
33007 IEE=IEII(IRE +1)
33008 AM1=AMH(N )
33009 AM12=AM1**2
33010 AM2=AMH(ITTA)
33011 AM22=AM2**2
33012 DO 10 IE=IEO,IEE
33013 PLAB2=PLABF(IE)**2
33014 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33015 UMO(IE)=ELAB
33016 10 CONTINUE
33017 IKO=IKII(IRE)+1
33018 IKE=IKII(IRE +1)
33019 UMOO=UMO(IEO)
33020 DO 30 IK=IKO,IKE
33021 IF(NRK(2,IK).GT.0) GO TO 30
33022 IKI=NRK(1,IK)
33023 AMSS=5.0D0
33024 K11=K1H(IKI)
33025 K22=K2H(IKI)
33026 DO 20 IK1=K11,K22
33027 IN=NZKI(IK1,1)
33028 AMS=AMH(IN)
33029 IN=NZKI(IK1,2)
33030 IF(IN.GT.0)AMS=AMS+AMH(IN)
33031 IN=NZKI(IK1,3)
33032 IF(IN.GT.0) AMS=AMS+AMH(IN)
33033 IF (AMS.LT.AMSS) AMSS=AMS
33034 20 CONTINUE
33035 IF(UMOO.LT.AMSS) UMOO=AMSS
33036 THRESH(IK)=UMOO
33037 30 CONTINUE
33038 RETURN
33039 END
33040
33041*$ CREATE DT_DCHANH.FOR
33042*COPY DT_DCHANH
33043*
33044*===dchanh=============================================================*
33045*
33046 SUBROUTINE DT_DCHANH
33047
33048 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33049 SAVE
33050
33051 PARAMETER ( LINP = 10 ,
33052 & LOUT = 6 ,
33053 & LDAT = 9 )
33054
33055* particle properties (BAMJET index convention),
33056* (dublicate of DTPART for HADRIN)
33057 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33058 & K1H(110),K2H(110)
33059
33060 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33061
33062 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33063
33064 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33065 & NRK(2,268),NURE(30,2)
33066
33067 DIMENSION HWT(460),HWK(40),SI(5184)
33068 EQUIVALENCE (WK(1),SI(1))
33069C--------------------
33070C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33071C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33072C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33073C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33074C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33075C--------------------------
33076 IREG=16
33077 DO 90 IRE=1,IREG
33078 IWKO=IRII(IRE)
33079 IEE=IEII(IRE+1)-IEII(IRE)
33080 IKE=IKII(IRE+1)-IKII(IRE)
33081 IEO=IEII(IRE)+1
33082 IIKA=IKII(IRE)
33083* modifications to suppress elestic scattering 24/07/91
33084 DO 80 IE=1,IEE
33085 SIS=1.D-14
33086 SINORC=0.0D0
33087 DO 10 IK=1,IKE
33088 IWK=IWKO+IEE*(IK-1)+IE
33089 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33090 SIS=SIS+SI(IWK)*SINORC
33091 10 CONTINUE
33092 SIIN(IEO+IE-1)=SIS
33093 SIO=0.D0
33094 IF (SIS.GE.1.D-12) GO TO 20
33095 SIS=1.D0
33096 SIO=1.D0
33097 20 CONTINUE
33098 SINORC=0.0D0
33099 DO 30 IK=1,IKE
33100 IWK=IWKO+IEE*(IK-1)+IE
33101 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33102 SIO=SIO+SI(IWK)*SINORC/SIS
33103 HWK(IK)=SIO
33104 30 CONTINUE
33105 DO 40 IK=1,IKE
33106 IWK=IWKO+IEE*(IK-1)+IE
33107 40 WK(IWK)=HWK(IK)
33108 IIKI=IKII(IRE)
33109 DO 70 IK=1,IKE
33110 AM111=0.D0
33111 INRK1=NRK(1,IIKI+IK)
33112 IF (INRK1.GT.0) AM111=AMH(INRK1)
33113 AM222=0.D0
33114 INRK2=NRK(2,IIKI+IK)
33115 IF (INRK2.GT.0) AM222=AMH(INRK2)
33116 THRESH(IIKI+IK)=AM111 +AM222
33117 IF (INRK2-1.GE.0) GO TO 60
33118 INRKK=K1H(INRK1)
33119 AMSS=5.D0
33120 INRKO=K2H(INRK1)
33121 DO 50 INRK1=INRKK,INRKO
33122 INZK1=NZKI(INRK1,1)
33123 INZK2=NZKI(INRK1,2)
33124 INZK3=NZKI(INRK1,3)
33125 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33126 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33127 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33128C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33129 1000 FORMAT (4I10)
33130 AMS=AMH(INZK1)+AMH(INZK2)
33131 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33132 IF (AMSS.GT.AMS) AMSS=AMS
33133 50 CONTINUE
33134 AMS=AMSS
33135 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33136 THRESH(IIKI+IK)=AMS
33137 60 CONTINUE
33138 70 CONTINUE
33139 80 CONTINUE
33140 90 CONTINUE
33141 DO 100 J=1,460
33142 100 HWT(J)=0.D0
33143 DO 120 I=1,110
33144 IK1=K1H(I)
33145 IK2=K2H(I)
33146 HV=0.D0
33147 IF (IK2.GT.460)IK2=460
33148 IF (IK1.LE.0)IK1=1
33149 DO 110 J=IK1,IK2
33150 HV=HV+WTI(J)
33151 HWT(J)=HV
33152 JI=J
33153 110 CONTINUE
33154 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33155 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33156 120 CONTINUE
33157 DO 130 J=1,460
33158 130 WTI(J)=HWT(J)
33159 RETURN
33160 END
33161
33162*$ CREATE DT_DHADDE.FOR
33163*COPY DT_DHADDE
33164*
33165*===dhadde=============================================================*
33166*
33167 SUBROUTINE DT_DHADDE
33168
33169 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33170 SAVE
33171
33172* particle properties (BAMJET index convention)
33173 CHARACTER*8 ANAME
33174 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33175 & IICH(210),IIBAR(210),K1(210),K2(210)
33176
33177* HADRIN: decay channel information
33178 PARAMETER (IDMAX9=602)
33179 CHARACTER*8 ZKNAME
33180 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33181
33182* particle properties (BAMJET index convention),
33183* (dublicate of DTPART for HADRIN)
33184 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33185 & K1H(110),K2H(110)
33186
33187 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33188
33189* decay channel information for HADRIN
33190 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33191 & K1Z(16),K2Z(16),WTZ(153),II22,
33192 & NZK1(153),NZK2(153),NZK3(153)
33193
33194 DATA IRETUR/0/
33195
33196 IRETUR=IRETUR+1
33197 AMH(31)=0.48D0
33198 IF (IRETUR.GT.1) RETURN
33199 DO 10 I=1,94
33200 AMH(I) = AAM(I)
33201 GAH(I) = GA(I)
33202 TAUH(I) = TAU(I)
33203 ICHH(I) = IICH(I)
33204 IBARH(I) = IIBAR(I)
33205 K1H(I) = K1(I)
33206 K2H(I) = K2(I)
33207 10 CONTINUE
33208**sr
33209C AMH(1)=0.93828D0
33210 AMH(1)=0.9383D0
33211**
33212 AMH(2)=AMH(1)
33213 DO 20 I=26,30
33214 K1H(I)=452
33215 K2H(I)=452
33216 20 CONTINUE
33217 DO 30 I=1,307
33218 WTI(I) = WT(I)
33219 NZKI(I,1) = NZK(I,1)
33220 NZKI(I,2) = NZK(I,2)
33221 NZKI(I,3) = NZK(I,3)
33222 30 CONTINUE
33223 DO 40 I=1,16
33224 L=I+94
33225 AMH(L)=AMZ(I)
33226 GAH( L)=GAZ(I)
33227 TAUH( L)=TAUZ(I)
33228 ICHH( L)=ICHZ(I)
33229 IBARH( L)=IBARZ(I)
33230 K1H( L)=K1Z(I)
33231 K2H( L)=K2Z(I)
33232 40 CONTINUE
33233 DO 50 I=1,153
33234 L=I+307
33235 WTI(L) = WTZ(I)
33236 NZKI(L,3) = NZK3(I)
33237 NZKI(L,2) = NZK2(I)
33238 NZKI(L,1) = NZK1(I)
33239 50 CONTINUE
33240 RETURN
33241 END
33242
33243*$ CREATE IDT_IEFUND.FOR
33244*COPY IDT_IEFUND
33245*
33246*===iefund=============================================================*
33247*
33248 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33249
33250 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33251 SAVE
33252
33253C*****IEFUN CALCULATES A MOMENTUM INDEX
33254
33255 PARAMETER ( LINP = 10 ,
33256 & LOUT = 6 ,
33257 & LDAT = 9 )
33258
33259 COMMON /HNDRUN/ RUNTES,EFTES
33260
33261 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33262
33263 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33264 & NRK(2,268),NURE(30,2)
33265
33266 IPLA=IEII(IRE)+1
33267 *+1
33268 IPLE=IEII(IRE+1)
33269 IF (PL.LT.0.) GO TO 30
33270 DO 10 I=IPLA,IPLE
33271 J=I-IPLA+1
33272 IF (PL.LE.PLABF(I)) GO TO 60
33273 10 CONTINUE
33274 I=IPLE
33275 IF ( EFTES.GT.40.D0) GO TO 20
33276 EFTES=EFTES+1.0D0
33277 WRITE(LOUT,1000)PL,J
33278 20 CONTINUE
33279 GO TO 70
33280 30 CONTINUE
33281 DO 40 I=IPLA,IPLE
33282 J=I-IPLA+1
33283 IF (-PL.LE.UMO(I)) GO TO 60
33284 40 CONTINUE
33285 I=IPLE
33286 IF ( EFTES.GT.40.D0) GO TO 50
33287 EFTES=EFTES+1.0D0
33288 WRITE(LOUT,1000)PL,I
33289 50 CONTINUE
33290 60 CONTINUE
33291 70 CONTINUE
33292 IDT_IEFUND=I
33293 RETURN
33294 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33295 +7H IEFUN=,I5)
33296 END
33297
33298*$ CREATE DT_DSIGIN.FOR
33299*COPY DT_DSIGIN
33300*
33301*===dsigin=============================================================*
33302*
33303 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33304
33305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33306 SAVE
33307
33308* particle properties (BAMJET index convention),
33309* (dublicate of DTPART for HADRIN)
33310 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33311 & K1H(110),K2H(110)
33312
33313 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33314
33315 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33316 & NRK(2,268),NURE(30,2)
33317
33318 IE=IDT_IEFUND(PLAB,IRE)
33319 IF (IE.LE.IEII(IRE)) IE=IE+1
33320 AMT=AMH(ITAR)
33321 AMN=AMH(N)
33322 AMN2=AMN*AMN
33323 AMT2=AMT*AMT
33324 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33325C*** INTERPOLATION PREPARATION
33326 ECMO=UMO(IE)
33327 ECM1=UMO(IE-1)
33328 DECM=ECMO-ECM1
33329 DEC=ECMO-ECM
33330 IIKI=IKII(IRE)+1
33331 EKLIM=-THRESH(IIKI)
33332 WOK=SIIN(IE)
33333 WDK=WOK-SIIN(IE-1)
33334 IF (ECM.GT.ECMO) WDK=0.0D0
33335C*** INTERPOLATION IN CHANNEL WEIGHTS
33336 IELIM=IDT_IEFUND(EKLIM,IRE)
33337 DELIM=UMO(IELIM)+EKLIM
33338 *+1.D-16
33339 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33340 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33341 10 DECC=DELIM
33342 GO TO 30
33343 20 DECC=DECM
33344 30 CONTINUE
33345 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33346 IF (WKK.LT.0.0D0) WKK=0.0D0
33347 SI=WKK+1.D-12
33348 IF (-EKLIM.GT.ECM) SI=1.D-14
33349 RETURN
33350 END
33351
33352*$ CREATE DT_DTCHOI.FOR
33353*COPY DT_DTCHOI
33354*
33355*===dtchoi=============================================================*
33356*
33357 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33358
33359 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33360 SAVE
33361
33362C ****************************
33363C TCHOIC CALCULATES A RANDOM VALUE
33364C FOR THE FOUR-MOMENTUM-TRANSFER T
33365C ****************************
33366
33367* particle properties (BAMJET index convention),
33368* (dublicate of DTPART for HADRIN)
33369 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33370 & K1H(110),K2H(110)
33371
33372* slope parameters for HADRIN interactions
33373 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33374
33375 AMA=AM1
33376 AMB=AM2
33377 IF (I.GT.30.AND.II.GT.30) GO TO 20
33378 III=II
33379 AM3=AM2
33380 IF (I.LE.30) GO TO 10
33381 III=I
33382 AM3=AM1
33383 10 CONTINUE
33384 GO TO 30
33385 20 CONTINUE
33386 III=II
33387 AM3=AM2
33388 IF (AMA.LE.AMB) GO TO 30
33389 III=I
33390 AM3=AM1
33391 30 CONTINUE
33392 IB=IBARH(III)
33393 AMA=AM3
33394 K=INT((AMA-0.75D0)/0.05D0)
33395 IF (K-2.LT.0) K=1
33396 IF (K-26.GE.0) K=25
33397 IF (IB)50,40,50
33398 40 BM=BBM(K)
33399 GO TO 60
33400 50 BM=BBB(K)
33401 60 CONTINUE
33402C NORMALIZATION
33403 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33404 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33405 VB=DT_RNDM(TMIN)
33406**sr test
33407C IF (VB.LT.0.2D0) BM=BM*0.1
33408C **0.5
33409 BM = BM*5.05D0
33410**
33411 TMI=BM*TMIN
33412 TMA=BM*TMAX
33413 ETMA=0.D0
33414 IF (ABS(TMA).GT.120.D0) GO TO 70
33415 ETMA=EXP(TMA)
33416 70 CONTINUE
33417 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33418C*** RANDOM CHOICE OF THE T - VALUE
33419 R=DT_RNDM(TMI)
33420 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33421 RETURN
33422 END
33423
33424*$ CREATE DT_DTWOPA.FOR
33425*COPY DT_DTWOPA
33426*
33427*===dtwopa=============================================================*
33428*
33429 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33430 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33431
33432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33433 SAVE
33434
33435C ******************************************************
33436C QUASI TWO PARTICLE PRODUCTION
33437C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33438C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33439C IN THE CM - SYSTEM
33440C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33441C SPHERICAL COORDINATES
33442C ******************************************************
33443
33444* particle properties (BAMJET index convention),
33445* (dublicate of DTPART for HADRIN)
33446 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33447 & K1H(110),K2H(110)
33448
33449 AMA=AM1
33450 AMB=AM2
33451 AMA2=AMA*AMA
33452 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33453 E2=UMOO - E1
33454 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33455 AMTE=(E1-AMA)*(E1+AMA)
33456 AMTE=AMTE+1.D-18
33457 P1=SQRT(AMTE)
33458 P2=P1
33459C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33460C DETERMINATION OF THE ANGLES
33461C COS(THETA1)=COD1 COS(THETA2)=COD2
33462C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33463C COS(PHI1)=COF1 COS(PHI2)=COF2
33464C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33465 CALL DT_DSFECF(COF1,SIF1)
33466 COF2=-COF1
33467 SIF2=-SIF1
33468C CALCULATION OF THETA1
33469 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33470 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33471 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33472 COD2=-COD1
33473 RETURN
33474 END
33475
33476*$ CREATE DT_ZK.FOR
33477*COPY DT_ZK
33478*
33479*===zk=================================================================*
33480*
33481 BLOCK DATA DT_ZK
33482
33483 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33484 SAVE
33485
33486* decay channel information for HADRIN
33487 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33488 & K1Z(16),K2Z(16),WTZ(153),II22,
33489 & NZK1(153),NZK2(153),NZK3(153)
33490
33491* decay channel information for HADRIN
33492 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33493 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33494
33495* Particle masses in GeV *
33496 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33497 & 2*1.7D0, 3*0.D0/
33498* Resonance width Gamma in GeV *
33499 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33500* Mean life time in seconds *
33501 DATA TAUZ / 16*0.D0 /
33502* Charge of particles and resonances *
33503 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33504* Baryonic charge *
33505 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33506* First number of decay channels used for resonances *
33507* and decaying particles *
33508 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33509 & 3*460/
33510* Last number of decay channels used for resonances *
33511* and decaying particles *
33512 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33513 & 3*460/
33514* Weight of decay channel *
33515 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33516 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33517 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33518 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33519 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33520 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33521 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33522 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33523 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33524 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33525 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33526 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33527 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33528 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33529 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33530 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33531 & .05D0, .65D0, 9*1.D0 /
33532* Particle numbers in decay channel *
33533 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33534 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33535 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33536 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33537 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33538 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33539 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33540 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33541 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33542 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33543 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33544 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33545 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33546 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33547 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33548 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33549 & 1, 8, 1, 8, 1, 9*0 /
33550 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33551 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33552 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33553 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33554 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33555 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33556* Particle names *
33557 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33558 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33559 & 3*'BLANK' /
33560* Name of decay channel *
33561 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33562 & 'ANNPI0','APPPI0','ANPPI-'/
33563 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33564 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33565 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33566 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33567 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33568 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33569 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33570 & 'OMOMOM',
33571 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33572 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33573 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33574 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33575 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33576 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33577 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33578 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33579 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33580 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33581 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33582 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33583 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33584 & 9*'BLANK'/
33585*= end*block.zk *
33586 END
33587
33588*$ CREATE DT_BLKD43.FOR
33589*COPY DT_BLKD43
33590*
33591*===blkd43=============================================================*
33592*
33593 BLOCK DATA DT_BLKD43
33594
33595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33596 SAVE
33597
33598*
33599*=== reac =============================================================*
33600*
33601*----------------------------------------------------------------------*
33602* *
33603* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33604* Infn - Milan *
33605* *
33606* Last change on 10-dec-91 by Alfredo Ferrari *
33607* *
33608* This is the original common reac of Hadrin *
33609* *
33610*----------------------------------------------------------------------*
33611*
33612
33613 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33614 & NRK(2,268),NURE(30,2)
33615
33616 DIMENSION
33617 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33618 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33619 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33620 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33621 & SPIKP5(187), SPIKP6(289),
33622 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33623 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33624 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33625 & SANPEL(84) , SPIKPF(273),
33626 & SPKP15(187), SPKP16(272),
33627 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33628 & NURELN(60)
33629*
33630 DIMENSION NRKLIN(532)
33631 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33632 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33633 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33634 EQUIVALENCE ( UMO(263), UMOK0(1))
33635 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33636 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33637 EQUIVALENCE ( PLABF(263), PLAK0(1))
33638 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33639 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33640 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33641 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33642 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33643 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33644 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33645 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33646 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33647 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33648 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33649 EQUIVALENCE ( WK(4913), SPKP16(1))
33650 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33651 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33652 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33653 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33654 EQUIVALENCE (NURE(1,1), NURELN(1))
33655*
33656**** pi- p data *
33657**** pi+ n data *
33658 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33659 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33660 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33661 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33662 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33663 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33664 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33665 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33666 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33667 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33668 DATA PLAKC /
33669 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33670 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33671 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33672 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33673 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33674 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33675 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33676 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33677 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33678 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33679 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33680 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33681 DATA PLAK0 /
33682 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33683 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33684 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33685 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33686 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33687 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33688* pp pn np nn *
33689 DATA PLAP /
33690 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33691 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33692 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33693 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33694 & 0.D0, 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* app apn anp ann *
33697 DATA PLAN /
33698 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33699 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33700 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33701 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33702 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33703 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33704 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33705 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33706 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33707 DATA SIIN / 296*0.D0 /
33708 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33709 & 1.557D0,1.615D0,1.6435D0,
33710 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33711 & 2.286D0,2.366D0,2.482D0,2.56D0,
33712 & 2.735D0,2.90D0,
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.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33719 & 1.496D0,1.527D0,1.557D0,
33720 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33721 & 2.071D0,2.159D0,2.286D0,2.366D0,
33722 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33723 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33724 & 1.557D0,1.615D0,1.6435D0,
33725 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33726 & 2.286D0,2.366D0,2.482D0,2.56D0,
33727 & 2.735D0, 2.90D0/
33728 DATA UMOKC/ 1.44D0,
33729 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33730 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33731 & 3.1D0,1.44D0,
33732 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33733 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33734 & 3.1D0,1.44D0,
33735 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33736 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33737 & 3.1D0,1.44D0,
33738 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33739 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33740 & 3.1D0/
33741 DATA UMOK0/ 1.44D0,
33742 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33743 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33744 & 3.1D0,1.44D0,
33745 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33746 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33747 & 3.1D0/
33748* pp pn np nn *
33749 DATA UMOP/
33750 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33751 & 3.D0,3.1D0,3.2D0,
33752 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33753 & 3.D0,3.1D0,3.2D0,
33754 & 1.88D0,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* app apn anp ann *
33757 DATA UMON /
33758 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33759 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33760 & 3.D0,3.1D0,3.2D0,
33761 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33762 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33763 & 3.D0,3.1D0,3.2D0,
33764 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33765 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33766 & 3.D0,3.1D0,3.2D0/
33767**** reaction channel state particles *
33768 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33769 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33770 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33771 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33772 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33773 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33774 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33775 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33776 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33777 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33778 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33779 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33780 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33781 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33782 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33783 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33784 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33785 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33786* *
33787* k0 p k0 n ak0 p ak/ n *
33788* *
33789 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33790 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33791 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33792 & 53, 47, 1, 103, 0, 93, 0/
33793* pp pn np nn *
33794 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33795 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33796 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33797 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33798* app apn anp ann *
33799 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33800 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33801 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33802 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33803 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33804 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33805 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33806**** channel cross section *
33807 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33808 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33809 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33810 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33811 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33812 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33813 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33814 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33815 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33816 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33817 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33818 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33819 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33820 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33821 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33822 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33823 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33824 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33825 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33826 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33827**** pi+ n data *
33828 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33829 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33830 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33831 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33832 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33833 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33834 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33835 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33836 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33837 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33838 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33839 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33840 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33841 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33842 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33843 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33844 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33845 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33846 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33847 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33848*
33849 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33850 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33851 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33852 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33853 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33854 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33855 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33856 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33857 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33858 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33859 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33860 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33861 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33862 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33863 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33864 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33865 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33866 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33867 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33868 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33869**** pi- p data *
33870 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33871 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33872 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33873 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33874 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33875 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33876 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33877 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33878 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33879 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33880 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33881 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33882 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33883 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33884 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33885 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33886 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33887 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33888 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33889*
33890 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33891 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33892 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33893 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33894 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33895 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33896 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33897 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33898 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33899 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33900 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33901 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33902 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33903 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33904 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33905 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33906 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33907 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33908 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33909 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33910**** pi- n data *
33911 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33912 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33913 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33914 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33915 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33916 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33917 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33918 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33919 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33920 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33921 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33922 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33923 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33924 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33925 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33926 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33927 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33928 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33929 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33930 & 3.3D0, 5.4D0, 7.D0 /
33931**** k+ p data *
33932 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33933 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33934 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33935 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33936 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33937 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33938 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33939 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33940 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33941 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33942 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33943 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33944 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33945**** k+ n data *
33946 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33947 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33948 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33949 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33950 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33951 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33952 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33953 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33954 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33955 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33956 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33957 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33958 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33959 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33960 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33961 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33962 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33963 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33964 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33965**** k- p data *
33966 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33967 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33968 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33969 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33970 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33971 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33972 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33973 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33974 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33975 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33976 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33977 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33978 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33979 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33980 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33981 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33982 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33983 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33984 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33985 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33986 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33987 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33988 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33989 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33990 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33991 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33992 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33993 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33994 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33995 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33996 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33997 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33998 & 10*0.D0/
33999***** k- n data *
34000 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34001 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
34002 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
34003 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
34004 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34005 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34006 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34007 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34008 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34009 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34010 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34011 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34012 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34013 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34014 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34015 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34016 & .39D0, .22D0, .07D0, 0.D0,
34017 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34018 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34019 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34020 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34021 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34022 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34023 & 5.10D0, 5.44D0, 5.3D0,
34024 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34025***** p p data *
34026 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34027 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34028 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34029 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34030 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34031 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34032 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34033 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34034 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34035 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34036 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34037 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34038 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34039 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34040 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34041***** p n data *
34042 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34043 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34044 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34045 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34046 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34047 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34048 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34049 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34050 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34051 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34052 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34053 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34054 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34055 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34056 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34057 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34058 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34059 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34060* nn - data *
34061* *
34062 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34063 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34064 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34065 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34066 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34067 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34068 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34069 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34070 & 11.D0, 5.5D0, 3.5D0,
34071 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34072 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34073 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34074 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34075 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34076 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34077**************** ap - p - data *
34078 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34079 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34080 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34081 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34082 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34083 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34084 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34085 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34086 & 1.55D0, 1.3D0, .95D0, .75D0,
34087 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34088 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34089 & .01D0, .008D0, .006D0, .005D0/
34090 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34091 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34092 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34093 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34094 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34095 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34096 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34097 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34098 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34099 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34100 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34101 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34102 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34103 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34104 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34105 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34106 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34107 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34108 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34109 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34110**************** ap - n - data *
34111 DATA SAPNEL/
34112 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34113 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34114 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34115 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34116 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34117 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34118 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34119 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34120 & .01D0, .008D0, .006D0, .005D0 /
34121 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34122 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34123 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34124 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34125 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34126 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34127 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34128 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34129 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34130 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34131 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34132 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34133 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34134 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34135* *
34136* *
34137**************** an - p - data *
34138* *
34139 DATA SANPEL/
34140 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34141 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34142 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34143 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34144 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34145 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34146 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34147 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34148 & .01D0, .008D0, .006D0, .005D0 /
34149 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34150 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34151 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34152 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34153 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34154 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34155 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34156 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34157 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34158 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34159 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34160 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34161 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34162 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34163**** ko - n - data *
34164 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34165 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34166 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34167 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34168 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34169 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34170 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34171 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34172 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34173 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34174 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34175 & 4.85D0, 4.9D0,
34176 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34177 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34178 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34179 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34180 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34181**** ako - p - data *
34182 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34183 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34184 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34185 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34186 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34187 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34188 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34189 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34190 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34191 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34192 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34193 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34194 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34195 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34196 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34197 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34198 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34199 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34200 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34201 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34202 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34203 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34204 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34205*= end*block.blkdt3 *
34206 END
34207*$ CREATE DT_QEL_POL.FOR
34208*COPY DT_QEL_POL
34209*
34210*===qel_pol============================================================*
34211*
34212 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34213
34214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34215 SAVE
34216
34217 CALL DT_MASS_INI
34218 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34219
34220 RETURN
34221 END
34222
34223*$ CREATE DT_GEN_QEL.FOR
34224*COPY DT_GEN_QEL
34225C==================================================================
34226C Generation of a Quasi-Elastic neutrino scattering
34227C==================================================================
34228*
34229*===gen_qel============================================================*
34230*
34231 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34232
34233C...Generate a quasi-elastic neutrino/antineutrino
34234C. Interaction on a nuclear target
34235C. INPUT : LTYP = neutrino type (1,...,6)
34236C. ENU (GeV) = neutrino energy
34237C----------------------------------------------------
34238
34239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34240 SAVE
34241
34242 PARAMETER ( LINP = 10 ,
34243 & LOUT = 6 ,
34244 & LDAT = 9 )
34245 PARAMETER (MAXLND=4000)
34246 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34247
34248* nuclear potential
34249 LOGICAL LFERMI
34250 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34251 & EBINDP(2),EBINDN(2),EPOT(2,210),
34252 & ETACOU(2),ICOUL,LFERMI
34253
34254* steering flags for qel neutrino scattering modules
34255 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34256**sr - removed (not needed)
34257C COMMON /CBAD/ LBAD, NBAD
34258C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34259**
34260
34261 DIMENSION PI(3),PO(3)
34262CJR+
34263 DATA ININU/0/
34264CJR-
34265C REAL*8 DBETA(3)
34266C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34267 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34268 DATA AMN /0.93827231D0, 0.93956563D0/
34269 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34270 DATA INIPRI/0/
34271
34272C DATA PFERMI/0.22D0/
34273CGB+...Binding Energy
34274 DATA EBIND/0.008D0/
34275CGB-...
34276
34277 ININU=ININU+1
34278 IF(ININU.EQ.1)NDSIG=0
34279 LBAD = 0
34280 enu0=enu
34281c write(*,*) enu0
34282C...Lepton mass
34283 AML = AML0(LTYP) ! massa leptoni
34284 AML2 = AML**2 ! massa leptoni **2
34285C...Particle labels (LUND)
34286 N = 5
34287 K(1,1) = 21
34288 K(2,1) = 21
34289 K(3,1) = 21
34290 K(3,3) = 1
34291 K(4,1) = 1
34292 K(4,3) = 1
34293 K(5,1) = 1
34294 K(5,3) = 2
34295 K0 = (LTYP-1)/2 ! 2
34296 K1 = LTYP/2 ! 2
34297 KA = 12 + 2*K0 ! 16
34298 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34299 K(1,2) = IS*KA
34300 K(4,2) = IS*(KA-1)
34301 K(3,2) = IS*24
34302 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34303 IF (LNU .EQ. 2) THEN
34304 K(2,2) = 2212
34305 K(5,2) = 2112
34306 AMI = AMN(1)
34307 AMF = AMN(2)
34308CJR+
34309 PFERMI=PFERMN(2)
34310CJR-
34311 ELSE
34312 K(2,2) = 2112
34313 K(5,2) = 2212
34314 AMI = AMN(2)
34315 AMF = AMN(1)
34316CJR+
34317 PFERMI=PFERMP(2)
34318CJR-
34319 ENDIF
34320 AMI2 = AMI**2
34321 AMF2 = AMF**2
34322
34323 DO IGB=1,5
34324 P(3,IGB) = 0.
34325 P(4,IGB) = 0.
34326 P(5,IGB) = 0.
34327 END DO
34328
34329 NTRY = 0
34330CGB+...
34331 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34332 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34333CGB-...
34334
34335 100 CONTINUE
34336
34337C...4-momentum initial lepton
34338 P(1,5) = 0. ! massa
34339 P(1,4) = ENU0 ! energia
34340 P(1,1) = 0. ! px
34341 P(1,2) = 0. ! py
34342 P(1,3) = ENU0 ! pz
34343
34344C PF = PFERMI*PYR(0)**(1./3.)
34345c write(23,*) PYR(0)
34346c write(*,*) 'Pfermi=',PF
34347c PF = 0.
34348 NTRY=NTRY+1
34349C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34350 IF (NTRY .GT. 500) THEN
34351 LBAD = 1
34352 WRITE (LOUT,1001) NBAD, ENU
34353 RETURN
34354 ENDIF
34355C CT = -1. + 2.*PYR(0)
34356c CT = -1.
34357C ST = SQRT(1.-CT*CT)
34358C F = 2.*3.1415926*PYR(0)
34359c F = 0.
34360
34361C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34362C P(2,1) = PF*ST*COS(F) ! px
34363C P(2,2) = PF*ST*SIN(F) ! py
34364C P(2,3) = PF*CT ! pz
34365C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34366 P(2,1) = P21
34367 P(2,2) = P22
34368 P(2,3) = P23
34369 P(2,4) = P24
34370 P(2,5) = P25
34371 beta1=-p(2,1)/p(2,4)
34372 beta2=-p(2,2)/p(2,4)
34373 beta3=-p(2,3)/p(2,4)
34374 N=2
34375C WRITE(6,*)' before transforming into target rest frame'
34376
34377 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34378
34379C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34380 N=5
34381
34382 phi11=atan(p(1,2)/p(1,3))
34383 pi(1)=p(1,1)
34384 pi(2)=p(1,2)
34385 pi(3)=p(1,3)
34386
34387 CALL DT_TESTROT(PI,Po,PHI11,1)
34388 DO ll=1,3
34389 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34390 END DO
34391c WRITE(*,*) po
34392 p(1,1)=po(1)
34393 p(1,2)=po(2)
34394 p(1,3)=po(3)
34395 phi12=atan(p(1,1)/p(1,3))
34396
34397 pi(1)=p(1,1)
34398 pi(2)=p(1,2)
34399 pi(3)=p(1,3)
34400 CALL DT_TESTROT(Pi,Po,PHI12,2)
34401 DO ll=1,3
34402 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34403 END DO
34404c WRITE(*,*) po
34405 p(1,1)=po(1)
34406 p(1,2)=po(2)
34407 p(1,3)=po(3)
34408
34409 enu=p(1,4)
34410
34411C...Kinematical limits in Q**2
34412c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34413 S = P(2,5)**2 + 2.*ENU*P(2,5)
34414 SQS = SQRT(S) ! E centro massa
34415 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34416 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34417 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34418 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34419 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34420 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34421 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34422
34423C...Generate Q**2
34424 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34425 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34426 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34427 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34428 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34429 NDSIG=NDSIG+1
34430C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34431C &Q2,Q2min,Q2MAX,DSIGEV
34432
34433C...c.m. frame. Neutrino along z axis
34434 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34435 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34436 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34437 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34438c WRITE(*,*)
34439c WRITE(*,*)
34440C WRITE(*,*) 'Input values laboratory frame'
34441 N=2
34442
34443 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34444
34445 N=5
34446c STHETA = ULANGL(P(1,3),P(1,1))
34447c write(*,*) 'stheta' ,stheta
34448c stheta=0.
34449c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34450c WRITE(*,*)
34451c WRITE(*,*)
34452C WRITE(*,*) 'Output values cm frame'
34453C...Kinematic in c.m. frame
34454 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34455 STSTAR = SQRT(1.-CTSTAR**2)
34456 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34457 P(4,5) = AML ! massa leptone
34458 P(4,4) = ELF ! e leptone
34459 P(4,3) = PLF*CTSTAR ! px
34460 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34461 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34462
34463 P(5,5) = AMF ! barione
34464 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34465 P(5,3) = -P(4,3) ! px
34466 P(5,1) = -P(4,1) ! py
34467 P(5,2) = -P(4,2) ! pz
34468
34469 P(3,5) = -Q2
34470 P(3,1) = P(1,1)-P(4,1)
34471 P(3,2) = P(1,2)-P(4,2)
34472 P(3,3) = P(1,3)-P(4,3)
34473 P(3,4) = P(1,4)-P(4,4)
34474
34475C...Transform back to laboratory frame
34476C WRITE(*,*) 'before going back to nucl rest frame'
34477c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34478 N=5
34479
34480 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34481
34482C WRITE(*,*) 'Now back in nucl rest frame'
34483 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34484
34485c********************************************
34486
34487 DO kw=1,5
34488 pi(1)=p(kw,1)
34489 pi(2)=p(kw,2)
34490 pi(3)=p(kw,3)
34491 CALL DT_TESTROT(Pi,Po,PHI12,3)
34492 DO ll=1,3
34493 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34494 END DO
34495 p(kw,1)=po(1)
34496 p(kw,2)=po(2)
34497 p(kw,3)=po(3)
34498 END DO
34499c********************************************
34500
34501 DO kw=1,5
34502 pi(1)=p(kw,1)
34503 pi(2)=p(kw,2)
34504 pi(3)=p(kw,3)
34505 CALL DT_TESTROT(Pi,Po,PHI11,4)
34506 DO ll=1,3
34507 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34508 END DO
34509 p(kw,1)=po(1)
34510 p(kw,2)=po(2)
34511 p(kw,3)=po(3)
34512 END DO
34513
34514c********************************************
34515
34516C WRITE(*,*) 'Now back in lab frame'
34517
34518 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34519
34520CGB+...
34521C...test (on final momentum of nucleon) if Fermi-blocking
34522C...is operating
34523 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34524 & - P(5,5)
34525 IF (ENUCL.LT. EFMAX) THEN
34526 IF(INIPRI.LT.10)THEN
34527 INIPRI=INIPRI+1
34528C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34529C...the interaction is not possible due to Pauli-Blocking and
34530C...it must be resampled
34531 ENDIF
34532 GOTO 100
34533 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34534 IF(INIPRI.LT.10)THEN
34535 INIPRI=INIPRI+1
34536C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34537 ENDIF
34538C Reject (J:R) here all these events
34539C are otherwise rejected in dpmjet
34540 GOTO 100
34541C...the interaction is possible, but the nucleon remains inside
34542C...the nucleus. The nucleus is therefore left excited.
34543C...We treat this case as a nucleon with 0 kinetic energy.
34544C P(5,5) = AMF
34545C P(5,4) = AMF
34546C P(5,1) = 0.
34547C P(5,2) = 0.
34548C P(5,3) = 0.
34549 ELSE IF (ENUCL.GE.ENWELL) THEN
34550C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34551C...the interaction is possible, the nucleon can exit the nucleus
34552C...but the nuclear well depth must be subtracted. The nucleus could be
34553C...left in an excited state.
34554 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34555C P(5,4) = ENUCL-ENWELL + AMF
34556 Pnucl = SQRT(P(5,4)**2-AMF**2)
34557C...The 3-momentum is scaled assuming that the direction remains
34558C...unaffected
34559 P(5,1) = P(5,1) * Pnucl/Pstart
34560 P(5,2) = P(5,2) * Pnucl/Pstart
34561 P(5,3) = P(5,3) * Pnucl/Pstart
34562C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34563 ENDIF
34564CGB-...
34565 DSIGSU=DSIGSU+DSIGEV
34566
34567 GA=P(4,4)/P(4,5)
34568 BGX=P(4,1)/P(4,5)
34569 BGY=P(4,2)/P(4,5)
34570 BGZ=P(4,3)/P(4,5)
34571*
34572 DBETB(1)=BGX/GA
34573 DBETB(2)=BGY/GA
34574 DBETB(3)=BGZ/GA
34575 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34576
34577 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34578
34579 ENDIF
34580c
34581C PRINT*,' FINE EVENTO '
34582 enu=enu0
34583 RETURN
34584
34585 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34586 END
34587
34588*$ CREATE DT_MASS_INI.FOR
34589*COPY DT_MASS_INI
34590C====================================================================
34591C. Masses
34592C====================================================================
34593*
34594*===mass_ini===========================================================*
34595*
34596 SUBROUTINE DT_MASS_INI
34597C...Initialize the kinematics for the quasi-elastic cross section
34598
34599 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34600 SAVE
34601
34602* particle masses used in qel neutrino scattering modules
34603 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34604 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34605 & EMPROTSQ,EMNEUTSQ,EMNSQ
34606
34607 EML(1) = 0.51100D-03 ! e-
34608 EML(2) = EML(1) ! e+
34609 EML(3) = 0.105659D0 ! mu-
34610 EML(4) = EML(3) ! mu+
34611 EML(5) = 1.7777D0 ! tau-
34612 EML(6) = EML(5) ! tau+
34613 EMPROT = 0.93827231D0 ! p
34614 EMNEUT = 0.93956563D0 ! n
34615 EMPROTSQ = EMPROT**2
34616 EMNEUTSQ = EMNEUT**2
34617 EMN = (EMPROT + EMNEUT)/2.
34618 EMNSQ = EMN**2
34619 DO J=1,3
34620 J0 = 2*(J-1)
34621 EMN1(J0+1) = EMNEUT
34622 EMN1(J0+2) = EMPROT
34623 EMN2(J0+1) = EMPROT
34624 EMN2(J0+2) = EMNEUT
34625 ENDDO
34626 DO J=1,6
34627 EMLSQ(J) = EML(J)**2
34628 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34629 ENDDO
34630 RETURN
34631 END
34632
34633*$ CREATE DT_DSQEL_Q2.FOR
34634*COPY DT_DSQEL_Q2
34635*
34636*===dsqel_q2===========================================================*
34637*
34638 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34639
34640C...differential cross section for Quasi-Elastic scattering
34641C. nu + N -> l + N'
34642C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34643C.
34644C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34645C. ENU (GeV) = Neutrino energy
34646C. Q2 (GeV**2) = (Transfer momentum)**2
34647C.
34648C. OUTPUT : DSQEL_Q2 = differential cross section :
34649C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34650C------------------------------------------------------------------
34651
34652 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34653 SAVE
34654
34655* particle masses used in qel neutrino scattering modules
34656 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34657 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34658 & EMPROTSQ,EMNEUTSQ,EMNSQ
34659**sr - removed (not needed)
34660C COMMON /CAXIAL/ FA0, AXIAL2
34661**
34662
34663 DIMENSION SS(6)
34664 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34665 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34666 DATA AXIAL2 /1.03D0/ ! to be checked
34667
34668 FA0=-1.253D0
34669 CSI = 3.71D0 ! ???
34670 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34671 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34672 X = Q2/(EMN*EMN) ! emn=massa barione
34673 XA = X/4.D0
34674 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34675 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34676 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34677 FFA = FA*FA
34678 FFV1 = FV1*FV1
34679 FFV2 = FV2*FV2
34680 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34681 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34682 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34683 AA = (XA+0.25D0*RM)*(A1 + A2)
34684 BB = -X*FA*(FV1 + FV2)
34685 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34686 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34687 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34688 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34689
34690 RETURN
34691 END
34692
34693*$ CREATE DT_PREPOLA.FOR
34694*COPY DT_PREPOLA
34695*
34696*===prepola============================================================*
34697*
34698 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34699
34700 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34701 SAVE
34702c
34703c By G. Battistoni and E. Scapparone (sept. 1997)
34704c According to:
34705c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34706c
34707c
34708 PARAMETER (MAXLND=4000)
34709 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34710
34711 COMMON /QNPOL/ POLARX(4),PMODUL
34712
34713* particle masses used in qel neutrino scattering modules
34714 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34715 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34716 & EMPROTSQ,EMNEUTSQ,EMNSQ
34717
34718* steering flags for qel neutrino scattering modules
34719 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34720**sr - removed (not needed)
34721C COMMON /CAXIAL/ FA0, AXIAL2
34722C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34723C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34724**
34725 REAL*8 POL(4,4),BB2(3)
34726 DIMENSION SS(6)
34727C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34728 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34729**sr uncommented since common block CAXIAL is now commented
34730 DATA AXIAL2 /1.03D0/ ! to be checked
34731**
34732
34733 RML=P(4,5)
34734 RMM=0.93960D+00
34735 FM2 = RMM**2
34736 MPI = 0.135D+00
34737 OLDQ2=Q2
34738 FA0=-1.253D+00
34739 CSI = 3.71D+00 !
34740 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34741 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34742 X = Q2/(EMN*EMN) ! emn=massa barione
34743 XA = X/4.D0
34744 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34745 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34746 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34747 FFA = FA*FA
34748 FFV1 = FV1*FV1
34749 FFV2 = FV2*FV2
34750 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34751 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34752 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34753 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34754 AA = (XA+0.25D+00*RM)*(A1 + A2)
34755 BB = -X*FA*(FV1 + FV2)
34756 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34757 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34758
34759 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34760 OMEGA2=4.D+00*CC
34761 OMEGA3=2.D+00*FA*(FV1+FV2)
34762 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34763 1 (Q2/FM2))*FP**2)
34764 OMEGA5=OMEGA2
34765 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34766 WW1=2.D+00*OMEGA1*EMN**2
34767 WW2=2.D+00*OMEGA2*EMN**2
34768 WW3=2.D+00*OMEGA3*EMN**2
34769 WW4=2.D+00*OMEGA4*EMN**2
34770 WW5=2.D+00*OMEGA5*EMN**2
34771
34772 DO I=1,3
34773 BB2(I)=-P(4,I)/P(4,4)
34774 END DO
34775c WRITE(*,*)
34776c WRITE(*,*)
34777c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34778 N=5
34779
34780 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34781
34782* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34783c WRITE(*,*)
34784c WRITE(*,*)
34785c WRITE(*,*) 'Prepola: now in lepton rest frame'
34786 EE=ENU
34787 QM2=Q2+RML**2
34788 U=Q2/(2.*RMM)
34789 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34790 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34791 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34792
34793 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34794 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34795
34796 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34797
34798 DO I=1,3
34799 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34800 POLARX(I)=POL(4,I)
34801 END DO
34802
34803 PMODUL=0.D0
34804 DO I=1,3
34805 PMODUL=PMODUL+POL(4,I)**2
34806 END DO
34807
34808 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34809 IF(NEUDEC.EQ.1) THEN
34810 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34811 + ETL,PXL,PYL,PZL,
34812 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34813c
34814c Tau has decayed in muon
34815c
34816 ENDIF
34817 IF(NEUDEC.EQ.2) THEN
34818 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34819 + ETL,PXL,PYL,PZL,
34820 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34821c
34822c Tau has decayed in electron
34823c
34824 ENDIF
34825 K(4,1)=15
34826 K(4,4) = 6
34827 K(4,5) = 8
34828 N=N+3
34829c
34830c fill common for muon(electron)
34831c
34832 P(6,1)=PXL
34833 P(6,2)=PYL
34834 P(6,3)=PZL
34835 P(6,4)=ETL
34836 K(6,1)=1
34837 IF(JTYP.EQ.5) THEN
34838 IF(NEUDEC.EQ.1) THEN
34839 P(6,5)=EML(JTYP-2)
34840 K(6,2)=13
34841 ELSEIF(NEUDEC.EQ.2) THEN
34842 P(6,5)=EML(JTYP-4)
34843 K(6,2)=11
34844 ENDIF
34845 ELSEIF(JTYP.EQ.6) THEN
34846 IF(NEUDEC.EQ.1) THEN
34847 K(6,2)=-13
34848 ELSEIF(NEUDEC.EQ.2) THEN
34849 K(6,2)=-11
34850 ENDIF
34851 END IF
34852 K(6,3)=4
34853 K(6,4)=0
34854 K(6,5)=0
34855c
34856c fill common for tau_(anti)neutrino
34857c
34858 P(7,1)=PXB
34859 P(7,2)=PYB
34860 P(7,3)=PZB
34861 P(7,4)=ETB
34862 P(7,5)=0.
34863 K(7,1)=1
34864 IF(JTYP.EQ.5) THEN
34865 K(7,2)=16
34866 ELSEIF(JTYP.EQ.6) THEN
34867 K(7,2)=-16
34868 END IF
34869 K(7,3)=4
34870 K(7,4)=0
34871 K(7,5)=0
34872c
34873c Fill common for muon(electron)_(anti)neutrino
34874c
34875 P(8,1)=PXN
34876 P(8,2)=PYN
34877 P(8,3)=PZN
34878 P(8,4)=ETN
34879 P(8,5)=0.
34880 K(8,1)=1
34881 IF(JTYP.EQ.5) THEN
34882 IF(NEUDEC.EQ.1) THEN
34883 K(8,2)=-14
34884 ELSEIF(NEUDEC.EQ.2) THEN
34885 K(8,2)=-12
34886 ENDIF
34887 ELSEIF(JTYP.EQ.6) THEN
34888 IF(NEUDEC.EQ.1) THEN
34889 K(8,2)=14
34890 ELSEIF(NEUDEC.EQ.2) THEN
34891 K(8,2)=12
34892 ENDIF
34893 END IF
34894 K(8,3)=4
34895 K(8,4)=0
34896 K(8,5)=0
34897 ENDIF
34898c WRITE(*,*)
34899c WRITE(*,*)
34900
34901c IF(PMODUL.GE.1.D+00) THEN
34902c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34903c write(*,*) pmodul
34904c DO I=1,3
34905c POL(4,I)=POL(4,I)/PMODUL
34906c POLARX(I)=POL(4,I)
34907c END DO
34908c PMODUL=0.
34909c DO I=1,3
34910c PMODUL=PMODUL+POL(4,I)**2
34911c END DO
34912c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34913c
34914c ENDIF
34915
34916c WRITE(*,*) 'PMODUL = ',PMODUL
34917
34918c WRITE(*,*)
34919c WRITE(*,*)
34920c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34921
34922 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34923
34924 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34925 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34926 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34927 DO NDC =6,8
34928 V(NDC,1) = XDC
34929 V(NDC,2) = YDC
34930 V(NDC,3) = ZDC
34931 END DO
34932
34933 RETURN
34934 END
34935
34936*$ CREATE DT_TESTROT.FOR
34937*COPY DT_TESTROT
34938*
34939*===testrot============================================================*
34940*
34941 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34942
34943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34944 SAVE
34945
34946 DIMENSION ROT(3,3),PI(3),PO(3)
34947
34948 IF (MODE.EQ.1) THEN
34949 ROT(1,1) = 1.D0
34950 ROT(1,2) = 0.D0
34951 ROT(1,3) = 0.D0
34952 ROT(2,1) = 0.D0
34953 ROT(2,2) = COS(PHI)
34954 ROT(2,3) = -SIN(PHI)
34955 ROT(3,1) = 0.D0
34956 ROT(3,2) = SIN(PHI)
34957 ROT(3,3) = COS(PHI)
34958 ELSEIF (MODE.EQ.2) THEN
34959 ROT(1,1) = 0.D0
34960 ROT(1,2) = 1.D0
34961 ROT(1,3) = 0.D0
34962 ROT(2,1) = COS(PHI)
34963 ROT(2,2) = 0.D0
34964 ROT(2,3) = -SIN(PHI)
34965 ROT(3,1) = SIN(PHI)
34966 ROT(3,2) = 0.D0
34967 ROT(3,3) = COS(PHI)
34968 ELSEIF (MODE.EQ.3) THEN
34969 ROT(1,1) = 0.D0
34970 ROT(2,1) = 1.D0
34971 ROT(3,1) = 0.D0
34972 ROT(1,2) = COS(PHI)
34973 ROT(2,2) = 0.D0
34974 ROT(3,2) = -SIN(PHI)
34975 ROT(1,3) = SIN(PHI)
34976 ROT(2,3) = 0.D0
34977 ROT(3,3) = COS(PHI)
34978 ELSEIF (MODE.EQ.4) THEN
34979 ROT(1,1) = 1.D0
34980 ROT(2,1) = 0.D0
34981 ROT(3,1) = 0.D0
34982 ROT(1,2) = 0.D0
34983 ROT(2,2) = COS(PHI)
34984 ROT(3,2) = -SIN(PHI)
34985 ROT(1,3) = 0.D0
34986 ROT(2,3) = SIN(PHI)
34987 ROT(3,3) = COS(PHI)
34988 ELSE
34989 STOP ' TESTROT: mode not supported!'
34990 ENDIF
34991 DO 1 J=1,3
34992 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34993 1 CONTINUE
34994
34995 RETURN
34996 END
34997
34998*$ CREATE DT_LEPDCYP.FOR
34999*COPY DT_LEPDCYP
35000*
35001*===lepdcyp============================================================*
35002*
35003 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
35004 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35005C
35006C-----------------------------------------------------------------
35007C
35008C Author :- G. Battistoni 10-NOV-1995
35009C
35010C=================================================================
35011C
35012C Purpose : performs decay of polarized lepton in
35013C its rest frame: a => b + l + anti-nu
35014C (Example: mu- => nu-mu + e- + anti-nu-e)
35015C Polarization is assumed along Z-axis
35016C WARNING:
35017C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35018C OF NEGLIGIBLE MASS
35019C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35020C IN THIS VERSION
35021C
35022C Method : modifies phase space distribution obtained
35023C by routine EXPLOD using a rejection against the
35024C matrix element for unpolarized lepton decay
35025C
35026C Inputs : Mass of a : AMA
35027C Mass of l : AML
35028C Polar. of a: POL
35029C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35030C POL = -1)
35031C
35032C Outputs : kinematic variables in the rest frame of decaying lepton
35033C ETL,PXL,PYL,PZL 4-moment of l
35034C ETB,PXB,PYB,PZB 4-moment of b
35035C ETN,PXN,PYN,PZN 4-moment of anti-nu
35036C
35037C============================================================
35038C +
35039C Declarations.
35040C -
35041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35042 SAVE
35043
35044 PARAMETER ( LINP = 10 ,
35045 & LOUT = 6 ,
35046 & LDAT = 9 )
35047
35048 PARAMETER ( KALGNM = 2 )
35049 PARAMETER ( ANGLGB = 5.0D-16 )
35050 PARAMETER ( ANGLSQ = 2.5D-31 )
35051 PARAMETER ( AXCSSV = 0.2D+16 )
35052 PARAMETER ( ANDRFL = 1.0D-38 )
35053 PARAMETER ( AVRFLW = 1.0D+38 )
35054 PARAMETER ( AINFNT = 1.0D+30 )
35055 PARAMETER ( AZRZRZ = 1.0D-30 )
35056 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35057 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35058 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35059 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35060 PARAMETER ( CSNNRM = 2.0D-15 )
35061 PARAMETER ( DMXTRN = 1.0D+08 )
35062 PARAMETER ( ZERZER = 0.D+00 )
35063 PARAMETER ( ONEONE = 1.D+00 )
35064 PARAMETER ( TWOTWO = 2.D+00 )
35065 PARAMETER ( THRTHR = 3.D+00 )
35066 PARAMETER ( FOUFOU = 4.D+00 )
35067 PARAMETER ( FIVFIV = 5.D+00 )
35068 PARAMETER ( SIXSIX = 6.D+00 )
35069 PARAMETER ( SEVSEV = 7.D+00 )
35070 PARAMETER ( EIGEIG = 8.D+00 )
35071 PARAMETER ( ANINEN = 9.D+00 )
35072 PARAMETER ( TENTEN = 10.D+00 )
35073 PARAMETER ( HLFHLF = 0.5D+00 )
35074 PARAMETER ( ONETHI = ONEONE / THRTHR )
35075 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35076 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35077 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35078 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35079 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35080 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35081 PARAMETER ( AMELGR = 9.1093897 D-28 )
35082 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35083 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35084 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35085 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35086 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35087 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35088 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35089 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35090 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35091 PARAMETER ( PLABRC = 0.197327053 D+00 )
35092 PARAMETER ( AMELCT = 0.51099906 D-03 )
35093 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35094 PARAMETER ( AMMUON = 0.105658389 D+00 )
35095 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35096 PARAMETER ( GEVMEV = 1.0 D+03 )
35097 PARAMETER ( EMVGEV = 1.0 D-03 )
35098 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35099 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35100 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35101C +
35102C variables for EXPLOD
35103C -
35104 PARAMETER ( KPMX = 10 )
35105 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35106 & PZEXPL (KPMX), ETEXPL (KPMX)
35107C +
35108C test variables
35109C -
35110**sr - removed (not needed)
35111C COMMON /GBATNU/ ELERAT,NTRY
35112**
35113C +
35114C Initializes test variables
35115C -
35116 NTRY = 0
35117 ELERAT = 0.D+00
35118C +
35119C Maximum value for matrix element
35120C -
35121 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35122 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35123C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35124C Inputs for EXPLOD
35125C part. no. 1 is l (e- in mu- decay)
35126C part. no. 2 is b (nu-mu in mu- decay)
35127C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35128C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35129 NPEXPL = 3
35130 ETOTEX = AMA
35131 AMEXPL(1) = AML
35132 AMEXPL(2) = 0.D+00
35133 AMEXPL(3) = 0.D+00
35134C +
35135C phase space distribution
35136C -
35137 100 CONTINUE
35138 NTRY = NTRY + 1
35139
35140 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35141 & PYEXPL, PZEXPL )
35142
35143C +
35144C Calculates matrix element:
35145C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35146C Here CTH is the cosine of the angle between anti-nu and Z axis
35147C -
35148 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35149 & PZEXPL(3)**2 )
35150 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35151 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35152 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35153 ELEMAT = 16.D+00 * PROD1 * PROD2
35154 IF(ELEMAT.GT.ELEMAX) THEN
35155 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35156 STOP
35157 ENDIF
35158C +
35159C Here performs the rejection
35160C -
35161 TEST = DT_RNDM(ETOTEX) * ELEMAX
35162 IF ( TEST .GT. ELEMAT ) GO TO 100
35163C +
35164C final assignment of variables
35165C -
35166 ELERAT = ELEMAT/ELEMAX
35167 ETL = ETEXPL(1)
35168 PXL = PXEXPL(1)
35169 PYL = PYEXPL(1)
35170 PZL = PZEXPL(1)
35171 ETB = ETEXPL(2)
35172 PXB = PXEXPL(2)
35173 PYB = PYEXPL(2)
35174 PZB = PZEXPL(2)
35175 ETN = ETEXPL(3)
35176 PXN = PXEXPL(3)
35177 PYN = PYEXPL(3)
35178 PZN = PZEXPL(3)
35179 999 RETURN
35180 END
35181
35182*$ CREATE DT_GEN_DELTA.FOR
35183*COPY DT_GEN_DELTA
35184C==================================================================
35185C. Generation of Delta resonance events
35186C==================================================================
35187*
35188*===gen_delta==========================================================*
35189*
35190 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35191
35192 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35193 SAVE
35194
35195 PARAMETER ( LINP = 10 ,
35196 & LOUT = 6 ,
35197 & LDAT = 9 )
35198
35199C...Generate a Delta-production neutrino/antineutrino
35200C. CC-interaction on a nucleon
35201C
35202C. INPUT ENU (GeV) = Neutrino Energy
35203C. LLEP = neutrino type
35204C. LTARG = nucleon target type 1=p, 2=n.
35205C. JINT = 1:CC, 2::NC
35206C.
35207C. OUTPUT PPL(4) 4-monentum of final lepton
35208C----------------------------------------------------
35209 PARAMETER (MAXLND=4000)
35210 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35211
35212**sr - removed (not needed)
35213C COMMON /CBAD/ LBAD, NBAD
35214**
35215
35216 DIMENSION PI(3),PO(3)
35217C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35218 DIMENSION AML0(6),AMN(2)
35219 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35220 DATA AMN /0.93827231, 0.93956563/
35221 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35222
35223c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35224 LBAD = 0
35225C...Final lepton mass
35226 IF (JINT.EQ.1) THEN
35227 AML = AML0(LLEP)
35228 ELSE
35229 AML = 0.
35230 ENDIF
35231 AML2 = AML**2
35232
35233C...Particle labels (LUND)
35234 N = 5
35235 K(1,1) = 21
35236 K(2,1) = 21
35237 K(3,1) = 21
35238 K(4,1) = 1
35239 K(3,3) = 1
35240 K(4,3) = 1
35241 IF (LTARG .EQ. 1) THEN
35242 K(2,2) = 2212
35243 ELSE
35244 K(2,2) = 2112
35245 ENDIF
35246 K0 = (LLEP-1)/2
35247 K1 = LLEP/2
35248 KA = 12 + 2*K0
35249 IS = -1 + 2*LLEP - 4*K1
35250 LNU = 2 - LLEP + 2*K1
35251 K(1,2) = IS*KA
35252 K(5,1) = 1
35253 K(5,3) = 2
35254 IF (JINT .EQ. 1) THEN ! CC interactions
35255 K(3,2) = IS*24
35256 K(4,2) = IS*(KA-1)
35257 IF(LNU.EQ.1) THEN
35258 IF (LTARG .EQ. 1) THEN
35259 K(5,2) = 2224
35260 ELSE
35261 K(5,2) = 2214
35262 ENDIF
35263 ELSE
35264 IF (LTARG .EQ. 1) THEN
35265 K(5,2) = 2114
35266 ELSE
35267 K(5,2) = 1114
35268 ENDIF
35269 ENDIF
35270 ELSE
35271 K(3,2) = 23 ! NC (Z0) interactions
35272 K(4,2) = K(1,2)
35273**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35274* Delta0 for neutron (LTARG=2)
35275C IF (LTARG .EQ. 1) THEN
35276C K(5,2) = 2114
35277C ELSE
35278C K(5,2) = 2214
35279C ENDIF
35280 IF (LTARG .EQ. 1) THEN
35281 K(5,2) = 2214
35282 ELSE
35283 K(5,2) = 2114
35284 ENDIF
35285**
35286 ENDIF
35287
35288C...4-momentum initial lepton
35289 P(1,5) = 0.
35290 P(1,4) = ENU
35291 P(1,1) = 0.
35292 P(1,2) = 0.
35293 P(1,3) = ENU
35294C...4-momentum initial nucleon
35295 P(2,5) = AMN(LTARG)
35296C P(2,4) = P(2,5)
35297C P(2,1) = 0.
35298C P(2,2) = 0.
35299C P(2,3) = 0.
35300 P(2,1) = P21
35301 P(2,2) = P22
35302 P(2,3) = P23
35303 P(2,4) = P24
35304 P(2,5) = P25
35305 N=2
35306 beta1=-p(2,1)/p(2,4)
35307 beta2=-p(2,2)/p(2,4)
35308 beta3=-p(2,3)/p(2,4)
35309 N=2
35310
35311 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35312
35313C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35314
35315 phi11=atan(p(1,2)/p(1,3))
35316 pi(1)=p(1,1)
35317 pi(2)=p(1,2)
35318 pi(3)=p(1,3)
35319
35320 CALL DT_TESTROT(PI,Po,PHI11,1)
35321 DO ll=1,3
35322 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35323 END DO
35324 p(1,1)=po(1)
35325 p(1,2)=po(2)
35326 p(1,3)=po(3)
35327 phi12=atan(p(1,1)/p(1,3))
35328
35329 pi(1)=p(1,1)
35330 pi(2)=p(1,2)
35331 pi(3)=p(1,3)
35332 CALL DT_TESTROT(Pi,Po,PHI12,2)
35333 DO ll=1,3
35334 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35335 END DO
35336 p(1,1)=po(1)
35337 p(1,2)=po(2)
35338 p(1,3)=po(3)
35339
35340 ENUU=P(1,4)
35341
35342C...Generate the Mass of the Delta
35343 NTRY = 0
35344100 R = PYR(0)
35345 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35346 NTRY = NTRY + 1
35347 IF (NTRY .GT. 1000) THEN
35348 LBAD = 1
35349 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35350 RETURN
35351 ENDIF
35352 IF (AMD .LT. AMDMIN) GOTO 100
35353 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35354 IF (ENUU .LT. ET) GOTO 100
35355
35356C...Kinematical limits in Q**2
35357 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35358 SQS = SQRT(S)
35359 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35360 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35361 PLF = SQRT(ELF**2 - AML2)
35362 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35363 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35364 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35365
35366 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35367200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35368 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35369 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35370
35371C...Generate the kinematics of the final particles
35372 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35373 GAM = EISTAR/AMN(LTARG)
35374 BET = PSTAR/EISTAR
35375 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35376 EL = GAM*(ELF + BET*PLF*CTSTAR)
35377 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35378 PL = SQRT(EL**2 - AML2)
35379 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35380 PHI = 6.28319*PYR(0)
35381 P(4,1) = PLT*COS(PHI)
35382 P(4,2) = PLT*SIN(PHI)
35383 P(4,3) = PLZ
35384 P(4,4) = EL
35385 P(4,5) = AML
35386
35387C...4-momentum of Delta
35388 P(5,1) = -P(4,1)
35389 P(5,2) = -P(4,2)
35390 P(5,3) = ENUU-P(4,3)
35391 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35392 P(5,5) = AMD
35393
35394C...4-momentum of intermediate boson
35395 P(3,5) = -Q2
35396 P(3,4) = P(1,4)-P(4,4)
35397 P(3,1) = P(1,1)-P(4,1)
35398 P(3,2) = P(1,2)-P(4,2)
35399 P(3,3) = P(1,3)-P(4,3)
35400 N=5
35401
35402 DO kw=1,5
35403 pi(1)=p(kw,1)
35404 pi(2)=p(kw,2)
35405 pi(3)=p(kw,3)
35406 CALL DT_TESTROT(Pi,Po,PHI12,3)
35407 DO ll=1,3
35408 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35409 END DO
35410 p(kw,1)=po(1)
35411 p(kw,2)=po(2)
35412 p(kw,3)=po(3)
35413 END DO
35414
35415c********************************************
35416
35417 DO kw=1,5
35418 pi(1)=p(kw,1)
35419 pi(2)=p(kw,2)
35420 pi(3)=p(kw,3)
35421 CALL DT_TESTROT(Pi,Po,PHI11,4)
35422 DO ll=1,3
35423 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35424 END DO
35425 p(kw,1)=po(1)
35426 p(kw,2)=po(2)
35427 p(kw,3)=po(3)
35428 END DO
35429c********************************************
35430C transform back into Lab.
35431
35432 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35433
35434C WRITE(6,*)' Lab fram ( fermi incl.) '
35435 N=5
35436 CALL PYEXEC
35437
35438 RETURN
354391001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35440 END
35441
35442*$ CREATE DT_DSIGMA_DELTA.FOR
35443*COPY DT_DSIGMA_DELTA
35444*
35445*===dsigma_delta=======================================================*
35446*
35447 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35448
35449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35450 SAVE
35451
35452C...Reaction nu + N -> lepton + Delta
35453C. returns the cross section
35454C. dsigma/dt
35455C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35456C. QQ = t (always negative) GeV**2
35457C. S = (c.m energy)**2 GeV**2
35458C. OUTPUT = 10**-38 cm+2/GeV**2
35459C-----------------------------------------------------
35460 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35461 DATA MN /0.938/
35462 DATA PI /3.1415926/
35463
35464 GF = (1.1664 * 1.97)
35465 GF2 = GF*GF
35466 MN2 = MN*MN
35467 MN4 = MN2*MN2
35468 MD2 = MD*MD
35469 MD4 = MD2*MD2
35470 AML2 = AML*AML
35471 AML4 = AML2*AML2
35472 VQ = (MN2 - MD2 - QQ)/2.
35473 VPI = (MN2 + MD2 - QQ)/2.
35474 VK = (S + QQ - MN2 - AML2)/2.
35475 PIK = (S - MN2)/2.
35476 QK = (AML2 - QQ)/2.
35477 PIQ = (QQ + MN2 - MD2)/2.
35478 Q = SQRT(-QQ)
35479 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35480 C3 = SQRT(3.)*C3V/MN
35481 C4 = -C3/MD ! attenzione al segno
35482 C5A = 1.18/(1.-QQ/0.4225)**2
35483 C32 = C3**2
35484 C42 = C4**2
35485 C5A2 = C5A**2
35486
35487 IF (LNU .EQ. 1) THEN
35488 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35489 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35490 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35491 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35492 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35493 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35494 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35495 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35496 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35497 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35498 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35499 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35500 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35501 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35502 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35503 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35504 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35505 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35506 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35507 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35508 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35509 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35510 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35511 ELSE
35512 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35513 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35514 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35515 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35516 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35517 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35518 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35519 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35520 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35521 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35522 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35523 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35524 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35525 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35526 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35527 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35528 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35529 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35530 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35531 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35532 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35533 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35534 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35535 ENDIF
35536 ANS1=32.*ANS2
35537 ANS=ANS1/(3.*MD2)
35538 P1CM = (S-MN2)/(2.*SQRT(S))
35539 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35540
35541 RETURN
35542 END
35543
35544*$ CREATE DT_QGAUS.FOR
35545*COPY DT_QGAUS
35546*
35547*===qgaus==============================================================*
35548*
35549 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35550
35551 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35552 SAVE
35553
35554 DIMENSION X(5),W(5)
35555 DATA X/.1488743389D0,.4333953941D0,
35556 & .6794095682D0,.8650633666D0,.9739065285D0
35557 */
35558 DATA W/.2955242247D0,.2692667193D0,
35559 & .2190863625D0,.1494513491D0,.0666713443D0
35560 */
35561 XM=0.5D0*(B+A)
35562 XR=0.5D0*(B-A)
35563 SS=0
35564 DO 11 J=1,5
35565 DX=XR*X(J)
35566 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35567 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3556811 CONTINUE
35569 SS=XR*SS
35570
35571 RETURN
35572 END
35573*$ CREATE DT_DIQBRK.FOR
35574*COPY DT_DIQBRK
35575*
35576*===diqbrk=============================================================*
35577*
35578 SUBROUTINE DT_DIQBRK
35579
35580 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35581 SAVE
35582
35583* event history
35584
35585 PARAMETER (NMXHKK=200000)
35586
35587 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35588 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35589 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35590
35591* extended event history
35592 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35593 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35594 & IHIST(2,NMXHKK)
35595
35596* event flag
35597 COMMON /DTEVNO/ NEVENT,ICASCA
35598
35599C IF(DT_RNDM(VV).LE.0.5D0)THEN
35600C CALL GSQBS1(NHKK)
35601C CALL GSQBS2(NHKK)
35602C CALL USQBS1(NHKK)
35603C CALL USQBS2(NHKK)
35604C CALL GSABS1(NHKK)
35605C CALL GSABS2(NHKK)
35606C CALL USABS1(NHKK)
35607C CALL USABS2(NHKK)
35608C ELSE
35609C CALL GSQBS2(NHKK)
35610C CALL GSQBS1(NHKK)
35611C CALL USQBS2(NHKK)
35612C CALL USQBS1(NHKK)
35613C CALL GSABS2(NHKK)
35614C CALL GSABS1(NHKK)
35615C CALL USABS2(NHKK)
35616C CALL USABS1(NHKK)
35617C ENDIF
35618
35619 IF(DT_RNDM(VV).LE.0.5D0) THEN
35620 CALL DT_DBREAK(1)
35621 CALL DT_DBREAK(2)
35622 CALL DT_DBREAK(3)
35623 CALL DT_DBREAK(4)
35624 CALL DT_DBREAK(5)
35625 CALL DT_DBREAK(6)
35626 CALL DT_DBREAK(7)
35627 CALL DT_DBREAK(8)
35628 ELSE
35629 CALL DT_DBREAK(2)
35630 CALL DT_DBREAK(1)
35631 CALL DT_DBREAK(4)
35632 CALL DT_DBREAK(3)
35633 CALL DT_DBREAK(6)
35634 CALL DT_DBREAK(5)
35635 CALL DT_DBREAK(8)
35636 CALL DT_DBREAK(7)
35637 ENDIF
35638
35639 RETURN
35640 END
35641
35642*$ CREATE MUSQBS2.FOR
35643*COPY MUSQBS2
35644C
35645C
35646C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35647 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35648 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35649C
35650C USQBS-2 diagram (split target diquark)
35651C
35652 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35653 SAVE
35654
35655 PARAMETER ( LINP = 10 ,
35656 & LOUT = 6 ,
35657 & LDAT = 9 )
35658
35659* event history
35660
35661 PARAMETER (NMXHKK=200000)
35662
35663 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35664 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35665 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35666
35667* extended event history
35668 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35669 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35670 & IHIST(2,NMXHKK)
35671
35672* Lorentz-parameters of the current interaction
35673 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35674 & UMO,PPCM,EPROJ,PPROJ
35675
35676* diquark-breaking mechanism
35677 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35678
35679C
35680 PARAMETER (NTMHKK= 300)
35681 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35682 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35683 +(4,NTMHKK)
35684*KEEP,XSEADI.
35685 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35686 +SSMIMQ,VVMTHR
35687*KEEP,DPRIN.
35688 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35689 COMMON /EVFLAG/ NUMEV
35690C
35691C USQBS-2 diagram (split target diquark)
35692C
35693C
35694C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35695C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35696C
35697C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35698C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35699C
35700C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35701C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35702C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35703C
35704C
35705C Put new chains into COMMON /HKKTMP/
35706C
35707 IIGLU1=NC1T-NC1P-1
35708 IIGLU2=NC2T-NC2P-1
35709 IGCOUN=0
35710C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35711 CVQ=1.D0
35712 IREJ=0
35713 IF(IPIP.EQ.2)THEN
35714C IF(NUMEV.EQ.-324)THEN
35715C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35716C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35717C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35718C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35719 ENDIF
35720C
35721C
35722C
35723C determine x-values of NC1T diquark
35724 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35725 XVQP=PHKK(4,NC1P)*2.D0/UMO
35726C
35727C determine x-values of sea quark pair
35728C
35729 IPCO=1
35730 ICOU=0
35731 2234 CONTINUE
35732 ICOU=ICOU+1
35733 IF(ICOU.GE.500)THEN
35734 IREJ=1
35735 IF(ISQ.EQ.3)IREJ=3
35736 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35737 IPCO=0
35738 RETURN
35739 ENDIF
35740 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35741 * UMO, XDIQT,XVQP
35742 XSQ=0.D0
35743 XSAQ=0.D0
35744**NEW
35745C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35746 IF (IPIP.EQ.1) THEN
35747 XQMAX = XDIQT/2.0D0
35748 XAQMAX = 2.D0*XVQP/3.0D0
35749 ELSE
35750 XQMAX = 2.D0*XVQP/3.0D0
35751 XAQMAX = XDIQT/2.0D0
35752 ENDIF
35753 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35754 ISAQ = 6+ISQ
35755C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35756**
35757 IF(IPCO.GE.3)
35758 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35759 IF(IREJ.GE.1)THEN
35760 IF(IPCO.GE.3)
35761 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35762 IPCO=0
35763 RETURN
35764 ENDIF
35765 IF(IPIP.EQ.1)THEN
35766 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35767 ELSEIF(IPIP.EQ.2)THEN
35768 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35769 ENDIF
35770 IF(IPCO.GE.3)THEN
35771 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35772 & XDIQT,XVQP,XSQ,XSAQ
35773 ENDIF
35774C
35775C subtract xsq,xsaq from NC1T diquark and NC1P quark
35776C
35777C XSQ=0.D0
35778 IF(IPIP.EQ.1)THEN
35779 XDIQT=XDIQT-XSQ
35780 XVQP =XVQP -XSAQ
35781 ELSEIF(IPIP.EQ.2)THEN
35782 XDIQT=XDIQT-XSAQ
35783 XVQP =XVQP -XSQ
35784 ENDIF
35785 IF(IPCO.GE.3)
35786 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35787C
35788C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35789C
35790 XVTHRO=CVQ/UMO
35791 IVTHR=0
35792 3466 CONTINUE
35793 IF(IVTHR.EQ.10)THEN
35794 IREJ=1
35795 IF(ISQ.EQ.3)IREJ=3
35796 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35797 IPCO=0
35798 RETURN
35799 ENDIF
35800 IVTHR=IVTHR+1
35801 XVTHR=XVTHRO/(201-IVTHR)
35802 UNOPRV=UNON
35803 380 CONTINUE
35804 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35805 IREJ=1
35806 IF(ISQ.EQ.3)IREJ=3
35807 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35808 * XVTHR
35809 IPCO=0
35810 RETURN
35811 ENDIF
35812 IF(DT_RNDM(V).LT.0.5D0)THEN
35813 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35814 XVTQII=XDIQT-XVTQI
35815 ELSE
35816 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35817 XVTQI=XDIQT-XVTQII
35818 ENDIF
35819 IF(IPCO.GE.3)THEN
35820 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35821 ENDIF
35822C
35823C Prepare 4 momenta of new chains and chain ends
35824C
35825C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35826C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35827C +(4,NTMHKK)
35828C
35829C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35830C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35831C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35832C
35833C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35834C * IP1,IP21,IP22,IPP1,IPP2)
35835C
35836 IF(IPIP.EQ.1)THEN
35837 XSQ1=XSQ
35838 XSAQ1=XSAQ
35839 ISQ1=ISQ
35840 ISAQ1=ISAQ
35841 ELSEIF(IPIP.EQ.2)THEN
35842 XSQ1=XSAQ
35843 XSAQ1=XSQ
35844 ISQ1=ISAQ
35845 ISAQ1=ISQ
35846 ENDIF
35847 IDHKT(1) =IPP1
35848 ISTHKT(1) =951
35849 JMOHKT(1,1)=NC2P
35850 JMOHKT(2,1)=0
35851 JDAHKT(1,1)=3+IIGLU1
35852 JDAHKT(2,1)=0
35853C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35854 PHKT(1,1) =PHKK(1,NC2P)
35855 PHKT(2,1) =PHKK(2,NC2P)
35856 PHKT(3,1) =PHKK(3,NC2P)
35857 PHKT(4,1) =PHKK(4,NC2P)
35858C PHKT(5,1) =PHKK(5,NC2P)
35859 XMIST =(PHKT(4,1)**2-
35860 * PHKT(3,1)**2-PHKT(2,1)**2-
35861 *PHKT(1,1)**2)
35862 IF(XMIST.GT.0.D0)THEN
35863 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35864 *PHKT(1,1)**2)
35865 ELSE
35866C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35867 PHKT(5,1)=0.D0
35868 ENDIF
35869 VHKT(1,1) =VHKK(1,NC2P)
35870 VHKT(2,1) =VHKK(2,NC2P)
35871 VHKT(3,1) =VHKK(3,NC2P)
35872 VHKT(4,1) =VHKK(4,NC2P)
35873 WHKT(1,1) =WHKK(1,NC2P)
35874 WHKT(2,1) =WHKK(2,NC2P)
35875 WHKT(3,1) =WHKK(3,NC2P)
35876 WHKT(4,1) =WHKK(4,NC2P)
35877C Add here IIGLU1 gluons to this chaina
35878 PG1=0.D0
35879 PG2=0.D0
35880 PG3=0.D0
35881 PG4=0.D0
35882 IF(IIGLU1.GE.1)THEN
35883 JJG=NC1P
35884 DO 61 IIG=2,2+IIGLU1-1
35885 KKG=JJG+IIG-1
35886 IDHKT(IIG) =IDHKK(KKG)
35887 ISTHKT(IIG) =921
35888 JMOHKT(1,IIG)=KKG
35889 JMOHKT(2,IIG)=0
35890 JDAHKT(1,IIG)=3+IIGLU1
35891 JDAHKT(2,IIG)=0
35892 PHKT(1,IIG)=PHKK(1,KKG)
35893 PG1=PG1+ PHKT(1,IIG)
35894 PHKT(2,IIG)=PHKK(2,KKG)
35895 PG2=PG2+ PHKT(2,IIG)
35896 PHKT(3,IIG)=PHKK(3,KKG)
35897 PG3=PG3+ PHKT(3,IIG)
35898 PHKT(4,IIG)=PHKK(4,KKG)
35899 PG4=PG4+ PHKT(4,IIG)
35900 PHKT(5,IIG)=PHKK(5,KKG)
35901 VHKT(1,IIG) =VHKK(1,KKG)
35902 VHKT(2,IIG) =VHKK(2,KKG)
35903 VHKT(3,IIG) =VHKK(3,KKG)
35904 VHKT(4,IIG) =VHKK(4,KKG)
35905 WHKT(1,IIG) =WHKK(1,KKG)
35906 WHKT(2,IIG) =WHKK(2,KKG)
35907 WHKT(3,IIG) =WHKK(3,KKG)
35908 WHKT(4,IIG) =WHKK(4,KKG)
35909 61 CONTINUE
35910 ENDIF
35911 IDHKT(2+IIGLU1) =IP21
35912 ISTHKT(2+IIGLU1) =952
35913 JMOHKT(1,2+IIGLU1)=NC1T
35914 JMOHKT(2,2+IIGLU1)=0
35915 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35916 JDAHKT(2,2+IIGLU1)=0
35917 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35918 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35919 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35920 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35921C PHKT(5,2) =PHKK(5,NC1T)
35922 XMIST =(PHKT(4,2+IIGLU1)**2-
35923 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35924 *PHKT(1,2+IIGLU1)**2)
35925 IF(XMIST.GT.0.D0)THEN
35926 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35927 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35928 *PHKT(1,2+IIGLU1)**2)
35929 ELSE
35930C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35931 PHKT(5,5+IIGLU1)=0.D0
35932 ENDIF
35933 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35934 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35935 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35936 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35937 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35938 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35939 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35940 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35941 IDHKT(3+IIGLU1) =88888
35942 ISTHKT(3+IIGLU1) =95
35943 JMOHKT(1,3+IIGLU1)=1
35944 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35945 JDAHKT(1,3+IIGLU1)=0
35946 JDAHKT(2,3+IIGLU1)=0
35947 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35948 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35949 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35950 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35951 XMIST
35952 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35953 * -PHKT(3,3+IIGLU1)**2)
35954 IF(XMIST.GT.0.D0)THEN
35955 PHKT(5,3+IIGLU1)
35956 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35957 * -PHKT(3,3+IIGLU1)**2)
35958 ELSE
35959C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35960 PHKT(5,5+IIGLU1)=0.D0
35961 ENDIF
35962 IF(IPIP.GE.2)THEN
35963C IF(NUMEV.EQ.-324)THEN
35964C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35965C * JDAHKT(1,1),
35966C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35967 DO 71 IIG=2,2+IIGLU1-1
35968C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35969C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35970C * JDAHKT(1,IIG),
35971C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35972 71 CONTINUE
35973C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35974C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35975C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35976C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35977C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35978C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35979 ENDIF
35980 CHAMAL=CHAM1
35981 IF(IPIP.EQ.1)THEN
35982 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35983 ELSEIF(IPIP.EQ.2)THEN
35984 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35985 ENDIF
35986 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35987C IREJ=1
35988 IPCO=0
35989C RETURN
35990C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35991 GO TO 3466
35992 ENDIF
35993 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35994 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35995 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35996 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35997 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35998 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35999 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36000 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36001 IF(IPIP.EQ.1)THEN
36002 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36003 ELSEIF(IPIP.EQ.2)THEN
36004 IDHKT(4+IIGLU1) =ISAQ1
36005 ENDIF
36006 ISTHKT(4+IIGLU1) =951
36007 JMOHKT(1,4+IIGLU1)=NC1P
36008 JMOHKT(2,4+IIGLU1)=0
36009 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36010 JDAHKT(2,4+IIGLU1)=0
36011C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36012 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36013 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36014 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36015 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36016C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36017 XMIST =(PHKT(4,4+IIGLU1)**2-
36018 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36019 *PHKT(1,4+IIGLU1)**2)
36020 IF(XMIST.GT.0.D0)THEN
36021 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36022 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36023 *PHKT(1,4+IIGLU1)**2)
36024 ELSE
36025C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36026 PHKT(5,4+IIGLU1)=0.D0
36027 ENDIF
36028 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36029 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36030 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36031 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36032 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36033 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36034 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36035 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36036 IDHKT(5+IIGLU1) =IP22
36037 ISTHKT(5+IIGLU1) =952
36038 JMOHKT(1,5+IIGLU1)=NC1T
36039 JMOHKT(2,5+IIGLU1)=0
36040 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36041 JDAHKT(2,5+IIGLU1)=0
36042 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36043 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36044 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36045 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36046C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36047 XMIST =(PHKT(4,5+IIGLU1)**2-
36048 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36049 *PHKT(1,5+IIGLU1)**2)
36050 IF(XMIST.GT.0.D0)THEN
36051 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36052 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36053 *PHKT(1,5+IIGLU1)**2)
36054 ELSE
36055C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36056 PHKT(5,5+IIGLU1)=0.D0
36057 ENDIF
36058 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36059 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36060 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36061 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36062 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36063 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36064 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36065 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36066 IDHKT(6+IIGLU1) =88888
36067 ISTHKT(6+IIGLU1) =95
36068 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36069 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36070 JDAHKT(1,6+IIGLU1)=0
36071 JDAHKT(2,6+IIGLU1)=0
36072 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36073 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36074 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36075 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36076 XMIST
36077 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36078 * -PHKT(3,6+IIGLU1)**2)
36079 IF(XMIST.GT.0.D0)THEN
36080 PHKT(5,6+IIGLU1)
36081 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36082 * -PHKT(3,6+IIGLU1)**2)
36083 ELSE
36084C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36085 PHKT(5,5+IIGLU1)=0.D0
36086 ENDIF
36087C IF(IPIP.GE.2)THEN
36088C IF(NUMEV.EQ.-324)THEN
36089C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36090C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36091C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36092C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36093C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36094C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36095C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36096C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36097C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36098C ENDIF
36099 CHAMAL=CHAM1
36100 IF(IPIP.EQ.1)THEN
36101 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36102 ELSEIF(IPIP.EQ.2)THEN
36103 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36104 ENDIF
36105 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36106C IREJ=1
36107 IPCO=0
36108C RETURN
36109C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36110C * CHAMAL,PHKT(5,6+IIGLU1)
36111 GO TO 3466
36112 ENDIF
36113 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36114 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36115 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36116 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36117 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36118 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36119 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36120 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36121C IDHKT(7) =1000*IPP1+100*ISQ+1
36122 IDHKT(7+IIGLU1) =IP1
36123 ISTHKT(7+IIGLU1) =951
36124 JMOHKT(1,7+IIGLU1)=NC1P
36125 JMOHKT(2,7+IIGLU1)=0
36126**NEW
36127C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36128 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36129**
36130 JDAHKT(2,7+IIGLU1)=0
36131 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36132 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36133 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36134 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36135C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36136 XMIST =(PHKT(4,7+IIGLU1)**2-
36137 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36138 *PHKT(1,7+IIGLU1)**2)
36139 IF(XMIST.GT.0.D0)THEN
36140 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36141 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36142 *PHKT(1,7+IIGLU1)**2)
36143 ELSE
36144C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36145 PHKT(5,7+IIGLU1)=0.D0
36146 ENDIF
36147 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36148 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36149 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36150 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36151 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36152 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36153 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36154 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36155C Insert here the IIGLU2 gluons
36156 PG1=0.D0
36157 PG2=0.D0
36158 PG3=0.D0
36159 PG4=0.D0
36160 IF(IIGLU2.GE.1)THEN
36161 JJG=NC2P
36162 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36163 KKG=JJG+IIG-7-IIGLU1
36164 IDHKT(IIG) =IDHKK(KKG)
36165 ISTHKT(IIG) =921
36166 JMOHKT(1,IIG)=KKG
36167 JMOHKT(2,IIG)=0
36168 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36169 JDAHKT(2,IIG)=0
36170 PHKT(1,IIG)=PHKK(1,KKG)
36171 PG1=PG1+ PHKT(1,IIG)
36172 PHKT(2,IIG)=PHKK(2,KKG)
36173 PG2=PG2+ PHKT(2,IIG)
36174 PHKT(3,IIG)=PHKK(3,KKG)
36175 PG3=PG3+ PHKT(3,IIG)
36176 PHKT(4,IIG)=PHKK(4,KKG)
36177 PG4=PG4+ PHKT(4,IIG)
36178 PHKT(5,IIG)=PHKK(5,KKG)
36179 VHKT(1,IIG) =VHKK(1,KKG)
36180 VHKT(2,IIG) =VHKK(2,KKG)
36181 VHKT(3,IIG) =VHKK(3,KKG)
36182 VHKT(4,IIG) =VHKK(4,KKG)
36183 WHKT(1,IIG) =WHKK(1,KKG)
36184 WHKT(2,IIG) =WHKK(2,KKG)
36185 WHKT(3,IIG) =WHKK(3,KKG)
36186 WHKT(4,IIG) =WHKK(4,KKG)
36187 81 CONTINUE
36188 ENDIF
36189 IF(IPIP.EQ.1)THEN
36190 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+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 ELSEIF(IPIP.EQ.2)THEN
36195 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36196 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36197 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36198 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36199 ENDIF
36200 ISTHKT(8+IIGLU1+IIGLU2) =952
36201 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36202 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36203 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36204 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36205 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36206 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36207 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36208 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36209 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36210 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36211 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36212 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36213C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36214C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36215 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36216C IREJ=1
36217C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36218C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36219 IPCO=0
36220C RETURN
36221 GO TO 3466
36222 ENDIF
36223C PHKT(5,8) =PHKK(5,NC2T)
36224 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36225 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36226 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36227 IF(XMIST.GT.0.D0)THEN
36228 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36229 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36230 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36231 ELSE
36232C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36233 PHKT(5,5+IIGLU1)=0.D0
36234 ENDIF
36235 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36236 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36237 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36238 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36239 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36240 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36241 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36242 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36243 IDHKT(9+IIGLU1+IIGLU2) =88888
36244 ISTHKT(9+IIGLU1+IIGLU2) =95
36245 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36246 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36247 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36248 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36249**NEW
36250C PHKT(1,9+IIGLU1+IIGLU2)
36251C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36252C PHKT(2,9+IIGLU1+IIGLU2)
36253C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36254C PHKT(3,9+IIGLU1+IIGLU2)
36255C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36256C PHKT(4,9+IIGLU1+IIGLU2)
36257C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36258 PHKT(1,9+IIGLU1+IIGLU2)
36259 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36260 PHKT(2,9+IIGLU1+IIGLU2)
36261 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36262 PHKT(3,9+IIGLU1+IIGLU2)
36263 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36264 PHKT(4,9+IIGLU1+IIGLU2)
36265 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36266**
36267 XMIST
36268 * =(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 IF(XMIST.GT.0.D0)THEN
36272 PHKT(5,9+IIGLU1+IIGLU2)
36273 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36274 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36275 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36276 ELSE
36277C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36278 PHKT(5,5+IIGLU1)=0.D0
36279 ENDIF
36280 IF(IPIP.GE.2)THEN
36281C IF(NUMEV.EQ.-324)THEN
36282C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36283C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36284C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36285C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36286C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36287C * JDAHKT(1,IIG),
36288C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36289C 91 CONTINUE
36290C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36291C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36292C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36293C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36294C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36295C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36296C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36297C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36298 ENDIF
36299 CHAMAL=CHAB1
36300 IF(IPIP.EQ.1)THEN
36301 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36302 ELSEIF(IPIP.EQ.2)THEN
36303 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36304 ENDIF
36305 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36306C IREJ=1
36307 IPCO=0
36308C RETURN
36309C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36310C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36311 GO TO 3466
36312 ENDIF
36313 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36314 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36315 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36316 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36317 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36318 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36319 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36320 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36321C
36322 IPCO=0
36323 IGCOUN=9+IIGLU1+IIGLU2
36324 RETURN
36325 END
36326
36327*$ CREATE MGSQBS2.FOR
36328*COPY MGSQBS2
36329C
36330C
36331C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36332 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36333 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36334C
36335C GSQBS-2 diagram (split target diquark)
36336C
36337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36338 SAVE
36339
36340 PARAMETER ( LINP = 10 ,
36341 & LOUT = 6 ,
36342 & LDAT = 9 )
36343
36344* event history
36345
36346 PARAMETER (NMXHKK=200000)
36347
36348 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36349 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36350 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36351
36352* extended event history
36353 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36354 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36355 & IHIST(2,NMXHKK)
36356
36357* Lorentz-parameters of the current interaction
36358 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36359 & UMO,PPCM,EPROJ,PPROJ
36360
36361* diquark-breaking mechanism
36362 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36363
36364C
36365 PARAMETER (NTMHKK= 300)
36366 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36367 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36368 +(4,NTMHKK)
36369
36370*KEEP,XSEADI.
36371 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36372 +SSMIMQ,VVMTHR
36373*KEEP,DPRIN.
36374 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36375C
36376C GSQBS-2 diagram (split target diquark)
36377C
36378C
36379C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36380C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36381C
36382C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36383C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36384C
36385C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36386C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36387C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36388C
36389C
36390C
36391C Put new chains into COMMON /HKKTMP/
36392C
36393 IIGLU1=NC1T-NC1P-1
36394 IIGLU2=NC2T-NC2P-1
36395 IGCOUN=0
36396C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36397 CVQ=1.D0
36398 IREJ=0
36399C IF(IPIP.EQ.2)THEN
36400C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36401C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36402C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36403C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36404C ENDIF
36405C
36406C
36407C
36408C determine x-values of NC1T diquark
36409 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36410 XVQP=PHKK(4,NC1P)*2.D0/UMO
36411C
36412C determine x-values of sea quark pair
36413C
36414 IPCO=1
36415 ICOU=0
36416 2234 CONTINUE
36417 ICOU=ICOU+1
36418 IF(ICOU.GE.500)THEN
36419 IREJ=1
36420 IF(ISQ.EQ.3)IREJ=3
36421 IF(IPCO.GE.3)
36422 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36423 IPCO=0
36424 RETURN
36425 ENDIF
36426 IF(IPCO.GE.3)
36427 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36428 * UMO, XDIQT,XVQP
36429 XSQ=0.D0
36430 XSAQ=0.D0
36431**NEW
36432C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36433 IF (IPIP.EQ.1) THEN
36434 XQMAX = XDIQT/2.0D0
36435 XAQMAX = 2.D0*XVQP/3.0D0
36436 ELSE
36437 XQMAX = 2.D0*XVQP/3.0D0
36438 XAQMAX = XDIQT/2.0D0
36439 ENDIF
36440 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36441 ISAQ = 6+ISQ
36442C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36443**
36444 IF(IPCO.GE.3)
36445 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36446 IF(IREJ.GE.1)THEN
36447 IF(IPCO.GE.3)
36448 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36449 IPCO=0
36450 RETURN
36451 ENDIF
36452 IF(IPIP.EQ.1)THEN
36453 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36454 ELSEIF(IPIP.EQ.2)THEN
36455 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36456 ENDIF
36457 IF(IPCO.GE.3)THEN
36458 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36459 & XDIQT,XVQP,XSQ,XSAQ
36460 ENDIF
36461C
36462C subtract xsq,xsaq from NC1T diquark and NC1P quark
36463C
36464C XSQ=0.D0
36465 IF(IPIP.EQ.1)THEN
36466 XDIQT=XDIQT-XSQ
36467 XVQP =XVQP -XSAQ
36468 ELSEIF(IPIP.EQ.2)THEN
36469 XDIQT=XDIQT-XSAQ
36470 XVQP =XVQP -XSQ
36471 ENDIF
36472 IF(IPCO.GE.3)
36473 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36474C
36475C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36476C
36477 XVTHRO=CVQ/UMO
36478 IVTHR=0
36479 3466 CONTINUE
36480 IF(IVTHR.EQ.10)THEN
36481 IREJ=1
36482 IF(ISQ.EQ.3)IREJ=3
36483 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36484 IPCO=0
36485 RETURN
36486 ENDIF
36487 IVTHR=IVTHR+1
36488 XVTHR=XVTHRO/(201-IVTHR)
36489 UNOPRV=UNON
36490 380 CONTINUE
36491 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36492 IREJ=1
36493 IF(ISQ.EQ.3)IREJ=3
36494 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36495 * XVTHR
36496 IPCO=0
36497 RETURN
36498 ENDIF
36499 IF(DT_RNDM(V).LT.0.5D0)THEN
36500 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36501 XVTQII=XDIQT-XVTQI
36502 ELSE
36503 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36504 XVTQI=XDIQT-XVTQII
36505 ENDIF
36506 IF(IPCO.GE.3)THEN
36507 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36508 ENDIF
36509C
36510C Prepare 4 momenta of new chains and chain ends
36511C
36512C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36513C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36514C +(4,NTMHKK)
36515C
36516C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36517C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36518C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36519C
36520C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36521C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36522C
36523 IF(IPIP.EQ.1)THEN
36524 XSQ1=XSQ
36525 XSAQ1=XSAQ
36526 ISQ1=ISQ
36527 ISAQ1=ISAQ
36528 ELSEIF(IPIP.EQ.2)THEN
36529 XSQ1=XSAQ
36530 XSAQ1=XSQ
36531 ISQ1=ISAQ
36532 ISAQ1=ISQ
36533 ENDIF
36534 KK11=IP21
36535C IDHKT(1) =1000*IPP11+100*IPP12+1
36536 KK21=IPP11
36537 KK22=IPP12
36538 XGIVE=0.D0
36539 IF(IPIP.EQ.1)THEN
36540 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36541 ELSEIF(IPIP.EQ.2)THEN
36542 IDHKT(4+IIGLU1) =ISAQ1
36543 ENDIF
36544 ISTHKT(4+IIGLU1) =961
36545 JMOHKT(1,4+IIGLU1)=NC1P
36546 JMOHKT(2,4+IIGLU1)=0
36547 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36548 JDAHKT(2,4+IIGLU1)=0
36549C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36550 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36551 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36552 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36553 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36554C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36555 XXMIST=(PHKT(4,4+IIGLU1)**2-
36556 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36557 *PHKT(1,4+IIGLU1)**2)
36558 IF(XXMIST.GT.0.D0)THEN
36559 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36560 ELSE
36561 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36562 XXMIST=ABS(XXMIST)
36563 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36564 ENDIF
36565 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36566 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36567 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36568 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36569 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36570 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36571 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36572 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36573 IDHKT(5+IIGLU1) =IP22
36574 ISTHKT(5+IIGLU1) =962
36575 JMOHKT(1,5+IIGLU1)=NC1T
36576 JMOHKT(2,5+IIGLU1)=0
36577 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36578 JDAHKT(2,5+IIGLU1)=0
36579 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36580 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36581 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36582 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36583C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36584 XXMIST=(PHKT(4,5+IIGLU1)**2-
36585 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36586 *PHKT(1,5+IIGLU1)**2)
36587 IF(XXMIST.GT.0.D0)THEN
36588 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36589 ELSE
36590 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36591 XXMIST=ABS(XXMIST)
36592 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36593 ENDIF
36594 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36595 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36596 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36597 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36598 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36599 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36600 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36601 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36602 IDHKT(6+IIGLU1) =88888
36603 ISTHKT(6+IIGLU1) =96
36604 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36605 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36606 JDAHKT(1,6+IIGLU1)=0
36607 JDAHKT(2,6+IIGLU1)=0
36608 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36609 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36610 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36611 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36612 PHKT(5,6+IIGLU1)
36613 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36614 * -PHKT(3,6+IIGLU1)**2)
36615 CHAMAL=CHAM1
36616 IF(IPIP.EQ.1)THEN
36617 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36618 ELSEIF(IPIP.EQ.2)THEN
36619 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36620 ENDIF
36621C---------------------------------------------------
36622 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36623 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36624C we drop chain 6 and give the energy to chain 3
36625 IDHKT(6+IIGLU1)=22888
36626 XGIVE=1.D0
36627C WRITE(6,*)' drop chain 6 xgive=1'
36628 GO TO 7788
36629 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36630C we drop chain 6 and give the energy to chain 3
36631C and change KK11 to IDHKT(5)
36632 IDHKT(6+IIGLU1)=22888
36633 XGIVE=1.D0
36634C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36635 KK11=IDHKT(5+IIGLU1)
36636 GO TO 7788
36637 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36638C we drop chain 6 and give the energy to chain 3
36639C and change KK21 to IDHKT(5+IIGLU1)
36640C IDHKT(1) =1000*IPP11+100*IPP12+1
36641 IDHKT(6+IIGLU1)=22888
36642 XGIVE=1.D0
36643C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36644 KK21=IDHKT(5+IIGLU1)
36645 GO TO 7788
36646 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36647C we drop chain 6 and give the energy to chain 3
36648C and change KK22 to IDHKT(5)
36649C IDHKT(1) =1000*IPP11+100*IPP12+1
36650 IDHKT(6+IIGLU1)=22888
36651 XGIVE=1.D0
36652C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36653 KK22=IDHKT(5+IIGLU1)
36654 GO TO 7788
36655 ENDIF
36656C IREJ=1
36657 IPCO=0
36658C RETURN
36659 GO TO 3466
36660 ENDIF
36661 7788 CONTINUE
36662C---------------------------------------------------
36663 IF(IPIP.GE.3)THEN
36664 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36665 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36666 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36667 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36668 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36669 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36670 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36671 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36672 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36673 ENDIF
36674 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36675 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36676 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36677 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36678 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36679 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36680 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36681 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36682C IDHKT(1) =1000*IPP11+100*IPP12+1
36683 IF(IPIP.EQ.1)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 ELSEIF(IPIP.EQ.2)THEN
36689 IDHKT(1) =1000*KK21+100*KK22-3
36690 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36691 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36692 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36693 ENDIF
36694 ISTHKT(1) =961
36695 JMOHKT(1,1)=NC2P
36696 JMOHKT(2,1)=0
36697 JDAHKT(1,1)=3+IIGLU1
36698 JDAHKT(2,1)=0
36699C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36700 PHKT(1,1) =PHKK(1,NC2P)
36701 *+XGIVE*PHKT(1,4+IIGLU1)
36702 PHKT(2,1) =PHKK(2,NC2P)
36703 *+XGIVE*PHKT(2,4+IIGLU1)
36704 PHKT(3,1) =PHKK(3,NC2P)
36705 *+XGIVE*PHKT(3,4+IIGLU1)
36706 PHKT(4,1) =PHKK(4,NC2P)
36707 *+XGIVE*PHKT(4,4+IIGLU1)
36708C PHKT(5,1) =PHKK(5,NC2P)
36709 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36710 *PHKT(1,1)**2
36711 IF(XXMIST.GT.0.D0)THEN
36712 PHKT(5,1) =SQRT(XXMIST)
36713 ELSE
36714 WRITE(LOUT,*)'MGSQBS2',XXMIST
36715 XXMIST=ABS(XXMIST)
36716 PHKT(5,1) =SQRT(XXMIST)
36717 ENDIF
36718 VHKT(1,1) =VHKK(1,NC2P)
36719 VHKT(2,1) =VHKK(2,NC2P)
36720 VHKT(3,1) =VHKK(3,NC2P)
36721 VHKT(4,1) =VHKK(4,NC2P)
36722 WHKT(1,1) =WHKK(1,NC2P)
36723 WHKT(2,1) =WHKK(2,NC2P)
36724 WHKT(3,1) =WHKK(3,NC2P)
36725 WHKT(4,1) =WHKK(4,NC2P)
36726C Add here IIGLU1 gluons to this chaina
36727 PG1=0.D0
36728 PG2=0.D0
36729 PG3=0.D0
36730 PG4=0.D0
36731 IF(IIGLU1.GE.1)THEN
36732 JJG=NC1P
36733 DO 61 IIG=2,2+IIGLU1-1
36734 KKG=JJG+IIG-1
36735 IDHKT(IIG) =IDHKK(KKG)
36736 ISTHKT(IIG) =921
36737 JMOHKT(1,IIG)=KKG
36738 JMOHKT(2,IIG)=0
36739 JDAHKT(1,IIG)=3+IIGLU1
36740 JDAHKT(2,IIG)=0
36741 PHKT(1,IIG)=PHKK(1,KKG)
36742 PG1=PG1+ PHKT(1,IIG)
36743 PHKT(2,IIG)=PHKK(2,KKG)
36744 PG2=PG2+ PHKT(2,IIG)
36745 PHKT(3,IIG)=PHKK(3,KKG)
36746 PG3=PG3+ PHKT(3,IIG)
36747 PHKT(4,IIG)=PHKK(4,KKG)
36748 PG4=PG4+ PHKT(4,IIG)
36749 PHKT(5,IIG)=PHKK(5,KKG)
36750 VHKT(1,IIG) =VHKK(1,KKG)
36751 VHKT(2,IIG) =VHKK(2,KKG)
36752 VHKT(3,IIG) =VHKK(3,KKG)
36753 VHKT(4,IIG) =VHKK(4,KKG)
36754 WHKT(1,IIG) =WHKK(1,KKG)
36755 WHKT(2,IIG) =WHKK(2,KKG)
36756 WHKT(3,IIG) =WHKK(3,KKG)
36757 WHKT(4,IIG) =WHKK(4,KKG)
36758 61 CONTINUE
36759 ENDIF
36760C IDHKT(2) =IP21
36761 IDHKT(2+IIGLU1) =KK11
36762 ISTHKT(2+IIGLU1) =962
36763 JMOHKT(1,2+IIGLU1)=NC1T
36764 JMOHKT(2,2+IIGLU1)=0
36765 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36766 JDAHKT(2,2+IIGLU1)=0
36767 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36768C * +0.5D0*PHKK(1,NC2T)
36769 *+XGIVE*PHKT(1,5+IIGLU1)
36770 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36771C *+0.5D0*PHKK(2,NC2T)
36772 *+XGIVE*PHKT(2,5+IIGLU1)
36773 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36774C *+0.5D0*PHKK(3,NC2T)
36775 *+XGIVE*PHKT(3,5+IIGLU1)
36776 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36777C *+0.5D0*PHKK(4,NC2T)
36778 *+XGIVE*PHKT(4,5+IIGLU1)
36779C PHKT(5,2) =PHKK(5,NC1T)
36780 XXMIST=(PHKT(4,2+IIGLU1)**2-
36781 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36782 *PHKT(1,2+IIGLU1)**2)
36783 IF(XXMIST.GT.0.D0)THEN
36784 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36785 ELSE
36786 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36787 XXMIST=ABS(XXMIST)
36788 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36789 ENDIF
36790 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36791 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36792 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36793 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36794 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36795 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36796 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36797 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36798 IDHKT(3+IIGLU1) =88888
36799 ISTHKT(3+IIGLU1) =96
36800 JMOHKT(1,3+IIGLU1)=1
36801 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36802 JDAHKT(1,3+IIGLU1)=0
36803 JDAHKT(2,3+IIGLU1)=0
36804 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36805 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36806 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36807 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36808 PHKT(5,3+IIGLU1)
36809 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36810 * -PHKT(3,3+IIGLU1)**2)
36811 IF(IPIP.EQ.3)THEN
36812 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36813 * JDAHKT(1,1),
36814 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36815 DO 71 IIG=2,2+IIGLU1-1
36816 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36817 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36818 * JDAHKT(1,IIG),
36819 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36820 71 CONTINUE
36821 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36822 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36823 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36824 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36825 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36826 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36827 ENDIF
36828 CHAMAL=CHAB1
36829 IF(IPIP.EQ.1)THEN
36830 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36831 ELSEIF(IPIP.EQ.2)THEN
36832 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36833 ENDIF
36834 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36835C IREJ=1
36836 IPCO=0
36837C RETURN
36838 GO TO 3466
36839 ENDIF
36840 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36841 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36842 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36843 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36844 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36845 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36846 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36847 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36848C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36849 IDHKT(7+IIGLU1) =IP1
36850 ISTHKT(7+IIGLU1) =961
36851 JMOHKT(1,7+IIGLU1)=NC1P
36852 JMOHKT(2,7+IIGLU1)=0
36853 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36854 JDAHKT(2,7+IIGLU1)=0
36855 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36856 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36857 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36858 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36859C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36860 XXMIST=(PHKT(4,7+IIGLU1)**2-
36861 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36862 *PHKT(1,7+IIGLU1)**2)
36863 IF(XXMIST.GT.0.D0)THEN
36864 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36865 ELSE
36866 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36867 XXMIST=ABS(XXMIST)
36868 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36869 ENDIF
36870 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36871 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36872 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36873 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36874 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36875 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36876 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36877 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36878C IDHKT(7) =1000*IPP1+100*ISQ+1
36879C Insert here the IIGLU2 gluons
36880 PG1=0.D0
36881 PG2=0.D0
36882 PG3=0.D0
36883 PG4=0.D0
36884 IF(IIGLU2.GE.1)THEN
36885 JJG=NC2P
36886 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36887 KKG=JJG+IIG-7-IIGLU1
36888 IDHKT(IIG) =IDHKK(KKG)
36889 ISTHKT(IIG) =921
36890 JMOHKT(1,IIG)=KKG
36891 JMOHKT(2,IIG)=0
36892 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36893 JDAHKT(2,IIG)=0
36894 PHKT(1,IIG)=PHKK(1,KKG)
36895 PG1=PG1+ PHKT(1,IIG)
36896 PHKT(2,IIG)=PHKK(2,KKG)
36897 PG2=PG2+ PHKT(2,IIG)
36898 PHKT(3,IIG)=PHKK(3,KKG)
36899 PG3=PG3+ PHKT(3,IIG)
36900 PHKT(4,IIG)=PHKK(4,KKG)
36901 PG4=PG4+ PHKT(4,IIG)
36902 PHKT(5,IIG)=PHKK(5,KKG)
36903 VHKT(1,IIG) =VHKK(1,KKG)
36904 VHKT(2,IIG) =VHKK(2,KKG)
36905 VHKT(3,IIG) =VHKK(3,KKG)
36906 VHKT(4,IIG) =VHKK(4,KKG)
36907 WHKT(1,IIG) =WHKK(1,KKG)
36908 WHKT(2,IIG) =WHKK(2,KKG)
36909 WHKT(3,IIG) =WHKK(3,KKG)
36910 WHKT(4,IIG) =WHKK(4,KKG)
36911 81 CONTINUE
36912 ENDIF
36913 IF(IPIP.EQ.1)THEN
36914 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36915 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36916 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36917 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36918 ELSEIF(IPIP.EQ.2)THEN
36919**NEW
36920C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36921 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36922**
36923 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36924 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36925 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36926 ENDIF
36927 ISTHKT(8+IIGLU1+IIGLU2) =962
36928 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36929 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36930 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36931 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36932C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36933C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36934C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36935C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36936 PHKT(1,8+IIGLU1+IIGLU2) =
36937 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36938 PHKT(2,8+IIGLU1+IIGLU2) =
36939 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36940 PHKT(3,8+IIGLU1+IIGLU2) =
36941 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36942 PHKT(4,8+IIGLU1+IIGLU2) =
36943 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36944C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36945C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36946 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36947C IREJ=1
36948C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36949 IPCO=0
36950C RETURN
36951 GO TO 3466
36952 ENDIF
36953C PHKT(5,8) =PHKK(5,NC2T)
36954 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36955 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36956 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36957 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36958 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36959 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36960 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36961 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36962 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36963 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36964 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36965 IDHKT(9+IIGLU1+IIGLU2) =88888
36966 ISTHKT(9+IIGLU1+IIGLU2) =96
36967 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36968 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36969 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36970 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36971 PHKT(1,9+IIGLU1+IIGLU2)
36972 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36973 PHKT(2,9+IIGLU1+IIGLU2)
36974 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36975 PHKT(3,9+IIGLU1+IIGLU2)
36976 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36977 PHKT(4,9+IIGLU1+IIGLU2)
36978 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36979 PHKT(5,9+IIGLU1+IIGLU2)
36980 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36981 * PHKT(2,9+IIGLU1+IIGLU2)**2
36982 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36983 IF(IPIP.GE.3)THEN
36984 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36985 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36986 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36987 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36988 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36989 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36990 * JDAHKT(1,IIG),
36991 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36992 91 CONTINUE
36993 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36994 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36995 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36996 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36997 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36998 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36999 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37000 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37001 ENDIF
37002 CHAMAL=CHAB1
37003 IF(IPIP.EQ.1)THEN
37004 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37005 ELSEIF(IPIP.EQ.2)THEN
37006 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37007 ENDIF
37008 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37009C IREJ=1
37010 IPCO=0
37011C RETURN
37012 GO TO 3466
37013 ENDIF
37014 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37015 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37016 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37017 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37018 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37019 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37020 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37021 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37022C
37023 IPCO=0
37024 IGCOUN=9+IIGLU1+IIGLU2
37025 RETURN
37026 END
37027
37028*$ CREATE MUSQBS1.FOR
37029*COPY MUSQBS1
37030C
37031C
37032C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37033 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37034 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37035C
37036C USQBS-1 diagram (split projectile diquark)
37037C
37038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37039 SAVE
37040
37041 PARAMETER ( LINP = 10 ,
37042 & LOUT = 6 ,
37043 & LDAT = 9 )
37044
37045* event history
37046
37047 PARAMETER (NMXHKK=200000)
37048
37049 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37050 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37051 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37052
37053* extended event history
37054 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37055 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37056 & IHIST(2,NMXHKK)
37057
37058* Lorentz-parameters of the current interaction
37059 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37060 & UMO,PPCM,EPROJ,PPROJ
37061
37062* diquark-breaking mechanism
37063 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37064
37065C
37066 PARAMETER (NTMHKK= 300)
37067 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37068 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37069 +(4,NTMHKK)
37070*KEEP,XSEADI.
37071 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37072 +SSMIMQ,VVMTHR
37073*KEEP,DPRIN.
37074 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37075 COMMON /EVFLAG/ NUMEV
37076C
37077C USQBS-1 diagram (split projectile diquark)
37078C
37079C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37080C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37081C
37082C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37083C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37084C
37085C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37086C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37087C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37088C
37089C Put new chains into COMMON /HKKTMP/
37090C
37091 IIGLU1=NC1T-NC1P-1
37092 IIGLU2=NC2T-NC2P-1
37093 IGCOUN=0
37094C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37095 CVQ=1.D0
37096 IREJ=0
37097 IF(IPIP.EQ.3)THEN
37098C IF(NUMEV.EQ.-324)THEN
37099 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37100 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37101 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37102 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37103 ENDIF
37104C
37105C
37106C
37107C determine x-values of NC1P diquark
37108 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37109 XVQT=PHKK(4,NC1T)*2.D0/UMO
37110C
37111C determine x-values of sea quark pair
37112C
37113 IPCO=1
37114 ICOU=0
37115 2234 CONTINUE
37116 ICOU=ICOU+1
37117 IF(ICOU.GE.500)THEN
37118 IREJ=1
37119 IF(ISQ.EQ.3)IREJ=3
37120 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37121 IPCO=0
37122 RETURN
37123 ENDIF
37124 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37125 * UMO, XDIQP,XVQT
37126 XSQ=0.D0
37127 XSAQ=0.D0
37128**NEW
37129C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37130 IF (IPIP.EQ.1) THEN
37131 XQMAX = XDIQP/2.0D0
37132 XAQMAX = 2.D0*XVQT/3.0D0
37133 ELSE
37134 XQMAX = 2.D0*XVQT/3.0D0
37135 XAQMAX = XDIQP/2.0D0
37136 ENDIF
37137 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37138 ISAQ = 6+ISQ
37139C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37140**
37141 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37142 IF(IREJ.GE.1)THEN
37143 IF(IPCO.GE.3)
37144 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37145 IPCO=0
37146 RETURN
37147 ENDIF
37148 IF(IPIP.EQ.1)THEN
37149 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37150 ELSEIF(IPIP.EQ.2)THEN
37151 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37152 ENDIF
37153 IF(IPCO.GE.3)THEN
37154 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37155 & XDIQP,XVQT,XSQ,XSAQ
37156 ENDIF
37157C
37158C subtract xsq,xsaq from NC1P diquark and NC1T quark
37159C
37160C XSQ=0.D0
37161 IF(IPIP.EQ.1)THEN
37162 XDIQP=XDIQP-XSQ
37163 XVQT =XVQT -XSAQ
37164 ELSEIF(IPIP.EQ.2)THEN
37165 XDIQP=XDIQP-XSAQ
37166 XVQT =XVQT -XSQ
37167 ENDIF
37168 IF(IPCO.GE.3)
37169 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37170C
37171C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37172C
37173 XVTHRO=CVQ/UMO
37174 IVTHR=0
37175 3466 CONTINUE
37176 IF(IVTHR.EQ.10)THEN
37177 IREJ=1
37178 IF(ISQ.EQ.3)IREJ=3
37179 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37180 IPCO=0
37181 RETURN
37182 ENDIF
37183 IVTHR=IVTHR+1
37184 XVTHR=XVTHRO/(201-IVTHR)
37185 UNOPRV=UNON
37186 380 CONTINUE
37187 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37188 IREJ=1
37189 IF(ISQ.EQ.3)IREJ=3
37190 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37191 * XVTHR
37192 IPCO=0
37193 RETURN
37194 ENDIF
37195 IF(DT_RNDM(V).LT.0.5D0)THEN
37196 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37197 XVPQII=XDIQP-XVPQI
37198 ELSE
37199 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37200 XVPQI=XDIQP-XVPQII
37201 ENDIF
37202 IF(IPCO.GE.3)THEN
37203 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37204 ENDIF
37205C
37206C Prepare 4 momenta of new chains and chain ends
37207C
37208C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37209C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37210C +(4,NTMHKK)
37211C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37212C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37213C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37214 IF(IPIP.EQ.1)THEN
37215 XSQ1=XSQ
37216 XSAQ1=XSAQ
37217 ISQ1=ISQ
37218 ISAQ1=ISAQ
37219 ELSEIF(IPIP.EQ.2)THEN
37220 XSQ1=XSAQ
37221 XSAQ1=XSQ
37222 ISQ1=ISAQ
37223 ISAQ1=ISQ
37224 ENDIF
37225 IDHKT(1) =IP11
37226 ISTHKT(1) =931
37227 JMOHKT(1,1)=NC1P
37228 JMOHKT(2,1)=0
37229 JDAHKT(1,1)=3+IIGLU1
37230 JDAHKT(2,1)=0
37231C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37232 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37233 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37234 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37235 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37236C PHKT(5,1) =PHKK(5,NC1P)
37237 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37238 *PHKT(1,1)**2)
37239 IF(XMIST.GE.0.D0)THEN
37240 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37241 *PHKT(1,1)**2)
37242 ELSE
37243C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37244 PHKT(5,1)=0.D0
37245 ENDIF
37246 VHKT(1,1) =VHKK(1,NC1P)
37247 VHKT(2,1) =VHKK(2,NC1P)
37248 VHKT(3,1) =VHKK(3,NC1P)
37249 VHKT(4,1) =VHKK(4,NC1P)
37250 WHKT(1,1) =WHKK(1,NC1P)
37251 WHKT(2,1) =WHKK(2,NC1P)
37252 WHKT(3,1) =WHKK(3,NC1P)
37253 WHKT(4,1) =WHKK(4,NC1P)
37254C Add here IIGLU1 gluons to this chaina
37255 PG1=0.D0
37256 PG2=0.D0
37257 PG3=0.D0
37258 PG4=0.D0
37259 IF(IIGLU1.GE.1)THEN
37260 JJG=NC1P
37261 DO 61 IIG=2,2+IIGLU1-1
37262 KKG=JJG+IIG-1
37263 IDHKT(IIG) =IDHKK(KKG)
37264 ISTHKT(IIG) =921
37265 JMOHKT(1,IIG)=KKG
37266 JMOHKT(2,IIG)=0
37267 JDAHKT(1,IIG)=3+IIGLU1
37268 JDAHKT(2,IIG)=0
37269 PHKT(1,IIG)=PHKK(1,KKG)
37270 PG1=PG1+ PHKT(1,IIG)
37271 PHKT(2,IIG)=PHKK(2,KKG)
37272 PG2=PG2+ PHKT(2,IIG)
37273 PHKT(3,IIG)=PHKK(3,KKG)
37274 PG3=PG3+ PHKT(3,IIG)
37275 PHKT(4,IIG)=PHKK(4,KKG)
37276 PG4=PG4+ PHKT(4,IIG)
37277 PHKT(5,IIG)=PHKK(5,KKG)
37278 VHKT(1,IIG) =VHKK(1,KKG)
37279 VHKT(2,IIG) =VHKK(2,KKG)
37280 VHKT(3,IIG) =VHKK(3,KKG)
37281 VHKT(4,IIG) =VHKK(4,KKG)
37282 WHKT(1,IIG) =WHKK(1,KKG)
37283 WHKT(2,IIG) =WHKK(2,KKG)
37284 WHKT(3,IIG) =WHKK(3,KKG)
37285 WHKT(4,IIG) =WHKK(4,KKG)
37286 61 CONTINUE
37287 ENDIF
37288 IDHKT(2+IIGLU1) =IPP2
37289 ISTHKT(2+IIGLU1) =932
37290 JMOHKT(1,2+IIGLU1)=NC2T
37291 JMOHKT(2,2+IIGLU1)=0
37292 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37293 JDAHKT(2,2+IIGLU1)=0
37294 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37295 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37296 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37297 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37298C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37299 XMIST=(PHKT(4,2+IIGLU1)**2-
37300 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37301 *PHKT(1,2+IIGLU1)**2)
37302 IF(XMIST.GT.0.D0)THEN
37303 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37304 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37305 *PHKT(1,2+IIGLU1)**2)
37306 ELSE
37307C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37308 PHKT(5,2+IIGLU1)=0.D0
37309 ENDIF
37310 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37311 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37312 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37313 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37314 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37315 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37316 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37317 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37318 IDHKT(3+IIGLU1) =88888
37319 ISTHKT(3+IIGLU1) =94
37320 JMOHKT(1,3+IIGLU1)=1
37321 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37322 JDAHKT(1,3+IIGLU1)=0
37323 JDAHKT(2,3+IIGLU1)=0
37324 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37325 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37326 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37327 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37328 XMIST
37329 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37330 * -PHKT(3,3+IIGLU1)**2)
37331 IF(XMIST.GE.0.D0)THEN
37332 PHKT(5,3+IIGLU1)
37333 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37334 * -PHKT(3,3+IIGLU1)**2)
37335 ELSE
37336C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37337 PHKT(5,1)=0.D0
37338 ENDIF
37339 IF(IPIP.GE.3)THEN
37340C IF(NUMEV.EQ.-324)THEN
37341 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37342 * JMOHKT(2,1),JDAHKT(1,1),
37343 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37344 DO 71 IIG=2,2+IIGLU1-1
37345 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37346 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37347 * JDAHKT(1,IIG),
37348 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37349 71 CONTINUE
37350 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37351 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37352 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37353 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37354 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37355 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37356 ENDIF
37357 CHAMAL=CHAM1
37358 IF(IPIP.EQ.1)THEN
37359 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37360 ELSEIF(IPIP.EQ.2)THEN
37361 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37362 ENDIF
37363 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37364C IREJ=1
37365 IPCO=0
37366C RETURN
37367C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37368 GO TO 3466
37369 ENDIF
37370 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37371 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37372 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37373 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37374 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37375 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37376 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37377 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37378 IDHKT(4+IIGLU1) =IP12
37379 ISTHKT(4+IIGLU1) =931
37380 JMOHKT(1,4+IIGLU1)=NC1P
37381 JMOHKT(2,4+IIGLU1)=0
37382 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37383 JDAHKT(2,4+IIGLU1)=0
37384C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37385 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37386 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37387 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37388 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37389C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37390 XMIST =(PHKT(4,4+IIGLU1)**2-
37391 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37392 *PHKT(1,4+IIGLU1)**2)
37393 IF(XMIST.GT.0.D0)THEN
37394 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37395 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37396 *PHKT(1,4+IIGLU1)**2)
37397 ELSE
37398C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37399 PHKT(5,4+IIGLU1)=0.D0
37400 ENDIF
37401 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37402 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37403 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37404 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37405 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37406 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37407 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37408 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37409 IF(IPIP.EQ.1)THEN
37410 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37411 ELSEIF(IPIP.EQ.2)THEN
37412 IDHKT(5+IIGLU1) =ISAQ1
37413 ENDIF
37414 ISTHKT(5+IIGLU1) =932
37415 JMOHKT(1,5+IIGLU1)=NC1T
37416 JMOHKT(2,5+IIGLU1)=0
37417 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37418 JDAHKT(2,5+IIGLU1)=0
37419 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37420 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37421 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37422 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37423C IF( PHKT(4,5).EQ.0.D0)THEN
37424C IREJ=1
37425CIPCO=0
37426CRETURN
37427C ENDIF
37428C PHKT(5,5) =PHKK(5,NC1T)
37429 XMIST=(PHKT(4,5+IIGLU1)**2-
37430 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37431 *PHKT(1,5+IIGLU1)**2)
37432 IF(XMIST.GT.0.D0)THEN
37433 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37434 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37435 *PHKT(1,5+IIGLU1)**2)
37436 ELSE
37437C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37438 PHKT(5,5+IIGLU1)=0.D0
37439 ENDIF
37440 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37441 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37442 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37443 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37444 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37445 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37446 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37447 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37448 IDHKT(6+IIGLU1) =88888
37449 ISTHKT(6+IIGLU1) =94
37450 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37451 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37452 JDAHKT(1,6+IIGLU1)=0
37453 JDAHKT(2,6+IIGLU1)=0
37454 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37455 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37456 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37457 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37458 XMIST
37459 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37460 * -PHKT(3,6+IIGLU1)**2)
37461 IF(XMIST.GE.0.D0)THEN
37462 PHKT(5,6+IIGLU1)
37463 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37464 * -PHKT(3,6+IIGLU1)**2)
37465 ELSE
37466C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37467 PHKT(5,1)=0.D0
37468 ENDIF
37469C IF(IPIP.EQ.3)THEN
37470 CHAMAL=CHAM1
37471 IF(IPIP.EQ.1)THEN
37472 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37473 ELSEIF(IPIP.EQ.2)THEN
37474 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37475 ENDIF
37476 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37477C IREJ=1
37478 IPCO=0
37479C RETURN
37480C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37481C & CHAMAL,PHKT(5,6+IIGLU1)
37482 GO TO 3466
37483 ENDIF
37484 IF(IPIP.GE.3)THEN
37485C IF(NUMEV.EQ.-324)THEN
37486 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37487 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37488 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37489 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37490 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37491 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37492 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37493 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37494 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37495 ENDIF
37496 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37497 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37498 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37499 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37500 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37501 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37502 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37503 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37504 IF(IPIP.EQ.1)THEN
37505 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+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
37509 ELSEIF(IPIP.EQ.2)THEN
37510 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37511 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37512 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37513 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37514C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37515 ENDIF
37516 ISTHKT(7+IIGLU1) =931
37517 JMOHKT(1,7+IIGLU1)=NC2P
37518 JMOHKT(2,7+IIGLU1)=0
37519 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37520 JDAHKT(2,7+IIGLU1)=0
37521C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37522 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37523 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37524 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37525 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37526C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37527C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37528 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37529C IREJ=1
37530C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37531 IPCO=0
37532C RETURN
37533 GO TO 3466
37534 ENDIF
37535C PHKT(5,7) =PHKK(5,NC2P)
37536 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37537 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37538 *PHKT(1,7+IIGLU1)**2)
37539 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37540 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37541 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37542 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37543 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37544 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37545 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37546 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37547C Insert here the IIGLU2 gluons
37548 PG1=0.D0
37549 PG2=0.D0
37550 PG3=0.D0
37551 PG4=0.D0
37552 IF(IIGLU2.GE.1)THEN
37553 JJG=NC2P
37554 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37555 KKG=JJG+IIG-7-IIGLU1
37556 IDHKT(IIG) =IDHKK(KKG)
37557 ISTHKT(IIG) =921
37558 JMOHKT(1,IIG)=KKG
37559 JMOHKT(2,IIG)=0
37560 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37561 JDAHKT(2,IIG)=0
37562 PHKT(1,IIG)=PHKK(1,KKG)
37563 PG1=PG1+ PHKT(1,IIG)
37564 PHKT(2,IIG)=PHKK(2,KKG)
37565 PG2=PG2+ PHKT(2,IIG)
37566 PHKT(3,IIG)=PHKK(3,KKG)
37567 PG3=PG3+ PHKT(3,IIG)
37568 PHKT(4,IIG)=PHKK(4,KKG)
37569 PG4=PG4+ PHKT(4,IIG)
37570 PHKT(5,IIG)=PHKK(5,KKG)
37571 VHKT(1,IIG) =VHKK(1,KKG)
37572 VHKT(2,IIG) =VHKK(2,KKG)
37573 VHKT(3,IIG) =VHKK(3,KKG)
37574 VHKT(4,IIG) =VHKK(4,KKG)
37575 WHKT(1,IIG) =WHKK(1,KKG)
37576 WHKT(2,IIG) =WHKK(2,KKG)
37577 WHKT(3,IIG) =WHKK(3,KKG)
37578 WHKT(4,IIG) =WHKK(4,KKG)
37579 81 CONTINUE
37580 ENDIF
37581 IDHKT(8+IIGLU1+IIGLU2) =IP2
37582 ISTHKT(8+IIGLU1+IIGLU2) =932
37583 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37584 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37585 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37586 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37587 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37588 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37589 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37590 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37591C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37592 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37593 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37594 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37595 IF(XMIST.GT.0.D0)THEN
37596 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37597 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37598 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37599 ELSE
37600C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37601 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37602 ENDIF
37603 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37604 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37605 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37606 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37607 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37608 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37609 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37610 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37611 IDHKT(9+IIGLU1+IIGLU2) =88888
37612 ISTHKT(9+IIGLU1+IIGLU2) =94
37613 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37614 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37615 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37616 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37617 PHKT(1,9+IIGLU1+IIGLU2)
37618 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37619 PHKT(2,9+IIGLU1+IIGLU2)
37620 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37621 PHKT(3,9+IIGLU1+IIGLU2)
37622 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37623 PHKT(4,9+IIGLU1+IIGLU2)
37624 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37625 XMIST
37626 *=(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 IF(XMIST.GE.0.D0)THEN
37630 PHKT(5,9+IIGLU1+IIGLU2)
37631 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37632 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37633 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37634 ELSE
37635C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37636 PHKT(5,1)=0.D0
37637 ENDIF
37638 IF(IPIP.GE.3)THEN
37639C IF(NUMEV.EQ.-324)THEN
37640 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37641 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37642 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37643 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37644 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37645 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37646 * JDAHKT(1,IIG),
37647 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37648 91 CONTINUE
37649 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37650 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37651 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37652 *JDAHKT(1,8+IIGLU1+IIGLU2),
37653 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37654 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37655 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37656 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37657 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37658 ENDIF
37659 CHAMAL=CHAB1
37660 IF(IPIP.EQ.1)THEN
37661 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37662 ELSEIF(IPIP.EQ.2)THEN
37663 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37664 ENDIF
37665 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37666C IREJ=1
37667 IPCO=0
37668C RETURN
37669C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37670C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37671 GO TO 3466
37672 ENDIF
37673 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37674 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37675 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37676 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37677 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37678 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37679 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37680 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37681C
37682 IPCO=0
37683 IGCOUN=9+IIGLU1+IIGLU2
37684 RETURN
37685 END
37686
37687*$ CREATE MGSQBS1.FOR
37688*COPY MGSQBS1
37689C
37690C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37691 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37692 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37693C
37694C GSQBS-1 diagram (split projectile diquark)
37695C
37696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37697 SAVE
37698
37699 PARAMETER ( LINP = 10 ,
37700 & LOUT = 6 ,
37701 & LDAT = 9 )
37702
37703* event history
37704
37705 PARAMETER (NMXHKK=200000)
37706
37707 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37708 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37709 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37710
37711* extended event history
37712 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37713 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37714 & IHIST(2,NMXHKK)
37715
37716* Lorentz-parameters of the current interaction
37717 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37718 & UMO,PPCM,EPROJ,PPROJ
37719
37720* diquark-breaking mechanism
37721 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37722
37723C
37724 PARAMETER (NTMHKK= 300)
37725 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37726 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37727 +(4,NTMHKK)
37728*KEEP,XSEADI.
37729 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37730 +SSMIMQ,VVMTHR
37731*KEEP,DPRIN.
37732 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37733C
37734C GSQBS-1 diagram (split projectile diquark)
37735C
37736C
37737C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37738C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37739C
37740C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37741C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37742C
37743C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37744C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37745C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37746C
37747C Put new chains into COMMON /HKKTMP/
37748C
37749 IIGLU1=NC1T-NC1P-1
37750 IIGLU2=NC2T-NC2P-1
37751 IGCOUN=0
37752C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37753 CVQ=1.D0
37754 NNNC1=IDHKK(NC1)/1000
37755 MMMC1=IDHKK(NC1)-NNNC1*1000
37756 KKKC1=ISTHKK(NC1)
37757 NNNC2=IDHKK(NC2)/1000
37758 MMMC2=IDHKK(NC2)-NNNC2*1000
37759 KKKC2=ISTHKK(NC2)
37760 IREJ=0
37761 IF(IPIP.EQ.3)THEN
37762 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37763 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37764 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37765 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37766 ENDIF
37767C
37768C
37769C
37770C determine x-values of NC1P diquark
37771 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37772 XVQT=PHKK(4,NC1T)*2.D0/UMO
37773C
37774C determine x-values of sea quark pair
37775C
37776 IPCO=1
37777 ICOU=0
37778 2234 CONTINUE
37779 ICOU=ICOU+1
37780 IF(ICOU.GE.500)THEN
37781 IREJ=1
37782 IF(ISQ.EQ.3)IREJ=3
37783 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37784 IPCO=0
37785 RETURN
37786 ENDIF
37787 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37788 * UMO, XDIQP,XVQT
37789 XSQ=0.D0
37790 XSAQ=0.D0
37791**NEW
37792C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37793 IF (IPIP.EQ.1) THEN
37794 XQMAX = XDIQP/2.0D0
37795 XAQMAX = 2.D0*XVQT/3.0D0
37796 ELSE
37797 XQMAX = 2.D0*XVQT/3.0D0
37798 XAQMAX = XDIQP/2.0D0
37799 ENDIF
37800 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37801 ISAQ = 6+ISQ
37802C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37803**
37804 IF(IPCO.GE.3)
37805 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37806 IF(IREJ.GE.1)THEN
37807 IF(IPCO.GE.3)
37808 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37809 IPCO=0
37810 RETURN
37811 ENDIF
37812 IF(IPIP.EQ.1)THEN
37813 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37814 ELSEIF(IPIP.EQ.2)THEN
37815 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37816 ENDIF
37817 IF(IPCO.GE.3)THEN
37818 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37819 & XDIQP,XVQT,XSQ,XSAQ
37820 ENDIF
37821C
37822C subtract xsq,xsaq from NC1P diquark and NC1T quark
37823C
37824C XSQ=0.D0
37825 IF(IPIP.EQ.1)THEN
37826 XDIQP=XDIQP-XSQ
37827**NEW
37828C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37829**
37830 XVQT =XVQT -XSAQ
37831 ELSEIF(IPIP.EQ.2)THEN
37832 XDIQP=XDIQP-XSAQ
37833 XVQT =XVQT -XSQ
37834 ENDIF
37835 IF(IPCO.GE.3)
37836 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37837C
37838C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37839C
37840 XVTHRO=CVQ/UMO
37841 IVTHR=0
37842 3466 CONTINUE
37843 IF(IVTHR.EQ.10)THEN
37844 IREJ=1
37845 IF(ISQ.EQ.3)IREJ=3
37846 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37847 IPCO=0
37848 RETURN
37849 ENDIF
37850 IVTHR=IVTHR+1
37851 XVTHR=XVTHRO/(201-IVTHR)
37852 UNOPRV=UNON
37853 380 CONTINUE
37854 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37855 IREJ=1
37856 IF(ISQ.EQ.3)IREJ=3
37857 IF(IPCO.GE.3)
37858 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37859 * XVTHR
37860 IPCO=0
37861 RETURN
37862 ENDIF
37863 IF(DT_RNDM(V).LT.0.5D0)THEN
37864 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37865 XVPQII=XDIQP-XVPQI
37866 ELSE
37867 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37868 XVPQI=XDIQP-XVPQII
37869 ENDIF
37870 IF(IPCO.GE.3)THEN
37871 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37872 & XVTHR,XDIQP,XVPQI,XVPQII
37873 ENDIF
37874C
37875C Prepare 4 momenta of new chains and chain ends
37876C
37877C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37878C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37879C +(4,NTMHKK)
37880C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37881C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37882C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37883 IF(IPIP.EQ.1)THEN
37884 XSQ1=XSQ
37885 XSAQ1=XSAQ
37886 ISQ1=ISQ
37887 ISAQ1=ISAQ
37888 ELSEIF(IPIP.EQ.2)THEN
37889 XSQ1=XSAQ
37890 XSAQ1=XSQ
37891 ISQ1=ISAQ
37892 ISAQ1=ISQ
37893 ENDIF
37894 KK11=IP11
37895C IDHKT(2) =1000*IPP21+100*IPP22+1
37896 KK21= IPP21
37897 KK22= IPP22
37898 XGIVE=0.D0
37899 IDHKT(4+IIGLU1) =IP12
37900 ISTHKT(4+IIGLU1) =921
37901 JMOHKT(1,4+IIGLU1)=NC1P
37902 JMOHKT(2,4+IIGLU1)=0
37903 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37904 JDAHKT(2,4+IIGLU1)=0
37905**NEW
37906 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37907 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37908**
37909 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37910 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37911 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37912 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37913C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37914 XXMIST=(PHKT(4,4+IIGLU1)**2-
37915 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37916 * PHKT(1,4+IIGLU1)**2)
37917 IF(XXMIST.GT.0.D0)THEN
37918 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37919 ELSE
37920 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37921 XXMIST=ABS(XXMIST)
37922 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37923 ENDIF
37924 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37925 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37926 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37927 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37928 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37929 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37930 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37931 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37932 IF(IPIP.EQ.1)THEN
37933 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37934 ELSEIF(IPIP.EQ.2)THEN
37935 IDHKT(5+IIGLU1) =ISAQ1
37936 ENDIF
37937 ISTHKT(5+IIGLU1) =922
37938 JMOHKT(1,5+IIGLU1)=NC1T
37939 JMOHKT(2,5+IIGLU1)=0
37940 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37941 JDAHKT(2,5+IIGLU1)=0
37942**NEW
37943 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37944 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37945**
37946 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37947 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37948 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37949 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37950C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37951 XMIST=(PHKT(4,5+IIGLU1)**2-
37952 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37953 *PHKT(1,5+IIGLU1)**2)
37954 IF(XMIST.GT.0.D0)THEN
37955 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37956 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37957 *PHKT(1,5+IIGLU1)**2)
37958 ELSE
37959C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37960 PHKT(5,5+IIGLU1)=0.D0
37961 ENDIF
37962 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37963 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37964 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37965 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37966 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37967 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37968 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37969 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37970 IDHKT(6+IIGLU1) =88888
37971C IDHKT(6) =1000*NNNC1+MMMC1
37972 ISTHKT(6+IIGLU1) =93
37973C ISTHKT(6) =KKKC1
37974 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37975 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37976 JDAHKT(1,6+IIGLU1)=0
37977 JDAHKT(2,6+IIGLU1)=0
37978 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37979 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37980 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37981 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37982 PHKT(5,6+IIGLU1)
37983 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37984 * -PHKT(3,6+IIGLU1)**2)
37985 CHAMAL=CHAM1
37986 IF(IPIP.EQ.1)THEN
37987 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37988 ELSEIF(IPIP.EQ.2)THEN
37989 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37990 ENDIF
37991 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37992 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37993C we drop chain 6 and give the energy to chain 3
37994 IDHKT(6+IIGLU1)=33888
37995 XGIVE=1.D0
37996C WRITE(6,*)' drop chain 6 xgive=1'
37997 GO TO 7788
37998 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37999C we drop chain 6 and give the energy to chain 3
38000C and change KK11 to IDHKT(4)
38001 IDHKT(6+IIGLU1)=33888
38002 XGIVE=1.D0
38003C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
38004 KK11=IDHKT(4+IIGLU1)
38005 GO TO 7788
38006 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38007C we drop chain 6 and give the energy to chain 3
38008C and change KK21 to IDHKT(4)
38009C IDHKT(2) =1000*IPP21+100*IPP22+1
38010 IDHKT(6+IIGLU1)=33888
38011 XGIVE=1.D0
38012C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38013 KK21=IDHKT(4+IIGLU1)
38014 GO TO 7788
38015 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38016C we drop chain 6 and give the energy to chain 3
38017C and change KK22 to IDHKT(4)
38018C IDHKT(2) =1000*IPP21+100*IPP22+1
38019 IDHKT(6+IIGLU1)=33888
38020 XGIVE=1.D0
38021C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38022 KK22=IDHKT(4+IIGLU1)
38023 GO TO 7788
38024 ENDIF
38025C IREJ=1
38026 IPCO=0
38027C RETURN
38028C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38029 GO TO 3466
38030 ENDIF
38031 7788 CONTINUE
38032 IF(IPIP.GE.3)THEN
38033 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38034 * JMOHKT(1,4+IIGLU1),
38035 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38036 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38037 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38038 * JMOHKT(1,5+IIGLU1),
38039 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38040 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38041 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38042 * JMOHKT(1,6+IIGLU1),
38043 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38044 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38045 ENDIF
38046 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38047 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38048 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38049 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38050 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38051 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38052 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38053 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38054C IDHKT(1) =IP11
38055 IDHKT(1) =KK11
38056 ISTHKT(1) =921
38057 JMOHKT(1,1)=NC1P
38058 JMOHKT(2,1)=0
38059 JDAHKT(1,1)=3+IIGLU1
38060 JDAHKT(2,1)=0
38061 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38062C * +0.5D0*PHKK(1,NC2P)
38063 *+XGIVE*PHKT(1,4+IIGLU1)
38064 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38065C * +0.5D0*PHKK(2,NC2P)
38066 *+XGIVE*PHKT(2,4+IIGLU1)
38067 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38068C * +0.5D0*PHKK(3,NC2P)
38069 *+XGIVE*PHKT(3,4+IIGLU1)
38070 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38071C * +0.5D0*PHKK(4,NC2P)
38072 *+XGIVE*PHKT(4,4+IIGLU1)
38073C PHKT(5,1) =PHKK(5,NC1P)
38074 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38075 *PHKT(1,1)**2)
38076 IF(XMIST.GE.0.D0)THEN
38077 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38078 *PHKT(1,1)**2)
38079 ELSE
38080C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38081 PHKT(5,1)=0.D0
38082 ENDIF
38083 VHKT(1,1) =VHKK(1,NC1P)
38084 VHKT(2,1) =VHKK(2,NC1P)
38085 VHKT(3,1) =VHKK(3,NC1P)
38086 VHKT(4,1) =VHKK(4,NC1P)
38087 WHKT(1,1) =WHKK(1,NC1P)
38088 WHKT(2,1) =WHKK(2,NC1P)
38089 WHKT(3,1) =WHKK(3,NC1P)
38090 WHKT(4,1) =WHKK(4,NC1P)
38091C Add here IIGLU1 gluons to this chaina
38092 PG1=0.D0
38093 PG2=0.D0
38094 PG3=0.D0
38095 PG4=0.D0
38096 IF(IIGLU1.GE.1)THEN
38097 JJG=NC1P
38098 DO 61 IIG=2,2+IIGLU1-1
38099 KKG=JJG+IIG-1
38100 IDHKT(IIG) =IDHKK(KKG)
38101 ISTHKT(IIG) =921
38102 JMOHKT(1,IIG)=KKG
38103 JMOHKT(2,IIG)=0
38104 JDAHKT(1,IIG)=3+IIGLU1
38105 JDAHKT(2,IIG)=0
38106 PHKT(1,IIG)=PHKK(1,KKG)
38107 PG1=PG1+ PHKT(1,IIG)
38108 PHKT(2,IIG)=PHKK(2,KKG)
38109 PG2=PG2+ PHKT(2,IIG)
38110 PHKT(3,IIG)=PHKK(3,KKG)
38111 PG3=PG3+ PHKT(3,IIG)
38112 PHKT(4,IIG)=PHKK(4,KKG)
38113 PG4=PG4+ PHKT(4,IIG)
38114 PHKT(5,IIG)=PHKK(5,KKG)
38115 VHKT(1,IIG) =VHKK(1,KKG)
38116 VHKT(2,IIG) =VHKK(2,KKG)
38117 VHKT(3,IIG) =VHKK(3,KKG)
38118 VHKT(4,IIG) =VHKK(4,KKG)
38119 WHKT(1,IIG) =WHKK(1,KKG)
38120 WHKT(2,IIG) =WHKK(2,KKG)
38121 WHKT(3,IIG) =WHKK(3,KKG)
38122 WHKT(4,IIG) =WHKK(4,KKG)
38123 61 CONTINUE
38124 ENDIF
38125C IDHKT(2) =1000*IPP21+100*IPP22+1
38126 IF(IPIP.EQ.1)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 ELSEIF(IPIP.EQ.2)THEN
38132 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38133 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38134 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38135 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38136 ENDIF
38137 ISTHKT(2+IIGLU1) =922
38138 JMOHKT(1,2+IIGLU1)=NC2T
38139 JMOHKT(2,2+IIGLU1)=0
38140 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38141 JDAHKT(2,2+IIGLU1)=0
38142 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38143 *+XGIVE*PHKT(1,5+IIGLU1)
38144 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38145 *+XGIVE*PHKT(2,5+IIGLU1)
38146 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38147 *+XGIVE*PHKT(3,5+IIGLU1)
38148 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38149 *+XGIVE*PHKT(4,5+IIGLU1)
38150C PHKT(5,2) =PHKK(5,NC2T)
38151 XMIST=(PHKT(4,2+IIGLU1)**2-
38152 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38153 *PHKT(1,2+IIGLU1)**2)
38154 IF(XMIST.GT.0.D0)THEN
38155 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38156 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38157 *PHKT(1,2+IIGLU1)**2)
38158 ELSE
38159C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38160 PHKT(5,2+IIGLU1)=0.D0
38161 ENDIF
38162 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38163 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38164 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38165 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38166 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38167 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38168 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38169 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38170 IDHKT(3+IIGLU1) =88888
38171C IDHKT(3) =1000*NNNC1+MMMC1+10
38172 ISTHKT(3+IIGLU1) =93
38173C ISTHKT(3) =KKKC1
38174 JMOHKT(1,3+IIGLU1)=1
38175 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38176 JDAHKT(1,3+IIGLU1)=0
38177 JDAHKT(2,3+IIGLU1)=0
38178 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38179 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38180 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38181 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38182 PHKT(5,3+IIGLU1)
38183 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38184 * -PHKT(3,3+IIGLU1)**2)
38185 IF(IPIP.GE.3)THEN
38186 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38187 * JDAHKT(1,1),
38188 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38189 DO 71 IIG=2,2+IIGLU1-1
38190 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38191 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38192 * JDAHKT(1,IIG),
38193 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38194 71 CONTINUE
38195 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38196 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38197 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38198 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38199 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38200 * JMOHKT(1,3+IIGLU1),
38201 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38202 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38203 ENDIF
38204 CHAMAL=CHAB1
38205**NEW
38206C IF(IPIP.EQ.1)THEN
38207C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38208C ELSEIF(IPIP.EQ.2)THEN
38209C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38210C ENDIF
38211 IF(IPIP.EQ.1)THEN
38212 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38213 ELSEIF(IPIP.EQ.2)THEN
38214 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38215 ENDIF
38216**
38217 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38218C IREJ=1
38219 IPCO=0
38220C RETURN
38221C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38222 GO TO 3466
38223 ENDIF
38224 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38225 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38226 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38227 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38228 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38229 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38230 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38231 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38232 IF(IPIP.EQ.1)THEN
38233 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+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
38237 ELSEIF(IPIP.EQ.2)THEN
38238 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38239 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38240 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38241 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38242C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38243 ENDIF
38244 ISTHKT(7+IIGLU1) =921
38245 JMOHKT(1,7+IIGLU1)=NC2P
38246 JMOHKT(2,7+IIGLU1)=0
38247 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38248 JDAHKT(2,7+IIGLU1)=0
38249C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38250C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38251C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38252C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38253**NEW
38254 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38255 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38256**
38257 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38258 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38259 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38260 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38261C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38262C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38263 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38264C IREJ=1
38265C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38266 IPCO=0
38267C RETURN
38268 GO TO 3466
38269 ENDIF
38270C PHKT(5,7) =PHKK(5,NC2P)
38271 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38272 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38273 *PHKT(1,7+IIGLU1)**2)
38274 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38275 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38276 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38277 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38278 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38279 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38280 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38281 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38282C Insert here the IIGLU2 gluons
38283 PG1=0.D0
38284 PG2=0.D0
38285 PG3=0.D0
38286 PG4=0.D0
38287 IF(IIGLU2.GE.1)THEN
38288 JJG=NC2P
38289 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38290 KKG=JJG+IIG-7-IIGLU1
38291 IDHKT(IIG) =IDHKK(KKG)
38292 ISTHKT(IIG) =921
38293 JMOHKT(1,IIG)=KKG
38294 JMOHKT(2,IIG)=0
38295 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38296 JDAHKT(2,IIG)=0
38297 PHKT(1,IIG)=PHKK(1,KKG)
38298 PG1=PG1+ PHKT(1,IIG)
38299 PHKT(2,IIG)=PHKK(2,KKG)
38300 PG2=PG2+ PHKT(2,IIG)
38301 PHKT(3,IIG)=PHKK(3,KKG)
38302 PG3=PG3+ PHKT(3,IIG)
38303 PHKT(4,IIG)=PHKK(4,KKG)
38304 PG4=PG4+ PHKT(4,IIG)
38305 PHKT(5,IIG)=PHKK(5,KKG)
38306 VHKT(1,IIG) =VHKK(1,KKG)
38307 VHKT(2,IIG) =VHKK(2,KKG)
38308 VHKT(3,IIG) =VHKK(3,KKG)
38309 VHKT(4,IIG) =VHKK(4,KKG)
38310 WHKT(1,IIG) =WHKK(1,KKG)
38311 WHKT(2,IIG) =WHKK(2,KKG)
38312 WHKT(3,IIG) =WHKK(3,KKG)
38313 WHKT(4,IIG) =WHKK(4,KKG)
38314 81 CONTINUE
38315 ENDIF
38316 IDHKT(8+IIGLU1+IIGLU2) =IP2
38317 ISTHKT(8+IIGLU1+IIGLU2) =922
38318 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38319 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38320 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38321 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38322**NEW
38323 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38324 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38325**
38326 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38327 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38328 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38329 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38330C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38331 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38332 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38333 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38334 IF(XMIST.GT.0.D0)THEN
38335 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38336 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38337 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38338 ELSE
38339C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38340 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38341 ENDIF
38342 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38343 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38344 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38345 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38346 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38347 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38348 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38349 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38350 IDHKT(9+IIGLU1+IIGLU2) =88888
38351C IDHKT(9) =1000*NNNC2+MMMC2+10
38352 ISTHKT(9+IIGLU1+IIGLU2) =93
38353C ISTHKT(9) =KKKC2
38354 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38355 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38356 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38357 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38358 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38359 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38360 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38361 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38362 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38363 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38364 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38365 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38366 PHKT(5,9+IIGLU1+IIGLU2)
38367 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38368 * PHKT(2,9+IIGLU1+IIGLU2)**2
38369 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38370 IF(IPIP.GE.3)THEN
38371 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38372 * JMOHKT(1,7+IIGLU1),
38373 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38374 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38375 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38376 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38377 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38378 * JDAHKT(1,IIG),
38379 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38380 91 CONTINUE
38381 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38382 * IDHKT(8+IIGLU1+IIGLU2),
38383 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38384 * JDAHKT(1,8+IIGLU1+IIGLU2),
38385 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38386 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38387 * IDHKT(9+IIGLU1+IIGLU2),
38388 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38389 * JDAHKT(1,9+IIGLU1+IIGLU2),
38390 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38391 ENDIF
38392 CHAMAL=CHAB1
38393 IF(IPIP.EQ.1)THEN
38394 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38395 ELSEIF(IPIP.EQ.2)THEN
38396 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38397 ENDIF
38398 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38399C IREJ=1
38400 IPCO=0
38401C RETURN
38402C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38403C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38404 GO TO 3466
38405 ENDIF
38406 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38407 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38408 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38409 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38410 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38411 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38412 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38413 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38414C
38415 IGCOUN=9+IIGLU1+IIGLU2
38416 IPCO=0
38417 RETURN
38418 END
38419
38420*$ CREATE HKKHKT.FOR
38421*COPY HKKHKT
38422C
38423C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38424C
38425 SUBROUTINE HKKHKT(I,J)
38426 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38427 SAVE
38428
38429* event history
38430
38431 PARAMETER (NMXHKK=200000)
38432
38433 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38434 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38435 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38436
38437* extended event history
38438 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38439 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38440 & IHIST(2,NMXHKK)
38441
38442 PARAMETER (NTMHKK= 300)
38443 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38444 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38445 +(4,NTMHKK)
38446C
38447 ISTHKK(I) =ISTHKT(J)
38448 IDHKK(I) =IDHKT(J)
38449C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38450 IF(IDHKK(I).EQ.88888)THEN
38451C JMOHKK(1,I)=I-2
38452C JMOHKK(2,I)=I-1
38453 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38454 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38455 ELSE
38456 JMOHKK(1,I)=JMOHKT(1,J)
38457 JMOHKK(2,I)=JMOHKT(2,J)
38458 ENDIF
38459 JDAHKK(1,I)=JDAHKT(1,J)
38460 JDAHKK(2,I)=JDAHKT(2,J)
38461C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38462C JDAHKK(1,I)=I+2
38463C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38464C JDAHKK(1,I)=I+1
38465C ENDIF
38466 IF(JDAHKT(1,J).GT.0)THEN
38467 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38468 ENDIF
38469 PHKK(1,I) =PHKT(1,J)
38470 PHKK(2,I) =PHKT(2,J)
38471 PHKK(3,I) =PHKT(3,J)
38472 PHKK(4,I) =PHKT(4,J)
38473 PHKK(5,I) =PHKT(5,J)
38474 VHKK(1,I) =VHKT(1,J)
38475 VHKK(2,I) =VHKT(2,J)
38476 VHKK(3,I) =VHKT(3,J)
38477 VHKK(4,I) =VHKT(4,J)
38478 WHKK(1,I) =WHKT(1,J)
38479 WHKK(2,I) =WHKT(2,J)
38480 WHKK(3,I) =WHKT(3,J)
38481 WHKK(4,I) =WHKT(4,J)
38482 RETURN
38483 END
38484
38485*$ CREATE DT_DBREAK.FOR
38486*COPY DT_DBREAK
38487*
38488*===dbreak=============================================================*
38489*
38490 SUBROUTINE DT_DBREAK(MODE)
38491
38492************************************************************************
38493* This is the steering subroutine for the different diquark breaking *
38494* mechanisms. *
38495* *
38496* MODE = 1 breaking of projectile diquark in qq-q chain using *
38497* a sea quark (q-qq chain) of the same projectile *
38498* = 2 breaking of target diquark in q-qq chain using *
38499* a sea quark (qq-q chain) of the same target *
38500* = 3 breaking of projectile diquark in qq-q chain using *
38501* a sea quark (q-aq chain) of the same projectile *
38502* = 4 breaking of target diquark in q-qq chain using *
38503* a sea quark (aq-q chain) of the same target *
38504* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38505* a sea anti-quark (aq-aqaq chain) of the same projectile *
38506* = 6 breaking of target anti-diquark in aq-aqaq chain using *
38507* a sea anti-quark (aqaq-aq chain) of the same target *
38508* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38509* a sea anti-quark (aq-q chain) of the same projectile *
38510* = 8 breaking of target anti-diquark in aq-aqaq chain using *
38511* a sea anti-quark (q-aq chain) of the same target *
38512* *
38513* Original version by J. Ranft. *
38514* This version dated 17.5.00 is written by S. Roesler. *
38515************************************************************************
38516
38517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38518 SAVE
38519
38520 PARAMETER ( LINP = 10 ,
38521 & LOUT = 6 ,
38522 & LDAT = 9 )
38523
38524* event history
38525
38526 PARAMETER (NMXHKK=200000)
38527
38528 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38529 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38530 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38531
38532* extended event history
38533 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38534 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38535 & IHIST(2,NMXHKK)
38536
38537* flags for input different options
38538 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38539 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38540 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38541
38542* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38543 PARAMETER (MAXCHN=10000)
38544 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38545
38546* diquark-breaking mechanism
38547 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38548
38549* flags for particle decays
38550 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38551 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38552 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38553
38554*
38555* chain identifiers
38556* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38557* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38558 DIMENSION IDCHN1(8),IDCHN2(8)
38559 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38560 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38561*
38562* parton identifiers
38563* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38564* +-51/52 = unitarity-sea, +-61/62 = gluons )
38565 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38566 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38567 & 31, 31, 31, 31, 31, 31, 31, 31,
38568 & 41, 41, 41, 41, 51, 51, 51, 51/
38569 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38570 & 32, 32, 32, 32, 32, 32, 32, 32,
38571 & 42, 42, 42, 42, 52, 52, 52, 52/
38572 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38573 & 51, 31, 41, 41, 31, 31, 31, 31,
38574 & 0, 41, 51, 51, 51, 51, 51, 51/
38575 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38576 & 32, 52, 42, 42, 32, 32, 32, 32,
38577 & 42, 0, 52, 52, 52, 52, 52, 52/
38578
38579 IF (NCHAIN.LE.0) RETURN
38580 DO 1 I=1,NCHAIN
38581 IDX1 = IDXCHN(1,I)
38582 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38583 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38584 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38585 & .AND.
38586 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38587 & (IS1P.EQ.ISP1P(MODE,3)))
38588 & .AND.
38589 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38590 & (IS1T.EQ.ISP1T(MODE,3)))
38591 & ) THEN
38592 DO 2 J=1,NCHAIN
38593 IDX2 = IDXCHN(1,J)
38594 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38595 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38596 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38597 & .AND.
38598 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38599 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38600 & .AND.
38601 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38602 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38603 & ) THEN
38604* find mother nucleons of the diquark to be splitted and of the
38605* sea-quark and reject this combination if it is not the same
38606 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38607 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38608 IANCES = 1
38609 ELSE
38610 IANCES = 2
38611 ENDIF
38612 IDXMO1 = JMOHKK(IANCES,IDX1)
38613 4 CONTINUE
38614 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38615 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38616 IANC = IANCES
38617 ELSE
38618 IANC = 1
38619 ENDIF
38620 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38621 IDXMO1 = JMOHKK(IANC,IDXMO1)
38622 GOTO 4
38623 ENDIF
38624 IDXMO2 = JMOHKK(IANCES,IDX2)
38625 5 CONTINUE
38626 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38627 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38628 IANC = IANCES
38629 ELSE
38630 IANC = 1
38631 ENDIF
38632 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38633 IDXMO2 = JMOHKK(IANC,IDXMO2)
38634 GOTO 5
38635 ENDIF
38636 IF (IDXMO1.NE.IDXMO2) GOTO 2
38637* quark content of projectile parton
38638 IP1 = IDHKK(JMOHKK(1,IDX1))
38639 IP11 = IP1/1000
38640 IP12 = (IP1-1000*IP11)/100
38641 IP2 = IDHKK(JMOHKK(2,IDX1))
38642 IP21 = IP2/1000
38643 IP22 = (IP2-1000*IP21)/100
38644* quark content of target parton
38645 IT1 = IDHKK(JMOHKK(1,IDX2))
38646 IT11 = IT1/1000
38647 IT12 = (IT1-1000*IT11)/100
38648 IT2 = IDHKK(JMOHKK(2,IDX2))
38649 IT21 = IT2/1000
38650 IT22 = (IT2-1000*IT21)/100
38651* split diquark and form new chains
38652 IF (MODE.EQ.1) THEN
38653 IF (IT1.EQ.4) GOTO 2
38654 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38655 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38656 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38657 ELSEIF (MODE.EQ.2) THEN
38658 IF (IT2.EQ.4) GOTO 2
38659 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38660 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38661 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38662 ELSEIF (MODE.EQ.3) THEN
38663 IF (IT1.EQ.4) GOTO 2
38664 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38667 ELSEIF (MODE.EQ.4) THEN
38668 IF (IT2.EQ.4) GOTO 2
38669 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38670 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38671 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38672 ELSEIF (MODE.EQ.5) THEN
38673 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38674 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38675 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38676 ELSEIF (MODE.EQ.6) THEN
38677 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38678 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38679 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38680 ELSEIF (MODE.EQ.7) THEN
38681 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38682 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38683 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38684 ELSEIF (MODE.EQ.8) THEN
38685 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38686 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38687 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38688 ENDIF
38689 IF (IREJ.GE.1) THEN
38690 if ((ipq.lt.0).or.(ipq.ge.4))
38691 & write(LOUT,*) 'ipq !!!',ipq,mode
38692 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38693* accept or reject new chains corresponding to PDBSEA
38694 ELSE
38695 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38696 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38697 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38698 ELSEIF (IPQ.EQ.3) THEN
38699 ACC = DBRKA(3,MODE)
38700 REJ = DBRKR(3,MODE)
38701 ELSE
38702 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38703 STOP
38704 ENDIF
38705 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38706 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38707 IACC = 1
38708 ELSE
38709 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38710 IACC = 0
38711 ENDIF
38712* new chains have been accepted and are now copied into HKKEVT
38713 IF (IACC.EQ.1) THEN
38714 IF (LEMCCK) THEN
38715 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38716 & PHKK(3,IDX1),PHKK(4,IDX1),
38717 & 1,IDUM1,IDUM2)
38718 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38719 & PHKK(3,IDX2),PHKK(4,IDX2),
38720 & 2,IDUM1,IDUM2)
38721 ENDIF
38722 IDHKK(IDX1) = 99888
38723 IDHKK(IDX2) = 99888
38724 IDXCHN(2,I) = -1
38725 IDXCHN(2,J) = -1
38726 DO 3 K=1,IGCOUN
38727 NHKK = NHKK+1
38728 CALL HKKHKT(NHKK,K)
38729 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38730 PX = -PHKK(1,NHKK)
38731 PY = -PHKK(2,NHKK)
38732 PZ = -PHKK(3,NHKK)
38733 PE = -PHKK(4,NHKK)
38734 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38735 ENDIF
38736 3 CONTINUE
38737 IF (LEMCCK) THEN
38738 CHKLEV = 0.1D0
38739 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38740 & IREJ)
38741 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38742 ENDIF
38743 GOTO 1
38744 ENDIF
38745 ENDIF
38746 ENDIF
38747 2 CONTINUE
38748 ENDIF
38749 1 CONTINUE
38750 RETURN
38751 END
38752
38753*$ CREATE DT_CQPAIR.FOR
38754*COPY DT_CQPAIR
38755*
38756*===cqpair=============================================================*
38757*
38758 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38759
38760************************************************************************
38761* This subroutine Creates a Quark-antiquark PAIR from the sea. *
38762* *
38763* XQMAX maxium energy fraction of quark (input) *
38764* XAQMAX maxium energy fraction of antiquark (input) *
38765* XQ energy fraction of quark (output) *
38766* XAQ energy fraction of antiquark (output) *
38767* IFLV quark flavour (- antiquark flavor) (output) *
38768* *
38769* This version dated 14.5.00 is written by S. Roesler. *
38770************************************************************************
38771
38772 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38773 SAVE
38774
38775 PARAMETER ( LINP = 10 ,
38776 & LOUT = 6 ,
38777 & LDAT = 9 )
38778
38779* Lorentz-parameters of the current interaction
38780 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38781 & UMO,PPCM,EPROJ,PPROJ
38782
38783*
38784 IREJ = 0
38785 XQ = 0.0D0
38786 XAQ = 0.0D0
38787*
38788* sample quark flavour
38789*
38790* set seasq here (the one from DTCHAI should be used in the future)
38791 SEASQ = 0.5D0
38792 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38793*
38794* sample energy fractions of sea pair
38795* we first sample the energy fraction of a gluon and then split the gluon
38796*
38797* maximum energy fraction of the gluon forced via input
38798 XGMAXI = XQMAX+XAQMAX
38799* minimum energy fraction of the gluon
38800 XTHR1 = 4.0D0 /UMO**2
38801 XTHR2 = 0.54D0/UMO**1.5D0
38802 XGMIN = MAX(XTHR1,XTHR2)
38803* maximum energy fraction of the gluon
38804 XGMAX = 0.3D0
38805 XGMAX = MIN(XGMAXI,XGMAX)
38806 IF (XGMIN.GE.XGMAX) THEN
38807 IREJ = 1
38808 RETURN
38809 ENDIF
38810*
38811* sample energy fraction of the gluon
38812 NLOOP = 0
38813 1 CONTINUE
38814 NLOOP = NLOOP+1
38815 IF (NLOOP.GE.50) THEN
38816 IREJ = 1
38817 RETURN
38818 ENDIF
38819 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38820 EGLUON = XGLUON*UMO/2.0D0
38821*
38822* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38823 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38824 ZMAX = 1.0D0-ZMIN
38825 RZ = DT_RNDM(ZMAX)
38826 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38827 RQ = DT_RNDM(ZMAX)
38828 IF (RQ.LT.0.5D0) THEN
38829 XQ = XGLUON*XHLP
38830 XAQ = XGLUON-XQ
38831 ELSE
38832 XAQ = XGLUON*XHLP
38833 XQ = XGLUON-XAQ
38834 ENDIF
38835 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38836
38837 RETURN
38838 END