]> 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
Correction
[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
3595 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3596 & (ISTHKK(I).EQ.1001)) THEN
3597 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3598 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3599 PECMS = PHKK(4,I)
3600 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3601 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3602 ENDIF
3603 20 CONTINUE
3604 ELSE
3605 MODE = -1
3606 ENDIF
3607
3608 RETURN
3609 END
3610
3611*$ CREATE DT_REJUCO.FOR
3612*COPY DT_REJUCO
3613*
3614*===rejuco=============================================================*
3615*
3616 SUBROUTINE DT_REJUCO(MODE,IREJ)
3617
3618************************************************************************
3619* REJection of Unphysical COnfigurations *
3620* MODE = 1 rejection of particles with unphysically large energy *
3621* *
3622* This version dated 27.12.2006 is written by S. Roesler. *
3623************************************************************************
3624
3625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3626 SAVE
3627
3628 PARAMETER ( LINP = 10 ,
3629 & LOUT = 6 ,
3630 & LDAT = 9 )
3631
3632 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3633 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3634
3635* maximum x_cms of final state particle
3636 PARAMETER (XCMSMX = 1.4D0)
3637
3638* event history
3639
3640 PARAMETER (NMXHKK=200000)
3641
3642 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3643 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3644 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3645
3646* extended event history
3647 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3648 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3649 & IHIST(2,NMXHKK)
3650
3651* Lorentz-parameters of the current interaction
3652 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3653 & UMO,PPCM,EPROJ,PPROJ
3654
3655 IREJ = 0
3656
3657 IF (MODE.EQ.1) THEN
3658 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3659 ECMHLF = UMO/2.0D0
3660 DO 10 I=NPOINT(4),NHKK
3661 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3662 XCMS = ABS(PHKK(4,I))/ECMHLF
3663 IF (XCMS.GT.XCMSMX) GOTO 9999
3664 ENDIF
3665 10 CONTINUE
3666 ENDIF
3667
3668 RETURN
3669 9999 CONTINUE
3670 IREJ = 1
3671 RETURN
3672 END
3673*$ CREATE DT_EVENTB.FOR
3674*COPY DT_EVENTB
3675*
3676*===eventb=============================================================*
3677*
3678 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3679
3680************************************************************************
3681* Treatment of nucleon-nucleon interactions with full two-component *
3682* Dual Parton Model. *
3683* NCSY number of nucleon-nucleon interactions *
3684* IREJ rejection flag *
3685* This version dated 14.01.2000 is written by S. Roesler *
3686************************************************************************
3687
3688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3689 SAVE
3690
3691 PARAMETER ( LINP = 10 ,
3692 & LOUT = 6 ,
3693 & LDAT = 9 )
3694
3695 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3696
3697* event history
3698
3699 PARAMETER (NMXHKK=200000)
3700
3701 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3702 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3703 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3704
3705* extended event history
3706 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3707 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3708 & IHIST(2,NMXHKK)
3709*! uncomment this line for internal phojet-fragmentation
3710C #include "dtu_dtevtp.inc"
3711
3712* particle properties (BAMJET index convention)
3713 CHARACTER*8 ANAME
3714 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3715 & IICH(210),IIBAR(210),K1(210),K2(210)
3716
3717* flags for input different options
3718 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3719 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3720 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3721
3722* rejection counter
3723 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3724 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3725 & IREXCI(3),IRDIFF(2),IRINC
3726
3727* properties of interacting particles
3728 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3729
3730* properties of photon/lepton projectiles
3731 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3732
3733* various options for treatment of partons (DTUNUC 1.x)
3734* (chain recombination, Cronin,..)
3735 LOGICAL LCO2CR,LINTPT
3736 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3737 & LCO2CR,LINTPT
3738
3739* statistics
3740 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3741 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3742 & ICEVTG(8,0:30)
3743
3744* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3745 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3746
3747* Glauber formalism: collision properties
3748 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3749 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3750
3751* flags for diffractive interactions (DTUNUC 1.x)
3752 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3753
3754* statistics: double-Pomeron exchange
3755 COMMON /DTFLG2/ INTFLG,IPOPO
3756
3757* flags for particle decays
3758 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3759 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3760 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3761
3762* nucleon-nucleon event-generator
3763 CHARACTER*8 CMODEL
3764 LOGICAL LPHOIN
3765 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3766
3767C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3768 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3769 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3770 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3771 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3772
3773C model switches and parameters
3774 CHARACTER*8 MDLNA
3775 INTEGER ISWMDL,IPAMDL
3776 DOUBLE PRECISION PARMDL
3777 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3778
3779C initial state parton radiation (internal part)
3780 INTEGER MXISR3,MXISR4
3781 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3782 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3783 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3784 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3785 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3786 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3787 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3788
3789C event debugging information
3790 INTEGER NMAXD
3791 PARAMETER (NMAXD=100)
3792 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3793 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3794 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3795 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3796
3797C general process information
3798 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3799 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3800
3801 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3802 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3803 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3804 & KPRON(15),ISINGL(2000)
3805
3806* initial values for max. number of phojet scatterings and dtunuc chains
3807* to be fragmented with one pyexec call
3808 DATA MXPHFR,MXDTFR /10,100/
3809
3810 IREJ = 0
3811* pointer to first parton of the first chain in dtevt common
3812 NPOINT(3) = NHKK+1
3813* special flag for double-Pomeron statistics
3814 IPOPO = 1
3815* counter for low-mass (DTUNUC) interactions
3816 NDTUSC = 0
3817* counter for interactions treated by PHOJET
3818 NPHOSC = 0
3819
3820* scan interactions for single nucleon-nucleon interactions
3821* (this has to be checked here because Cronin modifies parton momenta)
3822 NC = NPOINT(2)
3823 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3824 DO 8 I=1,NCSY
3825 ISINGL(I) = 0
3826 MOP = JMOHKK(1,NC)
3827 MOT = JMOHKK(1,NC+1)
3828 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3829 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3830 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3831 NC = NC+4
3832 8 CONTINUE
3833
3834* multiple scattering of chain ends
3835 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3836 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3837
3838* switch to PHOJET-settings for JETSET parameter
3839 CALL DT_INITJS(1)
3840
3841* loop over nucleon-nucleon interaction
3842 NC = NPOINT(2)
3843 DO 2 I=1,NCSY
3844*
3845* pick up one nucleon-nucleon interaction from DTEVT1
3846* ppnn / ptnn - momenta of the interacting nucleons (cms)
3847* ptotnn - total momentum of the interacting nucleons (cms)
3848* pp1,2 / pt1,2 - momenta of the four partons
3849* pp / pt - total momenta of the proj / targ partons
3850* ptot - total momentum of the four partons
3851 MOP = JMOHKK(1,NC)
3852 MOT = JMOHKK(1,NC+1)
3853 DO 3 K=1,4
3854 PPNN(K) = PHKK(K,MOP)
3855 PTNN(K) = PHKK(K,MOT)
3856 PTOTNN(K) = PPNN(K)+PTNN(K)
3857 PP1(K) = PHKK(K,NC)
3858 PT1(K) = PHKK(K,NC+1)
3859 PP2(K) = PHKK(K,NC+2)
3860 PT2(K) = PHKK(K,NC+3)
3861 PP(K) = PP1(K)+PP2(K)
3862 PT(K) = PT1(K)+PT2(K)
3863 PTOT(K) = PP(K)+PT(K)
3864 3 CONTINUE
3865*
3866*-----------------------------------------------------------------------
3867* this is a complete nucleon-nucleon interaction
3868*
3869 IF (ISINGL(I).EQ.1) THEN
3870*
3871* initialize PHOJET-variables for remnant/valence-partons
3872 IHFLD(1,1) = 0
3873 IHFLD(1,2) = 0
3874 IHFLD(2,1) = 0
3875 IHFLD(2,2) = 0
3876 IHFLS(1) = 1
3877 IHFLS(2) = 1
3878* save current settings of PHOJET process and min. bias flags
3879 DO 9 K=1,11
3880 KPRON(K) = IPRON(K,1)
3881 9 CONTINUE
3882 ISWSAV = ISWMDL(2)
3883*
3884* check if forced sampling of diffractive interaction requested
3885 IF (ISINGD.LT.-1) THEN
3886 DO 90 K=1,11
3887 IPRON(K,1) = 0
3888 90 CONTINUE
3889 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3890 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3891 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3892 ENDIF
3893*
3894* for photons: a direct/anomalous interaction is not sampled
3895* in PHOJET but already in Glauber-formalism. Here we check if such
3896* an interaction is requested
3897 IF (IJPROJ.EQ.7) THEN
3898* first switch off direct interactions
3899 IPRON(8,1) = 0
3900* this is a direct interactions
3901 IF (IDIREC.EQ.1) THEN
3902 DO 12 K=1,11
3903 IPRON(K,1) = 0
3904 12 CONTINUE
3905 IPRON(8,1) = 1
3906* this is an anomalous interactions
3907* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3908 ELSEIF (IDIREC.EQ.2) THEN
3909 ISWMDL(2) = 0
3910 ENDIF
3911 ELSE
3912 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3913 ENDIF
3914*
3915* make sure that total momenta of partons, pp and pt, are on mass
3916* shell (Cronin may have srewed this up..)
3917 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3918 IF (IR1.NE.0) THEN
3919 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3920 & 'EVENTB: mass shell correction rejected'
3921 GOTO 9999
3922 ENDIF
3923*
3924* initialize the incoming particles in PHOJET
3925 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3926
3927 CALL PHO_SETPAR(1,22,0,VIRT)
3928
3929 ELSE
3930
3931 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3932
3933 ENDIF
3934
3935 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3936
3937*
3938* initialize rejection loop counter for anomalous processes
3939 IRJANO = 0
3940 800 CONTINUE
3941 IRJANO = IRJANO+1
3942*
3943* temporary fix for ifano problem
3944 IFANO(1) = 0
3945 IFANO(2) = 0
3946*
3947* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3948
3949 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3950
3951*
3952* for photons: special consistency check for anomalous interactions
3953 IF (IJPROJ.EQ.7) THEN
3954 IF (IRJANO.LT.30) THEN
3955 IF (IFANO(1).NE.0) THEN
3956* here, an anomalous interaction was generated. Check if it
3957* was also requested. Otherwise reject this event.
3958 IF (IDIREC.EQ.0) GOTO 800
3959 ELSE
3960* here, an anomalous interaction was not generated. Check if it
3961* was requested in which case we need to reject this event.
3962 IF (IDIREC.EQ.2) GOTO 800
3963 ENDIF
3964 ELSE
3965 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3966 & IRJANO,IDIREC,NEVHKK
3967 ENDIF
3968 ENDIF
3969*
3970* copy back original settings of PHOJET process and min. bias flags
3971 DO 10 K=1,11
3972 IPRON(K,1) = KPRON(K)
3973 10 CONTINUE
3974 ISWMDL(2) = ISWSAV
3975*
3976* check if PHOJET has rejected this event
3977 IF (IREJ1.NE.0) THEN
3978C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979 WRITE(LOUT,'(1X,A,I4)')
3980 & 'EVENTB: chain system rejected',IDIREC
3981
3982 CALL PHO_PREVNT(0)
3983
3984 GOTO 9999
3985 ENDIF
3986*
3987* copy partons and strings from PHOJET common back into DTEVT for
3988* external fragmentation
3989 MO1 = NC
3990 MO2 = NC+3
3991*! uncomment this line for internal phojet-fragmentation
3992C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3993 NPHOSC = NPHOSC+1
3994 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3995 IF (IREJ1.NE.0) THEN
3996 IF (IOULEV(1).GT.0)
3997 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3998 GOTO 9999
3999 ENDIF
4000*
4001* update statistics counter
4002 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4003*
4004*-----------------------------------------------------------------------
4005* this interaction involves "remnants"
4006*
4007 ELSE
4008*
4009* total mass of this system
4010 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4011 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4012 IF (AMTOT2.LT.ZERO) THEN
4013 AMTOT = ZERO
4014 ELSE
4015 AMTOT = SQRT(AMTOT2)
4016 ENDIF
4017*
4018* systems with masses larger than elojet are treated with PHOJET
4019 IF (AMTOT.GT.ELOJET) THEN
4020*
4021* initialize PHOJET-variables for remnant/valence-partons
4022* projectile parton flavors and valence flag
4023 IHFLD(1,1) = IDHKK(NC)
4024 IHFLD(1,2) = IDHKK(NC+2)
4025 IHFLS(1) = 0
4026 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4027 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4028* target parton flavors and valence flag
4029 IHFLD(2,1) = IDHKK(NC+1)
4030 IHFLD(2,2) = IDHKK(NC+3)
4031 IHFLS(2) = 0
4032 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4033 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4034* flag signalizing PHOJET how to treat the remnant:
4035* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4036* iremn > -1 valence remnant: PHOJET assumes flavors according
4037* to mother particle
4038 IREMN1 = IHFLS(1)-1
4039 IREMN2 = IHFLS(2)-1
4040*
4041* initialize the incoming particles in PHOJET
4042 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4043
4044 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4045
4046 ELSE
4047
4048 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4049
4050 ENDIF
4051
4052 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4053
4054*
4055* calculate Lorentz parameter of the nucleon-nucleon cm-system
4056 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4057 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4058 BGX = PTOTNN(1)/AMNN
4059 BGY = PTOTNN(2)/AMNN
4060 BGZ = PTOTNN(3)/AMNN
4061 GAM = PTOTNN(4)/AMNN
4062* transform interacting nucleons into nucleon-nucleon cm-system
4063 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4064 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4065 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4066 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4067 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4068 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4069* transform (total) momenta of the proj and targ partons into
4070* nucleon-nucleon cm-system
4071 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4072 & PP(1),PP(2),PP(3),PP(4),
4073 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4074 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4075 & PT(1),PT(2),PT(3),PT(4),
4076 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4077* energy fractions of the proj and targ partons
4078 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4079 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4080***
4081* testprint
4082c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4083c & (PPTCMS(2)+PTTCMS(2))**2 +
4084c & (PPTCMS(3)+PTTCMS(3))**2 )
4085c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4086c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4087c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4088c & (PPSUB(2)+PTSUB(2))**2 +
4089c & (PPSUB(3)+PTSUB(3))**2 )
4090c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4091c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4092***
4093*
4094* save current settings of PHOJET process and min. bias flags
4095 DO 7 K=1,11
4096 KPRON(K) = IPRON(K,1)
4097 7 CONTINUE
4098* disallow direct photon int. (does not make sense here anyway)
4099 IPRON(8,1) = 0
4100* disallow double pomeron processes (due to technical problems
4101* in PHOJET, needs to be solved sometime)
4102 IPRON(4,1) = 0
4103* disallow diffraction for sea-diquarks
4104 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4105 & (IABS(IHFLD(1,2)).GT.1100)) THEN
4106 IPRON(3,1) = 0
4107 IPRON(6,1) = 0
4108 ENDIF
4109 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4110 & (IABS(IHFLD(2,2)).GT.1100)) THEN
4111 IPRON(3,1) = 0
4112 IPRON(5,1) = 0
4113 ENDIF
4114*
4115* we need massless partons: transform them on mass shell
4116 XMP = ZERO
4117 XMT = ZERO
4118 DO 6 K=1,4
4119 PPTMP(K) = PPSUB(K)
4120 PTTMP(K) = PTSUB(K)
4121 6 CONTINUE
4122 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4123 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4124 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4125 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4126 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4127* total energy of the subsysten after mass transformation
4128* (should be the same as before..)
4129 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4130 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
4131*
4132* after mass shell transformation the x_sub - relation has to be
4133* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4134*
4135* The old version was to scale based on the original x_sub and the
4136* 4-momenta of the subsystem. At very high energy this could lead to
4137* "pseudo-cm energies" of the parent system considerably exceeding
4138* the true cm energy. Now we keep the true cm energy and calculate
4139* new x_sub instead.
4140C old version PPTCMS(4) = PPSUB(4)/XPSUB
4141 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4142 XPSUB = PPSUB(4)/PPTCMS(4)
4143 IF (IJPROJ.EQ.7) THEN
4144 AMP2 = PHKK(5,MOT)**2
4145 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4146 ELSE
4147*???????
4148 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4149 & *(PPTCMS(4)+PHKK(5,MOP)))
4150C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4151C & *(PPTCMS(4)+PHKK(5,MOT)))
4152 ENDIF
4153C old version PTTCMS(4) = PTSUB(4)/XTSUB
4154 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4155 XTSUB = PTSUB(4)/PTTCMS(4)
4156 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4157 & *(PTTCMS(4)+PHKK(5,MOT)))
4158 DO 4 K=1,3
4159 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4160 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4161 4 CONTINUE
4162***
4163* testprint
4164*
4165* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
4166* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
4167* pptcms/ pttcms - momenta of the interacting nucleons (cms)
4168* pp1,2 / pt1,2 - momenta of the four partons
4169*
4170* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
4171* ptot - total momentum of the four partons (cms, negl. Fermi)
4172* ppsub / ptsub - total momenta of the proj / targ partons (cms)
4173*
4174c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4175c & (PPTCMS(2)+PTTCMS(2))**2 +
4176c & (PPTCMS(3)+PTTCMS(3))**2 )
4177c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4178c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4179c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4180c & (PPSUB(2)+PTSUB(2))**2 +
4181c & (PPSUB(3)+PTSUB(3))**2 )
4182c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4183c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4184c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4185c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4186c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4187c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
4188c ENDIF
4189c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4190c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4191c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4192c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4193* transform interacting nucleons into nucleon-nucleon cm-system
4194c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4195c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4196c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4197c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4198c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4199c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4200c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4201c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4202c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4203c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4204c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4205c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4206c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4207c & (PPNEW2+PTNEW2)**2 +
4208c & (PPNEW3+PTNEW3)**2 )
4209c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4210c & (PPNEW4+PTNEW4+PTSTCM) )
4211c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4212c & (PPSUB2+PTSUB2)**2 +
4213c & (PPSUB3+PTSUB3)**2 )
4214c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4215c & (PPSUB4+PTSUB4+PTSTSU) )
4216C WRITE(*,*) ' mother cmE :'
4217C WRITE(*,*) ETSTCM,ENEWCM
4218C WRITE(*,*) ' subsystem cmE :'
4219C WRITE(*,*) ETSTSU,ENEWSU
4220C WRITE(*,*) ' projectile mother :'
4221C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4222C WRITE(*,*) ' target mother :'
4223C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4224C WRITE(*,*) ' projectile subsystem:'
4225C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4226C WRITE(*,*) ' target subsystem:'
4227C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4228C WRITE(*,*) ' projectile subsystem should be:'
4229C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4230C & XPSUB*ETSTCM/2.0D0
4231C WRITE(*,*) ' target subsystem should be:'
4232C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4233C & XTSUB*ETSTCM/2.0D0
4234C WRITE(*,*) ' subsystem cmE should be: '
4235C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4236***
4237*
4238* generate complete remnant - nucleon/remnant event with PHOJET
4239
4240 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4241
4242*
4243* copy back original settings of PHOJET process flags
4244 DO 11 K=1,11
4245 IPRON(K,1) = KPRON(K)
4246 11 CONTINUE
4247*
4248* check if PHOJET has rejected this event
4249 IF (IREJ1.NE.0) THEN
4250 IF (IOULEV(1).GT.0)
4251 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
4252 WRITE(LOUT,*)
4253 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4254
4255 CALL PHO_PREVNT(0)
4256
4257 GOTO 9999
4258 ENDIF
4259*
4260* copy partons and strings from PHOJET common back into DTEVT for
4261* external fragmentation
4262 MO1 = NC
4263 MO2 = NC+3
4264*! uncomment this line for internal phojet-fragmentation
4265C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4266 NPHOSC = NPHOSC+1
4267 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4268 IF (IREJ1.NE.0) THEN
4269 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4270 & 'EVENTB: chain system rejected 2'
4271 GOTO 9999
4272 ENDIF
4273*
4274* update statistics counter
4275 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4276*
4277*-----------------------------------------------------------------------
4278* two-chain approx. for smaller systems
4279*
4280 ELSE
4281*
4282 NDTUSC = NDTUSC+1
4283* special flag for double-Pomeron statistics
4284 IPOPO = 0
4285*
4286* pick up flavors at the ends of the two chains
4287 IFP1 = IDHKK(NC)
4288 IFT1 = IDHKK(NC+1)
4289 IFP2 = IDHKK(NC+2)
4290 IFT2 = IDHKK(NC+3)
4291* ..and the indices of the mothers
4292 MOP1 = NC
4293 MOT1 = NC+1
4294 MOP2 = NC+2
4295 MOT2 = NC+3
4296 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4297 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4298*
4299* check if this chain system was rejected
4300 IF (IREJ1.GT.0) THEN
4301 IF (IOULEV(1).GT.0) THEN
4302 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4303 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4304 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4305 ENDIF
4306 IRHHA = IRHHA+1
4307 GOTO 9999
4308 ENDIF
4309* the following lines are for sea-sea chains rejected in GETCSY
4310 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4311 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4312 ENDIF
4313*
4314 ENDIF
4315*
4316* update statistics counter
4317 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4318*
4319 NC = NC+4
4320*
4321 2 CONTINUE
4322*
4323*-----------------------------------------------------------------------
4324* treatment of low-mass chains (if there are any)
4325*
4326 IF (NDTUSC.GT.0) THEN
4327*
4328* correct chains of very low masses for possible resonances
4329 IF (IRESCO.EQ.1) THEN
4330 CALL DT_EVTRES(IREJ1)
4331 IF (IREJ1.GT.0) THEN
4332 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4333 IRRES(1) = IRRES(1)+1
4334 GOTO 9999
4335 ENDIF
4336 ENDIF
4337* fragmentation of low-mass chains
4338*! uncomment this line for internal phojet-fragmentation
4339* (of course it will still be fragmented by DPMJET-routines but it
4340* has to be done here instead of further below)
4341C CALL DT_EVTFRA(IREJ1)
4342C IF (IREJ1.GT.0) THEN
4343C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4344C IRFRAG = IRFRAG+1
4345C GOTO 9999
4346C ENDIF
4347 ELSE
4348*! uncomment this line for internal phojet-fragmentation
4349C NPOINT(4) = NHKK+1
4350 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4351 ENDIF
4352*
4353*-----------------------------------------------------------------------
4354* new di-quark breaking mechanisms
4355*
4356 MXLEFT = 2
4357 CALL DT_CHASTA(0)
4358 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4359 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4360 CALL DT_DIQBRK
4361 MXLEFT = 4
4362 ENDIF
4363*
4364*-----------------------------------------------------------------------
4365* hadronize this event
4366*
4367* hadronize PHOJET chain systems
4368 NPYMAX = 0
4369 NPJE = NPHOSC/MXPHFR
4370 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4371 IF (NPJE.GT.1) THEN
4372 NLEFT = NPHOSC-NPJE*MXPHFR
4373 DO 20 JFRG=1,NPJE
4374 NFRG = JFRG*MXPHFR
4375 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4376 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4377 IF (IREJ1.GT.0) GOTO 22
4378 NLEFT = 0
4379 ELSE
4380 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4381 IF (IREJ1.GT.0) GOTO 22
4382 ENDIF
4383 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4384 20 CONTINUE
4385 IF (NLEFT.GT.0) THEN
4386 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4387 IF (IREJ1.GT.0) GOTO 22
4388 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4389 ENDIF
4390 ELSE
4391 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4392 IF (IREJ1.GT.0) GOTO 22
4393 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4394 ENDIF
4395*
4396* check max. filling level of jetset common and
4397* reduce mxphfr if necessary
4398 IF (NPYMAX.GT.3000) THEN
4399 IF (NPYMAX.GT.3500) THEN
4400 MXPHFR = MAX(1,MXPHFR-2)
4401 ELSE
4402 MXPHFR = MAX(1,MXPHFR-1)
4403 ENDIF
4404C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4405 ENDIF
4406*
4407* hadronize DTUNUC chain systems
4408 23 CONTINUE
4409 IBACK = MXDTFR
4410 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4411 IF (IREJ2.GT.0) GOTO 22
4412*
4413* check max. filling level of jetset common and
4414* reduce mxdtfr if necessary
4415 IF (NPYMEM.GT.3000) THEN
4416 IF (NPYMEM.GT.3500) THEN
4417 MXDTFR = MAX(1,MXDTFR-20)
4418 ELSE
4419 MXDTFR = MAX(1,MXDTFR-10)
4420 ENDIF
4421C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4422 ENDIF
4423*
4424 IF (IBACK.EQ.-1) GOTO 23
4425*
4426 22 CONTINUE
4427C CALL DT_EVTFRG(1,IREJ1)
4428C CALL DT_EVTFRG(2,IREJ2)
4429 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4430 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4431 IRFRAG = IRFRAG+1
4432 GOTO 9999
4433 ENDIF
4434*
4435* get final state particles from /DTEVTP/
4436*! uncomment this line for internal phojet-fragmentation
4437C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4438
4439 IF (IJPROJ.NE.7)
4440 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4441C IF (IREJ3.NE.0) GOTO 9999
4442
4443 RETURN
4444
4445 9999 CONTINUE
4446 IREVT = IREVT+1
4447 IREJ = 1
4448 RETURN
4449 END
4450
4451*$ CREATE DT_GETPJE.FOR
4452*COPY DT_GETPJE
4453*
4454*===getpje=============================================================*
4455*
4456 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4457
4458************************************************************************
4459* This subroutine copies PHOJET partons and strings from POEVT1 into *
4460* DTEVT1. *
4461* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4462* PP,PT 4-momenta of projectile/target being handled by *
4463* PHOJET *
4464* This version dated 11.12.99 is written by S. Roesler *
4465************************************************************************
4466
4467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4468 SAVE
4469
4470 PARAMETER ( LINP = 10 ,
4471 & LOUT = 6 ,
4472 & LDAT = 9 )
4473
4474 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4475 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4476
4477 LOGICAL LFLIP
4478
4479* event history
4480
4481 PARAMETER (NMXHKK=200000)
4482
4483 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4484 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4485 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4486
4487* extended event history
4488 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4489 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4490 & IHIST(2,NMXHKK)
4491
4492* Lorentz-parameters of the current interaction
4493 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4494 & UMO,PPCM,EPROJ,PPROJ
4495
4496* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4497 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4498
4499* flags for input different options
4500 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4501 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4502 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4503
4504* statistics: double-Pomeron exchange
4505 COMMON /DTFLG2/ INTFLG,IPOPO
4506
4507* statistics
4508 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4509 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4510 & ICEVTG(8,0:30)
4511
4512* rejection counter
4513 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4514 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4515 & IREXCI(3),IRDIFF(2),IRINC
4516C standard particle data interface
4517 INTEGER NMXHEP
4518
4519 PARAMETER (NMXHEP=4000)
4520
4521 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4522 DOUBLE PRECISION PHEP,VHEP
4523 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4524 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4525 & VHEP(4,NMXHEP)
4526C extension to standard particle data interface (PHOJET specific)
4527 INTEGER IMPART,IPHIST,ICOLOR
4528 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4529
4530C color string configurations including collapsed strings and hadrons
4531 INTEGER MSTR
4532 PARAMETER (MSTR=500)
4533 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4534 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4535 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4536 & NNCH(MSTR),IBHAD(MSTR),ISTR
4537
4538C general process information
4539 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4540 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4541
4542C model switches and parameters
4543 CHARACTER*8 MDLNA
4544 INTEGER ISWMDL,IPAMDL
4545 DOUBLE PRECISION PARMDL
4546 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4547
4548C event debugging information
4549 INTEGER NMAXD
4550 PARAMETER (NMAXD=100)
4551 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4552 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4553 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4554 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4555
4556 DIMENSION PP(4),PT(4)
4557 DATA MAXLOP /10000/
4558
4559 INHKK = NHKK
4560 LFLIP = .TRUE.
4561 1 CONTINUE
4562 NPVAL = 0
4563 NTVAL = 0
4564 IREJ = 0
4565
4566* store initial momenta for energy-momentum conservation check
4567 IF (LEMCCK) THEN
4568 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4569 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4570 ENDIF
4571* copy partons and strings from POEVT1 into DTEVT1
4572 DO 11 I=1,ISTR
4573C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4574 IF (NCODE(I).EQ.-99) THEN
4575 IDXSTG = NPOS(1,I)
4576 IDSTG = IDHEP(IDXSTG)
4577 PX = PHEP(1,IDXSTG)
4578 PY = PHEP(2,IDXSTG)
4579 PZ = PHEP(3,IDXSTG)
4580 PE = PHEP(4,IDXSTG)
4581 IF (MODE.LT.0) THEN
4582 ISTAT = 70000+IPJE
4583 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4584 & 11,IDSTG,0)
4585 IF (LEMCCK) THEN
4586 PX = -PX
4587 PY = -PY
4588 PZ = -PZ
4589 PE = -PE
4590 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4591 ENDIF
4592 ELSE
4593 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4594 & PPX,PPY,PPZ,PPE)
4595 ISTAT = 70000+IPJE
4596 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4597 & 11,IDSTG,0)
4598 IF (LEMCCK) THEN
4599 PX = -PPX
4600 PY = -PPY
4601 PZ = -PPZ
4602 PE = -PPE
4603 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4604 ENDIF
4605 ENDIF
4606 NOBAM(NHKK) = 0
4607 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4608 IHIST(2,NHKK) = 0
4609 ELSEIF (NCODE(I).GE.0) THEN
4610* indices of partons and string in POEVT1
4611 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4612 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4613 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4614 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4615 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4616 STOP ' GETPJE 1'
4617 ENDIF
4618 IDXSTG = NPOS(1,I)
4619* find "mother" string of the string
4620 IDXMS1 = ABS(JMOHEP(1,IDX1))
4621 IDXMS2 = ABS(JMOHEP(1,IDX2))
4622 IF (IDXMS1.NE.IDXMS2) THEN
4623 IDXMS1 = IDXSTG
4624 IDXMS2 = IDXSTG
4625C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4626 ENDIF
4627* search POEVT1 for the original hadron of the parton
4628 ILOOP = 0
4629 IPOM1 = 0
4630 14 CONTINUE
4631 ILOOP = ILOOP+1
4632
4633 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4634
4635 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4636 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4637 & (ILOOP.LT.MAXLOP)) GOTO 14
4638 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4639 IPOM2 = 0
4640 ILOOP = 0
4641 15 CONTINUE
4642 ILOOP = ILOOP+1
4643
4644 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4645
4646 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4647 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4648 ELSE
4649 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4650 ENDIF
4651 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4652 & (ILOOP.LT.MAXLOP)) GOTO 15
4653 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4654* parton 1
4655 IF (IDXMS1.EQ.1) THEN
4656 ISPTN1 = ISTHKK(MO1)
4657 M1PTN1 = MO1
4658 M2PTN1 = MO1+2
4659 ELSE
4660 ISPTN1 = ISTHKK(MO2)
4661 M1PTN1 = MO2-2
4662 M2PTN1 = MO2
4663 ENDIF
4664* parton 2
4665 IF (IDXMS2.EQ.1) THEN
4666 ISPTN2 = ISTHKK(MO1)
4667 M1PTN2 = MO1
4668 M2PTN2 = MO1+2
4669 ELSE
4670 ISPTN2 = ISTHKK(MO2)
4671 M1PTN2 = MO2-2
4672 M2PTN2 = MO2
4673 ENDIF
4674* check for mis-identified mothers and switch mother indices if necessary
4675 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4676 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4677 & (LFLIP)) THEN
4678 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4679 ISPTN1 = ISTHKK(MO1)
4680 M1PTN1 = MO1
4681 M2PTN1 = MO1+2
4682 ISPTN2 = ISTHKK(MO2)
4683 M1PTN2 = MO2-2
4684 M2PTN2 = MO2
4685 ELSE
4686 ISPTN1 = ISTHKK(MO2)
4687 M1PTN1 = MO2-2
4688 M2PTN1 = MO2
4689 ISPTN2 = ISTHKK(MO1)
4690 M1PTN2 = MO1
4691 M2PTN2 = MO1+2
4692 ENDIF
4693 ENDIF
4694* register partons in temporary common
4695* parton at chain end
4696 PX = PHEP(1,IDX1)
4697 PY = PHEP(2,IDX1)
4698 PZ = PHEP(3,IDX1)
4699 PE = PHEP(4,IDX1)
4700* flag only partons coming from Pomeron with 41/42
4701C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4702 IF (IPOM1.NE.0) THEN
4703 ISTX = ABS(ISPTN1)/10
4704 IMO = ABS(ISPTN1)-10*ISTX
4705 ISPTN1 = -(40+IMO)
4706 ELSE
4707 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4708 ISTX = ABS(ISPTN1)/10
4709 IMO = ABS(ISPTN1)-10*ISTX
4710 IF ((IDHEP(IDX1).EQ.21).OR.
4711 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4712 ISPTN1 = -(60+IMO)
4713 ELSE
4714 ISPTN1 = -(50+IMO)
4715 ENDIF
4716 ENDIF
4717 ENDIF
4718 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4719 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4720 IF (MODE.LT.0) THEN
4721 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4722 & PZ,PE,0,0,0)
4723 ELSE
4724 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4725 & PPX,PPY,PPZ,PPE)
4726 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4727 & PPZ,PPE,0,0,0)
4728 ENDIF
4729 IHIST(1,NHKK) = IPHIST(1,IDX1)
4730 IHIST(2,NHKK) = 0
4731 DO 19 KK=1,4
4732 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4733 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4734 19 CONTINUE
4735 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4736 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4737 M1STRG = NHKK
4738* gluon kinks
4739 NGLUON = IDX2-IDX1-1
4740 IF (NGLUON.GT.0) THEN
4741 DO 17 IGLUON=1,NGLUON
4742 IDX = IDX1+IGLUON
4743 IDXMS = ABS(JMOHEP(1,IDX))
4744 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4745 ILOOP = 0
4746 16 CONTINUE
4747 ILOOP = ILOOP+1
4748 IDXMS = ABS(JMOHEP(1,IDXMS))
4749 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4750 & (ILOOP.LT.MAXLOP)) GOTO 16
4751 IF (ILOOP.EQ.MAXLOP)
4752 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4753 ENDIF
4754 IF (IDXMS.EQ.1) THEN
4755 ISPTN = ISTHKK(MO1)
4756 M1PTN = MO1
4757 M2PTN = MO1+2
4758 ELSE
4759 ISPTN = ISTHKK(MO2)
4760 M1PTN = MO2-2
4761 M2PTN = MO2
4762 ENDIF
4763 PX = PHEP(1,IDX)
4764 PY = PHEP(2,IDX)
4765 PZ = PHEP(3,IDX)
4766 PE = PHEP(4,IDX)
4767 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4768 ISTX = ABS(ISPTN)/10
4769 IMO = ABS(ISPTN)-10*ISTX
4770 IF ((IDHEP(IDX).EQ.21).OR.
4771 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4772 ISPTN = -(60+IMO)
4773 ELSE
4774 ISPTN = -(50+IMO)
4775 ENDIF
4776 ENDIF
4777 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4778 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4779 IF (MODE.LT.0) THEN
4780 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4781 & PX,PY,PZ,PE,0,0,0)
4782 ELSE
4783 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4784 & PPX,PPY,PPZ,PPE)
4785 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4786 & PPX,PPY,PPZ,PPE,0,0,0)
4787 ENDIF
4788 IHIST(1,NHKK) = IPHIST(1,IDX)
4789 IHIST(2,NHKK) = 0
4790 DO 20 KK=1,4
4791 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4792 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4793 20 CONTINUE
4794 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4795 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4796 17 CONTINUE
4797 ENDIF
4798* parton at chain end
4799 PX = PHEP(1,IDX2)
4800 PY = PHEP(2,IDX2)
4801 PZ = PHEP(3,IDX2)
4802 PE = PHEP(4,IDX2)
4803* flag only partons coming from Pomeron with 41/42
4804C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4805 IF (IPOM2.NE.0) THEN
4806 ISTX = ABS(ISPTN2)/10
4807 IMO = ABS(ISPTN2)-10*ISTX
4808 ISPTN2 = -(40+IMO)
4809 ELSE
4810 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4811 ISTX = ABS(ISPTN2)/10
4812 IMO = ABS(ISPTN2)-10*ISTX
4813 IF ((IDHEP(IDX2).EQ.21).OR.
4814 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4815 ISPTN2 = -(60+IMO)
4816 ELSE
4817 ISPTN2 = -(50+IMO)
4818 ENDIF
4819 ENDIF
4820 ENDIF
4821 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4822 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4823 IF (MODE.LT.0) THEN
4824 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4825 & PX,PY,PZ,PE,0,0,0)
4826 ELSE
4827 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4828 & PPX,PPY,PPZ,PPE)
4829 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4830 & PPX,PPY,PPZ,PPE,0,0,0)
4831 ENDIF
4832 IHIST(1,NHKK) = IPHIST(1,IDX2)
4833 IHIST(2,NHKK) = 0
4834 DO 21 KK=1,4
4835 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4836 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4837 21 CONTINUE
4838 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4839 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4840 M2STRG = NHKK
4841* register string
4842 JSTRG = 100*IPROCE+NCODE(I)
4843 PX = PHEP(1,IDXSTG)
4844 PY = PHEP(2,IDXSTG)
4845 PZ = PHEP(3,IDXSTG)
4846 PE = PHEP(4,IDXSTG)
4847 IF (MODE.LT.0) THEN
4848 ISTAT = 70000+IPJE
4849 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4850 & PX,PY,PZ,PE,0,0,0)
4851 IF (LEMCCK) THEN
4852 PX = -PX
4853 PY = -PY
4854 PZ = -PZ
4855 PE = -PE
4856 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4857 ENDIF
4858 ELSE
4859 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4860 & PPX,PPY,PPZ,PPE)
4861 ISTAT = 70000+IPJE
4862 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4863 & PPX,PPY,PPZ,PPE,0,0,0)
4864 IF (LEMCCK) THEN
4865 PX = -PPX
4866 PY = -PPY
4867 PZ = -PPZ
4868 PE = -PPE
4869 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4870 ENDIF
4871 ENDIF
4872 NOBAM(NHKK) = 0
4873 IHIST(1,NHKK) = 0
4874 IHIST(2,NHKK) = 0
4875 DO 18 KK=1,4
4876 VHKK(KK,NHKK) = VHKK(KK,MO2)
4877 WHKK(KK,NHKK) = WHKK(KK,MO1)
4878 18 CONTINUE
4879 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4880 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4881 ENDIF
4882 11 CONTINUE
4883
4884 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4885 NHKK = INHKK
4886 LFLIP = .FALSE.
4887 GOTO 1
4888 ENDIF
4889
4890 IF (LEMCCK) THEN
4891 IF (UMO.GT.1.0D5) THEN
4892 CHKLEV = 1.0D0
4893 ELSE
4894 CHKLEV = TINY1
4895 ENDIF
4896 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4897
4898 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4899
4900 ENDIF
4901
4902* internal statistics
4903* dble-Po statistics.
4904 IF (IPROCE.NE.4) IPOPO = 0
4905
4906 INTFLG = IPROCE
4907 IDCHSY = IDCH(MO1)
4908 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4909 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4910 ELSE
4911 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4912 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4913 & ') at evt(chain) ',I6,'(',I2,')')
4914 ENDIF
4915 IF (IPROCE.EQ.5) THEN
4916 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4917 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4918 ELSE
4919C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4920 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4921 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4922 ENDIF
4923 ELSEIF (IPROCE.EQ.6) THEN
4924 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4925 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4926 ELSE
4927C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4928 ENDIF
4929 ELSEIF (IPROCE.EQ.7) THEN
4930 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4931 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4932 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4933 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4934 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4935 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4936 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4937 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4938 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4939 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4940 ELSE
4941 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4942 ENDIF
4943 ENDIF
4944 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4945 & THEN
4946 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4947 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4948 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4949 ENDIF
4950 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4951 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4952 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4953 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4954 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4955
4956 RETURN
4957
4958 9999 CONTINUE
4959 IREJ = 1
4960 RETURN
4961 END
4962
4963*$ CREATE DT_PHOINI.FOR
4964*COPY DT_PHOINI
4965*
4966*===phoini=============================================================*
4967*
4968 SUBROUTINE DT_PHOINI
4969
4970************************************************************************
4971* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4972* This version dated 16.11.95 is written by S. Roesler *
4973* *
4974* Last change 27.12.2006 by S. Roesler. *
4975************************************************************************
4976
4977 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4978 SAVE
4979
4980 PARAMETER ( LINP = 10 ,
4981 & LOUT = 6 ,
4982 & LDAT = 9 )
4983
4984 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4985
4986* nucleon-nucleon event-generator
4987 CHARACTER*8 CMODEL
4988 LOGICAL LPHOIN
4989 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4990
4991* particle properties (BAMJET index convention)
4992 CHARACTER*8 ANAME
4993 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4994 & IICH(210),IIBAR(210),K1(210),K2(210)
4995
4996* Lorentz-parameters of the current interaction
4997 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4998 & UMO,PPCM,EPROJ,PPROJ
4999
5000* properties of interacting particles
5001 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5002
5003* properties of photon/lepton projectiles
5004 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5005
5006 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5007
5008* emulsion treatment
5009 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5010 & NCOMPO,IEMUL
5011
5012* VDM parameter for photon-nucleus interactions
5013 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5014
5015* nuclear potential
5016 LOGICAL LFERMI
5017 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5018 & EBINDP(2),EBINDN(2),EPOT(2,210),
5019 & ETACOU(2),ICOUL,LFERMI
5020
5021* Glauber formalism: flags and parameters for statistics
5022 LOGICAL LPROD
5023 CHARACTER*8 CGLB
5024 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5025*
5026* parameters for cascade calculations:
5027* maximum mumber of PDF's which can be defined in phojet (limited
5028* by the dimension of ipdfs in pho_setpdf)
5029 PARAMETER (MAXPDF = 20)
5030* PDF parametrization and number of set for the first 30 hadrons in
5031* the bamjet-code list
5032* negative numbers mean that the PDF is set in phojet,
5033* zero stands for "not a hadron"
5034 DIMENSION IPARPD(30),ISETPD(30)
5035* PDF parametrization
5036 DATA IPARPD /
5037 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5038 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5039* number of set
5040 DATA ISETPD /
5041 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5042 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5043
5044**PHOJET105a
5045C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5046C PARAMETER ( MAXPRO = 16 )
5047C PARAMETER ( MAXTAB = 20 )
5048C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5049C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5050C CHARACTER*8 MDLNA
5051C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5052C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5053**PHOJET110
5054
5055C global event kinematics and particle IDs
5056 INTEGER IFPAP,IFPAB
5057 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5058 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5059
5060C hard cross sections and MC selection weights
5061 INTEGER Max_pro_2
5062 PARAMETER ( Max_pro_2 = 16 )
5063 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5064 & MH_acc_1,MH_acc_2
5065 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5066 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5067 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5068 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5069 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5070 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5071
5072C model switches and parameters
5073 CHARACTER*8 MDLNA
5074 INTEGER ISWMDL,IPAMDL
5075 DOUBLE PRECISION PARMDL
5076 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5077
5078C general process information
5079 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5080 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5081**
5082 DIMENSION PP(4),PT(4)
5083
5084 LOGICAL LSTART
5085 DATA LSTART /.TRUE./
5086
5087 IJP = IJPROJ
5088 IJT = IJTARG
5089 Q2 = VIRT
5090* lepton-projectiles: initialize real photon instead
5091 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5092 IJP = 7
5093 Q2 = ZERO
5094 ENDIF
5095
5096 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5097
5098* switch Reggeon off
5099C IPAMDL(3)= 0
5100 IF (IP.EQ.1) THEN
5101 IFPAP(1) = IDT_IPDGHA(IJP)
5102 IFPAB(1) = IJP
5103 ELSE
5104 IFPAP(1) = 2212
5105 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5106 ENDIF
5107 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5108 PVIRT(1) = PMASS(1)**2
5109 IF (IT.EQ.1) THEN
5110 IFPAP(2) = IDT_IPDGHA(IJT)
5111 IFPAB(2) = IJT
5112 ELSE
5113 IFPAP(2) = 2212
5114 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5115 ENDIF
5116 PMASS(2) = AAM(IFPAB(2))
5117 PVIRT(2) = ZERO
5118 DO 1 K=1,4
5119 PP(K) = ZERO
5120 PT(K) = ZERO
5121 1 CONTINUE
5122* get max. possible momenta of incoming particles to be used for PHOJET ini.
5123 PPF = ZERO
5124 PTF = ZERO
5125 SCPF= 1.5D0
5126 IF (UMO.GE.1.E5) THEN
5127 SCPF= 5.0D0
5128 ENDIF
5129 IF (NCOMPO.GT.0) THEN
5130 DO 2 I=1,NCOMPO
5131 IF (IT.GT.1) THEN
5132 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5133 ELSE
5134 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5135 ENDIF
5136 PPFTMP = MAX(PFERMP(1),PFERMN(1))
5137 PTFTMP = MAX(PFERMP(2),PFERMN(2))
5138 IF (PPFTMP.GT.PPF) PPF = PPFTMP
5139 IF (PTFTMP.GT.PTF) PTF = PTFTMP
5140 2 CONTINUE
5141 ELSE
5142 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5143 PPF = MAX(PFERMP(1),PFERMN(1))
5144 PTF = MAX(PFERMP(2),PFERMN(2))
5145 ENDIF
5146 PTF = -PTF
5147 PPF = SCPF*PPF
5148 PTF = SCPF*PTF
5149 IF (IJP.EQ.7) THEN
5150 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5151 PP(3) = PPCM
5152 PP(4) = SQRT(AMP2+PP(3)**2)
5153 ELSE
5154 EPF = SQRT(PPF**2+PMASS(1)**2)
5155 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5156 ENDIF
5157 ETF = SQRT(PTF**2+PMASS(2)**2)
5158 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5159 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5160 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5161 IF (LSTART) THEN
5162 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5163 1001 FORMAT(
5164 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
5165 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5166 IF (NCOMPO.GT.0) THEN
5167 WRITE(LOUT,1002) SCPF,PTF,PT
5168 ELSE
5169 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5170 ENDIF
5171 1002 FORMAT(
5172 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
5173 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5174 1003 FORMAT(
5175 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
5176 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5177 WRITE(LOUT,1004) ECMINI
5178 1004 FORMAT(' E_cm = ',E10.3)
5179 IF (IJP.EQ.8) WRITE(LOUT,1005)
5180 1005 FORMAT(
5181 & ' DT_PHOINI: warning! proton parameters used for neutron',
5182 & ' projectile')
5183 LSTART = .FALSE.
5184 ENDIF
5185* switch off new diffractive cross sections at low energies for nuclei
5186* (temporary solution)
5187 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5188 WRITE(LOUT,'(1X,A)')
5189 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5190 CALL PHO_SETMDL(30,0,1)
5191 ENDIF
5192*
5193C IF (IJP.EQ.7) THEN
5194C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5195C PP(3) = PPCM
5196C PP(4) = SQRT(AMP2+PP(3)**2)
5197C ELSE
5198C PFERMX = ZERO
5199C IF (IP.GT.1) PFERMX = 0.5D0
5200C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5201C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5202C ENDIF
5203C PFERMX = ZERO
5204C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5205C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5206C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5207**sr 26.10.96
5208 ISAV = IPAMDL(13)
5209 IF ((ISHAD(2).EQ.1).AND.
5210 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5211 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5212**
5213
5214 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5215
5216**sr 26.10.96
5217 IPAMDL(13) = ISAV
5218**
5219*
5220* patch for cascade calculations:
5221* define parton distribution functions for other hadrons, i.e. other
5222* then defined already in phojet
5223 IF (IOGLB.EQ.100) THEN
5224 WRITE(LOUT,1006)
5225 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5226 & ' assiged (ID,IPAR,ISET)',/)
5227 NPDF = 0
5228 DO 3 I=1,30
5229 IF (IPARPD(I).NE.0) THEN
5230 NPDF = NPDF+1
5231 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5232 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5233 IDPDG = IDT_IPDGHA(I)
5234 IPAR = IPARPD(I)
5235 ISET = ISETPD(I)
5236 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5237 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5238 ENDIF
5239 ENDIF
5240 3 CONTINUE
5241 ENDIF
5242
5243C CALL PHO_PHIST(-1,SIGMAX)
5244
5245 IF (IREJ1.NE.0) THEN
5246 WRITE(LOUT,1000)
5247 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
5248 STOP
5249 ENDIF
5250
5251 RETURN
5252 END
5253
5254*$ CREATE DT_EVENTD.FOR
5255*COPY DT_EVENTD
5256*
5257*===eventd=============================================================*
5258*
5259 SUBROUTINE DT_EVENTD(IREJ)
5260
5261************************************************************************
5262* Quasi-elastic neutrino nucleus scattering. *
5263* This version dated 29.04.00 is written by S. Roesler. *
5264************************************************************************
5265
5266 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5267 SAVE
5268
5269 PARAMETER ( LINP = 10 ,
5270 & LOUT = 6 ,
5271 & LDAT = 9 )
5272
5273 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5274 PARAMETER (SQTINF=1.0D+15)
5275
5276 LOGICAL LFIRST
5277
5278* event history
5279
5280 PARAMETER (NMXHKK=200000)
5281
5282 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5283 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5284 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5285
5286* extended event history
5287 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5288 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5289 & IHIST(2,NMXHKK)
5290
5291* flags for input different options
5292 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5293 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5294 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5295 PARAMETER (MAXLND=4000)
5296 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5297
5298* properties of interacting particles
5299 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5300
5301* Lorentz-parameters of the current interaction
5302 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5303 & UMO,PPCM,EPROJ,PPROJ
5304
5305* nuclear potential
5306 LOGICAL LFERMI
5307 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5308 & EBINDP(2),EBINDN(2),EPOT(2,210),
5309 & ETACOU(2),ICOUL,LFERMI
5310
5311* steering flags for qel neutrino scattering modules
5312 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5313
5314 COMMON /QNPOL/ POLARX(4),PMODUL
5315
5316 INTEGER PYK
5317
5318 DATA LFIRST /.TRUE./
5319
5320 IREJ = 0
5321
5322 IF (LFIRST) THEN
5323 LFIRST = .FALSE.
5324 CALL DT_MASS_INI
5325 ENDIF
5326
5327* JETSET parameter
5328 CALL DT_INITJS(0)
5329
5330* interacting target nucleon
5331 LTYP = NEUTYP
5332 IF (NEUDEC.LE.9) THEN
5333 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5334 NUCTYP = 2112
5335 NUCTOP = 2
5336 ELSE
5337 NUCTYP = 2212
5338 NUCTOP = 1
5339 ENDIF
5340 ELSE
5341 RTYP = DT_RNDM(RTYP)
5342 ZFRAC = DBLE(ITZ)/DBLE(IT)
5343 IF (RTYP.LE.ZFRAC) THEN
5344 NUCTYP = 2212
5345 NUCTOP = 1
5346 ELSE
5347 NUCTYP = 2112
5348 NUCTOP = 2
5349 ENDIF
5350 ENDIF
5351
5352* select first nucleon in list with matching id and reset all other
5353* nucleons which have been marked as "wounded" by ININUC
5354 IFOUND = 0
5355 DO 1 I=1,NHKK
5356 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5357 ISTHKK(I) = 12
5358 IFOUND = 1
5359 IDX = I
5360 ELSE
5361 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5362 ENDIF
5363 1 CONTINUE
5364 IF (IFOUND.EQ.0)
5365 & STOP ' EVENTD: interacting target nucleon not found! '
5366
5367* correct position of proj. lepton: assume position of target nucleon
5368 DO 3 I=1,4
5369 VHKK(I,1) = VHKK(I,IDX)
5370 WHKK(I,1) = WHKK(I,IDX)
5371 3 CONTINUE
5372
5373* load initial momenta for conservation check
5374 IF (LEMCCK) THEN
5375 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5376 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5377 & 2,IDUM,IDUM)
5378 ENDIF
5379
5380* quasi-elastic scattering
5381 IF (NEUDEC.LT.9) THEN
5382 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5383 & PHKK(4,IDX),PHKK(5,IDX))
5384* CC event on p or n
5385 ELSEIF (NEUDEC.EQ.10) THEN
5386 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5387 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5388* NC event on p or n
5389 ELSEIF (NEUDEC.EQ.11) THEN
5390 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5391 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392 ENDIF
5393
5394* get final state particles from Lund-common and write them into HKKEVT
5395 NPOINT(1) = NHKK+1
5396 NPOINT(4) = NHKK+1
5397
5398 NLINES = PYK(0,1)
5399
5400 NHKK0 = NHKK+1
5401 DO 4 I=4,NLINES
5402 IF (K(I,1).EQ.1) THEN
5403 ID = K(I,2)
5404 PX = P(I,1)
5405 PY = P(I,2)
5406 PZ = P(I,3)
5407 PE = P(I,4)
5408 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5409 IDBJ = IDT_ICIHAD(ID)
5410 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5411 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5412 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5413 ENDIF
5414 VHKK(1,NHKK) = VHKK(1,IDX)
5415 VHKK(2,NHKK) = VHKK(2,IDX)
5416 VHKK(3,NHKK) = VHKK(3,IDX)
5417 VHKK(4,NHKK) = VHKK(4,IDX)
5418C IF (I.EQ.4) THEN
5419C WHKK(1,NHKK) = POLARX(1)
5420C WHKK(2,NHKK) = POLARX(2)
5421C WHKK(3,NHKK) = POLARX(3)
5422C WHKK(4,NHKK) = POLARX(4)
5423C ELSE
5424 WHKK(1,NHKK) = WHKK(1,IDX)
5425 WHKK(2,NHKK) = WHKK(2,IDX)
5426 WHKK(3,NHKK) = WHKK(3,IDX)
5427 WHKK(4,NHKK) = WHKK(4,IDX)
5428C ENDIF
5429 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5430 ENDIF
5431 4 CONTINUE
5432
5433 IF (LEMCCK) THEN
5434 CHKLEV = TINY5
5435 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5436 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5437 ENDIF
5438
5439* transform momenta into cms (as required for inc etc.)
5440 DO 5 I=NHKK0,NHKK
5441 IF (ISTHKK(I).EQ.1) THEN
5442 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5443 PHKK(3,I) = PZ
5444 PHKK(4,I) = PE
5445 ENDIF
5446 5 CONTINUE
5447
5448 RETURN
5449 END
5450*$ CREATE DT_KKEVNT.FOR
5451*COPY DT_KKEVNT
5452*
5453*===kkevnt=============================================================*
5454*
5455 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5456
5457************************************************************************
5458* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5459* without nuclear effects (one event). *
5460* This subroutine is an update of the previous version (KKEVT) written *
5461* by J. Ranft/ H.-J. Moehring. *
5462* This version dated 20.04.95 is written by S. Roesler *
5463************************************************************************
5464
5465 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5466 SAVE
5467
5468 PARAMETER ( LINP = 10 ,
5469 & LOUT = 6 ,
5470 & LDAT = 9 )
5471
5472 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5473
5474 PARAMETER ( MAXNCL = 260,
5475
5476 & MAXVQU = MAXNCL,
5477 & MAXSQU = 20*MAXVQU,
5478 & MAXINT = MAXVQU+MAXSQU)
5479
5480* event history
5481
5482 PARAMETER (NMXHKK=200000)
5483
5484 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487
5488* extended event history
5489 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5490 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5491 & IHIST(2,NMXHKK)
5492
5493* flags for input different options
5494 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5495 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5496 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5497
5498* rejection counter
5499 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5500 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5501 & IREXCI(3),IRDIFF(2),IRINC
5502
5503* statistics
5504 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5505 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5506 & ICEVTG(8,0:30)
5507
5508* properties of interacting particles
5509 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5510
5511* Lorentz-parameters of the current interaction
5512 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5513 & UMO,PPCM,EPROJ,PPROJ
5514
5515* flags for diffractive interactions (DTUNUC 1.x)
5516 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5517
5518* interface HADRIN-DPM
5519 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5520
5521* nucleon-nucleon event-generator
5522 CHARACTER*8 CMODEL
5523 LOGICAL LPHOIN
5524 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5525
5526* coordinates of nucleons
5527 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5528
5529* interface between Glauber formalism and DPM
5530 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5531 & INTER1(MAXINT),INTER2(MAXINT)
5532
5533* Glauber formalism: collision properties
5534 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
ebb0c0e0 5535 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5536 & NCP,NCT
7b076c76 5537
5538* central particle production, impact parameter biasing
5539 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5540**temporary
5541
5542* statistics: Glauber-formalism
5543 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5544**
5545
5546 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5547
5548 IREJ = 0
5549 ICREQU = ICREQU+1
5550 NC = 0
ebb0c0e0 5551 NCP = 0
5552 NCT = 0
7b076c76 5553
5554 1 CONTINUE
5555 ICSAMP = ICSAMP+1
5556 NC = NC+1
5557 IF (MOD(NC,10).EQ.0) THEN
5558 WRITE(LOUT,1000) NEVHKK
5559 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5560 GOTO 9999
5561 ENDIF
5562
5563* initialize DTEVT1/DTEVT2
5564 CALL DT_EVTINI
5565
5566* We need the following only in order to sample nucleon coordinates.
5567* However we don't have parameters (cross sections, slope etc.)
5568* for neutrinos available. Therefore switch projectile to proton
5569* in this case.
5570 IF (MCGENE.EQ.4) THEN
5571 JJPROJ = 1
5572 ELSE
5573 JJPROJ = IJPROJ
5574 ENDIF
5575
5576 10 CONTINUE
5577 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5578* make sure that Glauber-formalism is called each time the interaction
5579* configuration changed
5580 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5581 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5582* sample number of nucleon-nucleon coll. according to Glauber-form.
5583 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5584 NWTSAM = NN
5585 NWASAM = NP
5586 NWBSAM = NT
5587 NEVOLD = NEVHKK
5588 IPOLD = IP
5589 ITOLD = IT
5590 JJPOLD = JJPROJ
5591 EPROLD = EPROJ
7d5a4d62 5592 DO 8 I=1, IP
ebb0c0e0 5593 NCP = NCP+JSSH(I)
5594* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5595 8 CONTINUE
7d5a4d62 5596 DO 9 I=1, IT
ebb0c0e0 5597 NCT = NCT+JTSH(I)
5598* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5599 9 CONTINUE
7b076c76 5600 ENDIF
5601
5602* force diffractive particle production in h-K interactions
5603 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5604 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5605 NEVOLD = 0
5606 GOTO 10
5607 ENDIF
5608
5609* check number of involved proj. nucl. (NP) if central prod.is requested
5610 IF (ICENTR.GT.0) THEN
5611 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5612 IF (IBACK.GT.0) GOTO 10
5613 ENDIF
5614
5615* get initial nucleon-configuration in projectile and target
5616* rest-system (including Fermi-momenta if requested)
5617 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5618 MODE = 2
5619 IF (EPROJ.LE.EHADTH) MODE = 3
5620 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5621
5622 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5623
5624* activate HADRIN at low energies (implemented for h-N scattering only)
5625 IF (EPROJ.LE.EHADHI) THEN
5626 IF (EHADTH.LT.ZERO) THEN
5627* smooth transition btwn. DPM and HADRIN
5628 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5629 RR = DT_RNDM(FRAC)
5630 IF (RR.GT.FRAC) THEN
5631 IF (IP.EQ.1) THEN
5632 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633 IF (IREJ1.GT.0) GOTO 1
5634 RETURN
5635 ELSE
5636 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5637 ENDIF
5638 ENDIF
5639 ELSE
5640* fixed threshold for onset of production via HADRIN
5641 IF (EPROJ.LE.EHADTH) THEN
5642 IF (IP.EQ.1) THEN
5643 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5644 IF (IREJ1.GT.0) GOTO 1
5645 RETURN
5646 ELSE
5647 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5648 ENDIF
5649 ENDIF
5650 ENDIF
5651 ENDIF
5652 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5653 & I3,') with target (m=',I3,')',/,11X,
5654 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5655 & 'GeV) cannot be handled')
5656
5657* sampling of momentum-x fractions & flavors of chain ends
5658 CALL DT_SPLPTN(NN)
5659
5660* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5661 CALL DT_NUC2CM
5662
5663* collect momenta of chain ends and put them into DTEVT1
5664 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5665 IF (IREJ1.NE.0) GOTO 1
5666
5667 ENDIF
5668
5669* handle chains including fragmentation (two-chain approximation)
5670 IF (MCGENE.EQ.1) THEN
5671* two-chain approximation
5672 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5673 IF (IREJ1.NE.0) THEN
5674 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5675 GOTO 1
5676 ENDIF
5677 ELSEIF (MCGENE.EQ.2) THEN
5678* multiple-Po exchange including minijets
5679 CALL DT_EVENTB(NCSY,IREJ1)
5680 IF (IREJ1.NE.0) THEN
5681 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5682 GOTO 1
5683 ENDIF
5684 ELSEIF (MCGENE.EQ.3) THEN
5685 STOP ' This version does not contain LEPTO !'
5686
5687 ELSEIF (MCGENE.EQ.4) THEN
5688* quasi-elastic neutrino scattering
5689 CALL DT_EVENTD(IREJ1)
5690 IF (IREJ1.NE.0) THEN
5691 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5692 GOTO 1
5693 ENDIF
5694 ELSE
5695 WRITE(LOUT,1002) MCGENE
5696 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5697 & ' not available - program stopped')
5698 STOP
5699 ENDIF
5700
5701 RETURN
5702
5703 9999 CONTINUE
5704 IREJ = 1
5705 RETURN
5706 END
5707
5708*$ CREATE DT_CHKCEN.FOR
5709*COPY DT_CHKCEN
5710*
5711*===chkcen=============================================================*
5712*
5713 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5714
5715************************************************************************
5716* Check of number of involved projectile nucleons if central production*
5717* is requested. *
5718* Adopted from a part of the old KKEVT routine which was written by *
5719* J. Ranft/H.-J.Moehring. *
5720* This version dated 13.01.95 is written by S. Roesler *
5721************************************************************************
5722
5723 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5724 SAVE
5725
5726 PARAMETER ( LINP = 10 ,
5727 & LOUT = 6 ,
5728 & LDAT = 9 )
5729
5730* statistics
5731 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5733 & ICEVTG(8,0:30)
5734
5735* central particle production, impact parameter biasing
5736 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5737
5738 IBACK = 0
5739
5740* old version
5741 IF (ICENTR.EQ.2) THEN
5742 IF (IP.LT.IT) THEN
5743 IF (IP.LE.8) THEN
5744 IF (NP.LT.IP-1) IBACK = 1
5745 ELSEIF (IP.LE.16) THEN
5746 IF (NP.LT.IP-2) IBACK = 1
5747 ELSEIF (IP.LE.32) THEN
5748 IF (NP.LT.IP-3) IBACK = 1
5749 ELSEIF (IP.GE.33) THEN
5750 IF (NP.LT.IP-5) IBACK = 1
5751 ENDIF
5752 ELSEIF (IP.EQ.IT) THEN
5753 IF (IP.EQ.32) THEN
5754 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5755 ELSE
5756 IF (NP.LT.IP-IP/8) IBACK = 1
5757 ENDIF
5758 ELSEIF (ABS(IP-IT).LT.3) THEN
5759 IF (NP.LT.IP-IP/8) IBACK = 1
5760 ENDIF
5761 ELSE
5762* new version (DPMJET, 5.6.99)
5763 IF (IP.LT.IT) THEN
5764 IF (IP.LE.8) THEN
5765 IF (NP.LT.IP-1) IBACK = 1
5766 ELSEIF (IP.LE.16) THEN
5767 IF (NP.LT.IP-2) IBACK = 1
5768 ELSEIF (IP.LT.32) THEN
5769 IF (NP.LT.IP-3) IBACK = 1
5770 ELSEIF (IP.GE.32) THEN
5771 IF (IT.LE.150) THEN
5772* Example: S-Ag
5773 IF (NP.LT.IP-1) IBACK = 1
5774 ELSE
5775* Example: S-Au
5776 IF (NP.LT.IP) IBACK = 1
5777 ENDIF
5778 ENDIF
5779 ELSEIF (IP.EQ.IT) THEN
5780* Example: S-S
5781 IF (IP.EQ.32) THEN
5782 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5783* Example: Pb-Pb
5784 ELSE
5785 IF (NP.LT.IP-IP/4) IBACK = 1
5786 ENDIF
5787 ELSEIF (ABS(IP-IT).LT.3) THEN
5788 IF (NP.LT.IP-IP/8) IBACK = 1
5789 ENDIF
5790 ENDIF
5791
5792 ICCPRO = ICCPRO+1
5793
5794 RETURN
5795 END
5796
5797*$ CREATE DT_ININUC.FOR
5798*COPY DT_ININUC
5799*
5800*===ininuc=============================================================*
5801*
5802 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5803
5804************************************************************************
5805* Samples initial configuration of nucleons in nucleus with mass NMASS *
5806* including Fermi-momenta (if reqested). *
5807* ID BAMJET-code for hadrons (instead of nuclei) *
5808* NMASS mass number of nucleus (number of nucleons) *
5809* NCH charge of nucleus *
5810* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5811* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5812* IMODE = 1 projectile nucleus *
5813* = 2 target nucleus *
5814* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5815* Adopted from a part of the old KKEVT routine which was written by *
5816* J. Ranft/H.-J.Moehring. *
5817* This version dated 13.01.95 is written by S. Roesler *
5818************************************************************************
5819
5820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5821 SAVE
5822
5823 PARAMETER ( LINP = 10 ,
5824 & LOUT = 6 ,
5825 & LDAT = 9 )
5826
5827 PARAMETER (FM2MM=1.0D-12)
5828
5829 PARAMETER ( MAXNCL = 260,
5830
5831 & MAXVQU = MAXNCL,
5832 & MAXSQU = 20*MAXVQU,
5833 & MAXINT = MAXVQU+MAXSQU)
5834
5835* event history
5836
5837 PARAMETER (NMXHKK=200000)
5838
5839 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5840 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5841 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5842
5843* extended event history
5844 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5845 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5846 & IHIST(2,NMXHKK)
5847
5848* flags for input different options
5849 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5850 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5851 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5852
5853* auxiliary common for chain system storage (DTUNUC 1.x)
5854 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5855
5856* nuclear potential
5857 LOGICAL LFERMI
5858 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5859 & EBINDP(2),EBINDN(2),EPOT(2,210),
5860 & ETACOU(2),ICOUL,LFERMI
5861
5862* properties of photon/lepton projectiles
5863 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5864
5865* particle properties (BAMJET index convention)
5866 CHARACTER*8 ANAME
5867 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5868 & IICH(210),IIBAR(210),K1(210),K2(210)
5869
5870* Glauber formalism: collision properties
5871 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5872 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5873
5874* flavors of partons (DTUNUC 1.x)
5875 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5876 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5877 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5878 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5879 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5880 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5881 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5882
5883* interface HADRIN-DPM
5884 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5885
5886 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5887
5888* number of neutrons
5889 NNEU = NMASS-NCH
5890* initializations
5891 NP = 0
5892 NN = 0
5893 DO 1 K=1,4
5894 PFTOT(K) = 0.0D0
5895 1 CONTINUE
5896 MODE = IMODE
5897 IF (IMODE.GT.2) MODE = 2
5898**sr 29.5. new NPOINT(1)-definition
5899C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5900**
5901 NHADRI = 0
5902 NC = NHKK
5903
5904* get initial configuration
5905 DO 2 I=1,NMASS
5906 NHKK = NHKK+1
5907 IF (JS(I).GT.0) THEN
5908 ISTHKK(NHKK) = 10+MODE
5909 IF (IMODE.EQ.3) THEN
5910* additional treatment if HADRIN-generator is requested
5911 NHADRI = NHADRI+1
5912 IF (NHADRI.EQ.1) IDXTA = NHKK
5913 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5914 ENDIF
5915 ELSE
5916 ISTHKK(NHKK) = 12+MODE
5917 ENDIF
5918 IF (NMASS.GE.2) THEN
5919* treatment for nuclei
5920 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5921 RR = DT_RNDM(FRAC)
5922 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5923 IDX = 8
5924 NN = NN+1
5925 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5926 IDX = 1
5927 NP = NP+1
5928 ELSEIF (NN.LT.NNEU) THEN
5929 IDX = 8
5930 NN = NN+1
5931 ELSEIF (NP.LT.NCH) THEN
5932 IDX = 1
5933 NP = NP+1
5934 ENDIF
5935 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5936 IDBAM(NHKK) = IDX
5937 IF (MODE.EQ.1) THEN
5938 IPOSP(I) = NHKK
5939 KKPROJ(I) = IDX
5940 ELSE
5941 IPOST(I) = NHKK
5942 KKTARG(I) = IDX
5943 ENDIF
5944 IF (IDX.EQ.1) THEN
5945 PFER = PFERMP(MODE)
5946 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5947 ELSE
5948 PFER = PFERMN(MODE)
5949 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5950 ENDIF
5951 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5952 DO 3 K=1,4
5953 PFTOT(K) = PFTOT(K)+PF(K)
5954 PHKK(K,NHKK) = PF(K)
5955 3 CONTINUE
5956 PHKK(5,NHKK) = AAM(IDX)
5957 ELSE
5958* treatment for hadrons
5959 IDHKK(NHKK) = IDT_IPDGHA(ID)
5960 IDBAM(NHKK) = ID
5961 PHKK(4,NHKK) = AAM(ID)
5962 PHKK(5,NHKK) = AAM(ID)
5963C* VDM assumption
5964C IF (IDHKK(NHKK).EQ.22) THEN
5965C PHKK(4,NHKK) = AAM(33)
5966C PHKK(5,NHKK) = AAM(33)
5967C ENDIF
5968 IF (MODE.EQ.1) THEN
5969 IPOSP(I) = NHKK
5970 KKPROJ(I) = ID
5971 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5972 ELSE
5973 IPOST(I) = NHKK
5974 KKTARG(I) = ID
5975 ENDIF
5976 ENDIF
5977 DO 4 K=1,3
5978 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5979 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5980 4 CONTINUE
5981 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5982 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5983 VHKK(4,NHKK) = 0.0D0
5984 WHKK(4,NHKK) = 0.0D0
5985 2 CONTINUE
5986
5987* balance Fermi-momenta
5988 IF (NMASS.GE.2) THEN
5989 DO 5 I=1,NMASS
5990 NC = NC+1
5991 DO 6 K=1,3
5992 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5993 6 CONTINUE
5994 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5995 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5996 5 CONTINUE
5997 ENDIF
5998
5999 RETURN
6000 END
6001
6002*$ CREATE DT_FER4M.FOR
6003*COPY DT_FER4M
6004*
6005*===fer4m==============================================================*
6006*
6007 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6008
6009************************************************************************
6010* Sampling of nucleon Fermi-momenta from distributions at T=0. *
6011* processed by S. Roesler, 17.10.95 *
6012************************************************************************
6013
6014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6015 SAVE
6016
6017 PARAMETER ( LINP = 10 ,
6018 & LOUT = 6 ,
6019 & LDAT = 9 )
6020
6021 LOGICAL LSTART
6022
6023* particle properties (BAMJET index convention)
6024 CHARACTER*8 ANAME
6025 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6026 & IICH(210),IIBAR(210),K1(210),K2(210)
6027
6028* nuclear potential
6029 LOGICAL LFERMI
6030 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6031 & EBINDP(2),EBINDN(2),EPOT(2,210),
6032 & ETACOU(2),ICOUL,LFERMI
6033
6034 DATA LSTART /.TRUE./
6035
6036 ILOOP = 0
6037 IF (LFERMI) THEN
6038 IF (LSTART) THEN
6039 WRITE(LOUT,1000)
6040 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6041 LSTART = .FALSE.
6042 ENDIF
6043 1 CONTINUE
6044 CALL DT_DFERMI(PABS)
6045 PABS = PFERM*PABS
6046C IF (PABS.GE.PBIND) THEN
6047C ILOOP = ILOOP+1
6048C IF (MOD(ILOOP,500).EQ.0) THEN
6049C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6050C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6051C & ' energy ',2E12.3,I6)
6052C ENDIF
6053C GOTO 1
6054C ENDIF
6055 CALL DT_DPOLI(POLC,POLS)
6056 CALL DT_DSFECF(SFE,CFE)
6057 CXTA = POLS*CFE
6058 CYTA = POLS*SFE
6059 CZTA = POLC
6060 ET = SQRT(PABS*PABS+AAM(KT)**2)
6061 PXT = CXTA*PABS
6062 PYT = CYTA*PABS
6063 PZT = CZTA*PABS
6064 ELSE
6065 ET = AAM(KT)
6066 PXT = 0.0D0
6067 PYT = 0.0D0
6068 PZT = 0.0D0
6069 ENDIF
6070
6071 RETURN
6072 END
6073
6074*$ CREATE DT_NUC2CM.FOR
6075*COPY DT_NUC2CM
6076*
6077*===nuc2cm=============================================================*
6078*
6079 SUBROUTINE DT_NUC2CM
6080
6081************************************************************************
6082* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6083* nucl. cms. (This subroutine replaces NUCMOM.) *
6084* This version dated 15.01.95 is written by S. Roesler *
6085************************************************************************
6086
6087 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6088 SAVE
6089
6090 PARAMETER ( LINP = 10 ,
6091 & LOUT = 6 ,
6092 & LDAT = 9 )
6093
6094 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6095
6096* event history
6097
6098 PARAMETER (NMXHKK=200000)
6099
6100 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6101 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6102 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6103
6104* extended event history
6105 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6106 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6107 & IHIST(2,NMXHKK)
6108
6109* statistics
6110 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6111 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6112 & ICEVTG(8,0:30)
6113
6114* properties of photon/lepton projectiles
6115 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6116
6117* particle properties (BAMJET index convention)
6118 CHARACTER*8 ANAME
6119 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6120 & IICH(210),IIBAR(210),K1(210),K2(210)
6121
6122* Glauber formalism: collision properties
6123 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6124 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6125**temporary
6126
6127* statistics: Glauber-formalism
6128 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6129**
6130
6131 ICWP = 0
6132 ICWT = 0
6133 NWTACC = 0
6134 NWAACC = 0
6135 NWBACC = 0
6136
6137 NPOINT(1) = NHKK+1
6138 NEND = NHKK
6139 DO 1 I=1,NEND
6140 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6141 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6142 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6143 MODE = ISTHKK(I)-9
6144C IF (IDHKK(I).EQ.22) THEN
6145C* VDM assumption
6146C PEIN = AAM(33)
6147C IDB = 33
6148C ELSE
6149C PEIN = PHKK(4,I)
6150C IDB = IDBAM(I)
6151C ENDIF
6152C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6153C & PX,PY,PZ,PE,IDB,MODE)
6154 IF (PHKK(5,I).GT.ZERO) THEN
6155 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6156 & PX,PY,PZ,PE,IDBAM(I),MODE)
6157 ELSE
6158 PX = PGAMM(1)
6159 PY = PGAMM(2)
6160 PZ = PGAMM(3)
6161 PE = PGAMM(4)
6162 ENDIF
6163 IST = ISTHKK(I)-2
6164 ID = IDHKK(I)
6165C* VDM assumption
6166C IF (ID.EQ.22) ID = 113
6167 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6168 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6169 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6170 ENDIF
6171 1 CONTINUE
6172
6173 NWTACC = MAX(NWAACC,NWBACC)
6174 ICDPR = ICDPR+ICWP
6175 ICDTA = ICDTA+ICWT
6176**temporary
6177 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6178 CALL DT_EVTOUT(4)
6179 STOP
6180 ENDIF
6181
6182 RETURN
6183 END
6184
6185*$ CREATE DT_SPLPTN.FOR
6186*COPY DT_SPLPTN
6187*
6188*===splptn=============================================================*
6189*
6190 SUBROUTINE DT_SPLPTN(NN)
6191
6192************************************************************************
6193* SamPLing of ParToN momenta and flavors. *
6194* This version dated 15.01.95 is written by S. Roesler *
6195************************************************************************
6196
6197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6198 SAVE
6199
6200 PARAMETER ( LINP = 10 ,
6201 & LOUT = 6 ,
6202 & LDAT = 9 )
6203
6204* Lorentz-parameters of the current interaction
6205 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6206 & UMO,PPCM,EPROJ,PPROJ
6207
6208* sample flavors of sea-quarks
6209 CALL DT_SPLFLA(NN,1)
6210
6211* sample x-values of partons at chain ends
6212 ECM = UMO
6213 CALL DT_XKSAMP(NN,ECM)
6214
6215* samle flavors
6216 CALL DT_SPLFLA(NN,2)
6217
6218 RETURN
6219 END
6220
6221*$ CREATE DT_SPLFLA.FOR
6222*COPY DT_SPLFLA
6223*
6224*===splfla=============================================================*
6225*
6226 SUBROUTINE DT_SPLFLA(NN,MODE)
6227
6228************************************************************************
6229* SamPLing of FLAvors of partons at chain ends. *
6230* This subroutine replaces FLKSAA/FLKSAM. *
6231* NN number of nucleon-nucleon interactions *
6232* MODE = 1 sea-flavors *
6233* = 2 valence-flavors *
6234* Based on the original version written by J. Ranft/H.-J. Moehring. *
6235* This version dated 16.01.95 is written by S. Roesler *
6236************************************************************************
6237
6238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6239 SAVE
6240
6241 PARAMETER ( LINP = 10 ,
6242 & LOUT = 6 ,
6243 & LDAT = 9 )
6244
6245 PARAMETER ( MAXNCL = 260,
6246
6247 & MAXVQU = MAXNCL,
6248 & MAXSQU = 20*MAXVQU,
6249 & MAXINT = MAXVQU+MAXSQU)
6250
6251* flavors of partons (DTUNUC 1.x)
6252 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6253 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6254 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6255 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6256 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6257 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6258 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6259
6260* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6261 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6262 & IXPV,IXPS,IXTV,IXTS,
6263 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6264 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6265 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6266 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6267 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6268 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6269 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6270 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6271
6272* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6273 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6274 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6275
6276* particle properties (BAMJET index convention)
6277 CHARACTER*8 ANAME
6278 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6279 & IICH(210),IIBAR(210),K1(210),K2(210)
6280
6281* various options for treatment of partons (DTUNUC 1.x)
6282* (chain recombination, Cronin,..)
6283 LOGICAL LCO2CR,LINTPT
6284 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6285 & LCO2CR,LINTPT
6286
6287 IF (MODE.EQ.1) THEN
6288* sea-flavors
6289 DO 1 I=1,NN
6290 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6291 IPSAQ(I) = -IPSQ(I)
6292 1 CONTINUE
6293 DO 2 I=1,NN
6294 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6295 ITSAQ(I)= -ITSQ(I)
6296 2 CONTINUE
6297 ELSEIF (MODE.EQ.2) THEN
6298* valence flavors
6299 DO 3 I=1,IXPV
6300 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6301 3 CONTINUE
6302 DO 4 I=1,IXTV
6303 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6304 4 CONTINUE
6305 ENDIF
6306
6307 RETURN
6308 END
6309
6310*$ CREATE DT_GETPTN.FOR
6311*COPY DT_GETPTN
6312*
6313*===getptn=============================================================*
6314*
6315 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6316
6317************************************************************************
6318* This subroutine collects partons at chain ends from temporary *
6319* commons and puts them into DTEVT1. *
6320* This version dated 15.01.95 is written by S. Roesler *
6321************************************************************************
6322
6323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6324 SAVE
6325
6326 PARAMETER ( LINP = 10 ,
6327 & LOUT = 6 ,
6328 & LDAT = 9 )
6329
6330 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6331
6332 LOGICAL LCHK
6333
6334 PARAMETER ( MAXNCL = 260,
6335
6336 & MAXVQU = MAXNCL,
6337 & MAXSQU = 20*MAXVQU,
6338 & MAXINT = MAXVQU+MAXSQU)
6339
6340* event history
6341
6342 PARAMETER (NMXHKK=200000)
6343
6344 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6345 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6346 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6347
6348* extended event history
6349 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6350 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6351 & IHIST(2,NMXHKK)
6352
6353* flags for input different options
6354 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6355 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6356 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6357
6358* auxiliary common for chain system storage (DTUNUC 1.x)
6359 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6360
6361* statistics
6362 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6363 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6364 & ICEVTG(8,0:30)
6365
6366* flags for diffractive interactions (DTUNUC 1.x)
6367 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6368
6369* x-values of partons (DTUNUC 1.x)
6370 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6371 & XTVQ(MAXVQU),XTVD(MAXVQU),
6372 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6373 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6374
6375* flavors of partons (DTUNUC 1.x)
6376 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6377 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6378 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6379 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6380 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6381 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6382 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6383
6384* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6385 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6386 & IXPV,IXPS,IXTV,IXTS,
6387 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6388 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6389 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6390 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6391 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6392 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6393 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6394 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6395
6396* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6397 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6398 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6399
6400 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6401
6402 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6403
6404 IREJ = 0
6405 NCSY = 0
6406 NPOINT(2) = NHKK+1
6407
6408* sea-sea chains
6409 DO 10 I=1,NSS
6410 IF (ISKPCH(1,I).EQ.99) GOTO 10
6411 ICCHAI(1,1) = ICCHAI(1,1)+2
6412 IDXP = INTSS1(I)
6413 IDXT = INTSS2(I)
6414 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6415 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6416 DO 11 K=1,4
6417 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6418 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6419 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6420 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6421 11 CONTINUE
6422 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6423 & +(PP1(3)+PT1(3))**2)
6424 ECH = PP1(4)+PT1(4)
6425 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6426 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6427 & +(PP2(3)+PT2(3))**2)
6428 ECH = PP2(4)+PT2(4)
6429 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6430 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6431 AM1 = SQRT(AM1)
6432 AM2 = SQRT(AM2)
6433 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6434C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6435 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6436 ENDIF
6437 ELSE
6438 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6439 ENDIF
6440 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6441 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6442 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6443 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6444 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6445 & 0,0,1)
6446 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6447 & 0,0,1)
6448 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6449 & 0,0,1)
6450 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6451 & 0,0,1)
6452 NCSY = NCSY+1
6453 10 CONTINUE
6454
6455* disea-sea chains
6456 DO 20 I=1,NDS
6457 IF (ISKPCH(2,I).EQ.99) GOTO 20
6458 ICCHAI(1,2) = ICCHAI(1,2)+2
6459 IDXP = INTDS1(I)
6460 IDXT = INTDS2(I)
6461 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6462 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6463 DO 21 K=1,4
6464 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6465 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6466 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6467 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6468 21 CONTINUE
6469 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6470 & +(PP1(3)+PT1(3))**2)
6471 ECH = PP1(4)+PT1(4)
6472 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6473 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6474 & +(PP2(3)+PT2(3))**2)
6475 ECH = PP2(4)+PT2(4)
6476 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6477 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6478 AM1 = SQRT(AM1)
6479 AM2 = SQRT(AM2)
6480 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6481C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6482 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6483 ENDIF
6484 ELSE
6485 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6486 ENDIF
6487 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6488 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6489 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6490 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6491 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6492 & 0,0,2)
6493 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6494 & 0,0,2)
6495 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6496 & 0,0,2)
6497 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6498 & 0,0,2)
6499 NCSY = NCSY+1
6500 20 CONTINUE
6501
6502* sea-disea chains
6503 DO 30 I=1,NSD
6504 IF (ISKPCH(3,I).EQ.99) GOTO 30
6505 ICCHAI(1,3) = ICCHAI(1,3)+2
6506 IDXP = INTSD1(I)
6507 IDXT = INTSD2(I)
6508 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6509 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6510 DO 31 K=1,4
6511 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6512 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6513 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6514 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6515 31 CONTINUE
6516 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6517 & +(PP1(3)+PT1(3))**2)
6518 ECH = PP1(4)+PT1(4)
6519 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6520 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6521 & +(PP2(3)+PT2(3))**2)
6522 ECH = PP2(4)+PT2(4)
6523 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6524 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6525 AM1 = SQRT(AM1)
6526 AM2 = SQRT(AM2)
6527 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6528C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6529 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6530 ENDIF
6531 ELSE
6532 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6533 ENDIF
6534 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6535 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6536 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6537 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6538 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6539 & 0,0,3)
6540 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6541 & 0,0,3)
6542 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6543 & 0,0,3)
6544 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6545 & 0,0,3)
6546 NCSY = NCSY+1
6547 30 CONTINUE
6548
6549* disea-valence chains
6550 DO 50 I=1,NDV
6551 IF (ISKPCH(5,I).EQ.99) GOTO 50
6552 ICCHAI(1,5) = ICCHAI(1,5)+2
6553 IDXP = INTDV1(I)
6554 IDXT = INTDV2(I)
6555 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6556 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6557 DO 51 K=1,4
6558 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6559 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6560 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6561 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6562 51 CONTINUE
6563 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6564 & +(PP1(3)+PT1(3))**2)
6565 ECH = PP1(4)+PT1(4)
6566 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6567 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6568 & +(PP2(3)+PT2(3))**2)
6569 ECH = PP2(4)+PT2(4)
6570 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6571 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6572 AM1 = SQRT(AM1)
6573 AM2 = SQRT(AM2)
6574 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6575C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6576 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6577 ENDIF
6578 ELSE
6579 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6580 ENDIF
6581 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6582 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6583 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6584 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6585 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6586 & 0,0,5)
6587 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6588 & 0,0,5)
6589 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6590 & 0,0,5)
6591 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6592 & 0,0,5)
6593 NCSY = NCSY+1
6594 50 CONTINUE
6595
6596* valence-sea chains
6597 DO 60 I=1,NVS
6598 IF (ISKPCH(6,I).EQ.99) GOTO 60
6599 ICCHAI(1,6) = ICCHAI(1,6)+2
6600 IDXP = INTVS1(I)
6601 IDXT = INTVS2(I)
6602 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6603 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6604 DO 61 K=1,4
6605 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6606 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6607 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6608 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6609 61 CONTINUE
6610 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6611 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6612 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6613 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6614 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6615 IF (LCHK) THEN
6616 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6617 & 0,0,6)
6618 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6619 & 0,0,6)
6620 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6621 & 0,0,6)
6622 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6623 & 0,0,6)
6624 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6625 & +(PP1(3)+PT1(3))**2)
6626 ECH = PP1(4)+PT1(4)
6627 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6628 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6629 & +(PP2(3)+PT2(3))**2)
6630 ECH = PP2(4)+PT2(4)
6631 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6632 ELSE
6633 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6634 & 0,0,6)
6635 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6636 & 0,0,6)
6637 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6638 & 0,0,6)
6639 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6640 & 0,0,6)
6641 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6642 & +(PP1(3)+PT2(3))**2)
6643 ECH = PP1(4)+PT2(4)
6644 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6645 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6646 & +(PP2(3)+PT1(3))**2)
6647 ECH = PP2(4)+PT1(4)
6648 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6649 ENDIF
6650 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6651 AM1 = SQRT(AM1)
6652 AM2 = SQRT(AM2)
6653 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6654C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6655 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6656 ENDIF
6657 ELSE
6658 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6659 ENDIF
6660 NCSY = NCSY+1
6661 60 CONTINUE
6662
6663* sea-valence chains
6664 DO 40 I=1,NSV
6665 IF (ISKPCH(4,I).EQ.99) GOTO 40
6666 ICCHAI(1,4) = ICCHAI(1,4)+2
6667 IDXP = INTSV1(I)
6668 IDXT = INTSV2(I)
6669 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6670 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6671 DO 41 K=1,4
6672 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6673 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6674 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6675 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6676 41 CONTINUE
6677 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6678 & +(PP1(3)+PT1(3))**2)
6679 ECH = PP1(4)+PT1(4)
6680 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6681 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6682 & +(PP2(3)+PT2(3))**2)
6683 ECH = PP2(4)+PT2(4)
6684 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6685 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6686 AM1 = SQRT(AM1)
6687 AM2 = SQRT(AM2)
6688 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6689C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6690 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6691 ENDIF
6692 ELSE
6693 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6694 ENDIF
6695 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6696 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6697 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6698 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6699 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6700 & 0,0,4)
6701 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6702 & 0,0,4)
6703 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6704 & 0,0,4)
6705 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6706 & 0,0,4)
6707 NCSY = NCSY+1
6708 40 CONTINUE
6709
6710* valence-disea chains
6711 DO 70 I=1,NVD
6712 IF (ISKPCH(7,I).EQ.99) GOTO 70
6713 ICCHAI(1,7) = ICCHAI(1,7)+2
6714 IDXP = INTVD1(I)
6715 IDXT = INTVD2(I)
6716 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6717 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6718 DO 71 K=1,4
6719 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6720 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6721 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6722 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6723 71 CONTINUE
6724 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6725 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6726 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6727 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6728 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6729 IF (LCHK) THEN
6730 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6731 & 0,0,7)
6732 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6733 & 0,0,7)
6734 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6735 & 0,0,7)
6736 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6737 & 0,0,7)
6738 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6739 & +(PP1(3)+PT1(3))**2)
6740 ECH = PP1(4)+PT1(4)
6741 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6742 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6743 & +(PP2(3)+PT2(3))**2)
6744 ECH = PP2(4)+PT2(4)
6745 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6746 ELSE
6747 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6748 & 0,0,7)
6749 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6750 & 0,0,7)
6751 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6752 & 0,0,7)
6753 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6754 & 0,0,7)
6755 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6756 & +(PP1(3)+PT2(3))**2)
6757 ECH = PP1(4)+PT2(4)
6758 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6759 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6760 & +(PP2(3)+PT1(3))**2)
6761 ECH = PP2(4)+PT1(4)
6762 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6763 ENDIF
6764 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6765 AM1 = SQRT(AM1)
6766 AM2 = SQRT(AM2)
6767 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6768C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6769 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6770 ENDIF
6771 ELSE
6772 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6773 ENDIF
6774 NCSY = NCSY+1
6775 70 CONTINUE
6776
6777* valence-valence chains
6778 DO 80 I=1,NVV
6779 IF (ISKPCH(8,I).EQ.99) GOTO 80
6780 ICCHAI(1,8) = ICCHAI(1,8)+2
6781 IDXP = INTVV1(I)
6782 IDXT = INTVV2(I)
6783 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6784 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6785 DO 81 K=1,4
6786 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6787 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6788 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6789 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6790 81 CONTINUE
6791 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6792 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6793 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6794 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6795
6796* check for diffractive event
6797 IDIFF = 0
6798 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6799 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6800 DO 800 K=1,4
6801 PP(K) = PP1(K)+PP2(K)
6802 PT(K) = PT1(K)+PT2(K)
6803 800 CONTINUE
6804 ISTCK = NHKK
6805 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6806 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6807C IF (IREJ1.NE.0) GOTO 9999
6808 IF (IREJ1.NE.0) THEN
6809 IDIFF = 0
6810 NHKK = ISTCK
6811 ENDIF
6812 ELSE
6813 IDIFF = 0
6814 ENDIF
6815
6816 IF (IDIFF.EQ.0) THEN
6817* valence-valence chain system
6818 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6819 IF (LCHK) THEN
6820* baryon-baryon
6821 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6822 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6823 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6824 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6825 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6826 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6827 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6828 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6829 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6830 & +(PP1(3)+PT1(3))**2)
6831 ECH = PP1(4)+PT1(4)
6832 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6833 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6834 & +(PP2(3)+PT2(3))**2)
6835 ECH = PP2(4)+PT2(4)
6836 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6837 ELSE
6838* antibaryon-baryon
6839 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6840 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6841 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6842 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6843 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6844 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6845 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6846 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6847 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6848 & +(PP1(3)+PT2(3))**2)
6849 ECH = PP1(4)+PT2(4)
6850 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6851 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6852 & +(PP2(3)+PT1(3))**2)
6853 ECH = PP2(4)+PT1(4)
6854 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6855 ENDIF
6856 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6857 AM1 = SQRT(AM1)
6858 AM2 = SQRT(AM2)
6859 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6860C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6861 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6862 ENDIF
6863 ELSE
6864 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6865 ENDIF
6866 NCSY = NCSY+1
6867 ENDIF
6868 80 CONTINUE
6869 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6870
6871* energy-momentum & flavor conservation check
6872 IF (ABS(IDIFF).NE.1) THEN
6873 IF (IDIFF.NE.0) THEN
6874 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6875 & 1,3,10,IREJ)
6876 ELSE
6877 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6878 & 1,3,10,IREJ)
6879 ENDIF
6880 IF (IREJ.NE.0) THEN
6881 CALL DT_EVTOUT(4)
6882 STOP
6883 ENDIF
6884 ENDIF
6885
6886 RETURN
6887
6888 9999 CONTINUE
6889 IREJ = 1
6890 RETURN
6891 END
6892
6893*$ CREATE DT_CHKCSY.FOR
6894*COPY DT_CHKCSY
6895*
6896*===chkcsy=============================================================*
6897*
6898 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6899
6900************************************************************************
6901* CHeCk Chain SYstem for consistency of partons at chain ends. *
6902* ID1,ID2 PDG-numbers of partons at chain ends *
6903* LCHK = .true. consistent chain *
6904* = .false. inconsistent chain *
6905* This version dated 18.01.95 is written by S. Roesler *
6906************************************************************************
6907
6908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6909 SAVE
6910
6911 PARAMETER ( LINP = 10 ,
6912 & LOUT = 6 ,
6913 & LDAT = 9 )
6914
6915 LOGICAL LCHK
6916
6917 LCHK = .TRUE.
6918
6919* q-aq chain
6920 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6921 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6922* q-qq, aq-aqaq chain
6923 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6924 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6925 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6926* qq-aqaq chain
6927 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6928 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6929 ENDIF
6930
6931 RETURN
6932 END
6933
6934*$ CREATE DT_EVENTA.FOR
6935*COPY DT_EVENTA
6936*
6937*===eventa=============================================================*
6938*
6939 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6940
6941************************************************************************
6942* Treatment of nucleon-nucleon interactions in a two-chain *
6943* approximation. *
6944* (input) ID BAMJET-index of projectile hadron (in case of *
6945* h-K scattering) *
6946* IP/IT mass number of projectile/target nucleus *
6947* NCSY number of two chain systems *
6948* IREJ rejection flag *
6949* This version dated 15.01.95 is written by S. Roesler *
6950************************************************************************
6951
6952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6953 SAVE
6954
6955 PARAMETER ( LINP = 10 ,
6956 & LOUT = 6 ,
6957 & LDAT = 9 )
6958
6959 PARAMETER (TINY10=1.0D-10)
6960
6961* event history
6962
6963 PARAMETER (NMXHKK=200000)
6964
6965 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6966 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6967 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6968
6969* extended event history
6970 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6971 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6972 & IHIST(2,NMXHKK)
6973
6974* rejection counter
6975 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6976 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6977 & IREXCI(3),IRDIFF(2),IRINC
6978
6979* flags for diffractive interactions (DTUNUC 1.x)
6980 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6981
6982* particle properties (BAMJET index convention)
6983 CHARACTER*8 ANAME
6984 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6985 & IICH(210),IIBAR(210),K1(210),K2(210)
6986
6987* flags for input different options
6988 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6989 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6990 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6991
6992* various options for treatment of partons (DTUNUC 1.x)
6993* (chain recombination, Cronin,..)
6994 LOGICAL LCO2CR,LINTPT
6995 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6996 & LCO2CR,LINTPT
6997
6998 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6999
7000 IREJ = 0
7001 NPOINT(3) = NHKK+1
7002
7003* skip following treatment for low-mass diffraction
7004 IF (ABS(IFLAGD).EQ.1) THEN
7005 NPOINT(3) = NPOINT(2)
7006 GOTO 5
7007 ENDIF
7008
7009* multiple scattering of chain ends
7010 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7011 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7012
7013 NC = NPOINT(2)
7014* get a two-chain system from DTEVT1
7015 DO 3 I=1,NCSY
7016 IFP1 = IDHKK(NC)
7017 IFT1 = IDHKK(NC+1)
7018 IFP2 = IDHKK(NC+2)
7019 IFT2 = IDHKK(NC+3)
7020 DO 4 K=1,4
7021 PP1(K) = PHKK(K,NC)
7022 PT1(K) = PHKK(K,NC+1)
7023 PP2(K) = PHKK(K,NC+2)
7024 PT2(K) = PHKK(K,NC+3)
7025 4 CONTINUE
7026 MOP1 = NC
7027 MOT1 = NC+1
7028 MOP2 = NC+2
7029 MOT2 = NC+3
7030 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7031 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7032 IF (IREJ1.GT.0) THEN
7033 IRHHA = IRHHA+1
7034 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7035 GOTO 9999
7036 ENDIF
7037 NC = NC+4
7038 3 CONTINUE
7039
7040* meson/antibaryon projectile:
7041* sample single-chain valence-valence systems (Reggeon contrib.)
7042 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7043 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7044 ENDIF
7045
7046 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7047* check DTEVT1 for remaining resonance mass corrections
7048 CALL DT_EVTRES(IREJ1)
7049 IF (IREJ1.GT.0) THEN
7050 IRRES(1) = IRRES(1)+1
7051 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7052 GOTO 9999
7053 ENDIF
7054 ENDIF
7055
7056* assign p_t to two-"chain" systems consisting of two resonances only
7057* since only entries for chains will be affected, this is obsolete
7058* in case of JETSET-fragmetation
7059 CALL DT_RESPT
7060
7061* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7062 IF (LCO2CR) CALL DT_COM2CR
7063
7064 5 CONTINUE
7065
7066* fragmentation of the complete event
7067**uncomment for internal phojet-fragmentation
7068C CALL DT_EVTFRA(IREJ1)
7069 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7070 IF (IREJ1.GT.0) THEN
7071 IRFRAG = IRFRAG+1
7072 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7073 GOTO 9999
7074 ENDIF
7075
7076* decay of possible resonances (should be obsolete)
7077 CALL DT_DECAY1
7078
7079 RETURN
7080
7081 9999 CONTINUE
7082 IREVT = IREVT+1
7083 IREJ = 1
7084 RETURN
7085 END
7086
7087*$ CREATE DT_GETCSY.FOR
7088*COPY DT_GETCSY
7089*
7090*===getcsy=============================================================*
7091*
7092 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7093 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7094
7095************************************************************************
7096* This version dated 15.01.95 is written by S. Roesler *
7097************************************************************************
7098
7099 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7100 SAVE
7101
7102 PARAMETER ( LINP = 10 ,
7103 & LOUT = 6 ,
7104 & LDAT = 9 )
7105
7106 PARAMETER (TINY10=1.0D-10)
7107
7108* event history
7109
7110 PARAMETER (NMXHKK=200000)
7111
7112 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7113 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7114 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7115
7116* extended event history
7117 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7118 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7119 & IHIST(2,NMXHKK)
7120
7121* rejection counter
7122 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7123 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7124 & IREXCI(3),IRDIFF(2),IRINC
7125
7126* flags for input different options
7127 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7128 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7129 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7130
7131* flags for diffractive interactions (DTUNUC 1.x)
7132 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7133
7134 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7135 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7136
7137 IREJ = 0
7138
7139* get quark content of partons
7140 DO 1 I=1,2
7141 IFP1(I) = 0
7142 IFP2(I) = 0
7143 IFT1(I) = 0
7144 IFT2(I) = 0
7145 1 CONTINUE
7146 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7147 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7148 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7149 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7150 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7151 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7152 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7153 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7154
7155* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7156 IDCH1 = 2
7157 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7158 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7159 IDCH2 = 2
7160 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7161 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7162
7163* store initial configuration for energy-momentum cons. check
7164 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7165
7166* sample intrinsic p_t at chain-ends
7167 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7168 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7169 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7170 IF (IREJ1.NE.0) THEN
7171 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7172 IRPT = IRPT+1
7173 GOTO 9999
7174 ENDIF
7175
7176C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7177C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7178C* check second chain for resonance
7179C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7180C & AMCH2,AMCH2N,IDCH2,IREJ1)
7181C IF (IREJ1.NE.0) GOTO 9999
7182C IF (IDR2.NE.0) THEN
7183C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7184C & AMCH2,AMCH2N,AMCH1,IREJ1)
7185C IF (IREJ1.NE.0) GOTO 9999
7186C ENDIF
7187C* check first chain for resonance
7188C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7189C & AMCH1,AMCH1N,IDCH1,IREJ1)
7190C IF (IREJ1.NE.0) GOTO 9999
7191C IF (IDR1.NE.0) IDR1 = 100*IDR1
7192C ELSE
7193C* check first chain for resonance
7194C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7195C & AMCH1,AMCH1N,IDCH1,IREJ1)
7196C IF (IREJ1.NE.0) GOTO 9999
7197C IF (IDR1.NE.0) THEN
7198C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7199C & AMCH1,AMCH1N,AMCH2,IREJ1)
7200C IF (IREJ1.NE.0) GOTO 9999
7201C ENDIF
7202C* check second chain for resonance
7203C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7204C & AMCH2,AMCH2N,IDCH2,IREJ1)
7205C IF (IREJ1.NE.0) GOTO 9999
7206C IF (IDR2.NE.0) IDR2 = 100*IDR2
7207C ENDIF
7208C ENDIF
7209
7210 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7211* check chains for resonances
7212 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7213 & AMCH1,AMCH1N,IDCH1,IREJ1)
7214 IF (IREJ1.NE.0) GOTO 9999
7215 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7216 & AMCH2,AMCH2N,IDCH2,IREJ1)
7217 IF (IREJ1.NE.0) GOTO 9999
7218* change kinematics corresponding to resonance-masses
7219 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7220 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7221 & AMCH1,AMCH1N,AMCH2,IREJ1)
7222 IF (IREJ1.GT.0) GOTO 9999
7223 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7224 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7225 & AMCH2,AMCH2N,IDCH2,IREJ1)
7226 IF (IREJ1.NE.0) GOTO 9999
7227 IF (IDR2.NE.0) IDR2 = 100*IDR2
7228 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7229 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7230 & AMCH2,AMCH2N,AMCH1,IREJ1)
7231 IF (IREJ1.GT.0) GOTO 9999
7232 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7233 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7234 & AMCH1,AMCH1N,IDCH1,IREJ1)
7235 IF (IREJ1.NE.0) GOTO 9999
7236 IF (IDR1.NE.0) IDR1 = 100*IDR1
7237 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7238 AMDIF1 = ABS(AMCH1-AMCH1N)
7239 AMDIF2 = ABS(AMCH2-AMCH2N)
7240 IF (AMDIF2.LT.AMDIF1) THEN
7241 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7242 & AMCH2,AMCH2N,AMCH1,IREJ1)
7243 IF (IREJ1.GT.0) GOTO 9999
7244 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7245 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7246 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7247 IF (IREJ1.NE.0) GOTO 9999
7248 IF (IDR1.NE.0) IDR1 = 100*IDR1
7249 ELSE
7250 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7251 & AMCH1,AMCH1N,AMCH2,IREJ1)
7252 IF (IREJ1.GT.0) GOTO 9999
7253 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7254 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7255 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7256 IF (IREJ1.NE.0) GOTO 9999
7257 IF (IDR2.NE.0) IDR2 = 100*IDR2
7258 ENDIF
7259 ENDIF
7260 ENDIF
7261
7262* store final configuration for energy-momentum cons. check
7263 IF (LEMCCK) THEN
7264 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7265 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7266 IF (IREJ1.NE.0) GOTO 9999
7267 ENDIF
7268
7269* put partons and chains into DTEVT1
7270 DO 10 I=1,4
7271 PCH1(I) = PP1(I)+PT1(I)
7272 PCH2(I) = PP2(I)+PT2(I)
7273 10 CONTINUE
7274 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7275 & PP1(3),PP1(4),0,0,0)
7276 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7277 & PT1(3),PT1(4),0,0,0)
7278 KCH = 100+IDCH(MOP1)*10+1
7279 CALL DT_EVTPUT(KCH,88888,-2,-1,
7280 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7281 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7282 & PP2(3),PP2(4),0,0,0)
7283 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7284 & PT2(3),PT2(4),0,0,0)
7285 KCH = KCH+1
7286 CALL DT_EVTPUT(KCH,88888,-2,-1,
7287 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7288
7289 RETURN
7290
7291 9999 CONTINUE
7292 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7293* "cancel" sea-sea chains
7294 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7295 IF (IREJ1.NE.0) GOTO 9998
7296**sr 16.5. flag for EVENTB
7297 IREJ = -1
7298 RETURN
7299 ENDIF
7300 9998 CONTINUE
7301 IREJ = 1
7302 RETURN
7303 END
7304
7305*$ CREATE DT_CHKINE.FOR
7306*COPY DT_CHKINE
7307*
7308*===chkine=============================================================*
7309*
7310 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7311 & AMCH1,AMCH1N,AMCH2,IREJ)
7312
7313************************************************************************
7314* This subroutine replaces CORMOM. *
7315* This version dated 05.01.95 is written by S. Roesler *
7316************************************************************************
7317
7318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7319 SAVE
7320
7321 PARAMETER ( LINP = 10 ,
7322 & LOUT = 6 ,
7323 & LDAT = 9 )
7324
7325 PARAMETER (TINY10=1.0D-10)
7326
7327* flags for input different options
7328 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7329 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7330 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7331
7332* rejection counter
7333 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7334 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7335 & IREXCI(3),IRDIFF(2),IRINC
7336
7337 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7338 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7339
7340 IREJ = 0
7341 JMSHL = IMSHL
7342
7343 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7344 DO 10 I=1,4
7345 PP1(I) = PP1I(I)
7346 PP2(I) = PP2I(I)
7347 PT1(I) = PT1I(I)
7348 PT2(I) = PT2I(I)
7349 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7350 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7351 PP1(I) = SCALE*PP1(I)
7352 PT1(I) = SCALE*PT1(I)
7353 10 CONTINUE
7354 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7355 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7356
7357 ECH = PP2(4)+PT2(4)
7358 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7359 & (PP2(3)+PT2(3))**2 )
7360 AMCH22 = (ECH-PCH)*(ECH+PCH)
7361 IF (AMCH22.LT.0.0D0) THEN
7362 IF (IOULEV(1).GT.0)
7363 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7364 GOTO 9997
7365 ENDIF
7366
7367 AMCH1 = AMCH1N
7368 AMCH2 = SQRT(AMCH22)
7369
7370* put partons again on mass shell
7371 13 CONTINUE
7372 XM1 = 0.0D0
7373 XM2 = 0.0D0
7374 IF (JMSHL.EQ.1) THEN
7375
7376 XM1 = PYMASS(IFP1)
7377 XM2 = PYMASS(IFT1)
7378
7379 ENDIF
7380 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7381 IF (IREJ1.NE.0) THEN
7382 IF (JMSHL.EQ.0) GOTO 9998
7383 JMSHL = 0
7384 GOTO 13
7385 ENDIF
7386 JMSHL = IMSHL
7387 DO 11 I=1,4
7388 PP1(I) = P1(I)
7389 PT1(I) = P2(I)
7390 11 CONTINUE
7391 14 CONTINUE
7392 XM1 = 0.0D0
7393 XM2 = 0.0D0
7394 IF (JMSHL.EQ.1) THEN
7395
7396 XM1 = PYMASS(IFP2)
7397 XM2 = PYMASS(IFT2)
7398
7399 ENDIF
7400 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7401 IF (IREJ1.NE.0) THEN
7402 IF (JMSHL.EQ.0) GOTO 9998
7403 JMSHL = 0
7404 GOTO 14
7405 ENDIF
7406 DO 12 I=1,4
7407 PP2(I) = P1(I)
7408 PT2(I) = P2(I)
7409 12 CONTINUE
7410 DO 15 I=1,4
7411 PP1I(I) = PP1(I)
7412 PP2I(I) = PP2(I)
7413 PT1I(I) = PT1(I)
7414 PT2I(I) = PT2(I)
7415 15 CONTINUE
7416 RETURN
7417
7418 9997 IRCHKI(1) = IRCHKI(1)+1
7419**sr
7420C GOTO 9999
7421 IREJ = -1
7422 RETURN
7423**
7424 9998 IRCHKI(2) = IRCHKI(2)+1
7425
7426 9999 CONTINUE
7427 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7428 IREJ = 1
7429 RETURN
7430 END
7431
7432*$ CREATE DT_CH2RES.FOR
7433*COPY DT_CH2RES
7434*
7435*===ch2res=============================================================*
7436*
7437 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7438 & AM,AMN,IMODE,IREJ)
7439
7440************************************************************************
7441* Check chains for resonance production. *
7442* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7443* input: *
7444* IF1,2,3,4 input flavors (q,aq in any order) *
7445* AM chain mass *
7446* MODE = 1 check q-aq chain for meson-resonance *
7447* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7448* = 3 check qq-aqaq chain for lower mass cut *
7449* output: *
7450* IDR = 0 no resonances found *
7451* = -1 pseudoscalar meson/octet baryon *
7452* = 1 vector-meson/decuplet baryon *
7453* IDXR BAMJET-index of corresponding resonance *
7454* AMN mass of corresponding resonance *
7455* *
7456* IREJ rejection flag *
7457* This version dated 06.01.95 is written by S. Roesler *
7458************************************************************************
7459
7460 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7461 SAVE
7462
7463 PARAMETER ( LINP = 10 ,
7464 & LOUT = 6 ,
7465 & LDAT = 9 )
7466
7467* particle properties (BAMJET index convention)
7468 CHARACTER*8 ANAME
7469 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7470 & IICH(210),IIBAR(210),K1(210),K2(210)
7471
7472* quark-content to particle index conversion (DTUNUC 1.x)
7473 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7474 & IA08(6,21),IA10(6,21)
7475
7476* rejection counter
7477 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7478 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7479 & IREXCI(3),IRDIFF(2),IRINC
7480
7481* flags for input different options
7482 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7483 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7484 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7485
7486 DIMENSION IF(4),JF(4)
7487
7488**sr 4.7. test
7489C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7490 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7491**
7492C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7493
7494 MODE = ABS(IMODE)
7495
7496 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7497 WRITE(LOUT,1000) MODE
7498 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7499 & 1X,' program stopped')
7500 STOP
7501 ENDIF
7502
7503 AMX = AM
7504 IREJ = 0
7505 IDR = 0
7506 IDXR = 0
7507 AMN = AMX
7508 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7509 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7510
7511 IF(1) = IF1
7512 IF(2) = IF2
7513 IF(3) = IF3
7514 IF(4) = IF4
7515 NF = 0
7516 DO 100 I=1,4
7517 IF (IF(I).NE.0) THEN
7518 NF = NF+1
7519 JF(NF) = IF(I)
7520 ENDIF
7521 100 CONTINUE
7522 IF (NF.LE.MODE) THEN
7523 WRITE(LOUT,1001) MODE,IF
7524 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7525 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7526 GOTO 9999
7527 ENDIF
7528
7529 GOTO (1,2,3) MODE
7530
7531* check for meson resonance
7532 1 CONTINUE
7533 IFQ = JF(1)
7534 IFAQ = ABS(JF(2))
7535 IF (JF(2).GT.0) THEN
7536 IFQ = JF(2)
7537 IFAQ = ABS(JF(1))
7538 ENDIF
7539 IFPS = IMPS(IFAQ,IFQ)
7540 IFV = IMVE(IFAQ,IFQ)
7541 AMPS = AAM(IFPS)
7542 AMV = AAM(IFV)
7543 AMHI = AMV+0.3D0
7544 IF (AMX.LT.AMV) THEN
7545 IF (AMX.LT.AMPS) THEN
7546 IF (IMODE.GT.0) THEN
7547 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7548 ELSE
7549 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7550 ENDIF
7551 LOMRES = LOMRES+1
7552 ENDIF
7553* replace chain by pseudoscalar meson
7554 IDR = -1
7555 IDXR = IFPS
7556 AMN = AMPS
7557 ELSEIF (AMX.LT.AMHI) THEN
7558* replace chain by vector-meson
7559 IDR = 1
7560 IDXR = IFV
7561 AMN = AMV
7562 ENDIF
7563 RETURN
7564
7565* check for baryon resonance
7566 2 CONTINUE
7567 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7568 AM8 = AAM(JB8)
7569 AM10 = AAM(JB10)
7570 AMHI = AM10+0.3D0
7571 IF (AMX.LT.AM10) THEN
7572 IF (AMX.LT.AM8) THEN
7573 IF (IMODE.GT.0) THEN
7574 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7575 ELSE
7576 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7577 ENDIF
7578 LOBRES = LOBRES+1
7579 ENDIF
7580* replace chain by oktet baryon
7581 IDR = -1
7582 IDXR = JB8
7583 AMN = AM8
7584 ELSEIF (AMX.LT.AMHI) THEN
7585 IDR = 1
7586 IDXR = JB10
7587 AMN = AM10
7588 ENDIF
7589 RETURN
7590
7591* check qq-aqaq for lower mass cut
7592 3 CONTINUE
7593* empirical definition of AMHI to allow for (b-antib)-pair prod.
7594 AMHI = 2.5D0
7595 IF (AMX.LT.AMHI) GOTO 9999
7596 RETURN
7597
7598 9999 CONTINUE
7599 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7600 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7601 IREJ = 1
7602 IRRES(2) = IRRES(2)+1
7603 RETURN
7604 END
7605
7606*$ CREATE DT_RJSEAC.FOR
7607*COPY DT_RJSEAC
7608*
7609*===rjseac=============================================================*
7610*
7611 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7612
7613************************************************************************
7614* ReJection of SEA-sea Chains. *
7615* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7616* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7617* This version dated 16.01.95 is written by S. Roesler *
7618************************************************************************
7619
7620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7621 SAVE
7622
7623 PARAMETER ( LINP = 10 ,
7624 & LOUT = 6 ,
7625 & LDAT = 9 )
7626
7627 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7628
7629* event history
7630
7631 PARAMETER (NMXHKK=200000)
7632
7633 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7634 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7635 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7636
7637* extended event history
7638 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7639 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7640 & IHIST(2,NMXHKK)
7641
7642* statistics
7643 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7644 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7645 & ICEVTG(8,0:30)
7646
7647 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7648
7649 IREJ = 0
7650
7651* projectile sea q-aq-pair
7652* indices of sea-pair
7653 IDXSEA(1,1) = MOP1
7654 IDXSEA(1,2) = MOP2
7655* index of mother-nucleon
7656 IDXNUC(1) = JMOHKK(1,MOP1)
7657* status of valence quarks to be corrected
7658 ISTVAL(1) = -21
7659
7660* target sea q-aq-pair
7661* indices of sea-pair
7662 IDXSEA(2,1) = MOT1
7663 IDXSEA(2,2) = MOT2
7664* index of mother-nucleon
7665 IDXNUC(2) = JMOHKK(1,MOT1)
7666* status of valence quarks to be corrected
7667 ISTVAL(2) = -22
7668
7669 DO 1 N=1,2
7670 IDONE = 0
7671 DO 2 I=NPOINT(2),NHKK
7672 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7673 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7674* valence parton found
7675* inrease 4-momentum by sea 4-momentum
7676 DO 3 K=1,4
7677 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7678 & PHKK(K,IDXSEA(N,2))
7679 3 CONTINUE
7680 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7681 & PHKK(2,I)**2-PHKK(3,I)**2))
7682* "cancel" sea-pair
7683 DO 4 J=1,2
7684 ISTHKK(IDXSEA(N,J)) = 100
7685 IDHKK(IDXSEA(N,J)) = 0
7686 JMOHKK(1,IDXSEA(N,J)) = 0
7687 JMOHKK(2,IDXSEA(N,J)) = 0
7688 JDAHKK(1,IDXSEA(N,J)) = 0
7689 JDAHKK(2,IDXSEA(N,J)) = 0
7690 DO 5 K=1,4
7691 PHKK(K,IDXSEA(N,J)) = ZERO
7692 VHKK(K,IDXSEA(N,J)) = ZERO
7693 WHKK(K,IDXSEA(N,J)) = ZERO
7694 5 CONTINUE
7695 PHKK(5,IDXSEA(N,J)) = ZERO
7696 4 CONTINUE
7697 IDONE = 1
7698 ENDIF
7699 2 CONTINUE
7700 IF (IDONE.NE.1) THEN
7701 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7702 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7703 & '-record!',/,1X,' sea-quark pairs ',
7704 & 2I5,4X,2I5,' could not be canceled!')
7705 GOTO 9999
7706 ENDIF
7707 1 CONTINUE
7708 ICRJSS = ICRJSS+1
7709 RETURN
7710
7711 9999 CONTINUE
7712 IREJ = 1
7713 RETURN
7714 END
7715
7716*$ CREATE DT_VV2SCH.FOR
7717*COPY DT_VV2SCH
7718*
7719*===vv2sch=============================================================*
7720*
7721 SUBROUTINE DT_VV2SCH
7722
7723************************************************************************
7724* Change Valence-Valence chain systems to Single CHain systems for *
7725* hadron-nucleus collisions with meson or antibaryon projectile. *
7726* (Reggeon contribution) *
7727* The single chain system is approximately treated as one chain and a *
7728* meson at rest. *
7729* This version dated 18.01.95 is written by S. Roesler *
7730************************************************************************
7731
7732 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7733 SAVE
7734
7735 PARAMETER ( LINP = 10 ,
7736 & LOUT = 6 ,
7737 & LDAT = 9 )
7738
7739 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7740
7741 LOGICAL LSTART
7742
7743* event history
7744
7745 PARAMETER (NMXHKK=200000)
7746
7747 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7748 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7749 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7750
7751* extended event history
7752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7754 & IHIST(2,NMXHKK)
7755
7756* flags for input different options
7757 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7758 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7759 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7760
7761* statistics
7762 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7763 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7764 & ICEVTG(8,0:30)
7765
7766 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7767 & PCH2(4)
7768
7769 DATA LSTART /.TRUE./
7770
7771 IFSC = 0
7772 IF (LSTART) THEN
7773 WRITE(LOUT,1000)
7774 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7775 & 'valence chains treated')
7776 LSTART = .FALSE.
7777 ENDIF
7778
7779 NSTOP = NHKK
7780
7781* get index of first chain
7782 DO 1 I=NPOINT(3),NHKK
7783 IF (IDHKK(I).EQ.88888) THEN
7784 NC = I
7785 GOTO 2
7786 ENDIF
7787 1 CONTINUE
7788
7789 2 CONTINUE
7790 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7791 & .AND.(NC.LT.NSTOP)) THEN
7792* get valence-valence chains
7793 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7794* get "mother"-hadron indices
7795 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7796 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7797 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7798 KTARG = IDT_ICIHAD(IDHKK(MO2))
7799* Lab momentum of projectile hadron
7800 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7801 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7802 & PHKK(3,MO1)**2)
7803
7804 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7805 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7806 ICVV2S = ICVV2S+1
7807* single chain requested
7808* get flavors of chain-end partons
7809 MO(1) = JMOHKK(1,NC)
7810 MO(2) = JMOHKK(2,NC)
7811 MO(3) = JMOHKK(1,NC+3)
7812 MO(4) = JMOHKK(2,NC+3)
7813 DO 3 I=1,4
7814 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7815 IF(I,2) = 0
7816 IF (ABS(IDHKK(MO(I))).GE.1000)
7817 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7818 3 CONTINUE
7819* which one is the q-aq chain?
7820* N1,N1+1 - DTEVT1-entries for q-aq system
7821* N2,N2+1 - DTEVT1-entries for the other chain
7822 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7823 K1 = 1
7824 K2 = 3
7825 N1 = NC-2
7826 N2 = NC+1
7827 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7828 K1 = 3
7829 K2 = 1
7830 N1 = NC+1
7831 N2 = NC-2
7832 ELSE
7833 GOTO 10
7834 ENDIF
7835 DO 4 K=1,4
7836 PP1(K) = PHKK(K,N1)
7837 PT1(K) = PHKK(K,N1+1)
7838 PP2(K) = PHKK(K,N2)
7839 PT2(K) = PHKK(K,N2+1)
7840 4 CONTINUE
7841 AMCH1 = PHKK(5,N1+2)
7842 AMCH2 = PHKK(5,N2+2)
7843* get meson-identity corresponding to flavors of q-aq chain
7844 ITMP = IRESRJ
7845 IRESRJ = 0
7846 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7847 & ZERO,AMCH1N,1,IDUM)
7848 IRESRJ = ITMP
7849* change kinematics of chains
7850 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7851 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7852 & AMCH1,AMCH1N,AMCH2,IREJ1)
7853 IF (IREJ1.NE.0) GOTO 10
7854* check second chain for resonance
7855 IDCHAI = 2
7856 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7857 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7858 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7859 IF (IREJ1.NE.0) GOTO 10
7860 IF (IDR2.NE.0) IDR2 = 100*IDR2
7861* add partons and chains to DTEVT1
7862 DO 5 K=1,4
7863 PCH1(K) = PP1(K)+PT1(K)
7864 PCH2(K) = PP2(K)+PT2(K)
7865 5 CONTINUE
7866 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7867 & PP1(3),PP1(4),0,0,0)
7868 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7869 & PT1(2),PT1(3),PT1(4),0,0,0)
7870 KCH = ISTHKK(N1+2)+100
7871 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7872 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7873 IDHKK(N1+2) = 22222
7874 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7875 & PP2(3),PP2(4),0,0,0)
7876 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7877 & PT2(2),PT2(3),PT2(4),0,0,0)
7878 KCH = ISTHKK(N2+2)+100
7879 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7880 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7881 IDHKK(N2+2) = 22222
7882 ENDIF
7883 ENDIF
7884 ELSE
7885 GOTO 11
7886 ENDIF
7887 10 CONTINUE
7888 NC = NC+6
7889 GOTO 2
7890
7891 11 CONTINUE
7892
7893 RETURN
7894 END
7895
7896*$ CREATE DT_PHNSCH.FOR
7897*COPY DT_PHNSCH
7898*
7899*=== phnsch ===========================================================*
7900*
7901 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7902
7903*----------------------------------------------------------------------*
7904* *
7905* Probability for Hadron Nucleon Single CHain interactions: *
7906* *
7907* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7908* Infn - Milan *
7909* *
7910* Last change on 04-jan-94 by Alfredo Ferrari *
7911* *
7912* modified by J.R.for use in DTUNUC 6.1.94 *
7913* *
7914* Input variables: *
7915* Kp = hadron projectile index (Part numbering *
7916* scheme) *
7917* Ktarg = target nucleon index (1=proton, 8=neutron) *
7918* Plab = projectile laboratory momentum (GeV/c) *
7919* Output variable: *
7920* Phnsch = probability per single chain (particle *
7921* exchange) interactions *
7922* *
7923*----------------------------------------------------------------------*
7924
7925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7926 SAVE
7927
7928 PARAMETER ( LUNOUT = 6 )
7929 PARAMETER ( LUNERR = 6 )
7930 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7931 PARAMETER ( ZERZER = 0.D+00 )
7932 PARAMETER ( ONEONE = 1.D+00 )
7933 PARAMETER ( TWOTWO = 2.D+00 )
7934 PARAMETER ( FIVFIV = 5.D+00 )
7935 PARAMETER ( HLFHLF = 0.5D+00 )
7936
7937 PARAMETER ( NALLWP = 39 )
7938 PARAMETER ( IDMAXP = 210 )
7939
7940 DIMENSION ICHRGE(39),AM(39)
7941
7942* particle properties (BAMJET index convention)
7943 CHARACTER*8 ANAME
7944 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7945 & IICH(210),IIBAR(210),K1(210),K2(210)
7946
7947 DIMENSION KPTOIP(210)
7948
7949* auxiliary common for reggeon exchange (DTUNUC 1.x)
7950 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7951 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7952 & IQTCHR(-6:6),MQUARK(3,39)
7953
7954 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7955 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7956 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7957 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7958 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7959
7960* Conversion from part to paprop numbering
7961 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7962 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7963 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7964
7965* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7966 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7967 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7968C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7969 DATA SGTCO1 /
7970* 1st reaction: gamma p total
7971 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7972* 2nd reaction: gamma d total
7973 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7974* 3rd reaction: pi+ p total
7975 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7976* 4th reaction: pi- p total
7977 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7978* 5th reaction: pi+/- d total
7979 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7980* 6th reaction: K+ p total
7981 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7982* 7th reaction: K+ n total
7983 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7984* 8th reaction: K+ d total
7985 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7986* 9th reaction: K- p total
7987 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7988* 10th reaction: K- n total
7989 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7990C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7991 DATA SGTCO2 /
7992* 11th reaction: K- d total
7993 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7994* 12th reaction: p p total
7995 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7996* 13th reaction: p n total
7997 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7998* 14th reaction: p d total
7999 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
8000* 15th reaction: pbar p total
8001 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
8002* 16th reaction: pbar n total
8003 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
8004* 17th reaction: pbar d total
8005 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
8006* 18th reaction: Lamda p total
8007 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
8008C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8009 DATA SGTCO3 /
8010* 19th reaction: pi+ p elastic
8011 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8012* 20th reaction: pi- p elastic
8013 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8014* 21st reaction: K+ p elastic
8015 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8016* 22nd reaction: K- p elastic
8017 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8018* 23rd reaction: p p elastic
8019 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8020* 24th reaction: p d elastic
8021 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8022* 25th reaction: pbar p elastic
8023 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8024* 26th reaction: pbar p elastic bis
8025 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8026* 27th reaction: pbar n elastic
8027 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8028* 28th reaction: Lamda p elastic
8029 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8030* 29th reaction: K- p ela bis
8031 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8032* 30th reaction: pi- p cx
8033 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8034* 31st reaction: K- p cx
8035 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8036* 32nd reaction: K+ n cx
8037 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8038* 33rd reaction: pbar p cx
8039 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8040*
8041* +-------------------------------------------------------------------*
8042 ICHRGE(KTARG)=IICH(KTARG)
8043 AM (KTARG)=AAM (KTARG)
8044* | Check for pi0 (d-dbar)
8045 IF ( KP .NE. 26 ) THEN
8046 IP = KPTOIP (KP)
8047 IF(IP.EQ.0)IP=1
8048 ICHRGE(IP)=IICH(KP)
8049 AM (IP)=AAM (KP)
8050* |
8051* +-------------------------------------------------------------------*
8052* |
8053 ELSE
8054 IP = 23
8055 ICHRGE(IP)=0
8056 END IF
8057* |
8058* +-------------------------------------------------------------------*
8059* +-------------------------------------------------------------------*
8060* | No such interactions for baryon-baryon
8061 IF ( IIBAR (KP) .GT. 0 ) THEN
8062 DT_PHNSCH = ZERZER
8063 RETURN
8064* |
8065* +-------------------------------------------------------------------*
8066* | No "annihilation" diagram possible for K+ p/n
8067 ELSE IF ( IP .EQ. 15 ) THEN
8068 DT_PHNSCH = ZERZER
8069 RETURN
8070* |
8071* +-------------------------------------------------------------------*
8072* | No "annihilation" diagram possible for K0 p/n
8073 ELSE IF ( IP .EQ. 24 ) THEN
8074 DT_PHNSCH = ZERZER
8075 RETURN
8076* |
8077* +-------------------------------------------------------------------*
8078* | No "annihilation" diagram possible for Omebar p/n
8079 ELSE IF ( IP .GE. 38 ) THEN
8080 DT_PHNSCH = ZERZER
8081 RETURN
8082 END IF
8083* |
8084* +-------------------------------------------------------------------*
8085* +-------------------------------------------------------------------*
8086* | If the momentum is larger than 50 GeV/c, compute the single
8087* | chain probability at 50 GeV/c and extrapolate to the present
8088* | momentum according to 1/sqrt(s)
8089* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8090* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8091* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8092* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8093* | x sqrt(s/s(50))
8094* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8095 IF ( PLAB .GT. 50.D+00 ) THEN
8096 PLA = 50.D+00
8097 AMPSQ = AM (IP)**2
8098 AMTSQ = AM (KTARG)**2
8099 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8100 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8101 EPROJ = SQRT ( PLA**2 + AMPSQ )
8102 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8103 UMORAT = SQRT ( UMOSQ / UMO50 )
8104* |
8105* +-------------------------------------------------------------------*
8106* | P < 3 GeV/c
8107 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8108 PLA = 3.D+00
8109 AMPSQ = AM (IP)**2
8110 AMTSQ = AM (KTARG)**2
8111 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8112 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8113 EPROJ = SQRT ( PLA**2 + AMPSQ )
8114 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8115 UMORAT = SQRT ( UMOSQ / UMO50 )
8116* |
8117* +-------------------------------------------------------------------*
8118* | P < 50 GeV/c
8119 ELSE
8120 PLA = PLAB
8121 UMORAT = ONEONE
8122 END IF
8123* |
8124* +-------------------------------------------------------------------*
8125 ALGPLA = LOG (PLA)
8126* +-------------------------------------------------------------------*
8127* | Pions:
8128 IF ( IHLP (IP) .EQ. 2 ) THEN
8129 ACOF = SGTCOE (1,3)
8130 BCOF = SGTCOE (2,3)
8131 ENNE = SGTCOE (3,3)
8132 CCOF = SGTCOE (4,3)
8133 DCOF = SGTCOE (5,3)
8134* | Compute the pi+ p total cross section:
8135 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8136 & + DCOF * ALGPLA
8137 ACOF = SGTCOE (1,19)
8138 BCOF = SGTCOE (2,19)
8139 ENNE = SGTCOE (3,19)
8140 CCOF = SGTCOE (4,19)
8141 DCOF = SGTCOE (5,19)
8142* | Compute the pi+ p elastic cross section:
8143 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8144 & + DCOF * ALGPLA
8145* | Compute the pi+ p inelastic cross section:
8146 SPPPIN = SPPPTT - SPPPEL
8147 ACOF = SGTCOE (1,4)
8148 BCOF = SGTCOE (2,4)
8149 ENNE = SGTCOE (3,4)
8150 CCOF = SGTCOE (4,4)
8151 DCOF = SGTCOE (5,4)
8152* | Compute the pi- p total cross section:
8153 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8154 & + DCOF * ALGPLA
8155 ACOF = SGTCOE (1,20)
8156 BCOF = SGTCOE (2,20)
8157 ENNE = SGTCOE (3,20)
8158 CCOF = SGTCOE (4,20)
8159 DCOF = SGTCOE (5,20)
8160* | Compute the pi- p elastic cross section:
8161 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8162 & + DCOF * ALGPLA
8163* | Compute the pi- p inelastic cross section:
8164 SPMPIN = SPMPTT - SPMPEL
8165 SIGDIA = SPMPIN - SPPPIN
8166* | +----------------------------------------------------------------*
8167* | | Charged pions: besides isospin consideration it is supposed
8168* | | that (pi+ n)el is almost equal to (pi- p)el
8169* | | and (pi+ p)el " " " " (pi- n)el
8170* | | and all are almost equal among each others
8171* | | (reasonable above 5 GeV/c)
8172 IF ( ICHRGE (IP) .NE. 0 ) THEN
8173 KHELP = KTARG / 8
8174 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8175 ACOF = SGTCOE (1,JREAC)
8176 BCOF = SGTCOE (2,JREAC)
8177 ENNE = SGTCOE (3,JREAC)
8178 CCOF = SGTCOE (4,JREAC)
8179 DCOF = SGTCOE (5,JREAC)
8180* | | Compute the total cross section:
8181 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8182 & + DCOF * ALGPLA
8183 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8184 ACOF = SGTCOE (1,JREAC)
8185 BCOF = SGTCOE (2,JREAC)
8186 ENNE = SGTCOE (3,JREAC)
8187 CCOF = SGTCOE (4,JREAC)
8188 DCOF = SGTCOE (5,JREAC)
8189* | | Compute the elastic cross section:
8190 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8191 & + DCOF * ALGPLA
8192* | | Compute the inelastic cross section:
8193 SHNCIN = SHNCTT - SHNCEL
8194* | | Number of diagrams:
8195 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8196* | | Now compute the chain end (anti)quark-(anti)diquark
8197 IQFSC1 = 1 + IP - 13
8198 IQFSC2 = 0
8199 IQBSC1 = 1 + KHELP
8200 IQBSC2 = 1 + IP - 13
8201* | |
8202* | +----------------------------------------------------------------*
8203* | | pi0: besides isospin consideration it is supposed that the
8204* | | elastic cross section is not very different from
8205* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8206 ELSE
8207 KHELP = KTARG / 8
8208 K2HLP = ( KP - 23 ) / 3
8209* | | Number of diagrams:
8210* | | For u ubar (k2hlp=0):
8211* NDIAGR = 2 - KHELP
8212* | | For d dbar (k2hlp=1):
8213* NDIAGR = 2 + KHELP - K2HLP
8214 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8215 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8216* | | Now compute the chain end (anti)quark-(anti)diquark
8217 IQFSC1 = 1 + K2HLP
8218 IQFSC2 = 0
8219 IQBSC1 = 1 + KHELP
8220 IQBSC2 = 2 - K2HLP
8221 END IF
8222* | |
8223* | +----------------------------------------------------------------*
8224* | end pi's
8225* +-------------------------------------------------------------------*
8226* | Kaons:
8227 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8228 ACOF = SGTCOE (1,6)
8229 BCOF = SGTCOE (2,6)
8230 ENNE = SGTCOE (3,6)
8231 CCOF = SGTCOE (4,6)
8232 DCOF = SGTCOE (5,6)
8233* | Compute the K+ p total cross section:
8234 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8235 & + DCOF * ALGPLA
8236 ACOF = SGTCOE (1,21)
8237 BCOF = SGTCOE (2,21)
8238 ENNE = SGTCOE (3,21)
8239 CCOF = SGTCOE (4,21)
8240 DCOF = SGTCOE (5,21)
8241* | Compute the K+ p elastic cross section:
8242 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8243 & + DCOF * ALGPLA
8244* | Compute the K+ p inelastic cross section:
8245 SKPPIN = SKPPTT - SKPPEL
8246 ACOF = SGTCOE (1,9)
8247 BCOF = SGTCOE (2,9)
8248 ENNE = SGTCOE (3,9)
8249 CCOF = SGTCOE (4,9)
8250 DCOF = SGTCOE (5,9)
8251* | Compute the K- p total cross section:
8252 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8253 & + DCOF * ALGPLA
8254 ACOF = SGTCOE (1,22)
8255 BCOF = SGTCOE (2,22)
8256 ENNE = SGTCOE (3,22)
8257 CCOF = SGTCOE (4,22)
8258 DCOF = SGTCOE (5,22)
8259* | Compute the K- p elastic cross section:
8260 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8261 & + DCOF * ALGPLA
8262* | Compute the K- p inelastic cross section:
8263 SKMPIN = SKMPTT - SKMPEL
8264 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8265* | +----------------------------------------------------------------*
8266* | | Charged Kaons: actually only K-
8267 IF ( ICHRGE (IP) .NE. 0 ) THEN
8268 KHELP = KTARG / 8
8269* | | +-------------------------------------------------------------*
8270* | | | Proton target:
8271 IF ( KHELP .EQ. 0 ) THEN
8272 SHNCIN = SKMPIN
8273* | | | Number of diagrams:
8274 NDIAGR = 2
8275* | | |
8276* | | +-------------------------------------------------------------*
8277* | | | Neutron target: besides isospin consideration it is supposed
8278* | | | that (K- n)el is almost equal to (K- p)el
8279* | | | (reasonable above 5 GeV/c)
8280 ELSE
8281 ACOF = SGTCOE (1,10)
8282 BCOF = SGTCOE (2,10)
8283 ENNE = SGTCOE (3,10)
8284 CCOF = SGTCOE (4,10)
8285 DCOF = SGTCOE (5,10)
8286* | | | Compute the total cross section:
8287 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8288 & + DCOF * ALGPLA
8289* | | | Compute the elastic cross section:
8290 SHNCEL = SKMPEL
8291* | | | Compute the inelastic cross section:
8292 SHNCIN = SHNCTT - SHNCEL
8293* | | | Number of diagrams:
8294 NDIAGR = 1
8295 END IF
8296* | | |
8297* | | +-------------------------------------------------------------*
8298* | | Now compute the chain end (anti)quark-(anti)diquark
8299 IQFSC1 = 3
8300 IQFSC2 = 0
8301 IQBSC1 = 1 + KHELP
8302 IQBSC2 = 2
8303* | |
8304* | +----------------------------------------------------------------*
8305* | | K0's: (actually only K0bar)
8306 ELSE
8307 KHELP = KTARG / 8
8308* | | +-------------------------------------------------------------*
8309* | | | Proton target: (K0bar p)in supposed to be given by
8310* | | | (K- p)in - Sig_diagr
8311 IF ( KHELP .EQ. 0 ) THEN
8312 SHNCIN = SKMPIN - SIGDIA
8313* | | | Number of diagrams:
8314 NDIAGR = 1
8315* | | |
8316* | | +-------------------------------------------------------------*
8317* | | | Neutron target: (K0bar n)in supposed to be given by
8318* | | | (K- n)in + Sig_diagr
8319* | | | besides isospin consideration it is supposed
8320* | | | that (K- n)el is almost equal to (K- p)el
8321* | | | (reasonable above 5 GeV/c)
8322 ELSE
8323 ACOF = SGTCOE (1,10)
8324 BCOF = SGTCOE (2,10)
8325 ENNE = SGTCOE (3,10)
8326 CCOF = SGTCOE (4,10)
8327 DCOF = SGTCOE (5,10)
8328* | | | Compute the total cross section:
8329 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8330 & + DCOF * ALGPLA
8331* | | | Compute the elastic cross section:
8332 SHNCEL = SKMPEL
8333* | | | Compute the inelastic cross section:
8334 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8335* | | | Number of diagrams:
8336 NDIAGR = 2
8337 END IF
8338* | | |
8339* | | +-------------------------------------------------------------*
8340* | | Now compute the chain end (anti)quark-(anti)diquark
8341 IQFSC1 = 3
8342 IQFSC2 = 0
8343 IQBSC1 = 1
8344 IQBSC2 = 1 + KHELP
8345 END IF
8346* | |
8347* | +----------------------------------------------------------------*
8348* | end Kaon's
8349* +-------------------------------------------------------------------*
8350* | Antinucleons:
8351 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8352* | For momenta between 3 and 5 GeV/c the use of tabulated data
8353* | should be implemented!
8354 ACOF = SGTCOE (1,15)
8355 BCOF = SGTCOE (2,15)
8356 ENNE = SGTCOE (3,15)
8357 CCOF = SGTCOE (4,15)
8358 DCOF = SGTCOE (5,15)
8359* | Compute the pbar p total cross section:
8360 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8361 & + DCOF * ALGPLA
8362 IF ( PLA .LT. FIVFIV ) THEN
8363 JREAC = 26
8364 ELSE
8365 JREAC = 25
8366 END IF
8367 ACOF = SGTCOE (1,JREAC)
8368 BCOF = SGTCOE (2,JREAC)
8369 ENNE = SGTCOE (3,JREAC)
8370 CCOF = SGTCOE (4,JREAC)
8371 DCOF = SGTCOE (5,JREAC)
8372* | Compute the pbar p elastic cross section:
8373 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8374 & + DCOF * ALGPLA
8375* | Compute the pbar p inelastic cross section:
8376 SAPPIN = SAPPTT - SAPPEL
8377 ACOF = SGTCOE (1,12)
8378 BCOF = SGTCOE (2,12)
8379 ENNE = SGTCOE (3,12)
8380 CCOF = SGTCOE (4,12)
8381 DCOF = SGTCOE (5,12)
8382* | Compute the p p total cross section:
8383 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8384 & + DCOF * ALGPLA
8385 ACOF = SGTCOE (1,23)
8386 BCOF = SGTCOE (2,23)
8387 ENNE = SGTCOE (3,23)
8388 CCOF = SGTCOE (4,23)
8389 DCOF = SGTCOE (5,23)
8390* | Compute the p p elastic cross section:
8391 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8392 & + DCOF * ALGPLA
8393* | Compute the K- p inelastic cross section:
8394 SPPINE = SPPTOT - SPPELA
8395 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8396 KHELP = KTARG / 8
8397* | +----------------------------------------------------------------*
8398* | | Pbar:
8399 IF ( ICHRGE (IP) .NE. 0 ) THEN
8400 NDIAGR = 5 - KHELP
8401* | | +-------------------------------------------------------------*
8402* | | | Proton target:
8403 IF ( KHELP .EQ. 0 ) THEN
8404* | | | Number of diagrams:
8405 SHNCIN = SAPPIN
8406 PUUBAR = 0.8D+00
8407* | | |
8408* | | +-------------------------------------------------------------*
8409* | | | Neutron target: it is supposed that (ap n)el is almost equal
8410* | | | to (ap p)el (reasonable above 5 GeV/c)
8411 ELSE
8412 ACOF = SGTCOE (1,16)
8413 BCOF = SGTCOE (2,16)
8414 ENNE = SGTCOE (3,16)
8415 CCOF = SGTCOE (4,16)
8416 DCOF = SGTCOE (5,16)
8417* | | | Compute the total cross section:
8418 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8419 & + DCOF * ALGPLA
8420* | | | Compute the elastic cross section:
8421 SHNCEL = SAPPEL
8422* | | | Compute the inelastic cross section:
8423 SHNCIN = SHNCTT - SHNCEL
8424 PUUBAR = HLFHLF
8425 END IF
8426* | | |
8427* | | +-------------------------------------------------------------*
8428* | | Now compute the chain end (anti)quark-(anti)diquark
8429* | | there are different possibilities, make a random choiche:
8430 IQFSC1 = -1
8431 RNCHEN = DT_RNDM(PUUBAR)
8432 IF ( RNCHEN .LT. PUUBAR ) THEN
8433 IQFSC2 = -2
8434 ELSE
8435 IQFSC2 = -1
8436 END IF
8437 IQBSC1 = -IQFSC1 + KHELP
8438 IQBSC2 = -IQFSC2
8439* | |
8440* | +----------------------------------------------------------------*
8441* | | nbar:
8442 ELSE
8443 NDIAGR = 4 + KHELP
8444* | | +-------------------------------------------------------------*
8445* | | | Proton target: (nbar p)in supposed to be given by
8446* | | | (pbar p)in - Sig_diagr
8447 IF ( KHELP .EQ. 0 ) THEN
8448 SHNCIN = SAPPIN - SIGDIA
8449 PDDBAR = HLFHLF
8450* | | |
8451* | | +-------------------------------------------------------------*
8452* | | | Neutron target: (nbar n)el is supposed to be equal to
8453* | | | (pbar p)el (reasonable above 5 GeV/c)
8454 ELSE
8455* | | | Compute the total cross section:
8456 SHNCTT = SAPPTT
8457* | | | Compute the elastic cross section:
8458 SHNCEL = SAPPEL
8459* | | | Compute the inelastic cross section:
8460 SHNCIN = SHNCTT - SHNCEL
8461 PDDBAR = 0.8D+00
8462 END IF
8463* | | |
8464* | | +-------------------------------------------------------------*
8465* | | Now compute the chain end (anti)quark-(anti)diquark
8466* | | there are different possibilities, make a random choiche:
8467 IQFSC1 = -2
8468 RNCHEN = DT_RNDM(RNCHEN)
8469 IF ( RNCHEN .LT. PDDBAR ) THEN
8470 IQFSC2 = -1
8471 ELSE
8472 IQFSC2 = -2
8473 END IF
8474 IQBSC1 = -IQFSC1 + KHELP - 1
8475 IQBSC2 = -IQFSC2
8476 END IF
8477* | |
8478* | +----------------------------------------------------------------*
8479* |
8480* +-------------------------------------------------------------------*
8481* | Others: not yet implemented
8482 ELSE
8483 SIGDIA = ZERZER
8484 SHNCIN = ONEONE
8485 NDIAGR = 0
8486 DT_PHNSCH = ZERZER
8487 RETURN
8488 END IF
8489* | end others
8490* +-------------------------------------------------------------------*
8491 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8492 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8493 & + IQECHR (IQBSC2)
8494 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8495 & + IQBCHR (IQBSC2)
8496 IQECHC = IQECHC / 3
8497 IQBCHC = IQBCHC / 3
8498 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8499 & + IQSCHR (IQBSC2)
8500 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8501 & + IQSCHR (MQUARK(3,IP))
8502* +-------------------------------------------------------------------*
8503* | Consistency check:
8504 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8505 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8506 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8507 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8508 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8509 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8510 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8511 END IF
8512* |
8513* +-------------------------------------------------------------------*
8514* +-------------------------------------------------------------------*
8515* | Consistency check:
8516 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8517 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8518 WRITE (LUNOUT,*)
8519 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8520 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8521 WRITE (LUNERR,*)
8522 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8523 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8524 END IF
8525* |
8526* +-------------------------------------------------------------------*
8527* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8528 IF ( UMORAT .GT. ONEPLS )
8529 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8530 & - ONEONE ) * UMORAT + ONEONE )
8531 RETURN
8532*
8533 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8534 DT_SCHQUA = ONEONE
8535 JQFSC1 = IQFSC1
8536 JQFSC2 = IQFSC2
8537 JQBSC1 = IQBSC1
8538 JQBSC2 = IQBSC2
8539*=== End of function Phnsch ===========================================*
8540 RETURN
8541 END
8542
8543*$ CREATE DT_RESPT.FOR
8544*COPY DT_RESPT
8545*
8546*===respt==============================================================*
8547*
8548 SUBROUTINE DT_RESPT
8549
8550************************************************************************
8551* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8552* This version dated 18.01.95 is written by S. Roesler *
8553************************************************************************
8554
8555 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8556 SAVE
8557
8558 PARAMETER ( LINP = 10 ,
8559 & LOUT = 6 ,
8560 & LDAT = 9 )
8561
8562 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8563
8564* event history
8565
8566 PARAMETER (NMXHKK=200000)
8567
8568 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8569 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8570 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8571
8572* extended event history
8573 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8574 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8575 & IHIST(2,NMXHKK)
8576
8577* get index of first chain
8578 DO 1 I=NPOINT(3),NHKK
8579 IF (IDHKK(I).EQ.88888) THEN
8580 NC = I
8581 GOTO 2
8582 ENDIF
8583 1 CONTINUE
8584
8585 2 CONTINUE
8586 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8587C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8588* skip VV-,SS- systems
8589 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8590 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8591* check if both "chains" are resonances
8592 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8593 CALL DT_SAPTRE(NC,NC+3)
8594 ENDIF
8595 ENDIF
8596 ELSE
8597 GOTO 3
8598 ENDIF
8599 NC = NC+6
8600 GOTO 2
8601
8602 3 CONTINUE
8603
8604 RETURN
8605 END
8606
8607*$ CREATE DT_EVTRES.FOR
8608*COPY DT_EVTRES
8609*
8610*===evtres=============================================================*
8611*
8612 SUBROUTINE DT_EVTRES(IREJ)
8613
8614************************************************************************
8615* This version dated 14.12.94 is written by S. Roesler *
8616************************************************************************
8617
8618 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8619 SAVE
8620
8621 PARAMETER ( LINP = 10 ,
8622 & LOUT = 6 ,
8623 & LDAT = 9 )
8624
8625 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8626
8627* event history
8628
8629 PARAMETER (NMXHKK=200000)
8630
8631 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8632 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8633 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8634
8635* extended event history
8636 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8637 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8638 & IHIST(2,NMXHKK)
8639
8640* flags for input different options
8641 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8642 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8643 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8644
8645* particle properties (BAMJET index convention)
8646 CHARACTER*8 ANAME
8647 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8648 & IICH(210),IIBAR(210),K1(210),K2(210)
8649
8650 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8651
8652 IREJ = 0
8653
8654 DO 1 I=NPOINT(3),NHKK
8655 IF (ABS(IDRES(I)).GE.100) THEN
8656 AMMX = 0.0D0
8657 DO 2 J=NPOINT(3),NHKK
8658 IF (IDHKK(J).EQ.88888) THEN
8659 IF (PHKK(5,J).GT.AMMX) THEN
8660 AMMX = PHKK(5,J)
8661 IMMX = J
8662 ENDIF
8663 ENDIF
8664 2 CONTINUE
8665 IF (IDRES(IMMX).NE.0) THEN
8666 IF (IOULEV(3).GT.0) THEN
8667 WRITE(LOUT,'(1X,A)')
8668 & 'EVTRES: no chain for correc. found'
8669C GOTO 6
8670 GOTO 9999
8671 ELSE
8672 GOTO 9999
8673 ENDIF
8674 ENDIF
8675 IMO11 = JMOHKK(1,I)
8676 IMO12 = JMOHKK(2,I)
8677 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8678 IMO11 = JMOHKK(2,I)
8679 IMO12 = JMOHKK(1,I)
8680 ENDIF
8681 IMO21 = JMOHKK(1,IMMX)
8682 IMO22 = JMOHKK(2,IMMX)
8683 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8684 IMO21 = JMOHKK(2,IMMX)
8685 IMO22 = JMOHKK(1,IMMX)
8686 ENDIF
8687 AMCH1 = PHKK(5,I)
8688 AMCH1N = AAM(IDXRES(I))
8689
8690 IFPR1 = IDHKK(IMO11)
8691 IFPR2 = IDHKK(IMO21)
8692 IFTA1 = IDHKK(IMO12)
8693 IFTA2 = IDHKK(IMO22)
8694 DO 4 J=1,4
8695 PP1(J) = PHKK(J,IMO11)
8696 PP2(J) = PHKK(J,IMO21)
8697 PT1(J) = PHKK(J,IMO12)
8698 PT2(J) = PHKK(J,IMO22)
8699 4 CONTINUE
8700* store initial configuration for energy-momentum cons. check
8701 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8702* correct kinematics of second chain
8703 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8704 & AMCH1,AMCH1N,AMCH2,IREJ1)
8705 IF (IREJ1.NE.0) GOTO 9999
8706* check now this chain for resonance mass
8707 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8708 IFP(2) = 0
8709 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8710 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8711 IFT(2) = 0
8712 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8713 IDCH2 = 2
8714 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8715 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8716 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8717 & AMCH2,AMCH2N,IDCH2,IREJ1)
8718 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8719 IF (IOULEV(1).GT.0)
8720 & WRITE(LOUT,*) ' correction for resonance not poss.'
8721**sr test
8722C GOTO 1
8723C GOTO 9999
8724**
8725 ENDIF
8726* store final configuration for energy-momentum cons. check
8727 IF (LEMCCK) THEN
8728 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8729 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8730 IF (IREJ1.NE.0) GOTO 9999
8731 ENDIF
8732 DO 5 J=1,4
8733 PHKK(J,IMO11) = PP1(J)
8734 PHKK(J,IMO21) = PP2(J)
8735 PHKK(J,IMO12) = PT1(J)
8736 PHKK(J,IMO22) = PT2(J)
8737 5 CONTINUE
8738* correct entries of chains
8739 DO 3 K=1,4
8740 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8741 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8742 3 CONTINUE
8743 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8744 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8745 & PHKK(3,IMMX)**2
8746* ?? the following should now be obsolete
8747**sr test
8748C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8749 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8750**
8751 WRITE(LOUT,'(1X,A,4G10.3)')
8752 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8753C GOTO 9999
8754 GOTO 1
8755 ENDIF
8756 PHKK(5,I) = SQRT(AM1)
8757 PHKK(5,IMMX) = SQRT(AM2)
8758 IDRES(I) = IDRES(I)/100
8759 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8760 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8761 WRITE(LOUT,'(1X,A,4G10.3)')
8762 & 'EVTRES: inconsistent chain-masses',
8763 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8764 GOTO 9999
8765 ENDIF
8766 ENDIF
8767 1 CONTINUE
8768 6 CONTINUE
8769 RETURN
8770
8771 9999 CONTINUE
8772 IREJ = 1
8773 RETURN
8774 END
8775
8776*$ CREATE DT_GETSPT.FOR
8777*COPY DT_GETSPT
8778*
8779*===getspt=============================================================*
8780*
8781 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8782 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8783 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8784
8785************************************************************************
8786* This version dated 12.12.94 is written by S. Roesler *
8787************************************************************************
8788
8789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8790 SAVE
8791
8792 PARAMETER ( LINP = 10 ,
8793 & LOUT = 6 ,
8794 & LDAT = 9 )
8795
8796 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8797
8798* various options for treatment of partons (DTUNUC 1.x)
8799* (chain recombination, Cronin,..)
8800 LOGICAL LCO2CR,LINTPT
8801 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8802 & LCO2CR,LINTPT
8803
8804* flags for input different options
8805 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8806 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8807 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8808
8809* flags for diffractive interactions (DTUNUC 1.x)
8810 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8811
8812 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8813 & PT2(4),PT2I(4),P1(4),P2(4),
8814 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8815 & PTOTI(4),PTOTF(4),DIFF(4)
8816
8817 IC = 0
8818 IREJ = 0
8819C B33P = 4.0D0
8820C B33T = 4.0D0
8821C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8822C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8823 REDU = 1.0D0
8824C B33P = 3.5D0
8825C B33T = 3.5D0
8826 B33P = 4.0D0
8827 B33T = 4.0D0
8828 IF (IDIFF.NE.0) THEN
8829 B33P = 16.0D0
8830 B33T = 16.0D0
8831 ENDIF
8832
8833 DO 1 I=1,4
8834 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8835 PP1(I) = PP1I(I)
8836 PP2(I) = PP2I(I)
8837 PT1(I) = PT1I(I)
8838 PT2(I) = PT2I(I)
8839 1 CONTINUE
8840* get initial chain masses
8841 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8842 & +(PP1(3)+PT1(3))**2)
8843 ECH = PP1(4)+PT1(4)
8844 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8845 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8846 & +(PP2(3)+PT2(3))**2)
8847 ECH = PP2(4)+PT2(4)
8848 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8849 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8850 IF (IOULEV(1).GT.0)
8851 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8852 & AM1,AM2
8853 GOTO 9999
8854 ENDIF
8855 AM1 = SQRT(AM1)
8856 AM2 = SQRT(AM2)
8857 AM1N = ZERO
8858 AM2N = ZERO
8859
8860 MODE = 0
8861C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8862C MODE = 0
8863C ELSE
8864C MODE = 1
8865C IF (AM1.LT.0.6) THEN
8866C B33P = 10.0D0
8867C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8868CC B33P = 4.0D0
8869C ENDIF
8870C IF (AM2.LT.0.6) THEN
8871C B33T = 10.0D0
8872C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8873CC B33T = 4.0D0
8874C ENDIF
8875C ENDIF
8876
8877* check chain masses for very low mass chains
8878C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8879C & AM1,DUM,-IDCH1,IREJ1)
8880C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8881C & AM2,DUM,-IDCH2,IREJ2)
8882C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8883C B33P = 20.0D0
8884C B33T = 20.0D0
8885C ENDIF
8886
8887 JMSHL = IMSHL
8888
8889 2 CONTINUE
8890 IC = IC+1
8891 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8892 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8893 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8894C IF (MOD(IC,19).EQ.0) JMSHL = 0
8895 IF (MOD(IC,20).EQ.0) GOTO 7
8896C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8897C RETURN
8898C GOTO 9999
8899C ENDIF
8900
8901* get transverse momentum
8902 IF (LINTPT) THEN
8903 ES = -2.0D0/(B33P**2)
8904 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8905 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8906 HPSP = HPSP*REDU
8907 ES = -2.0D0/(B33T**2)
8908 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8909 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8910 HPST = HPST*REDU
8911 ELSE
8912 HPSP = ZERO
8913 HPST = ZERO
8914 ENDIF
8915 CALL DT_DSFECF(SFE1,CFE1)
8916 CALL DT_DSFECF(SFE2,CFE2)
8917 IF (MODE.EQ.0) THEN
8918 PP1(1) = PP1I(1)+HPSP*CFE1
8919 PP1(2) = PP1I(2)+HPSP*SFE1
8920 PP2(1) = PP2I(1)-HPSP*CFE1
8921 PP2(2) = PP2I(2)-HPSP*SFE1
8922 PT1(1) = PT1I(1)+HPST*CFE2
8923 PT1(2) = PT1I(2)+HPST*SFE2
8924 PT2(1) = PT2I(1)-HPST*CFE2
8925 PT2(2) = PT2I(2)-HPST*SFE2
8926 ELSE
8927 PP1(1) = PP1I(1)+HPSP*CFE1
8928 PP1(2) = PP1I(2)+HPSP*SFE1
8929 PT1(1) = PT1I(1)-HPSP*CFE1
8930 PT1(2) = PT1I(2)-HPSP*SFE1
8931 PP2(1) = PP2I(1)+HPST*CFE2
8932 PP2(2) = PP2I(2)+HPST*SFE2
8933 PT2(1) = PT2I(1)-HPST*CFE2
8934 PT2(2) = PT2I(2)-HPST*SFE2
8935 ENDIF
8936
8937* put partons on mass shell
8938 XMP1 = 0.0D0
8939 XMT1 = 0.0D0
8940 IF (JMSHL.EQ.1) THEN
8941
8942 XMP1 = PYMASS(IFPR1)
8943 XMT1 = PYMASS(IFTA1)
8944
8945 ENDIF
8946 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8947 IF (IREJ1.NE.0) GOTO 2
8948 DO 3 I=1,4
8949 PTOTF(I) = P1(I)+P2(I)
8950 PP1(I) = P1(I)
8951 PT1(I) = P2(I)
8952 3 CONTINUE
8953 XMP2 = 0.0D0
8954 XMT2 = 0.0D0
8955 IF (JMSHL.EQ.1) THEN
8956
8957 XMP2 = PYMASS(IFPR2)
8958 XMT2 = PYMASS(IFTA2)
8959
8960 ENDIF
8961 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8962 IF (IREJ1.NE.0) GOTO 2
8963 DO 4 I=1,4
8964 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8965 PP2(I) = P1(I)
8966 PT2(I) = P2(I)
8967 4 CONTINUE
8968
8969* check consistency
8970 DO 5 I=1,4
8971 DIFF(I) = PTOTI(I)-PTOTF(I)
8972 5 CONTINUE
8973 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8974 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8975 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8976 GOTO 9999
8977 ENDIF
8978 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8979 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8980 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8981 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8982 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8983 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8984 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8985 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8986 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8987 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8988 & THEN
8989 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8990 & 'GETSPT: inconsistent masses',
8991 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8992* sr 22.11.00: commented. It should only have inconsistent masses for
8993* ultrahigh energies due to rounding problems
8994C GOTO 9999
8995 ENDIF
8996
8997* get chain masses
8998 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8999 & +(PP1(3)+PT1(3))**2)
9000 ECH = PP1(4)+PT1(4)
9001 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
9002 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9003 & +(PP2(3)+PT2(3))**2)
9004 ECH = PP2(4)+PT2(4)
9005 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
9006 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9007 IF (IOULEV(1).GT.0)
9008 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9009 & AM1N,AM2N
9010 GOTO 2
9011 ENDIF
9012 AM1N = SQRT(AM1N)
9013 AM2N = SQRT(AM2N)
9014
9015* check chain masses for very low mass chains
9016 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9017 & AM1N,DUM,-IDCH1,IREJ1)
9018 IF (IREJ1.NE.0) GOTO 2
9019 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9020 & AM2N,DUM,-IDCH2,IREJ2)
9021 IF (IREJ2.NE.0) GOTO 2
9022
9023 7 CONTINUE
9024 IF (AM1N.GT.ZERO) THEN
9025 AM1 = AM1N
9026 AM2 = AM2N
9027 ENDIF
9028 DO 6 I=1,4
9029 PP1I(I) = PP1(I)
9030 PP2I(I) = PP2(I)
9031 PT1I(I) = PT1(I)
9032 PT2I(I) = PT2(I)
9033 6 CONTINUE
9034
9035 RETURN
9036
9037 9999 CONTINUE
9038 IREJ = 1
9039 RETURN
9040 END
9041
9042*$ CREATE DT_SAPTRE.FOR
9043*COPY DT_SAPTRE
9044*
9045*===saptre=============================================================*
9046*
9047 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9048
9049************************************************************************
9050* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9051* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9052* Adopted from the original SAPTRE written by J. Ranft. *
9053* This version dated 18.01.95 is written by S. Roesler *
9054************************************************************************
9055
9056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9057 SAVE
9058
9059 PARAMETER ( LINP = 10 ,
9060 & LOUT = 6 ,
9061 & LDAT = 9 )
9062
9063 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9064
9065* event history
9066
9067 PARAMETER (NMXHKK=200000)
9068
9069 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9070 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9071 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9072
9073* extended event history
9074 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9075 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9076 & IHIST(2,NMXHKK)
9077
9078* flags for input different options
9079 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9080 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9081 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9082
9083 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9084
9085 DATA B3 /4.0D0/
9086
9087 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9088 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9089 ESMAX = MIN(ESMAX1,ESMAX2)
9090 IF (ESMAX.LE.0.05D0) RETURN
9091
9092 HMA = PHKK(5,IDX1)
9093 DO 1 K=1,4
9094 PA1(K) = PHKK(K,IDX1)
9095 PA2(K) = PHKK(K,IDX2)
9096 1 CONTINUE
9097
9098 IF (LEMCCK) THEN
9099 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9100 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9101 ENDIF
9102
9103 EXEB = 0.0D0
9104 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9105 BEXP = HMA*(1.0D0-EXEB)/B3
9106 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9107 WA = AXEXP/(BEXP+AXEXP)
9108 XAB = DT_RNDM(WA)
9109 10 CONTINUE
9110* ES is the transverse kinetic energy
9111 IF (XAB.LT.WA)THEN
9112 X = DT_RNDM(WA)
9113 Y = DT_RNDM(WA)
9114 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9115 ELSE
9116 X = DT_RNDM(Y)
9117 ES = ABS(-LOG(X+TINY7)/B3)
9118 ENDIF
9119 IF (ES.GT.ESMAX) GOTO 10
9120 ES = ES+HMA
9121* transverse momentum
9122 HPS = SQRT((ES-HMA)*(ES+HMA))
9123
9124 CALL DT_DSFECF(SFE,CFE)
9125 HPX = HPS*CFE
9126 HPY = HPS*SFE
9127 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9128 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9129 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9130
9131C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9132C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9133 PA1(1) = PA1(1)+HPX
9134 PA1(2) = PA1(2)+HPY
9135 PA2(1) = PA2(1)-HPX
9136 PA2(2) = PA2(2)-HPY
9137
9138* put resonances on mass-shell again
9139 XM1 = PHKK(5,IDX1)
9140 XM2 = PHKK(5,IDX2)
9141 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9142 IF (IREJ1.NE.0) RETURN
9143
9144 IF (LEMCCK) THEN
9145 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9146 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9147 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9148 IF (IREJ1.NE.0) RETURN
9149 ENDIF
9150
9151 DO 2 K=1,4
9152 PHKK(K,IDX1) = P1(K)
9153 PHKK(K,IDX2) = P2(K)
9154 2 CONTINUE
9155
9156 RETURN
9157 END
9158
9159*$ CREATE DT_CRONIN.FOR
9160*COPY DT_CRONIN
9161*
9162*===cronin=============================================================*
9163*
9164 SUBROUTINE DT_CRONIN(INCL)
9165
9166************************************************************************
9167* Cronin-Effect. Multiple scattering of partons at chain ends. *
9168* INCL = 1 multiple sc. in projectile *
9169* = 2 multiple sc. in target *
9170* This version dated 05.01.96 is written by S. Roesler. *
9171************************************************************************
9172
9173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9174 SAVE
9175
9176 PARAMETER ( LINP = 10 ,
9177 & LOUT = 6 ,
9178 & LDAT = 9 )
9179
9180 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9181
9182* event history
9183
9184 PARAMETER (NMXHKK=200000)
9185
9186 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9187 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9188 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9189
9190* extended event history
9191 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9192 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9193 & IHIST(2,NMXHKK)
9194
9195* rejection counter
9196 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9197 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9198 & IREXCI(3),IRDIFF(2),IRINC
9199
9200* Glauber formalism: collision properties
9201 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9202 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9203
9204 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9205
9206 DO 1 K=1,4
9207 DEV(K) = ZERO
9208 1 CONTINUE
9209
9210 DO 2 I=NPOINT(2),NHKK
9211 IF (ISTHKK(I).LT.0) THEN
9212* get z-position of the chain
9213 R(1) = VHKK(1,I)*1.0D12
9214 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9215 R(2) = VHKK(2,I)*1.0D12
9216 IDXNU = JMOHKK(1,I)
9217 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9218 & IDXNU = JMOHKK(1,I-1)
9219 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9220 & IDXNU = JMOHKK(1,I+1)
9221 R(3) = VHKK(3,IDXNU)*1.0D12
9222* position of target parton the chain is connected to
9223 DO 3 K=1,4
9224 PIN(K) = PHKK(K,I)
9225 3 CONTINUE
9226* multiple scattering of parton with DTEVT1-index I
9227 CALL DT_CROMSC(PIN,R,POUT,INCL)
9228**testprint
9229C IF (NEVHKK.EQ.5) THEN
9230C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9231C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9232C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9233C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9234C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9235C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9236C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9237C ENDIF
9238**
9239* increase accumulator by energy-momentum difference
9240 DO 4 K=1,4
9241 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9242 PHKK(K,I) = POUT(K)
9243 4 CONTINUE
9244 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9245 & PHKK(2,I)**2-PHKK(3,I)**2))
9246 ENDIF
9247 2 CONTINUE
9248
9249* dump accumulator to momenta of valence partons
9250 NVAL = 0
9251 ETOT = 0.0D0
9252 DO 5 I=NPOINT(2),NHKK
9253 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9254 NVAL = NVAL+1
9255 ETOT = ETOT+PHKK(4,I)
9256 ENDIF
9257 5 CONTINUE
9258C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9259 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9260 & 9X,4E12.4)
9261 DO 6 I=NPOINT(2),NHKK
9262 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9263 E = PHKK(4,I)
9264 DO 7 K=1,4
9265C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9266 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9267 7 CONTINUE
9268 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9269 & PHKK(2,I)**2-PHKK(3,I)**2))
9270 ENDIF
9271 6 CONTINUE
9272
9273 RETURN
9274 END
9275
9276*$ CREATE DT_CROMSC.FOR
9277*COPY DT_CROMSC
9278*
9279*===cromsc=============================================================*
9280*
9281 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9282
9283************************************************************************
9284* Cronin-Effect. Multiple scattering of one parton passing through *
9285* nuclear matter. *
9286* PIN(4) input 4-momentum of parton *
9287* POUT(4) 4-momentum of parton after mult. scatt. *
9288* R(3) spatial position of parton in target nucleus *
9289* INCL = 1 multiple sc. in projectile *
9290* = 2 multiple sc. in target *
9291* This is a revised version of the original version written by J. Ranft*
9292* This version dated 17.01.95 is written by S. Roesler. *
9293************************************************************************
9294
9295 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9296 SAVE
9297
9298 PARAMETER ( LINP = 10 ,
9299 & LOUT = 6 ,
9300 & LDAT = 9 )
9301
9302 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9303
9304 LOGICAL LSTART
9305
9306* rejection counter
9307 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9308 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9309 & IREXCI(3),IRDIFF(2),IRINC
9310
9311* Glauber formalism: collision properties
9312 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9313 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9314
9315* various options for treatment of partons (DTUNUC 1.x)
9316* (chain recombination, Cronin,..)
9317 LOGICAL LCO2CR,LINTPT
9318 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9319 & LCO2CR,LINTPT
9320
9321 DIMENSION PIN(4),POUT(4),R(3)
9322
9323 DATA LSTART /.TRUE./
9324
9325 IRCRON(1) = IRCRON(1)+1
9326
9327 IF (LSTART) THEN
9328 WRITE(LOUT,1000) CRONCO
9329 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9330 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9331 LSTART = .FALSE.
9332 ENDIF
9333
9334 NCBACK = 0
9335 RNCL = RPROJ
9336 IF (INCL.EQ.2) RNCL = RTARG
9337
9338* Lorentz-transformation into Lab.
9339 MODE = -(INCL+1)
9340 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9341
9342 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9343 IF (PTOT.LE.8.0D0) GOTO 9997
9344
9345* direction cosines of parton before mult. scattering
9346 COSX = PIN(1)/PTOT
9347 COSY = PIN(2)/PTOT
9348 COSZ = PZ/PTOT
9349
9350 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9351 IF (RTESQ.GE.-TINY3) GOTO 9999
9352
9353* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9354* in the direction of particle motion
9355
9356 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9357 TMP = A**2-RTESQ
9358 IF (TMP.LT.ZERO) GOTO 9998
9359 DIST = -A+SQRT(TMP)
9360
9361* multiple scattering angle
9362 THETO = CRONCO*SQRT(DIST)/PTOT
9363 IF (THETO.GT.0.1D0) THETO=0.1D0
9364
9365 1 CONTINUE
9366* Gaussian sampling of spatial angle
9367 CALL DT_RANNOR(R1,R2)
9368 THETA = ABS(R1*THETO)
9369 IF (THETA.GT.0.3D0) GOTO 9997
9370 CALL DT_DSFECF(SFE,CFE)
9371 COSTH = COS(THETA)
9372 SINTH = SIN(THETA)
9373
9374* new direction cosines
9375 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9376 & COSXN,COSYN,COSZN)
9377
9378 POUT(1) = COSXN*PTOT
9379 POUT(2) = COSYN*PTOT
9380 PZ = COSZN*PTOT
9381* Lorentz-transformation into nucl.-nucl. cms
9382 MODE = INCL+1
9383 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9384
9385C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9386C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9387 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9388 THETO = THETO/2.0D0
9389 NCBACK = NCBACK+1
9390 IF (MOD(NCBACK,200).EQ.0) THEN
9391 WRITE(LOUT,1001) THETO,PIN,POUT
9392 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9393 & E12.4,/,1X,' PIN :',4E12.4,/,
9394 & 1X,' POUT:',4E12.4)
9395 GOTO 9997
9396 ENDIF
9397 GOTO 1
9398 ENDIF
9399
9400 RETURN
9401
9402 9997 IRCRON(2) = IRCRON(2)+1
9403 GOTO 9999
9404 9998 IRCRON(3) = IRCRON(3)+1
9405
9406 9999 CONTINUE
9407 DO 100 K=1,4
9408 POUT(K) = PIN(K)
9409 100 CONTINUE
9410 RETURN
9411 END
9412
9413*$ CREATE DT_COM2CR.FOR
9414*COPY DT_COM2CR
9415*
9416*===com2sr=============================================================*
9417*
9418 SUBROUTINE DT_COM2CR
9419
9420************************************************************************
9421* COMbine q-aq chains to Color Ropes (qq-aqaq). *
9422* CUTOF parameter determining minimum number of not *
9423* combined q-aq chains *
9424* This subroutine replaces KKEVCC etc. *
9425* This version dated 11.01.95 is written by S. Roesler. *
9426************************************************************************
9427
9428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9429 SAVE
9430
9431 PARAMETER ( LINP = 10 ,
9432 & LOUT = 6 ,
9433 & LDAT = 9 )
9434
9435* event history
9436
9437 PARAMETER (NMXHKK=200000)
9438
9439 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9440 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9441 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9442
9443* extended event history
9444 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9445 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9446 & IHIST(2,NMXHKK)
9447
9448* statistics
9449 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9450 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9451 & ICEVTG(8,0:30)
9452
9453* various options for treatment of partons (DTUNUC 1.x)
9454* (chain recombination, Cronin,..)
9455 LOGICAL LCO2CR,LINTPT
9456 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9457 & LCO2CR,LINTPT
9458
9459 DIMENSION IDXQA(248),IDXAQ(248)
9460
9461 ICCHAI(1,9) = ICCHAI(1,9)+1
9462 NQA = 0
9463 NAQ = 0
9464* scan DTEVT1 for q-aq, aq-q chains
9465 DO 10 I=NPOINT(3),NHKK
9466* skip "chains" which are resonances
9467 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9468 MO1 = JMOHKK(1,I)
9469 MO2 = JMOHKK(2,I)
9470 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9471* q-aq, aq-q chain found, keep index
9472 IF (IDHKK(MO1).GT.0) THEN
9473 NQA = NQA+1
9474 IDXQA(NQA) = I
9475 ELSE
9476 NAQ = NAQ+1
9477 IDXAQ(NAQ) = I
9478 ENDIF
9479 ENDIF
9480 ENDIF
9481 10 CONTINUE
9482
9483* minimum number of q-aq chains requested for the same projectile/
9484* target
9485 NCHMIN = IDT_NPOISS(CUTOF)
9486
9487* combine q-aq chains of the same projectile
9488 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9489* combine q-aq chains of the same target
9490 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9491* combine aq-q chains of the same projectile
9492 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9493* combine aq-q chains of the same target
9494 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9495
9496 RETURN
9497 END
9498
9499*$ CREATE DT_SCN4CR.FOR
9500*COPY DT_SCN4CR
9501*
9502*===scn4cr=============================================================*
9503*
9504 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9505
9506************************************************************************
9507* SCan q-aq chains for Color Ropes. *
9508* This version dated 11.01.95 is written by S. Roesler. *
9509************************************************************************
9510
9511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9512 SAVE
9513
9514 PARAMETER ( LINP = 10 ,
9515 & LOUT = 6 ,
9516 & LDAT = 9 )
9517
9518* event history
9519
9520 PARAMETER (NMXHKK=200000)
9521
9522 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9523 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9524 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9525
9526* extended event history
9527 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9528 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9529 & IHIST(2,NMXHKK)
9530
9531 DIMENSION IDXCH(248),IDXJN(248)
9532
9533 DO 1 I=1,NCH
9534 IF (IDXCH(I).GT.0) THEN
9535 NJOIN = 1
9536 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9537 IDXJN(NJOIN) = I
9538 IF (I.LT.NCH) THEN
9539 DO 2 J=I+1,NCH
9540 IF (IDXCH(J).GT.0) THEN
9541 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9542 IF (IDXMO.EQ.IDXMO1) THEN
9543 NJOIN = NJOIN+1
9544 IDXJN(NJOIN) = J
9545 ENDIF
9546 ENDIF
9547 2 CONTINUE
9548 ENDIF
9549 IF (NJOIN.GE.NCHMIN+2) THEN
9550 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9551 DO 3 J=1,2*NJ,2
9552 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9553 IF (IREJ1.NE.0) GOTO 3
9554 IDXCH(IDXJN(J)) = 0
9555 IDXCH(IDXJN(J+1)) = 0
9556 3 CONTINUE
9557 ENDIF
9558 ENDIF
9559 1 CONTINUE
9560
9561 RETURN
9562 END
9563
9564*$ CREATE DT_JOIN.FOR
9565*COPY DT_JOIN
9566*
9567*===join===============================================================*
9568*
9569 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9570
9571************************************************************************
9572* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9573* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9574* This version dated 11.01.95 is written by S. Roesler. *
9575************************************************************************
9576
9577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9578 SAVE
9579
9580 PARAMETER ( LINP = 10 ,
9581 & LOUT = 6 ,
9582 & LDAT = 9 )
9583
9584* event history
9585
9586 PARAMETER (NMXHKK=200000)
9587
9588 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9589 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9590 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9591
9592* extended event history
9593 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9594 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9595 & IHIST(2,NMXHKK)
9596
9597* flags for input different options
9598 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9599 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9600 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9601
9602* statistics
9603 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9604 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9605 & ICEVTG(8,0:30)
9606
9607 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9608
9609 IREJ = 0
9610
9611 IDX(1) = IDX1
9612 IDX(2) = IDX2
9613 DO 1 I=1,2
9614 DO 2 J=1,2
9615 MO(I,J) = JMOHKK(J,IDX(I))
9616 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9617 2 CONTINUE
9618 1 CONTINUE
9619
9620* check consistency
9621 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9622 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9623 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9624 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9625 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9626 & MO(2,2)
9627 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9628 & 2I5,' chain ',I4,':',2I5)
9629 ENDIF
9630
9631* join chains
9632 DO 3 K=1,4
9633 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9634 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9635 3 CONTINUE
9636 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9637 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9638 IST1 = ISTHKK(MO(1,1))
9639 IST2 = ISTHKK(MO(1,2))
9640
9641* put partons again on mass shell
9642 XM1 = 0.0D0
9643 XM2 = 0.0D0
9644 IF (IMSHL.EQ.1) THEN
9645
9646 XM1 = PYMASS(IF1)
9647 XM2 = PYMASS(IF2)
9648
9649 ENDIF
9650 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9651 IF (IREJ1.NE.0) GOTO 9999
9652 DO 4 I=1,4
9653 PP(I) = P1(I)
9654 PT(I) = P2(I)
9655 4 CONTINUE
9656
9657* store new partons in DTEVT1
9658 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9659 & 0,0,0)
9660 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9661 & 0,0,0)
9662 DO 5 K=1,4
9663 PCH(K) = PP(K)+PT(K)
9664 5 CONTINUE
9665
9666* check new chain for lower mass limit
9667 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9668 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9669 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9670 & AMCH,AMCHN,3,IREJ1)
9671 IF (IREJ1.NE.0) THEN
9672 NHKK = NHKK-2
9673 GOTO 9999
9674 ENDIF
9675 ENDIF
9676
9677 ICCHAI(2,9) = ICCHAI(2,9)+1
9678* store new chain in DTEVT1
9679 KCH = 191
9680 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9681 IDHKK(IDX(1)) = 22222
9682 IDHKK(IDX(2)) = 22222
9683* special treatment for space-time coordinates
9684 DO 6 K=1,4
9685 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9686 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9687 6 CONTINUE
9688 RETURN
9689
9690 9999 CONTINUE
9691 IREJ = 1
9692 RETURN
9693 END
9694*$ CREATE DT_XSGLAU.FOR
9695*COPY DT_XSGLAU
9696*
9697*===xsglau=============================================================*
9698*
9699 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9700
9701************************************************************************
9702* Total, elastic, quasi-elastic, inelastic cross sections according to *
9703* Glauber's approach. *
9704* NA / NB mass numbers of proj./target nuclei *
9705* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9706* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9707* IE,IQ indices of energy and virtuality (the latter for gamma *
9708* projectiles only) *
9709* NIDX index of projectile/target nucleus *
9710* This version dated 17.3.98 is written by S. Roesler *
9711************************************************************************
9712
9713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9714 SAVE
9715
9716 PARAMETER ( LINP = 10 ,
9717 & LOUT = 6 ,
9718 & LDAT = 9 )
9719
9720 COMPLEX*16 CZERO,CONE,CTWO
9721 CHARACTER*12 CFILE
9722 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9723 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9724 PARAMETER (TWOPI = 6.283185307179586454D+00,
9725 & PI = TWOPI/TWO,
9726 & GEV2MB = 0.38938D0,
9727 & GEV2FM = 0.1972D0,
9728 & ALPHEM = ONE/137.0D0,
9729* proton mass
9730 & AMP = 0.938D0,
9731 & AMP2 = AMP**2,
9732* approx. nucleon radius
9733 & RNUCLE = 1.12D0)
9734
9735* particle properties (BAMJET index convention)
9736 CHARACTER*8 ANAME
9737 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9738 & IICH(210),IIBAR(210),K1(210),K2(210)
9739
9740 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9741
9742 PARAMETER ( MAXNCL = 260,
9743
9744 & MAXVQU = MAXNCL,
9745 & MAXSQU = 20*MAXVQU,
9746 & MAXINT = MAXVQU+MAXSQU)
9747
9748* Glauber formalism: parameters
9749 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9750 & BMAX(NCOMPX),BSTEP(NCOMPX),
9751 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9752 & NSITEB,NSTATB
9753
9754* Glauber formalism: cross sections
9755 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9756 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9757 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9758 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9759 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9760 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9761 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9762 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9763 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9764 & BSLOPE,NEBINI,NQBINI
9765
9766* Glauber formalism: flags and parameters for statistics
9767 LOGICAL LPROD
9768 CHARACTER*8 CGLB
9769 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9770
9771* nucleon-nucleon event-generator
9772 CHARACTER*8 CMODEL
9773 LOGICAL LPHOIN
9774 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9775
9776* VDM parameter for photon-nucleus interactions
9777 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9778
9779* parameters for hA-diffraction
9780 COMMON /DTDIHA/ DIBETA,DIALPH
9781
9782 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9783 & OMPP11,OMPP12,OMPP21,OMPP22,
9784 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9785 & PPTMP1,PPTMP2
9786 COMPLEX*16 C,CA,CI
9787 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9788 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9789 & BPROD(KSITEB)
9790
9791 PARAMETER (NPOINT=16)
9792 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9793
9794 LOGICAL LFIRST,LOPEN
9795 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9796
9797 NTARG = ABS(NIDX)
9798* for quasi-elastic neutrino scattering set projectile to proton
9799* it should not have an effect since the whole Glauber-formalism is
9800* not needed for these interactions..
9801 IF (MCGENE.EQ.4) THEN
9802 IJPROJ = 1
9803 ELSE
9804 IJPROJ = JJPROJ
9805 ENDIF
9806
9807 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9808 I = INDEX(CGLB,' ')
9809 IF (I.EQ.0) THEN
9810 CFILE = CGLB//'.glb'
9811 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9812 ELSEIF (I.GT.1) THEN
9813 CFILE = CGLB(1:I-1)//'.glb'
9814 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9815 ELSE
9816 STOP 'XSGLAU 1'
9817 ENDIF
9818 LOPEN = .TRUE.
9819 ENDIF
9820
9821 CZERO = DCMPLX(ZERO,ZERO)
9822 CONE = DCMPLX(ONE,ZERO)
9823 CTWO = DCMPLX(TWO,ZERO)
9824 NEBINI = IE
9825 NQBINI = IQ
9826
9827* re-define kinematics
9828 S = ECMI**2
9829 Q2 = Q2I
9830 X = XI
9831* g(Q2=0)-A, h-A, A-A scattering
9832 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9833 Q2 = 0.0001D0
9834 X = Q2/(S+Q2-AMP2)
9835* g(Q2>0)-A scattering
9836 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9837 X = Q2/(S+Q2-AMP2)
9838 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9839 Q2 = (S-AMP2)*X/(ONE-X)
9840 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9841 S = Q2*(ONE-X)/X+AMP2
9842 ELSE
9843 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9844 STOP
9845 ENDIF
9846 ECMNN(IE) = SQRT(S)
9847 Q2G(IQ) = Q2
9848 XNU = (S+Q2-AMP2)/(TWO*AMP)
9849
9850* parameters determining statistics in evaluating Glauber-xsection
9851 NSTATB = JSTATB
9852 NSITEB = JBINSB
9853 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9854
9855* set up interaction geometry (common /DTGLAM/)
9856* projectile/target radii
9857 RPRNCL = DT_RNCLUS(NA)
9858 RTANCL = DT_RNCLUS(NB)
9859 IF (IJPROJ.EQ.7) THEN
9860 RASH(1) = ZERO
9861 RBSH(NTARG) = RTANCL
9862 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9863 ELSE
9864 IF (NIDX.LE.-1) THEN
9865 RASH(1) = RPRNCL
9866 RBSH(NTARG) = RTANCL
9867 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9868 ELSE
9869 RASH(NTARG) = RPRNCL
9870 RBSH(1) = RTANCL
9871 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9872 ENDIF
9873 ENDIF
9874* maximum impact-parameter
9875 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9876
9877* slope, rho ( Re(f(0))/Im(f(0)) )
9878 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9879 IF (MCGENE.EQ.2) THEN
9880 ZERO1 = ZERO
9881 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9882 & BSLOPE,0)
9883 ELSE
9884 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9885 ENDIF
9886 IF (ECMNN(IE).LE.3.0D0) THEN
9887 ROSH = -0.43D0
9888 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9889 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9890 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9891 ROSH = 0.1D0
9892 ENDIF
9893 ELSEIF (IJPROJ.EQ.7) THEN
9894 ROSH = 0.1D0
9895 ELSE
9896 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9897 ROSH = 0.01D0
9898 ENDIF
9899
9900* projectile-nucleon xsection (in fm)
9901 IF (IJPROJ.EQ.7) THEN
9902 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9903 ELSE
9904 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9905 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9906C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9907 DUMZER = ZERO
9908 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9909 SIGSH = SIGSH/10.0D0
9910 ENDIF
9911
9912* parameters for projectile diffraction (hA scattering only)
9913 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9914 & .AND.(DIBETA.GE.ZERO)) THEN
9915 ZERO1 = ZERO
9916 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9917C DIBETA = SDIF1/STOT
9918 DIBETA = 0.2D0
9919 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9920 IF (DIBETA.LE.ZERO) THEN
9921 ALPGAM = ONE
9922 ELSE
9923 ALPGAM = DIALPH/DIGAMM
9924 ENDIF
9925 FACDI1 = ONE-ALPGAM
9926 FACDI2 = ONE+ALPGAM
9927 FACDI = SQRT(FACDI1*FACDI2)
9928 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9929 ELSE
9930 DIBETA = -1.0D0
9931 DIALPH = ZERO
9932 DIGAMM = ZERO
9933 FACDI1 = ZERO
9934 FACDI2 = 2.0D0
9935 FACDI = ZERO
9936 ENDIF
9937
9938* initializations
9939 DO 10 I=1,NSITEB
9940 BSITE( 0,IQ,NTARG,I) = ZERO
9941 BSITE(IE,IQ,NTARG,I) = ZERO
9942 BPROD(I) = ZERO
9943 10 CONTINUE
9944 STOT = ZERO
9945 STOT2 = ZERO
9946 SELA = ZERO
9947 SELA2 = ZERO
9948 SQEP = ZERO
9949 SQEP2 = ZERO
9950 SQET = ZERO
9951 SQET2 = ZERO
9952 SQE2 = ZERO
9953 SQE22 = ZERO
9954 SPRO = ZERO
9955 SPRO2 = ZERO
9956 SDEL = ZERO
9957 SDEL2 = ZERO
9958 SDQE = ZERO
9959 SDQE2 = ZERO
9960 FACN = ONE/DBLE(NSTATB)
9961
9962 IPNT = 0
9963 RPNT = ZERO
9964
9965* initialize Gauss-integration for photon-proj.
9966 JPOINT = 1
9967 IF (IJPROJ.EQ.7) THEN
9968 IF (INTRGE(1).EQ.1) THEN
9969 AMLO2 = (3.0D0*AAM(13))**2
9970 ELSEIF (INTRGE(1).EQ.2) THEN
9971 AMLO2 = AAM(33)**2
9972 ELSE
9973 AMLO2 = AAM(96)**2
9974 ENDIF
9975 IF (INTRGE(2).EQ.1) THEN
9976 AMHI2 = S/TWO
9977 ELSEIF (INTRGE(2).EQ.2) THEN
9978 AMHI2 = S/4.0D0
9979 ELSE
9980 AMHI2 = S
9981 ENDIF
9982 AMHI20 = (ECMNN(IE)-AMP)**2
9983 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9984 XAMLO = LOG( AMLO2+Q2 )
9985 XAMHI = LOG( AMHI2+Q2 )
9986**PHOJET105a
9987C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9988**PHOJET112
9989
9990 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9991
9992**
9993 JPOINT = NPOINT
9994* ratio direct/total photon-nucleon xsection
9995 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9996 ENDIF
9997
9998* read pre-initialized profile-function from file
9999 IF (IOGLB.EQ.1) THEN
10000 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10001 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10002 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10003 & NA,NB,NSTATB,NSITEB
10004 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10005 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10006 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
10007 STOP
10008 ENDIF
10009 IF (LFIRST) WRITE(LOUT,1001) CFILE
10010 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10011 & 'file ',A12,/)
10012 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10013 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10014 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10015 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10016 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10017 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10018 NLINES = INT(DBLE(NSITEB)/7.0D0)
10019 IF (NLINES.GT.0) THEN
10020 DO 21 I=1,NLINES
10021 ISTART = 7*I-6
10022 READ(LDAT,'(7E11.4)')
10023 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10024 21 CONTINUE
10025 ENDIF
10026 ISTART = 7*NLINES+1
10027 IF (ISTART.LE.NSITEB) THEN
10028 READ(LDAT,'(7E11.4)')
10029 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10030 ENDIF
10031 LFIRST = .FALSE.
10032 GOTO 100
10033* variable projectile/target/energy runs:
10034* read pre-initialized profile-functions from file
10035 ELSEIF (IOGLB.EQ.100) THEN
10036 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10037 GOTO 100
10038 ENDIF
10039
10040* cross sections averaged over NSTATB nucleon configurations
10041 DO 11 IS=1,NSTATB
10042C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10043 STOTN = ZERO
10044 SELAN = ZERO
10045 SQEPN = ZERO
10046 SQETN = ZERO
10047 SQE2N = ZERO
10048 SPRON = ZERO
10049 SDELN = ZERO
10050 SDQEN = ZERO
10051
10052 IF (NIDX.LE.-1) THEN
10053 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10054 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10055 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10056 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10057 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10058 ENDIF
10059 ELSE
10060 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10061 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10062 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10063 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10064 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10065 ENDIF
10066 ENDIF
10067
10068* integration over impact parameter B
10069 DO 12 IB=1,NSITEB-1
10070 STOTB = ZERO
10071 SELAB = ZERO
10072 SQEPB = ZERO
10073 SQETB = ZERO
10074 SQE2B = ZERO
10075 SPROB = ZERO
10076 SDIR = ZERO
10077 SDELB = ZERO
10078 SDQEB = ZERO
10079 B = DBLE(IB)*BSTEP(NTARG)
10080 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10081
10082* integration over M_V^2 for photon-proj.
10083 DO 14 IM=1,JPOINT
10084 PP11(1) = CONE
10085 PP12(1) = CONE
10086 PP21(1) = CONE
10087 PP22(1) = CONE
10088 IF (IJPROJ.EQ.7) THEN
10089 DO 13 K=2,NB
10090 PP11(K) = CONE
10091 PP12(K) = CONE
10092 PP21(K) = CONE
10093 PP22(K) = CONE
10094 13 CONTINUE
10095 ENDIF
10096 SHI = ZERO
10097 FACM = ONE
10098 DCOH = 1.0D10
10099
10100 IF (IJPROJ.EQ.7) THEN
10101 AMV2 = EXP(ABSZX(IM))-Q2
10102 AMV = SQRT(AMV2)
10103 IF (AMV2.LT.16.0D0) THEN
10104 R = TWO
10105 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10106 R = 10.0D0/3.0D0
10107 ELSE
10108 R = 11.0D0/3.0D0
10109 ENDIF
10110* define M_V dependent properties of nucleon scattering amplitude
10111* V_M-nucleon xsection
10112 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10113 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10114* slope-parametrisation a la Kaidalov
10115 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10116 & +0.25D0*LOG(S/(AMV2+Q2)))
10117* coherence length
10118 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10119* integration weight factor
10120 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10121 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10122 ENDIF
10123 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10124 GAM = GSH
10125 IF (IJPROJ.EQ.7) THEN
10126 RCA = GAM*SIGMV/TWOPI
10127 ELSE
10128 RCA = GAM*SIGSH/TWOPI
10129 ENDIF
10130 FCA = -ROSH*RCA
10131 CA = DCMPLX(RCA,FCA)
10132 CI = CONE
10133
10134 DO 15 INA=1,NA
10135 KK1 = 1
10136 INT1 = 1
10137 KK2 = 1
10138 INT2 = 1
10139 DO 16 INB=1,NB
10140* photon-projectile: check for supression by coherence length
10141 IF (IJPROJ.EQ.7) THEN
10142 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10143 KK1 = INB
10144 INT1 = INT1+1
10145 ENDIF
10146 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10147 KK2 = INB
10148 INT2 = INT2+1
10149 ENDIF
10150 ENDIF
10151
10152 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10153 Y11 = COOT1(2,INB)-COOP1(2,INA)
10154 XY11 = GAM*(X11*X11+Y11*Y11)
10155 IF (XY11.LE.15.0D0) THEN
10156 C = CONE-CA*EXP(-XY11)
10157 AR = DBLE(PP11(INT1))
10158 AI = DIMAG(PP11(INT1))
10159 IF (ABS(AR).LT.TINY25) AR = ZERO
10160 IF (ABS(AI).LT.TINY25) AI = ZERO
10161 PP11(INT1) = DCMPLX(AR,AI)
10162 PP11(INT1) = PP11(INT1)*C
10163 AR = DBLE(C)
10164 AI = DIMAG(C)
10165 SHI = SHI+LOG(AR*AR+AI*AI)
10166 ENDIF
10167 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10168 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10169 Y12 = COOT2(2,INB)-COOP1(2,INA)
10170 XY12 = GAM*(X12*X12+Y12*Y12)
10171 IF (XY12.LE.15.0D0) THEN
10172 C = CONE-CA*EXP(-XY12)
10173 AR = DBLE(PP12(INT2))
10174 AI = DIMAG(PP12(INT2))
10175 IF (ABS(AR).LT.TINY25) AR = ZERO
10176 IF (ABS(AI).LT.TINY25) AI = ZERO
10177 PP12(INT2) = DCMPLX(AR,AI)
10178 PP12(INT2) = PP12(INT2)*C
10179 ENDIF
10180 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10181 Y21 = COOT1(2,INB)-COOP2(2,INA)
10182 XY21 = GAM*(X21*X21+Y21*Y21)
10183 IF (XY21.LE.15.0D0) THEN
10184 C = CONE-CA*EXP(-XY21)
10185 AR = DBLE(PP21(INT1))
10186 AI = DIMAG(PP21(INT1))
10187 IF (ABS(AR).LT.TINY25) AR = ZERO
10188 IF (ABS(AI).LT.TINY25) AI = ZERO
10189 PP21(INT1) = DCMPLX(AR,AI)
10190 PP21(INT1) = PP21(INT1)*C
10191 ENDIF
10192 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10193 Y22 = COOT2(2,INB)-COOP2(2,INA)
10194 XY22 = GAM*(X22*X22+Y22*Y22)
10195 IF (XY22.LE.15.0D0) THEN
10196 C = CONE-CA*EXP(-XY22)
10197 AR = DBLE(PP22(INT2))
10198 AI = DIMAG(PP22(INT2))
10199 IF (ABS(AR).LT.TINY25) AR = ZERO
10200 IF (ABS(AI).LT.TINY25) AI = ZERO
10201 PP22(INT2) = DCMPLX(AR,AI)
10202 PP22(INT2) = PP22(INT2)*C
10203 ENDIF
10204 ENDIF
10205 16 CONTINUE
10206 15 CONTINUE
10207
10208 OMPP11 = CZERO
10209 OMPP21 = CZERO
10210 DIPP11 = CZERO
10211 DIPP21 = CZERO
10212 DO 17 K=1,INT1
10213 IF (PP11(K).EQ.CZERO) THEN
10214 PPTMP1 = CZERO
10215 PPTMP2 = CZERO
10216 ELSE
10217 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10218 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10219 ENDIF
10220 AVDIPP = 0.5D0*
10221 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10222 OMPP11 = OMPP11+AVDIPP
10223C OMPP11 = OMPP11+(CONE-PP11(K))
10224 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10225 DIPP11 = DIPP11+AVDIPP
10226 IF (PP21(K).EQ.CZERO) THEN
10227 PPTMP1 = CZERO
10228 PPTMP2 = CZERO
10229 ELSE
10230 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10231 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10232 ENDIF
10233 AVDIPP = 0.5D0*
10234 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10235 OMPP21 = OMPP21+AVDIPP
10236C OMPP21 = OMPP21+(CONE-PP21(K))
10237 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10238 DIPP21 = DIPP21+AVDIPP
10239 17 CONTINUE
10240 OMPP12 = CZERO
10241 OMPP22 = CZERO
10242 DIPP12 = CZERO
10243 DIPP22 = CZERO
10244 DO 18 K=1,INT2
10245 IF (PP12(K).EQ.CZERO) THEN
10246 PPTMP1 = CZERO
10247 PPTMP2 = CZERO
10248 ELSE
10249 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10250 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10251 ENDIF
10252 AVDIPP = 0.5D0*
10253 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10254 OMPP12 = OMPP12+AVDIPP
10255C OMPP12 = OMPP12+(CONE-PP12(K))
10256 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10257 DIPP12 = DIPP12+AVDIPP
10258 IF (PP22(K).EQ.CZERO) THEN
10259 PPTMP1 = CZERO
10260 PPTMP2 = CZERO
10261 ELSE
10262 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10263 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10264 ENDIF
10265 AVDIPP = 0.5D0*
10266 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10267 OMPP22 = OMPP22+AVDIPP
10268C OMPP22 = OMPP22+(CONE-PP22(K))
10269 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10270 DIPP22 = DIPP22+AVDIPP
10271 18 CONTINUE
10272
10273 SPROM = ONE-EXP(SHI)
10274 SPROB = SPROB+FACM*SPROM
10275 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10276 STOTM = DBLE(OMPP11+OMPP22)
10277 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10278 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10279 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10280 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10281 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10282 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10283 STOTB = STOTB+FACM*STOTM
10284 SELAB = SELAB+FACM*SELAM
10285 SDELB = SDELB+FACM*SDELM
10286 IF (NB.GT.1) THEN
10287 SQEPB = SQEPB+FACM*SQEPM
10288 SDQEB = SDQEB+FACM*SDQEM
10289 ENDIF
10290 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10291 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10292 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10293 ENDIF
10294
10295 14 CONTINUE
10296
10297 STOTN = STOTN+FACB*STOTB
10298 SELAN = SELAN+FACB*SELAB
10299 SQEPN = SQEPN+FACB*SQEPB
10300 SQETN = SQETN+FACB*SQETB
10301 SQE2N = SQE2N+FACB*SQE2B
10302 SPRON = SPRON+FACB*SPROB
10303 SDELN = SDELN+FACB*SDELB
10304 SDQEN = SDQEN+FACB*SDQEB
10305
10306 IF (IJPROJ.EQ.7) THEN
10307 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10308 ELSE
10309 IF (DIBETA.GT.ZERO) THEN
10310 BPROD(IB+1)= BPROD(IB+1)
10311 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10312 ELSE
10313 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10314 ENDIF
10315 ENDIF
10316
10317 12 CONTINUE
10318
10319 STOT = STOT +FACN*STOTN
10320 STOT2 = STOT2+FACN*STOTN**2
10321 SELA = SELA +FACN*SELAN
10322 SELA2 = SELA2+FACN*SELAN**2
10323 SQEP = SQEP +FACN*SQEPN
10324 SQEP2 = SQEP2+FACN*SQEPN**2
10325 SQET = SQET +FACN*SQETN
10326 SQET2 = SQET2+FACN*SQETN**2
10327 SQE2 = SQE2 +FACN*SQE2N
10328 SQE22 = SQE22+FACN*SQE2N**2
10329 SPRO = SPRO +FACN*SPRON
10330 SPRO2 = SPRO2+FACN*SPRON**2
10331 SDEL = SDEL +FACN*SDELN
10332 SDEL2 = SDEL2+FACN*SDELN**2
10333 SDQE = SDQE +FACN*SDQEN
10334 SDQE2 = SDQE2+FACN*SDQEN**2
10335
10336 11 CONTINUE
10337
10338* final cross sections
10339* 1) total
10340 XSTOT(IE,IQ,NTARG) = STOT
10341 IF (IJPROJ.EQ.7)
10342 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10343* 2) elastic
10344 XSELA(IE,IQ,NTARG) = SELA
10345* 3) quasi-el.: A+B-->A+X (excluding 2)
10346 XSQEP(IE,IQ,NTARG) = SQEP
10347* 4) quasi-el.: A+B-->X+B (excluding 2)
10348 XSQET(IE,IQ,NTARG) = SQET
10349* 5) quasi-el.: A+B-->X (excluding 2-4)
10350 XSQE2(IE,IQ,NTARG) = SQE2
10351* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10352 IF (SDEL.GT.ZERO) THEN
10353 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10354 ELSE
10355 XSPRO(IE,IQ,NTARG) = SPRO
10356 ENDIF
10357* 7) projectile diffraction (el. scatt. off target)
10358 XSDEL(IE,IQ,NTARG) = SDEL
10359* 8) projectile diffraction (quasi-el. scatt. off target)
10360 XSDQE(IE,IQ,NTARG) = SDQE
10361* stat. errors
10362 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10363 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10364 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10365 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10366 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10367 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10368 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10369 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10370
10371 IF (IJPROJ.EQ.7) THEN
10372 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10373 & -XSQEP(IE,IQ,NTARG)
10374 ELSE
10375 BNORM = XSPRO(IE,IQ,NTARG)
10376 ENDIF
10377 DO 19 I=2,NSITEB
10378 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10379 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10380 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10381 19 CONTINUE
10382
10383* write profile function data into file
10384 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10385 WRITE(LDAT,'(5I10,1P,E15.5)')
10386 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10387 WRITE(LDAT,'(1P,6E12.5)')
10388 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10389 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10390 WRITE(LDAT,'(1P,6E12.5)')
10391 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10392 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10393 NLINES = INT(DBLE(NSITEB)/7.0D0)
10394 IF (NLINES.GT.0) THEN
10395 DO 20 I=1,NLINES
10396 ISTART = 7*I-6
10397 WRITE(LDAT,'(1P,7E11.4)')
10398 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10399 20 CONTINUE
10400 ENDIF
10401 ISTART = 7*NLINES+1
10402 IF (ISTART.LE.NSITEB) THEN
10403 WRITE(LDAT,'(1P,7E11.4)')
10404 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10405 ENDIF
10406 ENDIF
10407
10408 100 CONTINUE
10409
10410C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10411
10412 RETURN
10413 END
10414
10415*$ CREATE DT_GETBXS.FOR
10416*COPY DT_GETBXS
10417*
10418*===getbxs=============================================================*
10419*
10420 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10421
10422************************************************************************
10423* Biasing in impact parameter space. *
10424* XSFRAC = 0 : BLO - minimum impact parameter (input) *
10425* BHI - maximum impact parameter (input) *
10426* XSFRAC - fraction of cross section corresponding *
10427* to impact parameter range (BLO,BHI) *
10428* (output) *
10429* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10430* BHI - maximum impact parameter giving requested *
10431* fraction of cross section in impact *
10432* parameter range (0,BMAX) (output) *
10433* This version dated 17.03.00 is written by S. Roesler *
10434************************************************************************
10435
10436 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10437 SAVE
10438
10439 PARAMETER ( LINP = 10 ,
10440 & LOUT = 6 ,
10441 & LDAT = 9 )
10442
10443 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10444
10445* Glauber formalism: parameters
10446 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10447 & BMAX(NCOMPX),BSTEP(NCOMPX),
10448 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10449 & NSITEB,NSTATB
10450
10451 NTARG = ABS(NIDX)
10452 IF (XSFRAC.LE.0.0D0) THEN
10453 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10454 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10455 IF (ILO.GE.IHI) THEN
10456 XSFRAC = 0.0D0
10457 RETURN
10458 ENDIF
10459 IF (ILO.EQ.NSITEB-1) THEN
10460 FRCLO = BSITE(0,1,NTARG,NSITEB)
10461 ELSE
10462 FRCLO = BSITE(0,1,NTARG,ILO+1)
10463 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10464 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10465 ENDIF
10466 IF (IHI.EQ.NSITEB-1) THEN
10467 FRCHI = BSITE(0,1,NTARG,NSITEB)
10468 ELSE
10469 FRCHI = BSITE(0,1,NTARG,IHI+1)
10470 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10471 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10472 ENDIF
10473 XSFRAC = FRCHI-FRCLO
10474 ELSE
10475 BLO = 0.0D0
10476 BHI = BMAX(NTARG)
10477 DO 1 I=1,NSITEB-1
10478 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10479 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10480 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10481 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10482 GOTO 2
10483 ENDIF
10484 1 CONTINUE
10485 2 CONTINUE
10486 ENDIF
10487
10488 RETURN
10489 END
10490
10491*$ CREATE DT_CONUCL.FOR
10492*COPY DT_CONUCL
10493*
10494*===conucl=============================================================*
10495*
10496 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10497
10498************************************************************************
10499* Calculation of coordinates of nucleons within nuclei. *
10500* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10501* N / R number of nucleons / radius of nucleus (input) *
10502* MODE = 0 coordinates not sorted *
10503* = 1 coordinates sorted with increasing X(3,i) *
10504* = 2 coordinates sorted with decreasing X(3,i) *
10505* This version dated 26.10.95 is revised by S. Roesler *
10506************************************************************************
10507
10508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10509 SAVE
10510
10511 PARAMETER ( LINP = 10 ,
10512 & LOUT = 6 ,
10513 & LDAT = 9 )
10514
10515 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10516 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10517
10518 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10519
10520 PARAMETER (NSRT=10)
10521 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10522 DIMENSION X(3,N),XTMP(3,260)
10523
10524 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10525
10526 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10527 K = 0
10528 DO 1 I=1,NSRT
10529 IF (MODE.EQ.2) THEN
10530 ISRT = NSRT+1-I
10531 ELSE
10532 ISRT = I
10533 ENDIF
10534 K1 = K
10535 DO 2 J=1,ICSRT(ISRT)
10536 K = K+1
10537 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10538 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10539 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10540 2 CONTINUE
10541 IF (ICSRT(ISRT).GT.1) THEN
10542 I0 = K1+1
10543 I1 = K
10544 CALL DT_SORT(X,N,I0,I1,MODE)
10545 ENDIF
10546 1 CONTINUE
10547 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10548 DO 3 I=1,N
10549 X(1,I) = XTMP(1,I)
10550 X(2,I) = XTMP(2,I)
10551 X(3,I) = XTMP(3,I)
10552 3 CONTINUE
10553 CALL DT_SORT(X,N,1,N,MODE)
10554 ELSE
10555 DO 4 I=1,N
10556 X(1,I) = XTMP(1,I)
10557 X(2,I) = XTMP(2,I)
10558 X(3,I) = XTMP(3,I)
10559 4 CONTINUE
10560 ENDIF
10561
10562 RETURN
10563 END
10564
10565*$ CREATE DT_COORDI.FOR
10566*COPY DT_COORDI
10567*
10568*===coordi=============================================================*
10569*
10570 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10571
10572************************************************************************
10573* Calculation of coordinates of nucleons within nuclei. *
10574* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10575* N / R number of nucleons / radius of nucleus (input) *
10576* Based on the original version by Shmakov et al. *
10577* This version dated 26.10.95 is revised by S. Roesler *
10578************************************************************************
10579
10580 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10581 SAVE
10582
10583 PARAMETER ( LINP = 10 ,
10584 & LOUT = 6 ,
10585 & LDAT = 9 )
10586
10587 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10588 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10589
10590 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10591
10592 LOGICAL LSTART
10593
10594 PARAMETER (NSRT=10)
10595 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10596 DIMENSION X(3,260),WD(4),RD(3)
10597
10598 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10599 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10600 DATA RD /2.09D0, 0.935D0, 0.697D0/
10601
10602 X1SUM = ZERO
10603 X2SUM = ZERO
10604 X3SUM = ZERO
10605
10606 IF (N.EQ.1) THEN
10607 X(1,1) = ZERO
10608 X(2,1) = ZERO
10609 X(3,1) = ZERO
10610 ELSEIF (N.EQ.2) THEN
10611 EPS = DT_RNDM(RD(1))
10612 DO 30 I=1,3
10613 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10614 30 CONTINUE
10615 40 CONTINUE
10616 DO 50 J=1,3
10617 CALL DT_RANNOR(X1,X2)
10618 X(J,1) = RD(I)*X1
10619 X(J,2) = -X(J,1)
10620 50 CONTINUE
10621 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10622 SIGMA = R/SQRTWO
10623 LSTART = .TRUE.
10624 CALL DT_RANNOR(X3,X4)
10625 DO 100 I=1,N
10626 CALL DT_RANNOR(X1,X2)
10627 X(1,I) = SIGMA*X1
10628 X(2,I) = SIGMA*X2
10629 IF (LSTART) GOTO 80
10630 X(3,I) = SIGMA*X4
10631 CALL DT_RANNOR(X3,X4)
10632 GOTO 90
10633 80 CONTINUE
10634 X(3,I) = SIGMA*X3
10635 90 CONTINUE
10636 LSTART = .NOT.LSTART
10637 X1SUM = X1SUM+X(1,I)
10638 X2SUM = X2SUM+X(2,I)
10639 X3SUM = X3SUM+X(3,I)
10640 100 CONTINUE
10641 X1SUM = X1SUM/DBLE(N)
10642 X2SUM = X2SUM/DBLE(N)
10643 X3SUM = X3SUM/DBLE(N)
10644 DO 101 I=1,N
10645 X(1,I) = X(1,I)-X1SUM
10646 X(2,I) = X(2,I)-X2SUM
10647 X(3,I) = X(3,I)-X3SUM
10648 101 CONTINUE
10649 ELSE
10650
10651* maximum nuclear radius for coordinate sampling
10652 RMAX = R+4.605D0*PDIF
10653
10654* initialize pre-sorting
10655 DO 121 I=1,NSRT
10656 ICSRT(I) = 0
10657 121 CONTINUE
10658 DR = TWO*RMAX/DBLE(NSRT)
10659
10660* sample coordinates for N nucleons
10661 DO 140 I=1,N
10662 120 CONTINUE
10663 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10664 F = DT_DENSIT(N,RAD,R)
10665 IF (DT_RNDM(RAD).GT.F) GOTO 120
10666* theta, phi uniformly distributed
10667 CT = ONE-TWO*DT_RNDM(F)
10668 ST = SQRT((ONE-CT)*(ONE+CT))
10669 CALL DT_DSFECF(SFE,CFE)
10670 X(1,I) = RAD*ST*CFE
10671 X(2,I) = RAD*ST*SFE
10672 X(3,I) = RAD*CT
10673* ensure that distance between two nucleons is greater than R2MIN
10674 IF (I.LT.2) GOTO 122
10675 I1 = I-1
10676 DO 130 I2=1,I1
10677 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10678 & (X(3,I)-X(3,I2))**2
10679 IF (DIST2.LE.R2MIN) GOTO 120
10680 130 CONTINUE
10681 122 CONTINUE
10682* save index according to z-bin
10683 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10684 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10685 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10686 X1SUM = X1SUM+X(1,I)
10687 X2SUM = X2SUM+X(2,I)
10688 X3SUM = X3SUM+X(3,I)
10689 140 CONTINUE
10690 X1SUM = X1SUM/DBLE(N)
10691 X2SUM = X2SUM/DBLE(N)
10692 X3SUM = X3SUM/DBLE(N)
10693 DO 141 I=1,N
10694 X(1,I) = X(1,I)-X1SUM
10695 X(2,I) = X(2,I)-X2SUM
10696 X(3,I) = X(3,I)-X3SUM
10697 141 CONTINUE
10698
10699 ENDIF
10700
10701 RETURN
10702 END
10703
10704*$ CREATE DT_DENSIT.FOR
10705*COPY DT_DENSIT
10706*
10707*===densit=============================================================*
10708*
10709 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10710
10711 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10712 SAVE
10713
10714 PARAMETER ( LINP = 10 ,
10715 & LOUT = 6 ,
10716 & LDAT = 9 )
10717
10718 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10719 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10720 & PI = TWOPI/TWO)
10721
10722 DIMENSION R0(18),FNORM(18)
10723 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10724 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10725 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10726 & 2.72D0, 2.66D0, 2.79D0/
10727 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10728 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10729 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10730 & .1214D+01,.1265D+01,.1318D+01/
10731 DATA PDIF /0.545D0/
10732
10733 DT_DENSIT = ZERO
10734* shell model
10735 IF (NA.LE.4) THEN
10736 STOP 'DT_DENSIT-0'
10737 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10738 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10739 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10740 & *EXP(-(R/R1)**2)/FNORM(NA)
10741* Woods-Saxon
10742 ELSEIF (NA.GT.18) THEN
10743 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10744 ENDIF
10745
10746 RETURN
10747 END
10748
10749*$ CREATE DT_RNCLUS.FOR
10750*COPY DT_RNCLUS
10751*
10752*===rnclus=============================================================*
10753*
10754 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10755
10756************************************************************************
10757* Nuclear radius for nucleus with mass number N. *
10758* This version dated 26.9.00 is written by S. Roesler *
10759************************************************************************
10760
10761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10762 SAVE
10763
10764 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10765
10766* nucleon radius
10767 PARAMETER (RNUCLE = 1.12D0)
10768
10769* nuclear radii for selected nuclei
10770 DIMENSION RADNUC(18)
10771 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10772 & 2.58D0,2.71D0,2.66D0,2.71D0/
10773
10774 IF (N.LE.18) THEN
10775 IF (RADNUC(N).GT.0.0D0) THEN
10776 DT_RNCLUS = RADNUC(N)
10777 ELSE
10778 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10779 ENDIF
10780 ELSE
10781 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10782 ENDIF
10783
10784 RETURN
10785 END
10786
10787*$ CREATE DT_DENTST.FOR
10788*COPY DT_DENTST
10789*
10790*===dentst=============================================================*
10791*
10792C PROGRAM DT_DENTST
10793 SUBROUTINE DT_DENTST
10794
10795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10796 SAVE
10797
10798 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10799 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10800
10801 RMIN = 0.0D0
10802 RMAX = 8.0D0
10803 NBINS = 500.0D0
10804 DR = (RMAX-RMIN)/DBLE(NBINS)
10805 DO 1 IA=5,18
10806 FMAX = 0.0D0
10807 DO 2 IR=1,NBINS+1
10808 R = RMIN+DBLE(IR-1)*DR
10809 F = DT_DENSIT(IA,R,R)
10810 IF (F.GT.FMAX) FMAX = F
10811 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10812 2 CONTINUE
10813 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10814 1 CONTINUE
10815
10816 CLOSE(40)
10817 CLOSE(41)
10818
10819 END
10820
10821*$ CREATE DT_SHMAKI.FOR
10822*COPY DT_SHMAKI
10823*
10824*===shmaki=============================================================*
10825*
10826 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10827
10828************************************************************************
10829* Initialisation of Glauber formalism. This subroutine has to be *
10830* called once (in case of target emulsions as often as many different *
10831* target nuclei are considered) before events are sampled. *
10832* NA / NCA mass number/charge of projectile nucleus *
10833* NB / NCB mass number/charge of target nucleus *
10834* IJP identity of projectile (hadrons/leptons/photons) *
10835* PPN projectile momentum (for projectile nuclei: *
10836* momentum per nucleon) in target rest system *
10837* MODE = 0 Glauber formalism invoked *
10838* = 1 fitted results are loaded from data-file *
10839* = 99 NTARG is forced to be 1 *
10840* (used in connection with GLAUBERI-card only) *
10841* This version dated 22.03.96 is based on the original SHMAKI-routine *
10842* and revised by S. Roesler. *
10843************************************************************************
10844
10845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10846 SAVE
10847
10848 PARAMETER ( LINP = 10 ,
10849 & LOUT = 6 ,
10850 & LDAT = 9 )
10851
10852 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10853 & THREE=3.0D0)
10854
10855 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10856
10857* Glauber formalism: parameters
10858 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10859 & BMAX(NCOMPX),BSTEP(NCOMPX),
10860 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10861 & NSITEB,NSTATB
10862
10863* Lorentz-parameters of the current interaction
10864 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10865 & UMO,PPCM,EPROJ,PPROJ
10866
10867* properties of photon/lepton projectiles
10868 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10869
10870* kinematical cuts for lepton-nucleus interactions
10871 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10872 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10873
10874* Glauber formalism: cross sections
10875 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10876 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10877 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10878 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10879 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10880 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10881 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10882 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10883 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10884 & BSLOPE,NEBINI,NQBINI
10885
10886* cuts for variable energy runs
10887 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10888
10889* nucleon-nucleon event-generator
10890 CHARACTER*8 CMODEL
10891 LOGICAL LPHOIN
10892 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10893
10894* Glauber formalism: flags and parameters for statistics
10895 LOGICAL LPROD
10896 CHARACTER*8 CGLB
10897 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10898
10899 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10900
10901C CALL DT_HISHAD
10902C STOP
10903
10904 NTARG = NTARG+1
10905 IF (MODE.EQ.99) NTARG = 1
10906 NIDX = -NTARG
10907 IF (MODE.EQ.-1) NIDX = NTARG
10908
10909 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10910 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10911 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10912 & ' initialization',/,12X,'--------------------------',
10913 & '-------------------------',/)
10914
10915 IF (MODE.EQ.2) THEN
10916 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10917 CALL DT_SHFAST(MODE,PPN,IBACK)
10918 STOP ' Glauber pre-initialization done'
10919 ENDIF
10920 IF (MODE.EQ.1) THEN
10921 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10922 ELSE
10923 IBACK = 1
10924 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10925 IF (IBACK.EQ.1) THEN
10926* lepton-nucleus (variable energy runs)
10927 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10928 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10929 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10930 & WRITE(LOUT,1002) NB,NCB
10931 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10932 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10933 & 'E_cm (GeV) Q^2 (GeV^2)',
10934 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10935 & '--------------------------------',
10936 & '------------------------------')
10937 AECMLO = LOG10(MIN(UMO,ECMLI))
10938 AECMHI = LOG10(MIN(UMO,ECMHI))
10939 IESTEP = NEB-1
10940 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10941 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10942 DO 1 I=1,IESTEP+1
10943 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10944 IF (Q2HI.GT.0.1D0) THEN
10945 IF (Q2LI.LT.0.01D0) THEN
10946 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10947 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10948 & WRITE(LOUT,1003)
10949 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10950 Q2LI = 0.01D0
10951 IBIN = 2
10952 ELSE
10953 IBIN = 1
10954 ENDIF
10955 IQSTEP = NQB-IBIN
10956 AQ2LO = LOG10(Q2LI)
10957 AQ2HI = LOG10(Q2HI)
10958 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10959 DO 2 J=IBIN,IQSTEP+IBIN
10960 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10961 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10962 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10963 & WRITE(LOUT,1003) ECMNN(I),
10964 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10965 2 CONTINUE
10966 ELSE
10967 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10968 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10969 & WRITE(LOUT,1003)
10970 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10971 ENDIF
10972 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10973 1 CONTINUE
10974 IVEOUT = 1
10975 ELSE
10976* hadron/photon/nucleus-nucleus
10977 IF ((ABS(VAREHI).GT.ZERO).AND.
10978 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10979 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10980 WRITE(LOUT,1004) NA,NB,NCB
10981 1004 FORMAT(1X,'variable energy run: projectile-id:',
10982 & I3,' target A/Z: ',I3,' /',I3,/)
10983 WRITE(LOUT,1005)
10984 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10985 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10986 & ' -------------------------------------',
10987 & '--------------------------------------')
10988 ENDIF
10989 AECMLO = LOG10(VARCLO)
10990 AECMHI = LOG10(VARCHI)
10991 IESTEP = NEB-1
10992 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10993 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10994 DO 3 I=1,IESTEP+1
10995 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10996 AMP = 0.938D0
10997 AMT = 0.938D0
10998 AMP2 = AMP**2
10999 AMT2 = AMT**2
11000 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11001 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11002 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11003 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11004 & WRITE(LOUT,1006)
11005 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11006 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11007 3 CONTINUE
11008 IVEOUT = 1
11009 ELSE
11010 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11011 ENDIF
11012 ENDIF
11013 ENDIF
11014 ENDIF
11015
11016 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11017 & (IOGLB.NE.100)) THEN
11018 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11019 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11020 1001 FORMAT(38X,'projectile',
11021 & ' target',/,1X,'Mass number / charge',
11022 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11023 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11024 & 'Parameters of elastic scattering amplitude:',/,5X,
11025 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11026 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11027 & 'statistics at each b-step',4X,I5,/,/,1X,
11028 & 'Prod. cross section ',5X,F10.4,' mb',/)
11029 ENDIF
11030
11031 RETURN
11032 END
11033
11034*$ CREATE DT_PROFBI.FOR
11035*COPY DT_PROFBI
11036*
11037*===profbi=============================================================*
11038*
11039 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11040
11041************************************************************************
11042* Integral over profile function (to be used for impact-parameter *
11043* sampling during event generation). *
11044* Fitted results are used. *
11045* NA / NB mass numbers of proj./target nuclei *
11046* PPN projectile momentum (for projectile nuclei: *
11047* momentum per nucleon) in target rest system *
11048* NTARG index of target material (i.e. kind of nucleus) *
11049* This version dated 31.05.95 is revised by S. Roesler *
11050************************************************************************
11051
11052 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11053 SAVE
11054
11055 PARAMETER ( LINP = 10 ,
11056 & LOUT = 6 ,
11057 & LDAT = 9 )
11058
11059 SAVE
11060
11061 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11062
11063 LOGICAL LSTART
11064 CHARACTER CNAME*80
11065
11066 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11067
11068* Glauber formalism: parameters
11069 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11070 & BMAX(NCOMPX),BSTEP(NCOMPX),
11071 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11072 & NSITEB,NSTATB
11073
11074* Glauber formalism: cross sections
11075 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11076 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11077 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11078 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11079 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11080 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11081 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11082 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11083 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11084 & BSLOPE,NEBINI,NQBINI
11085
11086 PARAMETER (NGLMAX=8000)
11087 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11088 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11089
11090 DATA LSTART /.TRUE./
11091
11092 IF (LSTART) THEN
11093* read fit-parameters from file
11094 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11095 I = 0
11096 1 CONTINUE
11097 READ(47,'(A80)') CNAME
11098 IF (CNAME.EQ.'STOP') GOTO 2
11099 I = I+1
11100 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11101 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11102 & GLAFIT(4,I),GLAFIT(5,I)
11103 IF (I+1.GT.NGLMAX) THEN
11104 WRITE(LOUT,1000)
11105 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11106 & 'program stopped')
11107 STOP
11108 ENDIF
11109 GOTO 1
11110 2 CONTINUE
11111 NGLPAR = I
11112 LSTART = .FALSE.
11113 ENDIF
11114
11115 NNA = NA
11116 NNB = NB
11117 IF (NA.GT.NB) THEN
11118 NNA = NB
11119 NNB = NA
11120 ENDIF
11121 IDXGLA = 0
11122 DO 3 J=1,NGLPAR
11123 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11124 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11125 DO 4 K=1,J-1
11126 IPOINT = J-K
11127 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11128 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11129 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11130 IF (IPOINT.EQ.1) IPOINT = 0
11131 NATMP = NGLIP(IPOINT+1)
11132 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11133 IDXGLA = IPOINT+1
11134 GOTO 6
11135 ELSE
11136 J1BEG = IPOINT+1
11137 J1END = J
11138C IF (J.EQ.NGLPAR) THEN
11139C J1BEG = IPOINT
11140C J1END = J
11141C ENDIF
11142 DO 5 J1=J1BEG,J1END
11143 IF (NGLIP(J1).EQ.NATMP) THEN
11144 IF (PPN.LT.GLAPPN(J1)) THEN
11145 IDXGLA = J1
11146 GOTO 6
11147 ENDIF
11148 ELSE
11149 IDXGLA = J1-1
11150 GOTO 6
11151 ENDIF
11152 5 CONTINUE
11153 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11154 & IDXGLA = NGLPAR
11155 ENDIF
11156 ENDIF
11157 4 CONTINUE
11158 ENDIF
11159 3 CONTINUE
11160
11161 6 CONTINUE
11162 IF (IDXGLA.EQ.0) THEN
11163 WRITE(LOUT,1001) NNA,NNB,PPN
11164 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11165 & 2I4,F6.0,') not found ')
11166 STOP
11167 ENDIF
11168
11169* no interpolation yet available
11170 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11171
11172 BSITE(1,1,NTARG,1) = ZERO
11173 DO 10 I=2,NSITEB
11174 XX = DBLE(I)
11175 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11176 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11177 & GLAFIT(5,IDXGLA)*XX**4
11178 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11179 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11180 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11181 10 CONTINUE
11182
11183 RETURN
11184 END
11185
11186*$ CREATE DT_GLAUBE.FOR
11187*COPY DT_GLAUBE
11188*
11189*===glaube=============================================================*
11190*
11191 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11192
11193************************************************************************
11194* Calculation of configuartion of interacting nucleons for one event. *
11195* NB / NB mass numbers of proj./target nuclei (input) *
11196* B impact parameter (output) *
11197* INTT total number of wounded nucleons " *
11198* INTA / INTB number of wounded nucleons in proj. / target " *
11199* JS / JT(i) number of collisions proj. / target nucleon i is *
11200* involved (output) *
11201* NIDX index of projectile/target material (input) *
11202* = -2 call within FLUKA transport calculation *
11203* This is an update of the original routine SHMAKO by J.Ranft/HJM *
11204* This version dated 22.03.96 is revised by S. Roesler *
11205* *
11206* Last change 27.12.2006 by S. Roesler. *
11207************************************************************************
11208
11209 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11210 SAVE
11211
11212 PARAMETER ( LINP = 10 ,
11213 & LOUT = 6 ,
11214 & LDAT = 9 )
11215
11216 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11217 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11218
11219 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11220
11221 PARAMETER ( MAXNCL = 260,
11222
11223 & MAXVQU = MAXNCL,
11224 & MAXSQU = 20*MAXVQU,
11225 & MAXINT = MAXVQU+MAXSQU)
11226
11227* Glauber formalism: parameters
11228 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11229 & BMAX(NCOMPX),BSTEP(NCOMPX),
11230 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11231 & NSITEB,NSTATB
11232
11233* Glauber formalism: cross sections
11234 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11235 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11236 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11237 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11238 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11239 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11240 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11241 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11242 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11243 & BSLOPE,NEBINI,NQBINI
11244
11245* Lorentz-parameters of the current interaction
11246 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11247 & UMO,PPCM,EPROJ,PPROJ
11248
11249* properties of photon/lepton projectiles
11250 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11251
11252* Glauber formalism: collision properties
11253 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11254 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11255
11256* Glauber formalism: flags and parameters for statistics
11257 LOGICAL LPROD
11258 CHARACTER*8 CGLB
11259 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11260
11261 DIMENSION JS(MAXNCL),JT(MAXNCL)
11262
11263 NTARG = ABS(NIDX)
11264
11265* get actual energy from /DTLTRA/
11266 ECMNOW = UMO
11267 Q2 = VIRT
11268*
11269* new patch for pre-initialized variable projectile/target/energy runs,
11270* bypassed for use within FLUKA (Nidx=-2)
11271 IF (IOGLB.EQ.100) THEN
11272 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11273*
11274* variable energy run, interpolate profile function
11275 ELSE
11276 I1 = 1
11277 I2 = 1
11278 RATE = ONE
11279 IF (NEBINI.GT.1) THEN
11280 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11281 I1 = NEBINI
11282 I2 = NEBINI
11283 RATE = ONE
11284 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11285 DO 1 I=2,NEBINI
11286 IF (ECMNOW.LT.ECMNN(I)) THEN
11287 I1 = I-1
11288 I2 = I
11289 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11290 GOTO 2
11291 ENDIF
11292 1 CONTINUE
11293 2 CONTINUE
11294 ENDIF
11295 ENDIF
11296 J1 = 1
11297 J2 = 1
11298 RATQ = ONE
11299 IF (NQBINI.GT.1) THEN
11300 IF (Q2.GE.Q2G(NQBINI)) THEN
11301 J1 = NQBINI
11302 J2 = NQBINI
11303 RATQ = ONE
11304 ELSEIF (Q2.GT.Q2G(1)) THEN
11305 DO 3 I=2,NQBINI
11306 IF (Q2.LT.Q2G(I)) THEN
11307 J1 = I-1
11308 J2 = I
11309 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11310 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11311C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11312 GOTO 4
11313 ENDIF
11314 3 CONTINUE
11315 4 CONTINUE
11316 ENDIF
11317 ENDIF
11318
11319 DO 5 I=1,KSITEB
11320 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11321 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11322 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11323 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11324 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11325 5 CONTINUE
11326 ENDIF
11327
11328 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11329 IF (NIDX.LE.-1) THEN
11330 RPROJ = RASH(1)
11331 RTARG = RBSH(NTARG)
11332 ELSE
11333 RPROJ = RASH(NTARG)
11334 RTARG = RBSH(1)
11335 ENDIF
11336
11337 RETURN
11338 END
11339
11340*$ CREATE DT_DIAGR.FOR
11341*COPY DT_DIAGR
11342*
11343*===diagr==============================================================*
11344*
11345 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11346 & NIDX)
11347
11348************************************************************************
11349* Based on the original version by Shmakov et al. *
11350* This version dated 21.04.95 is revised by S. Roesler *
11351************************************************************************
11352
11353 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11354 SAVE
11355
11356 PARAMETER ( LINP = 10 ,
11357 & LOUT = 6 ,
11358 & LDAT = 9 )
11359
11360 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11361 PARAMETER (TWOPI = 6.283185307179586454D+00,
11362 & PI = TWOPI/TWO,
11363 & GEV2MB = 0.38938D0,
11364 & GEV2FM = 0.1972D0,
11365 & ALPHEM = ONE/137.0D0,
11366* proton mass
11367 & AMP = 0.938D0,
11368 & AMP2 = AMP**2,
11369* rho0 mass
11370 & AMRHO0 = 0.77D0)
11371
11372 COMPLEX*16 C,CA,CI
11373
11374 PARAMETER ( MAXNCL = 260,
11375
11376 & MAXVQU = MAXNCL,
11377 & MAXSQU = 20*MAXVQU,
11378 & MAXINT = MAXVQU+MAXSQU)
11379
11380* particle properties (BAMJET index convention)
11381 CHARACTER*8 ANAME
11382 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11383 & IICH(210),IIBAR(210),K1(210),K2(210)
11384
11385 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11386
11387* emulsion treatment
11388 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11389 & NCOMPO,IEMUL
11390
11391* Glauber formalism: parameters
11392 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11393 & BMAX(NCOMPX),BSTEP(NCOMPX),
11394 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11395 & NSITEB,NSTATB
11396
11397* Glauber formalism: cross sections
11398 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11399 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11400 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11401 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11402 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11403 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11404 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11405 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11406 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11407 & BSLOPE,NEBINI,NQBINI
11408
11409* VDM parameter for photon-nucleus interactions
11410 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11411
11412* nucleon-nucleon event-generator
11413 CHARACTER*8 CMODEL
11414 LOGICAL LPHOIN
11415 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11416**PHOJET105a
11417C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11418**PHOJET112
11419
11420C obsolete cut-off information
11421 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11422 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11423**
11424
11425* coordinates of nucleons
11426 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11427
11428* interface between Glauber formalism and DPM
11429 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11430 & INTER1(MAXINT),INTER2(MAXINT)
11431
11432* statistics: Glauber-formalism
11433 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11434
11435* n-n cross section fluctuations
11436 PARAMETER (NBINS = 1000)
11437 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11438
11439 DIMENSION JS(MAXNCL),JT(MAXNCL),
11440 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11441 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11442 DIMENSION NWA(0:210),NWB(0:210)
11443
11444 LOGICAL LFIRST
11445 DATA LFIRST /.TRUE./
11446
11447 DATA NTARGO,ICNT /0,0/
11448
11449 NTARG = ABS(NIDX)
11450
11451 IF (LFIRST) THEN
11452 LFIRST = .FALSE.
11453 IF (NCOMPO.EQ.0) THEN
11454 NCALL = 0
11455 NWAMAX = NA
11456 NWBMAX = NB
11457 DO 17 I=0,210
11458 NWA(I) = 0
11459 NWB(I) = 0
11460 17 CONTINUE
11461 ENDIF
11462 ENDIF
11463 IF (NTARG.EQ.-1) THEN
11464 IF (NCOMPO.EQ.0) THEN
11465 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11466 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11467 & NCALL,NWAMAX,NWBMAX
11468 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11469 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11470 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11471 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11472 18 CONTINUE
11473 ENDIF
11474 RETURN
11475 ENDIF
11476
11477 DCOH = 1.0D10
11478 IPNT = 0
11479
11480 SQ2 = Q2
11481 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11482 S = ECMNOW**2
11483 X = SQ2/(S+SQ2-AMP2)
11484 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11485* photon projectiles: recalculate photon-nucleon amplitude
11486 IF (IJPROJ.EQ.7) THEN
11487 15 CONTINUE
11488* VDM assumption: mass of V-meson
11489 AMV2 = DT_SAM2(SQ2,ECMNOW)
11490 AMV = SQRT(AMV2)
11491 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11492* check for pointlike interaction
11493 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11494**sr 27.10.
11495C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11496 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11497**
11498 ROSH = 0.1D0
11499 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11500 & +0.25D0*LOG(S/(AMV2+SQ2)))
11501* coherence length
11502 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11503 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11504 IF (MCGENE.EQ.2) THEN
11505 ZERO1 = ZERO
11506 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11507 & BSLOPE,0)
11508 ELSE
11509 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11510 ENDIF
11511 IF (ECMNOW.LE.3.0D0) THEN
11512 ROSH = -0.43D0
11513 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11514 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11515 ELSEIF (ECMNOW.GT.50.0D0) THEN
11516 ROSH = 0.1D0
11517 ENDIF
11518 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11519 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11520 IF (MCGENE.EQ.2) THEN
11521 ZERO1 = ZERO
11522 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11523 & BDUM,0)
11524 SIGSH = SIGSH/10.0D0
11525 ELSE
11526C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11527 DUMZER = ZERO
11528 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11529 SIGSH = SIGSH/10.0D0
11530 ENDIF
11531 ELSE
11532 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11533 ROSH = 0.01D0
11534 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11535 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11536C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11537 DUMZER = ZERO
11538 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11539 SIGSH = SIGSH/10.0D0
11540 ENDIF
11541 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11542 GAM = GSH
11543 RCA = GAM*SIGSH/TWOPI
11544 FCA = -ROSH*RCA
11545 CA = DCMPLX(RCA,FCA)
11546 CI = DCMPLX(ONE,ZERO)
11547
11548 16 CONTINUE
11549* impact parameter
11550 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11551
11552 NTRY = 0
11553 3 CONTINUE
11554 NTRY = NTRY+1
11555* initializations
11556 JNT = 0
11557 DO 1 I=1,NA
11558 JS(I) = 0
11559 1 CONTINUE
11560 DO 2 I=1,NB
11561 JT(I) = 0
11562 2 CONTINUE
11563 IF (IJPROJ.EQ.7) THEN
11564 DO 8 I=1,MAXNCL
11565 JS0(I) = 0
11566 JNT0(I)= 0
11567 DO 9 J=1,NB
11568 JT0(I,J) = 0
11569 9 CONTINUE
11570 8 CONTINUE
11571 ENDIF
11572
11573* nucleon configuration
11574C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11575 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11576C CALL DT_CONUCL(PKOO,NA,RASH,2)
11577C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11578 IF (NIDX.LE.-1) THEN
11579 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11580 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11581 ELSE
11582 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11583 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11584 ENDIF
11585 NTARGO = NTARG
11586 ENDIF
11587 ICNT = ICNT+1
11588
11589* LEPTO: pick out one struck nucleon
11590 IF (MCGENE.EQ.3) THEN
11591 JNT = 1
11592 JS(1) = 1
11593 IDX = INT(DT_RNDM(X)*NB)+1
11594 JT(IDX) = 1
11595 B = ZERO
11596 GOTO 19
11597 ENDIF
11598
11599 DO 4 INA=1,NA
11600* cross section fluctuations
11601 AFLUC = ONE
11602 IF (IFLUCT.EQ.1) THEN
11603 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11604 AFLUC = FLUIXX(IFLUK)
11605 ENDIF
11606 KK1 = 1
11607 KINT = 1
11608 DO 5 INB=1,NB
11609* photon-projectile: check for supression by coherence length
11610 IF (IJPROJ.EQ.7) THEN
11611 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11612 KK1 = INB
11613 KINT = KINT+1
11614 ENDIF
11615 ENDIF
11616 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11617 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11618 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11619 IF (XY.LE.15.0D0) THEN
11620 C = CI-CA*AFLUC*EXP(-XY)
11621 AR = DBLE(C)
11622 AI = DIMAG(C)
11623 P = AR*AR+AI*AI
11624 IF (DT_RNDM(XY).GE.P) THEN
11625 JNT = JNT+1
11626 IF (IJPROJ.EQ.7) THEN
11627 JNT0(KINT) = JNT0(KINT)+1
11628 IF (JNT0(KINT).GT.MAXNCL) THEN
11629 WRITE(LOUT,1001) MAXNCL
11630 1001 FORMAT(1X,
11631 & 'DIAGR: no. of requested interactions',
11632 & ' exceeds array dimensions ',I4)
11633 STOP
11634 ENDIF
11635 JS0(KINT) = JS0(KINT)+1
11636 JT0(KINT,INB) = JT0(KINT,INB)+1
11637 JI1(KINT,JNT0(KINT)) = INA
11638 JI2(KINT,JNT0(KINT)) = INB
11639 ELSE
11640 IF (JNT.GT.MAXINT) THEN
11641 WRITE(LOUT,1000) JNT, MAXINT
11642 1000 FORMAT(1X,
11643 & 'DIAGR: no. of requested interactions ('
11644 & ,I4,') exceeds array dimensions (',I4,')')
11645 STOP
11646 ENDIF
11647 JS(INA) = JS(INA)+1
11648 JT(INB) = JT(INB)+1
11649 INTER1(JNT) = INA
11650 INTER2(JNT) = INB
11651 ENDIF
11652 ENDIF
11653 ENDIF
11654 5 CONTINUE
11655 4 CONTINUE
11656
11657 IF (JNT.EQ.0) THEN
11658 IF (NTRY.LT.500) THEN
11659 GOTO 3
11660 ELSE
11661C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11662 GOTO 16
11663 ENDIF
11664 ENDIF
11665
11666 IDIREC = 0
11667 IF (IJPROJ.EQ.7) THEN
11668 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11669 10 CONTINUE
11670 IF (JNT0(K).EQ.0) THEN
11671 K = K+1
11672 IF (K.GT.KINT) K = 1
11673 GOTO 10
11674 ENDIF
11675* supress Glauber-cascade by direct photon processes
11676 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11677 IF (IPNT.GT.0) THEN
11678 JNT = 1
11679 JS(1) = 1
11680 DO 11 INB=1,NB
11681 JT(INB) = JT0(K,INB)
11682 IF (JT(INB).GT.0) GOTO 12
11683 11 CONTINUE
11684 12 CONTINUE
11685 INTER1(1) = 1
11686 INTER2(1) = INB
11687 IDIREC = IPNT
11688 ELSE
11689 JNT = JNT0(K)
11690 JS(1) = JS0(K)
11691 DO 13 INB=1,NB
11692 JT(INB) = JT0(K,INB)
11693 13 CONTINUE
11694 DO 14 I=1,JNT
11695 INTER1(I) = JI1(K,I)
11696 INTER2(I) = JI2(K,I)
11697 14 CONTINUE
11698 ENDIF
11699 ENDIF
11700
11701 19 CONTINUE
11702 INTA = 0
11703 INTB = 0
11704 DO 6 I=1,NA
11705 IF (JS(I).NE.0) INTA=INTA+1
11706 6 CONTINUE
11707 DO 7 I=1,NB
11708 IF (JT(I).NE.0) INTB=INTB+1
11709 7 CONTINUE
11710 ICWPG = INTA
11711 ICWTG = INTB
11712 ICIG = JNT
11713 IPGLB = IPGLB+INTA
11714 ITGLB = ITGLB+INTB
11715 NGLB = NGLB+1
11716
11717 IF (NCOMPO.EQ.0) THEN
11718 NCALL = NCALL+1
11719 NWA(INTA) = NWA(INTA)+1
11720 NWB(INTB) = NWB(INTB)+1
11721 ENDIF
11722
11723 RETURN
11724 END
11725
11726*$ CREATE DT_MODB.FOR
11727*COPY DT_MODB
11728*
11729*===modb===============================================================*
11730*
11731 SUBROUTINE DT_MODB(B,NIDX)
11732
11733************************************************************************
11734* Sampling of impact parameter of collision. *
11735* B impact parameter (output) *
11736* NIDX index of projectile/target material (input)*
11737* Based on the original version by Shmakov et al. *
11738* This version dated 21.04.95 is revised by S. Roesler *
11739* *
11740* Last change 27.12.2006 by S. Roesler. *
11741************************************************************************
11742
11743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11744 SAVE
11745
11746 PARAMETER ( LINP = 10 ,
11747 & LOUT = 6 ,
11748 & LDAT = 9 )
11749
11750 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11751
11752 LOGICAL LEFT,LFIRST
11753
11754* central particle production, impact parameter biasing
11755 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11756
11757 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11758
11759* Glauber formalism: parameters
11760 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11761 & BMAX(NCOMPX),BSTEP(NCOMPX),
11762 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11763 & NSITEB,NSTATB
11764
11765* Glauber formalism: cross sections
11766 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11767 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11768 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11769 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11770 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11771 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11772 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11773 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11774 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11775 & BSLOPE,NEBINI,NQBINI
11776
11777 DATA LFIRST /.TRUE./
11778
11779 NTARG = ABS(NIDX)
11780 IF (NIDX.LE.-1) THEN
11781 RA = RASH(1)
11782 RB = RBSH(NTARG)
11783 ELSE
11784 RA = RASH(NTARG)
11785 RB = RBSH(1)
11786 ENDIF
11787
11788 IF (ICENTR.EQ.2) THEN
11789 IF (RA.EQ.RB) THEN
11790 BB = DT_RNDM(B)*(0.3D0*RA)**2
11791 B = SQRT(BB)
11792 ELSEIF(RA.LT.RB)THEN
11793 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11794 B = SQRT(BB)
11795 ELSEIF(RA.GT.RB)THEN
11796 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11797 B = SQRT(BB)
11798 ENDIF
11799 ELSE
11800 9 CONTINUE
11801 Y = DT_RNDM(BB)
11802 I0 = 1
11803 I2 = NSITEB
11804 10 CONTINUE
11805 I1 = (I0+I2)/2
11806 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11807 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11808 IF (LEFT) GOTO 20
11809 I0 = I1
11810 GOTO 30
11811 20 CONTINUE
11812 I2 = I1
11813 30 CONTINUE
11814 IF (I2-I0-2) 40,50,60
11815 40 CONTINUE
11816 I1 = I2+1
11817 IF (I1.GT.NSITEB) I1 = I0-1
11818 GOTO 70
11819 50 CONTINUE
11820 I1 = I0+1
11821 GOTO 70
11822 60 CONTINUE
11823 GOTO 10
11824 70 CONTINUE
11825 X0 = DBLE(I0-1)*BSTEP(NTARG)
11826 X1 = DBLE(I1-1)*BSTEP(NTARG)
11827 X2 = DBLE(I2-1)*BSTEP(NTARG)
11828 Y0 = BSITE(0,1,NTARG,I0)
11829 Y1 = BSITE(0,1,NTARG,I1)
11830 Y2 = BSITE(0,1,NTARG,I2)
11831 80 CONTINUE
11832 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11833 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11834 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11835**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11836 B = B+0.5D0*BSTEP(NTARG)
11837 IF (B.LT.ZERO) B = X1
11838 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11839 IF (ICENTR.LT.0) THEN
11840 IF (LFIRST) THEN
11841 LFIRST = .FALSE.
11842 IF (ICENTR.LE.-100) THEN
11843 BIMIN = 0.0D0
11844 ELSE
11845 XSFRAC = 0.0D0
11846 ENDIF
11847 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11848 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11849 & BIMIN,BIMAX,XSFRAC*100.0D0,
11850 & XSFRAC*XSPRO(1,1,NTARG)
11851 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11852 & /,15X,'---------------------------'/,/,4X,
11853 & 'average radii of proj / targ :',F10.3,' fm /',
11854 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11855 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11856 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11857 & ' cross section :',F10.3,' %',/,5X,
11858 & 'corresponding cross section :',F10.3,' mb',/)
11859 ENDIF
11860 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11861 B = BIMIN
11862 ELSE
11863 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11864 ENDIF
11865 ENDIF
11866 ENDIF
11867
11868 RETURN
11869 END
11870
11871*$ CREATE DT_SHFAST.FOR
11872*COPY DT_SHFAST
11873*
11874*===shfast=============================================================*
11875*
11876 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11877
11878 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11879 SAVE
11880
11881 PARAMETER ( LINP = 10 ,
11882 & LOUT = 6 ,
11883 & LDAT = 9 )
11884
11885 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11886 & ONE=1.0D0,TWO=2.0D0)
11887
11888 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11889
11890* Glauber formalism: parameters
11891 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11892 & BMAX(NCOMPX),BSTEP(NCOMPX),
11893 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11894 & NSITEB,NSTATB
11895
11896* properties of interacting particles
11897 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11898
11899* Glauber formalism: cross sections
11900 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11901 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11902 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11903 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11904 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11905 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11906 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11907 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11908 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11909 & BSLOPE,NEBINI,NQBINI
11910
11911 IBACK = 0
11912
11913 IF (MODE.EQ.2) THEN
11914 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11915 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11916 1000 FORMAT(1X,8I5,E15.5)
11917 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11918 1001 FORMAT(1X,4E15.5)
11919 WRITE(47,1002) SIGSH,ROSH,GSH
11920 1002 FORMAT(1X,3E15.5)
11921 DO 10 I=1,100
11922 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11923 10 CONTINUE
11924 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11925 1003 FORMAT(1X,2I10,3E15.5)
11926 CLOSE(47)
11927 ELSE
11928 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11929 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11930 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11931 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11932 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11933 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11934 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11935 READ(47,1002) SIGSH,ROSH,GSH
11936 DO 11 I=1,100
11937 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11938 11 CONTINUE
11939 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11940 ELSE
11941 IBACK = 1
11942 ENDIF
11943 CLOSE(47)
11944 ENDIF
11945
11946 RETURN
11947 END
11948
11949*$ CREATE DT_POILIK.FOR
11950*COPY DT_POILIK
11951*
11952*===poilik=============================================================*
11953*
11954 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11955
11956 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11957 SAVE
11958
11959 PARAMETER ( LINP = 10 ,
11960 & LOUT = 6 ,
11961 & LDAT = 9 )
11962
11963 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11964 PARAMETER (NE = 8)
11965
11966**PHOJET105a
11967C CHARACTER*8 MDLNA
11968C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11969C PARAMETER (IEETAB=10)
11970C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11971**PHOJET110
11972
11973C model switches and parameters
11974 CHARACTER*8 MDLNA
11975 INTEGER ISWMDL,IPAMDL
11976 DOUBLE PRECISION PARMDL
11977 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11978
11979C energy-interpolation table
11980 INTEGER IEETA2
11981 PARAMETER ( IEETA2 = 20 )
11982 INTEGER ISIMAX
11983 DOUBLE PRECISION SIGTAB,SIGECM
11984 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11985**
11986
11987* VDM parameter for photon-nucleus interactions
11988 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11989**sr 22.7.97
11990
11991 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11992
11993* Glauber formalism: cross sections
11994 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11995 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11996 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11997 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11998 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11999 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12000 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12001 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12002 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12003 & BSLOPE,NEBINI,NQBINI
12004**
12005
12006 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12007
12008 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12009
12010* load cross sections from interpolation table
12011 IP = 1
12012 IF(ECM.LE.SIGECM(IP,1)) THEN
12013 I1 = 1
12014 I2 = 1
12015 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12016 DO 50 I=2,ISIMAX
12017 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12018 50 CONTINUE
12019 200 CONTINUE
12020 I1 = I-1
12021 I2 = I
12022 ELSE
12023 WRITE(LOUT,'(/1X,A,2E12.3)')
12024 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12025 I1 = ISIMAX
12026 I2 = ISIMAX
12027 ENDIF
12028 FAC2 = ZERO
12029 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12030 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12031 FAC1 = ONE-FAC2
12032
12033 SIGANO = DT_SANO(ECM)
12034
12035* cross section dependence on photon virtuality
12036 FSUP1 = ZERO
12037 DO 150 I=1,3
12038 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12039 & /(ONE+VIRT/PARMDL(30+I))**2
12040 150 CONTINUE
12041 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12042 FAC1 = FAC1*FSUP1
12043 FAC2 = FAC2*FSUP1
12044 FSUP2 = ONE
12045
12046 ECMOLD = ECM
12047 Q2OLD = VIRT
12048
12049 3 CONTINUE
12050
12051C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12052 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12053 IF (ISHAD(1).EQ.1) THEN
12054 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12055 ELSE
12056 SIGDIR = ZERO
12057 ENDIF
12058 SIGANO = FSUP1*FSUP2*SIGANO
12059 SIGTOT = SIGTOT-SIGDIR-SIGANO
12060 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12061 SIGANO = SIGANO/(FSUP1*FSUP2)
12062 SIGTOT = SIGTOT+SIGDIR+SIGANO
12063
12064 RR = DT_RNDM(SIGTOT)
12065 IF (RR.LT.SIGDIR/SIGTOT) THEN
12066 IPNT = 1
12067 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12068 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12069 IPNT = 2
12070 ELSE
12071 IPNT = 0
12072 ENDIF
12073 RPNT = (SIGDIR+SIGANO)/SIGTOT
12074C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12075C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12076C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12077C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12078 IF (MODE.EQ.1) RETURN
12079
12080**sr 22.7.97
12081 K1 = 1
12082 K2 = 1
12083 RATE = ZERO
12084 IF (ECM.GE.ECMNN(NEBINI)) THEN
12085 K1 = NEBINI
12086 K2 = NEBINI
12087 RATE = ONE
12088 ELSEIF (ECM.GT.ECMNN(1)) THEN
12089 DO 10 I=2,NEBINI
12090 IF (ECM.LT.ECMNN(I)) THEN
12091 K1 = I-1
12092 K2 = I
12093 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12094 GOTO 11
12095 ENDIF
12096 10 CONTINUE
12097 11 CONTINUE
12098 ENDIF
12099 J1 = 1
12100 J2 = 1
12101 RATQ = ZERO
12102 IF (NQBINI.GT.1) THEN
12103 IF (VIRT.GE.Q2G(NQBINI)) THEN
12104 J1 = NQBINI
12105 J2 = NQBINI
12106 RATQ = ONE
12107 ELSEIF (VIRT.GT.Q2G(1)) THEN
12108 DO 12 I=2,NQBINI
12109 IF (VIRT.LT.Q2G(I)) THEN
12110 J1 = I-1
12111 J2 = I
12112 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12113 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12114 GOTO 13
12115 ENDIF
12116 12 CONTINUE
12117 13 CONTINUE
12118 ENDIF
12119 ENDIF
12120 SGA = XSPRO(K1,J1,NTARG)+
12121 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12122 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12123 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12124 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12125 SDI = DBLE(NB)*SIGDIR
12126 SAN = DBLE(NB)*SIGANO
12127 SPL = SDI+SAN
12128 RR = DT_RNDM(SPL)
12129 IF (RR.LT.SDI/SGA) THEN
12130 IPNT = 1
12131 ELSEIF ((RR.GE.SDI/SGA).AND.
12132 & (RR.LT.SPL/SGA)) THEN
12133 IPNT = 2
12134 ELSE
12135 IPNT = 0
12136 ENDIF
12137 RPNT = SPL/SGA
12138C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12139**
12140
12141 RETURN
12142 END
12143
12144*$ CREATE DT_GLBINI.FOR
12145*COPY DT_GLBINI
12146*
12147*===glbini=============================================================*
12148*
12149 SUBROUTINE DT_GLBINI(WHAT)
12150
12151************************************************************************
12152* Pre-initialization of profile function *
12153* This version dated 28.11.00 is written by S. Roesler. *
12154* *
12155* Last change 27.12.2006 by S. Roesler. *
12156************************************************************************
12157
12158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12159 SAVE
12160
12161 PARAMETER ( LINP = 10 ,
12162 & LOUT = 6 ,
12163 & LDAT = 9 )
12164
12165 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12166
12167 LOGICAL LCMS
12168
12169* particle properties (BAMJET index convention)
12170 CHARACTER*8 ANAME
12171 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12172 & IICH(210),IIBAR(210),K1(210),K2(210)
12173
12174* properties of interacting particles
12175 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12176
12177 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12178
12179* emulsion treatment
12180 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12181 & NCOMPO,IEMUL
12182
12183* Glauber formalism: flags and parameters for statistics
12184 LOGICAL LPROD
12185 CHARACTER*8 CGLB
12186 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12187
12188* number of data sets other than protons and nuclei
12189* at the moment = 2 (pions and kaons)
12190 PARAMETER (MAXOFF=2)
12191 DIMENSION IJPINI(5),IOFFST(25)
12192 DATA IJPINI / 13, 15, 0, 0, 0/
12193* Glauber data-set to be used for hadron projectiles
12194* (0=proton, 1=pion, 2=kaon)
12195 DATA (IOFFST(K),K=1,25) /
12196 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12197 & 0, 0, 1, 2, 2/
12198* Acceptance interval for target nucleus mass
12199 PARAMETER (KBACC = 6)
12200
12201* flags for input different options
12202 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12203 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12204 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12205
12206 PARAMETER (MAXMSS = 100)
12207 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12208 DIMENSION WHAT(6)
12209
12210 DATA JPEACH,JPSTEP / 18, 5 /
12211
12212* temporary patch until fix has been implemented in phojet:
12213* maximum energy for pion projectile
12214 DATA ECMXPI / 100000.0D0 /
12215*
12216*--------------------------------------------------------------------------
12217* general initializations
12218*
12219* steps in projectile mass number for initialization
12220 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12221 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12222*
12223* energy range and binning
12224 ELO = ABS(WHAT(1))
12225 EHI = ABS(WHAT(2))
12226 IF (ELO.GT.EHI) ELO = EHI
12227 NEBIN = MAX(INT(WHAT(3)),1)
12228 IF (ELO.EQ.EHI) NEBIN = 0
12229 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12230 IF (LCMS) THEN
12231 ECMINI = EHI
12232 ELSE
12233 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12234 & +2.0D0*AAM(IJTARG)*EHI)
12235 ENDIF
12236*
12237* default arguments for Glauber-routine
12238 XI = ZERO
12239 Q2I = ZERO
12240*
12241* initialize nuclear parameters, etc.
12242
12243* initialize evaporation if the code is not used as Fluka event generator
12244 IF (ITRSPT.NE.1) THEN
12245 CALL NCDTRD
12246 CALL INCINI
12247 ENDIF
12248
12249*
12250* open Glauber-data output file
12251 IDX = INDEX(CGLB,' ')
12252 K = 12
12253 IF (IDX.GT.1) K = IDX-1
12254 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12255*
12256*--------------------------------------------------------------------------
12257* Glauber-initialization for proton and nuclei projectiles
12258*
12259* initialize phojet for proton-proton interactions
12260 ELAB = ZERO
12261 PLAB = ZERO
12262 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12263 CALL DT_PHOINI
12264*
12265* record projectile masses
12266 NASAV = 0
12267 NPROJ = MIN(IP,JPEACH)
12268 DO 10 KPROJ=1,NPROJ
12269 NASAV = NASAV+1
12270 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12271 IASAV(NASAV) = KPROJ
12272 10 CONTINUE
12273 IF (IP.GT.JPEACH) THEN
12274 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12275 IF (NPROJ.EQ.0) THEN
12276 NASAV = NASAV+1
12277 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278 IASAV(NASAV) = IP
12279 ELSE
12280 DO 11 IPROJ=1,NPROJ
12281 KPROJ = JPEACH+IPROJ*JPSTEP
12282 NASAV = NASAV+1
12283 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12284 IASAV(NASAV) = KPROJ
12285 11 CONTINUE
12286 IF (KPROJ.LT.IP) THEN
12287 NASAV = NASAV+1
12288 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12289 IASAV(NASAV) = IP
12290 ENDIF
12291 ENDIF
12292 ENDIF
12293*
12294* record target masses
12295 NBSAV = 0
12296 NTARG = 1
12297 IF (NCOMPO.GT.0) NTARG = NCOMPO
12298 DO 12 ITARG=1,NTARG
12299 NBSAV = NBSAV+1
12300 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12301 IF (NCOMPO.GT.0) THEN
12302 IBSAV(NBSAV) = IEMUMA(ITARG)
12303 ELSE
12304 IBSAV(NBSAV) = IT
12305 ENDIF
12306 12 CONTINUE
12307*
12308* print masses
12309 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12310 1000 FORMAT(I4,A,1P,2E13.5)
12311 NLINES = DBLE(NASAV)/18.0D0
12312 IF (NLINES.GT.0) THEN
12313 DO 13 I=1,NLINES
12314 IF (I.EQ.1) THEN
12315 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12316 ELSE
12317 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12318 ENDIF
12319 13 CONTINUE
12320 ENDIF
12321 I0 = 18*NLINES+1
12322 IF (I0.LE.NASAV) THEN
12323 IF (I0.EQ.1) THEN
12324 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12325 ELSE
12326 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12327 ENDIF
12328 ENDIF
12329 NLINES = DBLE(NBSAV)/18.0D0
12330 IF (NLINES.GT.0) THEN
12331 DO 14 I=1,NLINES
12332 IF (I.EQ.1) THEN
12333 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12334 ELSE
12335 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12336 ENDIF
12337 14 CONTINUE
12338 ENDIF
12339 I0 = 18*NLINES+1
12340 IF (I0.LE.NBSAV) THEN
12341 IF (I0.EQ.1) THEN
12342 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12343 ELSE
12344 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12345 ENDIF
12346 ENDIF
12347*
12348* calculate Glauber-data for each energy and mass combination
12349*
12350* loop over energy bins
12351 ELO = LOG10(ELO)
12352 EHI = LOG10(EHI)
12353 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12354 DO 1 IE=1,NEBIN+1
12355 E = ELO+DBLE(IE-1)*DEBIN
12356 E = 10**E
12357 IF (LCMS) THEN
12358 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12359 ECM = E
12360 ELSE
12361 PLAB = ZERO
12362 ECM = ZERO
12363 E = MAX(AAM(IJPROJ)+0.1D0,E)
12364 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12365 ENDIF
12366*
12367* loop over projectile and target masses
12368 DO 2 ITARG=1,NBSAV
12369 DO 3 IPROJ=1,NASAV
12370 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12371 & XI,Q2I,ECM,1,1,-1)
12372 3 CONTINUE
12373 2 CONTINUE
12374*
12375 1 CONTINUE
12376*
12377*--------------------------------------------------------------------------
12378* Glauber-initialization for pion, kaon, ... projectiles
12379*
12380 DO 6 IJ=1,MAXOFF
12381*
12382* initialize phojet for this interaction
12383 ELAB = ZERO
12384 PLAB = ZERO
12385 IJPROJ = IJPINI(IJ)
12386 IP = 1
12387 IPZ = 1
12388*
12389* temporary patch until fix has been implemented in phojet:
12390 IF (ECMINI.GT.ECMXPI) THEN
12391 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12392 ELSE
12393 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12394 ENDIF
12395 CALL DT_PHOINI
12396*
12397* calculate Glauber-data for each energy and mass combination
12398*
12399* loop over energy bins
12400 DO 4 IE=1,NEBIN+1
12401 E = ELO+DBLE(IE-1)*DEBIN
12402 E = 10**E
12403 IF (LCMS) THEN
12404 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12405 ECM = E
12406 ELSE
12407 PLAB = ZERO
12408 ECM = ZERO
12409 E = MAX(AAM(IJPROJ)+TINY14,E)
12410 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12411 ENDIF
12412*
12413* loop over projectile and target masses
12414 DO 5 ITARG=1,NBSAV
12415 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12416 5 CONTINUE
12417*
12418 4 CONTINUE
12419*
12420 6 CONTINUE
12421
12422*--------------------------------------------------------------------------
12423* close output unit(s), etc.
12424*
12425 CLOSE(LDAT)
12426
12427 RETURN
12428 END
12429
12430*$ CREATE DT_GLBSET.FOR
12431*COPY DT_GLBSET
12432*
12433*===glbset=============================================================*
12434*
12435 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12436************************************************************************
12437* Interpolation of pre-initialized profile functions *
12438* This version dated 28.11.00 is written by S. Roesler. *
12439************************************************************************
12440
12441 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12442 SAVE
12443
12444 PARAMETER ( LINP = 10 ,
12445 & LOUT = 6 ,
12446 & LDAT = 9 )
12447
12448 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12449
12450 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12451
12452* particle properties (BAMJET index convention)
12453 CHARACTER*8 ANAME
12454 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12455 & IICH(210),IIBAR(210),K1(210),K2(210)
12456
12457* Glauber formalism: flags and parameters for statistics
12458 LOGICAL LPROD
12459 CHARACTER*8 CGLB
12460 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12461
12462 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12463
12464* Glauber formalism: parameters
12465 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12466 & BMAX(NCOMPX),BSTEP(NCOMPX),
12467 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12468 & NSITEB,NSTATB
12469
12470* Glauber formalism: cross sections
12471 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12472 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12473 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12474 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12475 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12476 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12477 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12478 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12479 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12480 & BSLOPE,NEBINI,NQBINI
12481
12482* number of data sets other than protons and nuclei
12483* at the moment = 2 (pions and kaons)
12484 PARAMETER (MAXOFF=2)
12485 DIMENSION IJPINI(5),IOFFST(25)
12486 DATA IJPINI / 13, 15, 0, 0, 0/
12487* Glauber data-set to be used for hadron projectiles
12488* (0=proton, 1=pion, 2=kaon)
12489 DATA (IOFFST(K),K=1,25) /
12490 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12491 & 0, 0, 1, 2, 2/
12492* Acceptance interval for target nucleus mass
12493 PARAMETER (KBACC = 6)
12494
12495* emulsion treatment
12496 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12497 & NCOMPO,IEMUL
12498
12499 PARAMETER (MAXSET=5000,
12500 & MAXBIN=100)
12501 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12502 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12503 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12504 & IAIDX(10)
12505
12506 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12507*
12508* read data from file
12509*
12510 IF (MODE.EQ.0) THEN
12511
12512 IF (LREAD) RETURN
12513
12514 DO 1 I=1,MAXSET
12515 DO 2 J=1,6
12516 XSIG(I,J) = ZERO
12517 XERR(I,J) = ZERO
12518 2 CONTINUE
12519 DO 3 J=1,KSITEB
12520 BPROFL(I,J) = ZERO
12521 3 CONTINUE
12522 1 CONTINUE
12523 DO 4 I=1,MAXBIN
12524 IABIN(I) = 0
12525 IBBIN(I) = 0
12526 4 CONTINUE
12527 DO 5 I=1,KSITEB
12528 BPRO0(I) = ZERO
12529 BPRO1(I) = ZERO
12530 BPRO(I) = ZERO
12531 5 CONTINUE
12532
12533 IDX = INDEX(CGLB,' ')
12534 K = 12
12535 IF (IDX.GT.1) K = IDX-1
12536 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12537 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12538 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12539 & 'file ',A12,/)
12540*
12541* read binning information
12542 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12543* return lower energy threshold to Fluka-interface
12544 ELAB = ELO
12545 LCMS = ELO.LT.ZERO
12546 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12547 IF (LCMS) THEN
12548 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12549 ELSE
12550 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12551 ENDIF
12552 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12553 & 'No. of bins:',I5,/)
12554 ELO = LOG10(ABS(ELO))
12555 EHI = LOG10(ABS(EHI))
12556 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12557 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12558 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12559 IF (NABIN.LT.18) THEN
12560 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12561 ELSE
12562 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12563 ENDIF
12564 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12565 IF (NABIN.GT.18) THEN
12566 NLINES = DBLE(NABIN-18)/18.0D0
12567 IF (NLINES.GT.0) THEN
12568 DO 7 I=1,NLINES
12569 I0 = 18*(I+1)-17
12570 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12571 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12572 7 CONTINUE
12573 ENDIF
12574 I0 = 18*(NLINES+1)+1
12575 IF (I0.LE.NABIN) THEN
12576 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12577 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12578 ENDIF
12579 ENDIF
12580 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12581 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12582 IF (NBBIN.LT.18) THEN
12583 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12584 ELSE
12585 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12586 ENDIF
12587 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12588 IF (NBBIN.GT.18) THEN
12589 NLINES = DBLE(NBBIN-18)/18.0D0
12590 IF (NLINES.GT.0) THEN
12591 DO 8 I=1,NLINES
12592 I0 = 18*(I+1)-17
12593 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12594 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12595 8 CONTINUE
12596 ENDIF
12597 I0 = 18*(NLINES+1)+1
12598 IF (I0.LE.NBBIN) THEN
12599 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12600 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12601 ENDIF
12602 ENDIF
12603* number of data sets to follow in the Glauber data file
12604* this variable is used for checks of consistency of projectile
12605* and target mass configurations given in header of Glauber data
12606* file and the data-sets which follow in this file
12607 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12608*
12609* read profile function data
12610 NSET = 0
12611 NAIDX = 0
12612 IPOLD = 0
12613 10 CONTINUE
12614 NSET = NSET+1
12615 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12616 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12617 1002 FORMAT(5I10,E15.5)
12618 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12619 NAIDX = NAIDX+1
12620 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12621 IAIDX(NAIDX) = IP
12622 IPOLD = IP
12623 ENDIF
12624 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12625 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12626 NLINES = INT(DBLE(ISITEB)/7.0D0)
12627 IF (NLINES.GT.0) THEN
12628 DO 11 I=1,NLINES
12629 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12630 11 CONTINUE
12631 ENDIF
12632 I0 = 7*NLINES+1
12633 IF (I0.LE.ISITEB)
12634 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12635 GOTO 10
12636 100 CONTINUE
12637 NSET = NSET-1
12638 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12639 WRITE(LOUT,'(/,1X,A)')
12640 & ' projectiles other than protons and nuclei: (particle index)'
12641 IF (NAIDX.GT.0) THEN
12642 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12643 ELSE
12644 WRITE(LOUT,'(6X,A)') 'none'
12645 ENDIF
12646*
12647 CLOSE(LDAT)
12648 WRITE(LOUT,*)
12649 LREAD = .TRUE.
12650
12651 IF (NCOMPO.EQ.0) THEN
12652 DO 12 J=1,NBBIN
12653 NCOMPO = NCOMPO+1
12654 IEMUMA(NCOMPO) = IBBIN(J)
12655 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12656 EMUFRA(NCOMPO) = 1.0D0
12657 12 CONTINUE
12658 IEMUL = 1
12659 ENDIF
12660*
12661* calculate profile function for certain set of parameters
12662*
12663 ELSE
12664
12665c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12666*
12667* check for type of projectile and set index-offset to entry in
12668* Glauber data array correspondingly
12669 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12670 IF (IOFFST(IDPROJ).EQ.-1) THEN
12671 STOP ' GLBSET: no data for this projectile !'
12672 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12673 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12674 ELSE
12675 IDXOFF = 0
12676 ENDIF
12677*
12678* get energy bin and interpolation factor
12679 IF (LCMS) THEN
12680 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12681 ELSE
12682 E = ELAB
12683 ENDIF
12684 E = LOG10(E)
12685 IF (E.LT.ELO) THEN
12686 IF (LFRST1) THEN
12687 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12688 LFRST1 = .FALSE.
12689 ENDIF
12690 E = ELO
12691 ENDIF
12692 IF (E.GT.EHI) THEN
12693 IF (LFRST2) THEN
12694 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12695 LFRST2 = .FALSE.
12696 ENDIF
12697 E = EHI
12698 ENDIF
12699 IE0 = (E-ELO)/DEBIN+1
12700 IE1 = IE0+1
12701 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12702*
12703* get target nucleus index
12704 KB = 0
12705 NBACC = KBACC
12706 DO 20 I=1,NBBIN
12707 NBDIFF = ABS(NB-IBBIN(I))
12708 IF (NB.EQ.IBBIN(I)) THEN
12709 KB = I
12710 GOTO 21
12711 ELSEIF (NBDIFF.LE.NBACC) THEN
12712 KB = I
12713 NBACC = NBDIFF
12714 ENDIF
12715 20 CONTINUE
12716 IF (KB.NE.0) GOTO 21
12717 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12718 STOP
12719 21 CONTINUE
12720*
12721* get projectile nucleus bin and interpolation factor
12722 KA0 = 0
12723 KA1 = 0
12724 FACNA = 0
12725 IF (IDXOFF.GT.0) THEN
12726 KA0 = 1
12727 KA1 = 1
12728 KABIN = 1
12729 ELSE
12730 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12731 DO 22 I=1,NABIN
12732 IF (NA.EQ.IABIN(I)) THEN
12733 KA0 = I
12734 KA1 = I
12735 GOTO 23
12736 ELSEIF (NA.LT.IABIN(I)) THEN
12737 KA0 = I-1
12738 KA1 = I
12739 GOTO 23
12740 ENDIF
12741 22 CONTINUE
12742 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12743 STOP
12744 23 CONTINUE
12745 IF (KA0.NE.KA1)
12746 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12747 KABIN = NABIN
12748 ENDIF
12749*
12750* interpolate profile functions for interactions ka0-kb and ka1-kb
12751* for energy E separately
12752 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12753 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12754 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12755 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12756 DO 30 I=1,ISITEB
12757 BPRO0(I) = BPROFL(IDX0,I)
12758 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12759 BPRO1(I) = BPROFL(IDY0,I)
12760 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12761 30 CONTINUE
12762 RADB = DT_RNCLUS(NB)
12763 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12764 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12765*
12766* interpolate cross sections for energy E and projectile mass
12767 DO 31 I=1,6
12768 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12769 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12770 XS(I) = XS0+FACNA*(XS1-XS0)
12771 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12772 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12773 XE(I) = XE0+FACNA*(XE1-XE0)
12774 31 CONTINUE
12775*
12776* interpolate between ka0 and ka1
12777 RADA = DT_RNCLUS(NA)
12778 BMX = 2.0D0*(RADA+RADB)
12779 BSTP = BMX/DBLE(ISITEB-1)
12780 BPRO(1) = ZERO
12781 DO 32 I=1,ISITEB-1
12782 B = DBLE(I)*BSTP
12783*
12784* calculate values of profile functions at B
12785 IDX0 = B/BSTP0+1
12786 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12787 IDX1 = MIN(IDX0+1,ISITEB)
12788 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12789 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12790 IDX0 = B/BSTP1+1
12791 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12792 IDX1 = MIN(IDX0+1,ISITEB)
12793 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12794 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12795*
12796 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12797 32 CONTINUE
12798*
12799* fill common dtglam
12800 NSITEB = ISITEB
12801 RASH(1) = RADA
12802 RBSH(1) = RADB
12803 BMAX(1) = BMX
12804 BSTEP(1) = BSTP
12805 DO 33 I=1,KSITEB
12806 BSITE(0,1,1,I) = BPRO(I)
12807 33 CONTINUE
12808*
12809* fill common dtglxs
12810 XSTOT(1,1,1) = XS(1)
12811 XSELA(1,1,1) = XS(2)
12812 XSQEP(1,1,1) = XS(3)
12813 XSQET(1,1,1) = XS(4)
12814 XSQE2(1,1,1) = XS(5)
12815 XSPRO(1,1,1) = XS(6)
12816 XETOT(1,1,1) = XE(1)
12817 XEELA(1,1,1) = XE(2)
12818 XEQEP(1,1,1) = XE(3)
12819 XEQET(1,1,1) = XE(4)
12820 XEQE2(1,1,1) = XE(5)
12821 XEPRO(1,1,1) = XE(6)
12822
12823 ENDIF
12824
12825 RETURN
12826 END
12827*$ CREATE DT_XKSAMP.FOR
12828*COPY DT_XKSAMP
12829*
12830*===xksamp=============================================================*
12831*
12832 SUBROUTINE DT_XKSAMP(NN,ECM)
12833
12834************************************************************************
12835* Sampling of parton x-values and chain system for one interaction. *
12836* processed by S. Roesler, 9.8.95 *
12837************************************************************************
12838
12839 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12840 SAVE
12841
12842 PARAMETER ( LINP = 10 ,
12843 & LOUT = 6 ,
12844 & LDAT = 9 )
12845
12846 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12847 SAVE
12848
12849 PARAMETER (
12850* lower cuts for (valence-sea/sea-valence) chain masses
12851* antiquark-quark (u/d-sea quark) (s-sea quark)
12852 & AMIU = 0.5D0, AMIS = 0.8D0,
12853* quark-diquark (u/d-sea quark) (s-sea quark)
12854 & AMAU = 2.6D0, AMAS = 2.6D0,
12855* maximum lower valence-x threshold
12856 & XVMAX = 0.98D0,
12857* fraction of sea-diquarks sampled out of sea-partons
12858**test
12859C & FRCDIQ = 0.9D0,
12860**
12861*
12862 & SQMA = 0.7D0,
12863*
12864* maximum number of trials to generate x's for the required number
12865* of sea quark pairs for a given hadron
12866 & NSEATY = 12
12867C & NSEATY = 3
12868 & )
12869
12870 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12871
12872 PARAMETER ( MAXNCL = 260,
12873
12874 & MAXVQU = MAXNCL,
12875 & MAXSQU = 20*MAXVQU,
12876 & MAXINT = MAXVQU+MAXSQU)
12877
12878* event history
12879
12880 PARAMETER (NMXHKK=200000)
12881
12882 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12883 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12884 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12885
12886* particle properties (BAMJET index convention)
12887 CHARACTER*8 ANAME
12888 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12889 & IICH(210),IIBAR(210),K1(210),K2(210)
12890
12891* interface between Glauber formalism and DPM
12892 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12893 & INTER1(MAXINT),INTER2(MAXINT)
12894
12895* properties of interacting particles
12896 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12897
12898* threshold values for x-sampling (DTUNUC 1.x)
12899 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12900 & SSMIMQ,VVMTHR
12901
12902* x-values of partons (DTUNUC 1.x)
12903 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12904 & XTVQ(MAXVQU),XTVD(MAXVQU),
12905 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12906 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12907
12908* flavors of partons (DTUNUC 1.x)
12909 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12910 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12911 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12912 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12913 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12914 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12915 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12916
12917* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12918 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12919 & IXPV,IXPS,IXTV,IXTS,
12920 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12921 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12922 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12923 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12924 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12925 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12926 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12927 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12928
12929* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12930 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12931 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12932
12933* auxiliary common for chain system storage (DTUNUC 1.x)
12934 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12935
12936* flags for input different options
12937 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12938 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12939 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12940
12941* various options for treatment of partons (DTUNUC 1.x)
12942* (chain recombination, Cronin,..)
12943 LOGICAL LCO2CR,LINTPT
12944 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12945 & LCO2CR,LINTPT
12946
12947 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12948 & INTLO(MAXINT)
12949
12950* (1) initializations
12951*-----------------------------------------------------------------------
12952
12953**test
12954 IF (ECM.LT.4.5D0) THEN
12955C FRCDIQ = 0.6D0
12956 FRCDIQ = 0.4D0
12957 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12958C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12959 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12960 ELSE
12961C FRCDIQ = 0.9D0
12962 FRCDIQ = 0.7D0
12963 ENDIF
12964**
12965 DO 30 I=1,MAXSQU
12966 ZUOSP(I) = .FALSE.
12967 ZUOST(I) = .FALSE.
12968 IF (I.LE.MAXVQU) THEN
12969 ZUOVP(I) = .FALSE.
12970 ZUOVT(I) = .FALSE.
12971 ENDIF
12972 30 CONTINUE
12973
12974* lower thresholds for x-selection
12975* sea-quarks (default: CSEA=0.2)
12976 IF (ECM.LT.10.0D0) THEN
12977**!!test
12978 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12979C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12980 NSEA = NSEATY
12981C XSTHR = ONE/ECM**2
12982 ELSE
12983**sr 30.3.98
12984C XSTHR = CSEA/ECM
12985 XSTHR = CSEA/ECM**2
12986C XSTHR = ONE/ECM**2
12987**
12988 IF ((IP.GE.150).AND.(IT.GE.150))
12989 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12990 NSEA = NSEATY
12991 ENDIF
12992* (default: SSMIMA=0.14) used for sea-diquarks (?)
12993 XSSTHR = SSMIMA/ECM
12994 BSQMA = SQMA/ECM
12995* valence-quarks (default: CVQ=1.0)
12996 XVTHR = CVQ/ECM
12997* valence-diquarks (default: CDQ=2.0)
12998 XDTHR = CDQ/ECM
12999
13000* maximum-x for sea-quarks
13001 XVCUT = XVTHR+XDTHR
13002 IF (XVCUT.GT.XVMAX) THEN
13003 XVCUT = XVMAX
13004 XVTHR = XVCUT/3.0D0
13005 XDTHR = XVCUT-XVTHR
13006 ENDIF
13007 XXSEAM = ONE-XVCUT
13008**sr 18.4. test: DPMJET
13009C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13010C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13011C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13012**
13013* maximum number of sea-pairs allowed kinematically
13014C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13015 RNSMAX = OHALF*XXSEAM/XSTHR
13016 IF (RNSMAX.GT.10000.0D0) THEN
13017 NSMAX = 10000
13018 ELSE
13019 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13020 ENDIF
13021* check kinematical limit for valence-x thresholds
13022* (should be obsolete now)
13023 IF (XVCUT.GT.XVMAX) THEN
13024 WRITE(LOUT,1000) XVCUT,ECM
13025 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13026 & ' thresholds not allowed (',2E9.3,')')
13027C XVTHR = XVMAX-XDTHR
13028C IF (XVTHR.LT.ZERO) STOP
13029 STOP
13030 ENDIF
13031
13032* set eta for valence-x sampling (BETREJ)
13033* (UNON per default, UNOM used for projectile mesons only)
13034 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13035 UNOPRV = UNOM
13036 ELSE
13037 UNOPRV = UNON
13038 ENDIF
13039
13040* (2) select parton x-values of interacting projectile nucleons
13041*-----------------------------------------------------------------------
13042
13043 IXPV = 0
13044 IXPS = 0
13045
13046 DO 100 IPP=1,IP
13047* get interacting projectile nucleon as sampled by Glauber
13048 IF (JSSH(IPP).NE.0) THEN
13049 IXSTMP = IXPS
13050 IXVTMP = IXPV
13051 99 CONTINUE
13052 IXPS = IXSTMP
13053 IXPV = IXVTMP
13054* JIPP is the actual number of sea-pairs sampled for this nucleon
13055 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13056 41 CONTINUE
13057 XXSEA = ZERO
13058 IF (JIPP.GT.0) THEN
13059 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13060*???
13061 IF (XSTHR.GE.XSMAX) THEN
13062 JIPP = JIPP-1
13063 GOTO 41
13064 ENDIF
13065
13066*>>>get x-values of sea-quark pairs
13067 NSCOUN = 0
13068 PLW = 0.5D0
13069 40 CONTINUE
13070* accumulator for sea x-values
13071 XXSEA = ZERO
13072 NSCOUN = NSCOUN+1
13073 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13074 IF (NSCOUN.GT.NSEA) THEN
13075* decrease the number of interactions after NSEA trials
13076 JIPP = JIPP-1
13077 NSCOUN = 0
13078 ENDIF
13079 DO 70 ISQ=1,JIPP
13080* sea-quarks
13081 IF (IPSQ(IXPS+1).LE.2) THEN
13082**sr 8.4.98 (1/sqrt(x))
13083C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13084C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13085 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13086**
13087 ELSE
13088 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13089 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13090 ELSE
13091**sr 8.4.98 (1/sqrt(x))
13092C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13093C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13094 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13095**
13096 ENDIF
13097 ENDIF
13098* sea-antiquarks
13099 IF (IPSAQ(IXPS+1).GE.-2) THEN
13100**sr 8.4.98 (1/sqrt(x))
13101C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13102C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13103 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13104**
13105 ELSE
13106 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13107 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13108 ELSE
13109**sr 8.4.98 (1/sqrt(x))
13110C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13111C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13112 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13113**
13114 ENDIF
13115 ENDIF
13116 XXSEA = XXSEA+XPSQI+XPSAQI
13117* check for maximum allowed sea x-value
13118 IF (XXSEA.GE.XXSEAM) THEN
13119 IXPS = IXPS-ISQ+1
13120 GOTO 40
13121 ENDIF
13122* accept this sea-quark pair
13123 IXPS = IXPS+1
13124 XPSQ(IXPS) = XPSQI
13125 XPSAQ(IXPS) = XPSAQI
13126 IFROSP(IXPS) = IPP
13127 ZUOSP(IXPS) = .TRUE.
13128 70 CONTINUE
13129 ENDIF
13130
13131*>>>get x-values of valence partons
13132* valence quark
13133 IF (XVTHR.GT.0.05D0) THEN
13134 XVHI = ONE-XXSEA-XDTHR
13135 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13136 ELSE
13137 90 CONTINUE
13138 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13139 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13140 & GOTO 90
13141 ENDIF
13142* valence diquark
13143 XPVDI = ONE-XPVQI-XXSEA
13144* reject according to x**1.5
13145 XDTMP = XPVDI**1.5D0
13146 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13147* accept these valence partons
13148 IXPV = IXPV+1
13149 XPVQ(IXPV) = XPVQI
13150 XPVD(IXPV) = XPVDI
13151 IFROVP(IXPV) = IPP
13152 ITOVP(IPP) = IXPV
13153 ZUOVP(IXPV) = .TRUE.
13154
13155 ENDIF
13156 100 CONTINUE
13157
13158* (3) select parton x-values of interacting target nucleons
13159*-----------------------------------------------------------------------
13160
13161 IXTV = 0
13162 IXTS = 0
13163
13164 DO 170 ITT=1,IT
13165* get interacting target nucleon as sampled by Glauber
13166 IF (JTSH(ITT).NE.0) THEN
13167 IXSTMP = IXTS
13168 IXVTMP = IXTV
13169 169 CONTINUE
13170 IXTS = IXSTMP
13171 IXTV = IXVTMP
13172* JITT is the actual number of sea-pairs sampled for this nucleon
13173 JITT = MIN(JTSH(ITT)-1,NSMAX)
13174 111 CONTINUE
13175 XXSEA = ZERO
13176 IF (JITT.GT.0) THEN
13177 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13178*???
13179 IF (XSTHR.GE.XSMAX) THEN
13180 JITT = JITT-1
13181 GOTO 111
13182 ENDIF
13183
13184*>>>get x-values of sea-quark pairs
13185 NSCOUN = 0
13186 PLW = 0.5D0
13187 110 CONTINUE
13188* accumulator for sea x-values
13189 XXSEA = ZERO
13190 NSCOUN = NSCOUN+1
13191 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13192 IF (NSCOUN.GT.NSEA)THEN
13193* decrease the number of interactions after NSEA trials
13194 JITT = JITT-1
13195 NSCOUN = 0
13196 ENDIF
13197 DO 140 ISQ=1,JITT
13198* sea-quarks
13199 IF (ITSQ(IXTS+1).LE.2) THEN
13200**sr 8.4.98 (1/sqrt(x))
13201C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13202C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13203 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13204**
13205 ELSE
13206 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13207 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13208 ELSE
13209**sr 8.4.98 (1/sqrt(x))
13210C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13211C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13212 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13213**
13214 ENDIF
13215 ENDIF
13216* sea-antiquarks
13217 IF (ITSAQ(IXTS+1).GE.-2) THEN
13218**sr 8.4.98 (1/sqrt(x))
13219C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13220C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13221 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13222**
13223 ELSE
13224 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13225 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13226 ELSE
13227**sr 8.4.98 (1/sqrt(x))
13228C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13229C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13230 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13231**
13232 ENDIF
13233 ENDIF
13234 XXSEA = XXSEA+XTSQI+XTSAQI
13235* check for maximum allowed sea x-value
13236 IF (XXSEA.GE.XXSEAM) THEN
13237 IXTS = IXTS-ISQ+1
13238 GOTO 110
13239 ENDIF
13240* accept this sea-quark pair
13241 IXTS = IXTS+1
13242 XTSQ(IXTS) = XTSQI
13243 XTSAQ(IXTS) = XTSAQI
13244 IFROST(IXTS) = ITT
13245 ZUOST(IXTS) = .TRUE.
13246 140 CONTINUE
13247 ENDIF
13248
13249*>>>get x-values of valence partons
13250* valence quark
13251 IF (XVTHR.GT.0.05D0) THEN
13252 XVHI = ONE-XXSEA-XDTHR
13253 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13254 ELSE
13255 160 CONTINUE
13256 XTVQI = DT_DBETAR(OHALF,UNON)
13257 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13258 & GOTO 160
13259 ENDIF
13260* valence diquark
13261 XTVDI = ONE-XTVQI-XXSEA
13262* reject according to x**1.5
13263 XDTMP = XTVDI**1.5D0
13264 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13265* accept these valence partons
13266 IXTV = IXTV+1
13267 XTVQ(IXTV) = XTVQI
13268 XTVD(IXTV) = XTVDI
13269 IFROVT(IXTV) = ITT
13270 ITOVT(ITT) = IXTV
13271 ZUOVT(IXTV) = .TRUE.
13272
13273 ENDIF
13274 170 CONTINUE
13275
13276* (4) get valence-valence chains
13277*-----------------------------------------------------------------------
13278
13279 NVV = 0
13280 DO 240 I=1,NN
13281 INTLO(I) = .TRUE.
13282 IPVAL = ITOVP(INTER1(I))
13283 ITVAL = ITOVT(INTER2(I))
13284 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13285 INTLO(I) = .FALSE.
13286 ZUOVP(IPVAL) = .FALSE.
13287 ZUOVT(ITVAL) = .FALSE.
13288 NVV = NVV+1
13289 ISKPCH(8,NVV) = 0
13290 INTVV1(NVV) = IPVAL
13291 INTVV2(NVV) = ITVAL
13292 ENDIF
13293 240 CONTINUE
13294
13295* (5) get sea-valence chains
13296*-----------------------------------------------------------------------
13297
13298 NSV = 0
13299 NDV = 0
13300 PLW = 0.5D0
13301 DO 270 I=1,NN
13302 IF (INTLO(I)) THEN
13303 IPVAL = ITOVP(INTER1(I))
13304 ITVAL = ITOVT(INTER2(I))
13305 DO 250 J=1,IXPS
13306 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13307 & ZUOVT(ITVAL)) THEN
13308 ZUOSP(J) = .FALSE.
13309 ZUOVT(ITVAL) = .FALSE.
13310 INTLO(I) = .FALSE.
13311 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13312* sample sea-diquark pair
13313 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13314 IF (IREJ1.EQ.0) GOTO 260
13315 ENDIF
13316 NSV = NSV+1
13317 ISKPCH(4,NSV) = 0
13318 INTSV1(NSV) = J
13319 INTSV2(NSV) = ITVAL
13320
13321*>>>correct chain kinematics according to minimum chain masses
13322* the actual chain masses
13323 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13324 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13325* get lower mass cuts
13326 IF (IPSQ(J).EQ.3) THEN
13327* q being s-quark
13328 AMCHK1 = AMAS
13329 AMCHK2 = AMIS
13330 ELSE
13331* q being u/d-quark
13332 AMCHK1 = AMAU
13333 AMCHK2 = AMIU
13334 ENDIF
13335* q-qq chain
13336* chain mass above minimum - resampling of sea-q x-value
13337 IF (AMSVQ1.GT.AMCHK1) THEN
13338 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339**sr 8.4.98 (1/sqrt(x))
13340C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13341C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13342 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13343**
13344 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13345 XPSQ(J) = XPSQXX
13346* chain mass below minimum - reset sea-q x-value and correct
13347* diquark-x of the same nucleon
13348 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13349 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13350 DXPSQ = XPSQW-XPSQ(J)
13351 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13353 XPSQ(J) = XPSQW
13354 ENDIF
13355 ENDIF
13356* aq-q chain
13357* chain mass below minimum - reset sea-aq x-value and correct
13358* diquark-x of the same nucleon
13359 IF (AMSVQ2.LT.AMCHK2) THEN
13360 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13361 DXPSQ = XPSQW-XPSAQ(J)
13362 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13363 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13364 XPSAQ(J) = XPSQW
13365 ENDIF
13366 ENDIF
13367*>>>end of chain mass correction
13368
13369 GOTO 260
13370 ENDIF
13371 250 CONTINUE
13372 ENDIF
13373 260 CONTINUE
13374 270 CONTINUE
13375
13376* (6) get valence-sea chains
13377*-----------------------------------------------------------------------
13378
13379 NVS = 0
13380 NVD = 0
13381 DO 300 I=1,NN
13382 IF (INTLO(I)) THEN
13383 IPVAL = ITOVP(INTER1(I))
13384 ITVAL = ITOVT(INTER2(I))
13385 DO 280 J=1,IXTS
13386 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13387 & (IFROST(J).EQ.INTER2(I))) THEN
13388 ZUOST(J) = .FALSE.
13389 ZUOVP(IPVAL) = .FALSE.
13390 INTLO(I) = .FALSE.
13391 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13392* sample sea-diquark pair
13393 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13394 IF (IREJ1.EQ.0) GOTO 290
13395 ENDIF
13396 NVS = NVS + 1
13397 ISKPCH(6,NVS) = 0
13398 INTVS1(NVS) = IPVAL
13399 INTVS2(NVS) = J
13400
13401*>>>correct chain kinematics according to minimum chain masses
13402* the actual chain masses
13403 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13404 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13405* get lower mass cuts
13406 IF (ITSQ(J).EQ.3) THEN
13407* q being s-quark
13408 AMCHK1 = AMIS
13409 AMCHK2 = AMAS
13410 ELSE
13411* q being u/d-quark
13412 AMCHK1 = AMIU
13413 AMCHK2 = AMAU
13414 ENDIF
13415* q-aq chain
13416* chain mass below minimum - reset sea-aq x-value and correct
13417* diquark-x of the same nucleon
13418 IF (AMVSQ1.LT.AMCHK1) THEN
13419 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13420 DXTSQ = XTSQW-XTSAQ(J)
13421 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13422 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13423 XTSAQ(J) = XTSQW
13424 ENDIF
13425 ENDIF
13426* qq-q chain
13427* chain mass above minimum - resampling of sea-q x-value
13428 IF (AMVSQ2.GT.AMCHK2) THEN
13429 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430**sr 8.4.98 (1/sqrt(x))
13431C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13432C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13433 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13434**
13435 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13436 XTSQ(J) = XTSQXX
13437* chain mass below minimum - reset sea-q x-value and correct
13438* diquark-x of the same nucleon
13439 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13440 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13441 DXTSQ = XTSQW-XTSQ(J)
13442 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13443 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13444 XTSQ(J) = XTSQW
13445 ENDIF
13446 ENDIF
13447*>>>end of chain mass correction
13448
13449 GOTO 290
13450 ENDIF
13451 280 CONTINUE
13452 ENDIF
13453 290 CONTINUE
13454 300 CONTINUE
13455
13456* (7) get sea-sea chains
13457*-----------------------------------------------------------------------
13458
13459 NSS = 0
13460 NDS = 0
13461 NSD = 0
13462 DO 420 I=1,NN
13463 IF (INTLO(I)) THEN
13464 IPVAL = ITOVP(INTER1(I))
13465 ITVAL = ITOVT(INTER2(I))
13466* loop over target partons not yet matched
13467 DO 400 J=1,IXTS
13468 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13469* loop over projectile partons not yet matched
13470 DO 390 JJ=1,IXPS
13471 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13472 ZUOSP(JJ) = .FALSE.
13473 ZUOST(J) = .FALSE.
13474 INTLO(I) = .FALSE.
13475 NSS = NSS+1
13476 ISKPCH(1,NSS) = 0
13477 INTSS1(NSS) = JJ
13478 INTSS2(NSS) = J
13479
13480*---->chain recombination option
13481 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13482 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13483 & THEN
13484* sea-sea chains may recombine with valence-valence chains
13485* only if they have the same projectile or target nucleon
13486 DO 4201 IVV=1,NVV
13487 IF (ISKPCH(8,IVV).NE.99) THEN
13488 IXVPR = INTVV1(IVV)
13489 IXVTA = INTVV2(IVV)
13490 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13491 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13492* recombination possible, drop old v-v and s-s chains
13493 ISKPCH(1,NSS) = 99
13494 ISKPCH(8,IVV) = 99
13495
13496* (a) assign new s-v chains
13497* ~~~~~~~~~~~~~~~~~~~~~~~~~
13498 IF (LSEADI.AND.
13499 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13500 & THEN
13501* sample sea-diquark pair
13502 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13503 & IREJ1)
13504 IF (IREJ1.EQ.0) GOTO 4202
13505 ENDIF
13506 NSV = NSV+1
13507 ISKPCH(4,NSV) = 0
13508 INTSV1(NSV) = JJ
13509 INTSV2(NSV) = IXVTA
13510*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13511* the actual chain masses
13512 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13513 & *ECM**2
13514 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13515 & *ECM**2
13516* get lower mass cuts
13517 IF (IPSQ(JJ).EQ.3) THEN
13518* q being s-quark
13519 AMCHK1 = AMAS
13520 AMCHK2 = AMIS
13521 ELSE
13522* q being u/d-quark
13523 AMCHK1 = AMAU
13524 AMCHK2 = AMIU
13525 ENDIF
13526* q-qq chain
13527* chain mass above minimum - resampling of sea-q x-value
13528 IF (AMSVQ1.GT.AMCHK1) THEN
13529 XPSQTH =
13530 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13531**sr 8.4.98 (1/sqrt(x))
13532 XPSQXX =
13533 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13534C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13535C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13536**
13537 XPVD(IPVAL) =
13538 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13539 XPSQ(JJ) = XPSQXX
13540* chain mass below minimum - reset sea-q x-value and correct
13541* diquark-x of the same nucleon
13542 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13543 XPSQW =
13544 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13545 DXPSQ = XPSQW-XPSQ(JJ)
13546 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13547 & THEN
13548 XPVD(IPVAL) =
13549 & XPVD(IPVAL)-DXPSQ
13550 XPSQ(JJ) = XPSQW
13551 ENDIF
13552 ENDIF
13553* aq-q chain
13554* chain mass below minimum - reset sea-aq x-value and correct
13555* diquark-x of the same nucleon
13556 IF (AMSVQ2.LT.AMCHK2) THEN
13557 XPSQW =
13558 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13559 DXPSQ = XPSQW-XPSAQ(JJ)
13560 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13561 & THEN
13562 XPVD(IPVAL) =
13563 & XPVD(IPVAL)-DXPSQ
13564 XPSAQ(JJ) = XPSQW
13565 ENDIF
13566 ENDIF
13567*>>>>>>>>>>>end of chain mass correction
13568 4202 CONTINUE
13569
13570* (b) assign new v-s chains
13571* ~~~~~~~~~~~~~~~~~~~~~~~~~
13572 IF (LSEADI.AND.(
13573 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13574 & THEN
13575* sample sea-diquark pair
13576 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13577 & IREJ1)
13578 IF (IREJ1.EQ.0) GOTO 4203
13579 ENDIF
13580 NVS = NVS+1
13581 ISKPCH(6,NVS) = 0
13582 INTVS1(NVS) = IXVPR
13583 INTVS2(NVS) = J
13584*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13585* the actual chain masses
13586 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13587 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13588* get lower mass cuts
13589 IF (ITSQ(J).EQ.3) THEN
13590* q being s-quark
13591 AMCHK1 = AMIS
13592 AMCHK2 = AMAS
13593 ELSE
13594* q being u/d-quark
13595 AMCHK1 = AMIU
13596 AMCHK2 = AMAU
13597 ENDIF
13598* q-aq chain
13599* chain mass below minimum - reset sea-aq x-value and correct
13600* diquark-x of the same nucleon
13601 IF (AMVSQ1.LT.AMCHK1) THEN
13602 XTSQW =
13603 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13604 DXTSQ = XTSQW-XTSAQ(J)
13605 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13606 & THEN
13607 XTVD(ITVAL) =
13608 & XTVD(ITVAL)-DXTSQ
13609 XTSAQ(J) = XTSQW
13610 ENDIF
13611 ENDIF
13612 IF (AMVSQ2.GT.AMCHK2) THEN
13613 XTSQTH =
13614 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13615**sr 8.4.98 (1/sqrt(x))
13616 XTSQXX =
13617 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13618C & DT_SAMSQX(XTSQTH,XTSQ(J))
13619C & DT_SAMPEX(XTSQTH,XTSQ(J))
13620**
13621 XTVD(ITVAL) =
13622 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13623 XTSQ(J) = XTSQXX
13624 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13625 XTSQW =
13626 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13627 DXTSQ = XTSQW-XTSQ(J)
13628 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13629 & THEN
13630 XTVD(ITVAL) =
13631 & XTVD(ITVAL)-DXTSQ
13632 XTSQ(J) = XTSQW
13633 ENDIF
13634 ENDIF
13635*>>>>>>>>>end of chain mass correction
13636 4203 CONTINUE
13637* jump out of s-s chain loop
13638 GOTO 420
13639 ENDIF
13640 ENDIF
13641 4201 CONTINUE
13642 ENDIF
13643*---->end of chain recombination option
13644
13645* sample sea-diquark pair (projectile)
13646 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13647 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13648 IF (IREJ1.EQ.0) THEN
13649 ISKPCH(1,NSS) = 99
13650 GOTO 410
13651 ENDIF
13652 ENDIF
13653* sample sea-diquark pair (target)
13654 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13655 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13656 IF (IREJ1.EQ.0) THEN
13657 ISKPCH(1,NSS) = 99
13658 GOTO 410
13659 ENDIF
13660 ENDIF
13661*>>>>>correct chain kinematics according to minimum chain masses
13662* the actual chain masses
13663 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13664 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13665* check for lower mass cuts
13666 IF ((SSMA1Q.LT.SSMIMQ).OR.
13667 & (SSMA2Q.LT.SSMIMQ)) THEN
13668 IPVAL = ITOVP(INTER1(I))
13669 ITVAL = ITOVT(INTER2(I))
13670 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13671 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13672* maximum allowed x values for sea quarks
13673 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13674 & 1.2D0*XSSTHR
13675 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13676 & 1.2D0*XSSTHR
13677* resampling of x values not possible - skip sea-sea chains
13678 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13679 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13680* resampling of x for projectile sea quark pair
13681 ICOUS = 0
13682 310 CONTINUE
13683 ICOUS = ICOUS+1
13684 IF (XSSTHR.GT.0.05D0) THEN
13685 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13686 & XSPMAX)
13687 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13688 & XSPMAX)
13689 ELSE
13690 320 CONTINUE
13691 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13692 IF ((XPSQI.LT.XSSTHR).OR.
13693 & (XPSQI.GT.XSPMAX)) GOTO 320
13694 330 CONTINUE
13695 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13696 IF ((XPSAQI.LT.XSSTHR).OR.
13697 & (XPSAQI.GT.XSPMAX)) GOTO 330
13698 ENDIF
13699* final test of remaining x for projectile diquark
13700 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13701 & +XPSQ(JJ)+XPSAQ(JJ)
13702 IF (XPVDCO.LE.XDTHR) THEN
13703*!!!
13704C IF (ICOUS.LT.5) GOTO 310
13705 IF (ICOUS.LT.0.5D0) GOTO 310
13706 GOTO 380
13707 ENDIF
13708* resampling of x for target sea quark pair
13709 ICOUS = 0
13710 350 CONTINUE
13711 ICOUS = ICOUS+1
13712 IF (XSSTHR.GT.0.05D0) THEN
13713 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13714 & XSTMAX)
13715 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13716 & XSTMAX)
13717 ELSE
13718 360 CONTINUE
13719 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13720 IF ((XTSQI.LT.XSSTHR).OR.
13721 & (XTSQI.GT.XSTMAX)) GOTO 360
13722 370 CONTINUE
13723 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13724 IF ((XTSAQI.LT.XSSTHR).OR.
13725 & (XTSAQI.GT.XSTMAX)) GOTO 370
13726 ENDIF
13727* final test of remaining x for target diquark
13728 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13729 & +XTSQ(J)+XTSAQ(J)
13730 IF (XTVDCO.LT.XDTHR) THEN
13731 IF (ICOUS.LT.5) GOTO 350
13732 GOTO 380
13733 ENDIF
13734 XPVD(IPVAL) = XPVDCO
13735 XTVD(ITVAL) = XTVDCO
13736 XPSQ(JJ) = XPSQI
13737 XPSAQ(JJ) = XPSAQI
13738 XTSQ(J) = XTSQI
13739 XTSAQ(J) = XTSAQI
13740*>>>>>end of chain mass correction
13741 GOTO 410
13742 ENDIF
13743* come here to discard s-s interaction
13744* resampling of x values not allowed or unsuccessful
13745 380 CONTINUE
13746 INTLO(I) = .FALSE.
13747 ZUOST(J) = .TRUE.
13748 ZUOSP(JJ) = .TRUE.
13749 NSS = NSS-1
13750 ENDIF
13751* consider next s-s interaction
13752 GOTO 410
13753 ENDIF
13754 390 CONTINUE
13755 ENDIF
13756 400 CONTINUE
13757 ENDIF
13758 410 CONTINUE
13759 420 CONTINUE
13760
13761* correct x-values of valence quarks for non-matching sea quarks
13762 DO 430 I=1,IXPS
13763 IF (ZUOSP(I)) THEN
13764 IPVAL = ITOVP(IFROSP(I))
13765 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13766 XPSQ(I) = ZERO
13767 XPSAQ(I) = ZERO
13768 ZUOSP(I) = .FALSE.
13769 ENDIF
13770 430 CONTINUE
13771 DO 440 I=1,IXTS
13772 IF (ZUOST(I)) THEN
13773 ITVAL = ITOVT(IFROST(I))
13774 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13775 XTSQ(I) = ZERO
13776 XTSAQ(I) = ZERO
13777 ZUOST(I) = .FALSE.
13778 ENDIF
13779 440 CONTINUE
13780 DO 450 I=1,IXPV
13781 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13782 450 CONTINUE
13783 DO 460 I=1,IXTV
13784 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13785 460 CONTINUE
13786
13787 RETURN
13788 END
13789
13790*$ CREATE DT_SAMSDQ.FOR
13791*COPY DT_SAMSDQ
13792*
13793*===samsdq=============================================================*
13794*
13795 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13796
13797************************************************************************
13798* SAMpling of Sea-DiQuarks *
13799* ECM cm-energy of the nucleon-nucleon system *
13800* IDX1,2 indices of x-values of the participating *
13801* partons (IDX2 is always the sea-q-pair to be *
13802* changed to sea-qq-pair) *
13803* MODE = 1 valence-q - sea-diq *
13804* = 2 sea-diq - valence-q *
13805* = 3 sea-q - sea-diq *
13806* = 4 sea-diq - sea-q *
13807* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13808* This version dated 17.10.95 is written by S. Roesler *
13809************************************************************************
13810
13811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13812 SAVE
13813
13814 PARAMETER (ZERO=0.0D0)
13815
13816* threshold values for x-sampling (DTUNUC 1.x)
13817 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13818 & SSMIMQ,VVMTHR
13819
13820* various options for treatment of partons (DTUNUC 1.x)
13821* (chain recombination, Cronin,..)
13822 LOGICAL LCO2CR,LINTPT
13823 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13824 & LCO2CR,LINTPT
13825
13826 PARAMETER ( MAXNCL = 260,
13827
13828 & MAXVQU = MAXNCL,
13829 & MAXSQU = 20*MAXVQU,
13830 & MAXINT = MAXVQU+MAXSQU)
13831
13832* x-values of partons (DTUNUC 1.x)
13833 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13834 & XTVQ(MAXVQU),XTVD(MAXVQU),
13835 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13836 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13837
13838* flavors of partons (DTUNUC 1.x)
13839 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13840 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13841 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13842 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13843 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13844 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13845 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13846
13847* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13848 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13849 & IXPV,IXPS,IXTV,IXTS,
13850 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13851 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13852 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13853 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13854 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13855 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13856 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13857 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13858
13859* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13860 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13861 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13862
13863* auxiliary common for chain system storage (DTUNUC 1.x)
13864 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13865
13866 IREJ = 0
13867* threshold-x for valence diquarks
13868 XDTHR = CDQ/ECM
13869
13870 GOTO (1,2,3,4) MODE
13871
13872*---------------------------------------------------------------------
13873* proj. valence partons - targ. sea partons
13874* get x-values and flavors for target sea-diquark pair
13875
13876 1 CONTINUE
13877 IDXVP = IDX1
13878 IDXST = IDX2
13879
13880* index of corr. val-diquark-x in target nucleon
13881 IDXVT = ITOVT(IFROST(IDXST))
13882* available x above diquark thresholds for valence- and sea-diquarks
13883 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13884
13885 IF (XXD.GE.ZERO) THEN
13886* x-values for the three diquarks of the target nucleon
13887 RR1 = DT_RNDM(XXD)
13888 RR2 = DT_RNDM(RR1)
13889 RR3 = DT_RNDM(RR2)
13890 SR123 = RR1+RR2+RR3
13891 XXTV = XDTHR+RR1*XXD/SR123
13892 XXTSQ = XDTHR+RR2*XXD/SR123
13893 XXTSAQ = XDTHR+RR3*XXD/SR123
13894 ELSE
13895 XXTV = XTVD(IDXVT)
13896 XXTSQ = XTSQ(IDXST)
13897 XXTSAQ = XTSAQ(IDXST)
13898 ENDIF
13899* flavor of the second quarks in the sea-diquark pair
13900 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13901 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13902* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13903 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13904 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13905 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13906* ss-asas pair
13907 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13908 IREJ = 1
13909 RETURN
13910 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13911* at least one strange quark
13912 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13913 IREJ = 1
13914 RETURN
13915 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13916 IREJ = 1
13917 RETURN
13918 ENDIF
13919* accept the new sea-diquark
13920 XTVD(IDXVT) = XXTV
13921 XTSQ(IDXST) = XXTSQ
13922 XTSAQ(IDXST) = XXTSAQ
13923 NVD = NVD+1
13924 INTVD1(NVD) = IDXVP
13925 INTVD2(NVD) = IDXST
13926 ISKPCH(7,NVD) = 0
13927 RETURN
13928
13929*---------------------------------------------------------------------
13930* proj. sea partons - targ. valence partons
13931* get x-values and flavors for projectile sea-diquark pair
13932
13933 2 CONTINUE
13934 IDXSP = IDX2
13935 IDXVT = IDX1
13936
13937* index of corr. val-diquark-x in projectile nucleon
13938 IDXVP = ITOVP(IFROSP(IDXSP))
13939* available x above diquark thresholds for valence- and sea-diquarks
13940 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13941
13942 IF (XXD.GE.ZERO) THEN
13943* x-values for the three diquarks of the projectile nucleon
13944 RR1 = DT_RNDM(XXD)
13945 RR2 = DT_RNDM(RR1)
13946 RR3 = DT_RNDM(RR2)
13947 SR123 = RR1+RR2+RR3
13948 XXPV = XDTHR+RR1*XXD/SR123
13949 XXPSQ = XDTHR+RR2*XXD/SR123
13950 XXPSAQ = XDTHR+RR3*XXD/SR123
13951 ELSE
13952 XXPV = XPVD(IDXVP)
13953 XXPSQ = XPSQ(IDXSP)
13954 XXPSAQ = XPSAQ(IDXSP)
13955 ENDIF
13956* flavor of the second quarks in the sea-diquark pair
13957 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13958 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13959* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13960 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13961 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13962 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13963* ss-asas pair
13964 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13965 IREJ = 1
13966 RETURN
13967 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13968* at least one strange quark
13969 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13970 IREJ = 1
13971 RETURN
13972 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13973 IREJ = 1
13974 RETURN
13975 ENDIF
13976* accept the new sea-diquark
13977 XPVD(IDXVP) = XXPV
13978 XPSQ(IDXSP) = XXPSQ
13979 XPSAQ(IDXSP) = XXPSAQ
13980 NDV = NDV+1
13981 INTDV1(NDV) = IDXSP
13982 INTDV2(NDV) = IDXVT
13983 ISKPCH(5,NDV) = 0
13984 RETURN
13985
13986*---------------------------------------------------------------------
13987* proj. sea partons - targ. sea partons
13988* get x-values and flavors for target sea-diquark pair
13989
13990 3 CONTINUE
13991 IDXSP = IDX1
13992 IDXST = IDX2
13993
13994* index of corr. val-diquark-x in target nucleon
13995 IDXVT = ITOVT(IFROST(IDXST))
13996* available x above diquark thresholds for valence- and sea-diquarks
13997 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13998
13999 IF (XXD.GE.ZERO) THEN
14000* x-values for the three diquarks of the target nucleon
14001 RR1 = DT_RNDM(XXD)
14002 RR2 = DT_RNDM(RR1)
14003 RR3 = DT_RNDM(RR2)
14004 SR123 = RR1+RR2+RR3
14005 XXTV = XDTHR+RR1*XXD/SR123
14006 XXTSQ = XDTHR+RR2*XXD/SR123
14007 XXTSAQ = XDTHR+RR3*XXD/SR123
14008 ELSE
14009 XXTV = XTVD(IDXVT)
14010 XXTSQ = XTSQ(IDXST)
14011 XXTSAQ = XTSAQ(IDXST)
14012 ENDIF
14013* flavor of the second quarks in the sea-diquark pair
14014 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14015 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14016* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14017 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14018 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14019 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14020* ss-asas pair
14021 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14022 IREJ = 1
14023 RETURN
14024 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14025* at least one strange quark
14026 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14027 IREJ = 1
14028 RETURN
14029 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14030 IREJ = 1
14031 RETURN
14032 ENDIF
14033* accept the new sea-diquark
14034 XTVD(IDXVT) = XXTV
14035 XTSQ(IDXST) = XXTSQ
14036 XTSAQ(IDXST) = XXTSAQ
14037 NSD = NSD+1
14038 INTSD1(NSD) = IDXSP
14039 INTSD2(NSD) = IDXST
14040 ISKPCH(3,NSD) = 0
14041 RETURN
14042
14043*---------------------------------------------------------------------
14044* proj. sea partons - targ. sea partons
14045* get x-values and flavors for projectile sea-diquark pair
14046
14047 4 CONTINUE
14048 IDXSP = IDX2
14049 IDXST = IDX1
14050
14051* index of corr. val-diquark-x in projectile nucleon
14052 IDXVP = ITOVP(IFROSP(IDXSP))
14053* available x above diquark thresholds for valence- and sea-diquarks
14054 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14055
14056 IF (XXD.GE.ZERO) THEN
14057* x-values for the three diquarks of the projectile nucleon
14058 RR1 = DT_RNDM(XXD)
14059 RR2 = DT_RNDM(RR1)
14060 RR3 = DT_RNDM(RR2)
14061 SR123 = RR1+RR2+RR3
14062 XXPV = XDTHR+RR1*XXD/SR123
14063 XXPSQ = XDTHR+RR2*XXD/SR123
14064 XXPSAQ = XDTHR+RR3*XXD/SR123
14065 ELSE
14066 XXPV = XPVD(IDXVP)
14067 XXPSQ = XPSQ(IDXSP)
14068 XXPSAQ = XPSAQ(IDXSP)
14069 ENDIF
14070* flavor of the second quarks in the sea-diquark pair
14071 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14072 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14073* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14074 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14075 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14076 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14077* ss-asas pair
14078 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14079 IREJ = 1
14080 RETURN
14081 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14082* at least one strange quark
14083 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14084 IREJ = 1
14085 RETURN
14086 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14087 IREJ = 1
14088 RETURN
14089 ENDIF
14090* accept the new sea-diquark
14091 XPVD(IDXVP) = XXPV
14092 XPSQ(IDXSP) = XXPSQ
14093 XPSAQ(IDXSP) = XXPSAQ
14094 NDS = NDS+1
14095 INTDS1(NDS) = IDXSP
14096 INTDS2(NDS) = IDXST
14097 ISKPCH(2,NDS) = 0
14098 RETURN
14099 END
14100*$ CREATE DT_DIFEVT.FOR
14101*COPY DT_DIFEVT
14102*
14103*===difevt=============================================================*
14104*
14105 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14106 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14107
14108************************************************************************
14109* Interface to treatment of diffractive interactions. *
14110* (input) IFP1/2 PDG-indizes of projectile partons *
14111* (baryon: IFP2 - adiquark) *
14112* PP(4) projectile 4-momentum *
14113* IFT1/2 PDG-indizes of target partons *
14114* (baryon: IFT1 - adiquark) *
14115* PT(4) target 4-momentum *
14116* (output) JDIFF = 0 no diffraction *
14117* = 1/-1 LMSD/LMDD *
14118* = 2/-2 HMSD/HMDD *
14119* NCSY counter for two-chain systems *
14120* dumped to DTEVT1 *
14121* This version dated 14.02.95 is written by S. Roesler *
14122************************************************************************
14123
14124 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14125 SAVE
14126
14127 PARAMETER ( LINP = 10 ,
14128 & LOUT = 6 ,
14129 & LDAT = 9 )
14130
14131 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14132 & OHALF=0.5D0)
14133
14134* event history
14135
14136 PARAMETER (NMXHKK=200000)
14137
14138 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14139 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14140 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14141
14142* extended event history
14143 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14144 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14145 & IHIST(2,NMXHKK)
14146
14147* flags for diffractive interactions (DTUNUC 1.x)
14148 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14149
14150 DIMENSION PP(4),PT(4)
14151
14152 LOGICAL LFIRST
14153 DATA LFIRST /.TRUE./
14154
14155 IREJ = 0
14156 JDIFF = 0
14157 IFLAGD = JDIFF
14158
14159* cm. energy
14160 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14161 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14162* identities of projectile hadron / target nucleon
14163 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14164 KTARG = IDT_ICIHAD(IDHKK(MOT))
14165
14166* single diffractive xsections
14167 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14168* double diffractive xsections
14169**!! no double diff yet
14170C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14171 DDTOT = 0.0D0
14172 DDHM = 0.0D0
14173**!!
14174* total inelastic xsection
14175C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14176 DUMZER = ZERO
14177 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14178 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14179
14180* fraction of diffractive processes
14181 FRADIF = (SDTOT+DDTOT)/SIGIN
14182
14183 IF (LFIRST) THEN
14184 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14185 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14186 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14187 & F5.1,' mb',/)
14188 LFIRST = .FALSE.
14189 ENDIF
14190
14191 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14192 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14193* diffractive interaction requested by x-section or by user
14194 FRASD = SDTOT/(SDTOT+DDTOT)
14195 FRASDH = SDHM/SDTOT
14196**sr needs to be specified!!
14197C FRADDH = DDHM/DDTOT
14198 FRADDH = 1.0D0
14199**
14200 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14201* single diffraction
14202 KDIFF = 1
14203 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14204 KP = 2
14205 KT = 0
14206 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14207 & ISINGD.NE.3) THEN
14208 KP = 0
14209 KT = 2
14210 ENDIF
14211 ELSE
14212 KP = 1
14213 KT = 0
14214 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14215 & ISINGD.NE.3) THEN
14216 KP = 0
14217 KT = 1
14218 ENDIF
14219 ENDIF
14220 ELSE
14221* double diffraction
14222 KDIFF = -1
14223 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14224 KP = 2
14225 KT = 2
14226 ELSE
14227 KP = 1
14228 KT = 1
14229 ENDIF
14230 ENDIF
14231 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14232 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14233 IF (IREJ1.EQ.0) THEN
14234 IFLAGD = 2*KDIFF
14235 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14236 ELSE
14237 GOTO 9999
14238 ENDIF
14239 ENDIF
14240 JDIFF = IFLAGD
14241
14242 RETURN
14243
14244 9999 CONTINUE
14245 IREJ = 1
14246 RETURN
14247 END
14248
14249*$ CREATE DT_DIFFKI.FOR
14250*COPY DT_DIFFKI
14251*
14252*===difkin=============================================================*
14253*
14254 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14255 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14256
14257************************************************************************
14258* Kinematics of diffractive nucleon-nucleon interaction. *
14259* IFP1/2 PDG-indizes of projectile partons *
14260* (baryon: IFP2 - adiquark) *
14261* PP(4) projectile 4-momentum *
14262* IFT1/2 PDG-indizes of target partons *
14263* (baryon: IFT1 - adiquark) *
14264* PT(4) target 4-momentum *
14265* KP = 0 projectile quasi-elastically scattered *
14266* = 1 excited to low-mass diff. state *
14267* = 2 excited to high-mass diff. state *
14268* KT = 0 target quasi-elastically scattered *
14269* = 1 excited to low-mass diff. state *
14270* = 2 excited to high-mass diff. state *
14271* This version dated 12.02.95 is written by S. Roesler *
14272************************************************************************
14273
14274 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14275 SAVE
14276
14277 PARAMETER ( LINP = 10 ,
14278 & LOUT = 6 ,
14279 & LDAT = 9 )
14280
14281 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14282
14283 LOGICAL LSTART
14284
14285* particle properties (BAMJET index convention)
14286 CHARACTER*8 ANAME
14287 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14288 & IICH(210),IIBAR(210),K1(210),K2(210)
14289
14290* flags for input different options
14291 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14292 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14293 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14294
14295* rejection counter
14296 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14297 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14298 & IREXCI(3),IRDIFF(2),IRINC
14299
14300* kinematics of diffractive interactions (DTUNUC 1.x)
14301 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14302 & PPF(4),PTF(4),
14303 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14304 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14305
14306 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14307 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14308
14309 DATA LSTART /.TRUE./
14310
14311 IF (LSTART) THEN
14312 WRITE(LOUT,2000)
14313 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14314 LSTART = .FALSE.
14315 ENDIF
14316
14317 IREJ = 0
14318
14319* initialize common /DTDIKI/
14320 CALL DT_DIFINI
14321* store momenta of initial incoming particles for emc-check
14322 IF (LEMCCK) THEN
14323 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14324 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14325 ENDIF
14326
14327* masses of initial particles
14328 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14329 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14330 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14331 XMP = SQRT(XMP2)
14332 XMT = SQRT(XMT2)
14333* check quark-input (used to adjust coherence cond. for M-selection)
14334 IBP = 0
14335 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14336 IBT = 0
14337 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14338
14339* parameter for Lorentz-transformation into nucleon-nucleon cms
14340 DO 3 K=1,4
14341 PITOT(K) = PP(K)+PT(K)
14342 3 CONTINUE
14343 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14344 IF (XMTOT2.LE.ZERO) THEN
14345 WRITE(LOUT,1000) XMTOT2
14346 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14347 & 'XMTOT2 = ',E12.3)
14348 GOTO 9999
14349 ENDIF
14350 XMTOT = SQRT(XMTOT2)
14351 DO 4 K=1,4
14352 BGTOT(K) = PITOT(K)/XMTOT
14353 4 CONTINUE
14354* transformation of nucleons into cms
14355 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14356 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14357 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14358 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14359* rotation angles
14360 COD = PP1(3)/PPTOT
14361C SID = SQRT((ONE-COD)*(ONE+COD))
14362 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14363 SID = PPT/PPTOT
14364 COF = ONE
14365 SIF = ZERO
14366 IF(PPTOT*SID.GT.TINY10) THEN
14367 COF = PP1(1)/(SID*PPTOT)
14368 SIF = PP1(2)/(SID*PPTOT)
14369 ANORF = SQRT(COF*COF+SIF*SIF)
14370 COF = COF/ANORF
14371 SIF = SIF/ANORF
14372 ENDIF
14373* check consistency
14374 DO 5 K=1,4
14375 DEV1(K) = ABS(PP1(K)+PT1(K))
14376 5 CONTINUE
14377 DEV1(4) = ABS(DEV1(4)-XMTOT)
14378 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14379 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14380 WRITE(LOUT,1001) DEV1
14381 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14382 & /,8X,4E12.3)
14383 GOTO 9999
14384 ENDIF
14385
14386* select x-fractions in high-mass diff. interactions
14387 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14388
14389* select diffractive masses
14390* - projectile
14391 IF (KP.EQ.1) THEN
14392 XMPF = DT_XMLMD(XMTOT)
14393 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14394 IF (IREJ1.GT.0) GOTO 9999
14395 ELSEIF (KP.EQ.2) THEN
14396 XMPF = DT_XMHMD(XMTOT,IBP,1)
14397 ELSE
14398 XMPF = XMP
14399 ENDIF
14400* - target
14401 IF (KT.EQ.1) THEN
14402 XMTF = DT_XMLMD(XMTOT)
14403 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14404 IF (IREJ1.GT.0) GOTO 9999
14405 ELSEIF (KT.EQ.2) THEN
14406 XMTF = DT_XMHMD(XMTOT,IBT,2)
14407 ELSE
14408 XMTF = XMT
14409 ENDIF
14410
14411* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14412 XMPF2 = XMPF**2
14413 XMTF2 = XMTF**2
14414 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14415 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14416
14417* select momentum transfer (all t-values used here are <0)
14418* minimum absolute value to produce diffractive masses
14419 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14420 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14421 IF (IREJ1.GT.0) GOTO 9999
14422
14423* longitudinal momentum of excited/elastically scattered projectile
14424 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14425* total transverse momentum due to t-selection
14426 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14427 IF (PPBLT2.LT.ZERO) THEN
14428 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14429 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14430 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14431 GOTO 9999
14432 ENDIF
14433 CALL DT_DSFECF(SINPHI,COSPHI)
14434 PPBLT = SQRT(PPBLT2)
14435 PPBLOB(1) = COSPHI*PPBLT
14436 PPBLOB(2) = SINPHI*PPBLT
14437
14438* rotate excited/elastically scattered projectile into n-n cms.
14439 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14440 & XX,YY,ZZ)
14441 PPBLOB(1) = XX
14442 PPBLOB(2) = YY
14443 PPBLOB(3) = ZZ
14444
14445* 4-momentum of excited/elastically scattered target and of exchanged
14446* Pomeron
14447 DO 6 K=1,4
14448 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14449 PPOM1(K) = PP1(K)-PPBLOB(K)
14450 6 CONTINUE
14451 PTBLOB(4) = XMTOT-PPBLOB(4)
14452
14453* Lorentz-transformation back into system of initial diff. collision
14454 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14455 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14456 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14457 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14458 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14459 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14460 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14461 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14462 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14463
14464* store 4-momentum of elastically scattered particle (in single diff.
14465* events)
14466 IF (KP.EQ.0) THEN
14467 DO 7 K=1,4
14468 PSC(K) = PPF(K)
14469 7 CONTINUE
14470 ELSEIF (KT.EQ.0) THEN
14471 DO 8 K=1,4
14472 PSC(K) = PTF(K)
14473 8 CONTINUE
14474 ENDIF
14475
14476* check consistency of kinematical treatment so far
14477 IF (LEMCCK) THEN
14478 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14479 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14480 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14481 IF (IREJ1.NE.0) GOTO 9999
14482 ENDIF
14483 DO 9 K=1,4
14484 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14485 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14486 9 CONTINUE
14487 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14488 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14489 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14490 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14491 WRITE(LOUT,1003) DEV1,DEV2
14492 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14493 & 2(/,8X,4E12.3))
14494 GOTO 9999
14495 ENDIF
14496
14497* kinematical treatment for low-mass diffraction
14498 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14499 IF (IREJ1.NE.0) GOTO 9999
14500
14501* dump diffractive chains into DTEVT1
14502 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14503 IF (IREJ1.NE.0) GOTO 9999
14504
14505 RETURN
14506
14507 9999 CONTINUE
14508 IRDIFF(1) = IRDIFF(1)+1
14509 IREJ = 1
14510 RETURN
14511 END
14512
14513*$ CREATE DT_XMHMD.FOR
14514*COPY DT_XMHMD
14515*
14516*===xmhmd==============================================================*
14517*
14518 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14519
14520************************************************************************
14521* Diffractive mass in high mass single/double diffractive events. *
14522* This version dated 11.02.95 is written by S. Roesler *
14523************************************************************************
14524
14525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14526 SAVE
14527
14528 PARAMETER ( LINP = 10 ,
14529 & LOUT = 6 ,
14530 & LDAT = 9 )
14531
14532 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14533
14534* kinematics of diffractive interactions (DTUNUC 1.x)
14535 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14536 & PPF(4),PTF(4),
14537 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14538 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14539
14540C DATA XCOLOW /0.05D0/
14541 DATA XCOLOW /0.15D0/
14542
14543 DT_XMHMD = ZERO
14544 XH = XPH(2)
14545 IF (MODE.EQ.2) XH = XTH(2)
14546
14547* minimum Pomeron-x for high-mass diffraction
14548* (adjusted to get a smooth transition between HM and LM component)
14549 R = DT_RNDM(XH)
14550 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14551 IF (ECM.LE.300.0D0) THEN
14552 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14553 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14554 ENDIF
14555* maximum Pomeron-x for high-mass diffraction
14556* (coherence condition, adjusted to fit to experimental data)
14557 IF (IB.NE.0) THEN
14558* baryon-diffraction
14559 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14560 ELSE
14561* meson-diffraction
14562 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14563 ENDIF
14564* check boundaries
14565 IF (XDIMIN.GE.XDIMAX) THEN
14566 XDIMIN = OHALF*XDIMAX
14567 ENDIF
14568
14569 KLOOP = 0
14570 1 CONTINUE
14571 KLOOP = KLOOP+1
14572 IF (KLOOP.GT.20) RETURN
14573* sample Pomeron-x from 1/x-distribution (critical Pomeron)
14574 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14575* corr. diffr. mass
14576 DT_XMHMD = ECM*SQRT(XDIFF)
14577 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14578
14579 RETURN
14580 END
14581
14582*$ CREATE DT_XMLMD.FOR
14583*COPY DT_XMLMD
14584*
14585*===xmlmd==============================================================*
14586*
14587 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14588
14589************************************************************************
14590* Diffractive mass in high mass single/double diffractive events. *
14591* This version dated 11.02.95 is written by S. Roesler *
14592************************************************************************
14593
14594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14595 SAVE
14596
14597 PARAMETER ( LINP = 10 ,
14598 & LOUT = 6 ,
14599 & LDAT = 9 )
14600
14601* minimum Pomeron-x for low-mass diffraction
14602C AMO = 1.5D0
14603 AMO = 2.0D0
14604* maximum Pomeron-x for low-mass diffraction
14605* (adjusted to get a smooth transition between HM and LM component)
14606 R = DT_RNDM(AMO)
14607 SAM = 1.0D0
14608 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14609 R = DT_RNDM(AMO)*SAM
14610 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14611 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14612
14613* selection of diffractive mass
14614* (adjusted to get a smooth transition between HM and LM component)
14615 R = DT_RNDM(AMU)
14616 IF (ECM.LE.50.0D0) THEN
14617 DT_XMLMD = AMO*(AMU/AMO)**R
14618 ELSE
14619 A = 0.7D0
14620 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14621 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14622 ENDIF
14623
14624 RETURN
14625 END
14626
14627*$ CREATE DT_TDIFF.FOR
14628*COPY DT_TDIFF
14629*
14630*===tdiff==============================================================*
14631*
14632 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14633
14634************************************************************************
14635* t-selection for single/double diffractive interactions. *
14636* ECM cm. energy *
14637* TMIN minimum momentum transfer to produce diff. masses *
14638* XM1/XM2 diffractively produced masses *
14639* (for single diffraction XM2 is obsolete) *
14640* K1/K2= 0 not excited *
14641* = 1 low-mass excitation *
14642* = 2 high-mass excitation *
14643* This version dated 11.02.95 is written by S. Roesler *
14644************************************************************************
14645
14646 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14647 SAVE
14648
14649 PARAMETER ( LINP = 10 ,
14650 & LOUT = 6 ,
14651 & LDAT = 9 )
14652
14653 PARAMETER (ZERO=0.0D0)
14654
14655 PARAMETER ( BTP0 = 3.7D0,
14656 & ALPHAP = 0.24D0 )
14657
14658 IREJ = 0
14659 NCLOOP = 0
14660 DT_TDIFF = ZERO
14661
14662 IF (K1.GT.0) THEN
14663 XM1 = XM1I
14664 XM2 = XM2I
14665 ELSE
14666 XM1 = XM2I
14667 ENDIF
14668 XDI = (XM1/ECM)**2
14669 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14670* slope for single diffraction
14671 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14672 ELSE
14673* slope for double diffraction
14674 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14675 ENDIF
14676
14677 1 CONTINUE
14678 NCLOOP = NCLOOP+1
14679 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14680 Y = DT_RNDM(XDI)
14681 T = -LOG(1.0D0-Y)/SLOPE
14682 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14683 DT_TDIFF = -ABS(T)
14684
14685 RETURN
14686
14687 9999 CONTINUE
14688 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14689 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14690 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14691 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14692 IREJ = 1
14693 RETURN
14694 END
14695
14696*$ CREATE DT_XVALHM.FOR
14697*COPY DT_XVALHM
14698*
14699*===xvalhm=============================================================*
14700*
14701 SUBROUTINE DT_XVALHM(KP,KT)
14702
14703************************************************************************
14704* Sampling of parton x-values in high-mass diffractive interactions. *
14705* This version dated 12.02.95 is written by S. Roesler *
14706************************************************************************
14707
14708 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14709 SAVE
14710
14711 PARAMETER ( LINP = 10 ,
14712 & LOUT = 6 ,
14713 & LDAT = 9 )
14714
14715 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14716
14717* kinematics of diffractive interactions (DTUNUC 1.x)
14718 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14719 & PPF(4),PTF(4),
14720 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14721 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14722
14723* various options for treatment of partons (DTUNUC 1.x)
14724* (chain recombination, Cronin,..)
14725 LOGICAL LCO2CR,LINTPT
14726 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14727 & LCO2CR,LINTPT
14728
14729 DATA UNON,XVQTHR /2.0D0,0.8D0/
14730
14731 IF (KP.EQ.2) THEN
14732* x-fractions of projectile valence partons
14733 1 CONTINUE
14734 XPH(1) = DT_DBETAR(OHALF,UNON)
14735 IF (XPH(1).GE.XVQTHR) GOTO 1
14736 XPH(2) = ONE-XPH(1)
14737* x-fractions of Pomeron q-aq-pair
14738 XPOLO = TINY2
14739 XPOHI = ONE-TINY2
14740 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14741 XPPO(2) = ONE-XPPO(1)
14742* flavors of Pomeron q-aq-pair
14743 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14744 IFPPO(1) = IFLAV
14745 IFPPO(2) = -IFLAV
14746 IF (DT_RNDM(UNON).GT.OHALF) THEN
14747 IFPPO(1) = -IFLAV
14748 IFPPO(2) = IFLAV
14749 ENDIF
14750 ENDIF
14751
14752 IF (KT.EQ.2) THEN
14753* x-fractions of projectile target partons
14754 2 CONTINUE
14755 XTH(1) = DT_DBETAR(OHALF,UNON)
14756 IF (XTH(1).GE.XVQTHR) GOTO 2
14757 XTH(2) = ONE-XTH(1)
14758* x-fractions of Pomeron q-aq-pair
14759 XPOLO = TINY2
14760 XPOHI = ONE-TINY2
14761 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14762 XTPO(2) = ONE-XTPO(1)
14763* flavors of Pomeron q-aq-pair
14764 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14765 IFTPO(1) = IFLAV
14766 IFTPO(2) = -IFLAV
14767 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14768 IFTPO(1) = -IFLAV
14769 IFTPO(2) = IFLAV
14770 ENDIF
14771 ENDIF
14772
14773 RETURN
14774 END
14775
14776*$ CREATE DT_LM2RES.FOR
14777*COPY DT_LM2RES
14778*
14779*===lm2res=============================================================*
14780*
14781 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14782
14783************************************************************************
14784* Check low-mass diffractive excitation for resonance mass. *
14785* (input) IF1/2 PDG-indizes of valence partons *
14786* (in/out) XM diffractive mass requested/corrected *
14787* (output) IDR/IDXR id./BAMJET-index of resonance *
14788* This version dated 12.02.95 is written by S. Roesler *
14789************************************************************************
14790
14791 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14792 SAVE
14793
14794 PARAMETER ( LINP = 10 ,
14795 & LOUT = 6 ,
14796 & LDAT = 9 )
14797
14798 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14799
14800* kinematics of diffractive interactions (DTUNUC 1.x)
14801 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14802 & PPF(4),PTF(4),
14803 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14804 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14805
14806 IREJ = 0
14807 IF1B = 0
14808 IF2B = 0
14809 XMI = XM
14810
14811* BAMJET indices of partons
14812 IF1A = IDT_IPDG2B(IF1,1,2)
14813 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14814 IF2A = IDT_IPDG2B(IF2,1,2)
14815 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14816
14817* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14818 IDCH = 2
14819 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14820
14821* check for resonance mass
14822 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14823 IF (IREJ1.NE.0) GOTO 9999
14824
14825 XM = XMN
14826 RETURN
14827
14828 9999 CONTINUE
14829 IREJ = 1
14830 RETURN
14831 END
14832
14833*$ CREATE DT_LMKINE.FOR
14834*COPY DT_LMKINE
14835*
14836*===lmkine=============================================================*
14837*
14838 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14839
14840************************************************************************
14841* Kinematical treatment of low-mass excitations. *
14842* This version dated 12.02.95 is written by S. Roesler *
14843************************************************************************
14844
14845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14846 SAVE
14847
14848 PARAMETER ( LINP = 10 ,
14849 & LOUT = 6 ,
14850 & LDAT = 9 )
14851
14852 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14853
14854* flags for input different options
14855 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14856 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14857 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14858
14859* kinematics of diffractive interactions (DTUNUC 1.x)
14860 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14861 & PPF(4),PTF(4),
14862 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14863 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14864
14865 DIMENSION P1(4),P2(4)
14866
14867 IREJ = 0
14868
14869 IF (KP.EQ.1) THEN
14870 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14871 POE = PPF(4)/PABS
14872 FAC1 = OHALF*(POE+ONE)
14873 FAC2 = -OHALF*(POE-ONE)
14874 DO 1 K=1,3
14875 PPLM1(K) = FAC1*PPF(K)
14876 PPLM2(K) = FAC2*PPF(K)
14877 1 CONTINUE
14878 PPLM1(4) = FAC1*PABS
14879 PPLM2(4) = -FAC2*PABS
14880 IF (IMSHL.EQ.1) THEN
14881
14882 XM1 = PYMASS(IFP1)
14883 XM2 = PYMASS(IFP2)
14884
14885 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14886 IF (IREJ1.NE.0) GOTO 9999
14887 DO 2 K=1,4
14888 PPLM1(K) = P1(K)
14889 PPLM2(K) = P2(K)
14890 2 CONTINUE
14891 ENDIF
14892 ENDIF
14893
14894 IF (KT.EQ.1) THEN
14895 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14896 POE = PTF(4)/PABS
14897 FAC1 = OHALF*(POE+ONE)
14898 FAC2 = -OHALF*(POE-ONE)
14899 DO 3 K=1,3
14900 PTLM2(K) = FAC1*PTF(K)
14901 PTLM1(K) = FAC2*PTF(K)
14902 3 CONTINUE
14903 PTLM2(4) = FAC1*PABS
14904 PTLM1(4) = -FAC2*PABS
14905 IF (IMSHL.EQ.1) THEN
14906
14907 XM1 = PYMASS(IFT1)
14908 XM2 = PYMASS(IFT2)
14909
14910 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14911 IF (IREJ1.NE.0) GOTO 9999
14912 DO 4 K=1,4
14913 PTLM1(K) = P1(K)
14914 PTLM2(K) = P2(K)
14915 4 CONTINUE
14916 ENDIF
14917 ENDIF
14918
14919 RETURN
14920
14921 9999 CONTINUE
14922 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14923 IREJ = 1
14924 RETURN
14925 END
14926
14927*$ CREATE DT_DIFINI.FOR
14928*COPY DT_DIFINI
14929*
14930*===difini=============================================================*
14931*
14932 SUBROUTINE DT_DIFINI
14933
14934************************************************************************
14935* Initialization of common /DTDIKI/ *
14936* This version dated 12.02.95 is written by S. Roesler *
14937************************************************************************
14938
14939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14940 SAVE
14941
14942 PARAMETER ( LINP = 10 ,
14943 & LOUT = 6 ,
14944 & LDAT = 9 )
14945
14946 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14947
14948* kinematics of diffractive interactions (DTUNUC 1.x)
14949 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14950 & PPF(4),PTF(4),
14951 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14952 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14953
14954 DO 1 K=1,4
14955 PPOM(K) = ZERO
14956 PSC(K) = ZERO
14957 PPF(K) = ZERO
14958 PTF(K) = ZERO
14959 PPLM1(K) = ZERO
14960 PPLM2(K) = ZERO
14961 PTLM1(K) = ZERO
14962 PTLM2(K) = ZERO
14963 1 CONTINUE
14964 DO 2 K=1,2
14965 XPH(K) = ZERO
14966 XPPO(K) = ZERO
14967 XTH(K) = ZERO
14968 XTPO(K) = ZERO
14969 IFPPO(K) = 0
14970 IFTPO(K) = 0
14971 2 CONTINUE
14972 IDPR = 0
14973 IDXPR = 0
14974 IDTR = 0
14975 IDXTR = 0
14976
14977 RETURN
14978 END
14979
14980*$ CREATE DT_DIFPUT.FOR
14981*COPY DT_DIFPUT
14982*
14983*===difput=============================================================*
14984*
14985 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14986 & IREJ)
14987
14988************************************************************************
14989* Dump diffractive chains into DTEVT1 *
14990* This version dated 12.02.95 is written by S. Roesler *
14991************************************************************************
14992
14993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14994 SAVE
14995
14996 PARAMETER ( LINP = 10 ,
14997 & LOUT = 6 ,
14998 & LDAT = 9 )
14999
15000 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15001
15002 LOGICAL LCHK
15003
15004* kinematics of diffractive interactions (DTUNUC 1.x)
15005 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15006 & PPF(4),PTF(4),
15007 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15008 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15009
15010* event history
15011
15012 PARAMETER (NMXHKK=200000)
15013
15014 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15015 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15016 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15017
15018* extended event history
15019 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15020 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15021 & IHIST(2,NMXHKK)
15022
15023* rejection counter
15024 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15025 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15026 & IREXCI(3),IRDIFF(2),IRINC
15027
15028 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15029 & P1(4),P2(4),P3(4),P4(4)
15030
15031 IREJ = 0
15032
15033 IF (KP.EQ.1) THEN
15034 DO 1 K=1,4
15035 PCH(K) = PPLM1(K)+PPLM2(K)
15036 1 CONTINUE
15037 ID1 = IFP1
15038 ID2 = IFP2
15039 IF (DT_RNDM(PT).GT.OHALF) THEN
15040 ID1 = IFP2
15041 ID2 = IFP1
15042 ENDIF
15043 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15044 & PPLM1(4),0,0,0)
15045 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15046 & PPLM2(4),0,0,0)
15047 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15048 & IDPR,IDXPR,8)
15049 ELSEIF (KP.EQ.2) THEN
15050 DO 2 K=1,4
15051 PP1(K) = XPH(1)*PP(K)
15052 PP2(K) = XPH(2)*PP(K)
15053 PT1(K) = -XPPO(1)*PPOM(K)
15054 PT2(K) = -XPPO(2)*PPOM(K)
15055 2 CONTINUE
15056 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15057 XM1 = ZERO
15058 XM2 = ZERO
15059 IF (LCHK) THEN
15060 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15061 IF (IREJ1.NE.0) GOTO 9999
15062 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15063 IF (IREJ1.NE.0) GOTO 9999
15064 DO 3 K=1,4
15065 PP1(K) = P1(K)
15066 PT1(K) = P2(K)
15067 PP2(K) = P3(K)
15068 PT2(K) = P4(K)
15069 3 CONTINUE
15070 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15071 & 0,0,8)
15072 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15073 & PT1(4),0,0,8)
15074 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15075 & 0,0,8)
15076 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15077 & PT2(4),0,0,8)
15078 ELSE
15079 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15080 IF (IREJ1.NE.0) GOTO 9999
15081 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15082 IF (IREJ1.NE.0) GOTO 9999
15083 DO 4 K=1,4
15084 PP1(K) = P1(K)
15085 PT2(K) = P2(K)
15086 PP2(K) = P3(K)
15087 PT1(K) = P4(K)
15088 4 CONTINUE
15089 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15090 & 0,0,8)
15091 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15092 & PT2(4),0,0,8)
15093 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15094 & 0,0,8)
15095 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15096 & PT1(4),0,0,8)
15097 ENDIF
15098 NCSY = NCSY+1
15099 ELSE
15100 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15101 & 0,0,0)
15102 ENDIF
15103
15104 IF (KT.EQ.1) THEN
15105 DO 5 K=1,4
15106 PCH(K) = PTLM1(K)+PTLM2(K)
15107 5 CONTINUE
15108 ID1 = IFT1
15109 ID2 = IFT2
15110 IF (DT_RNDM(PT).GT.OHALF) THEN
15111 ID1 = IFT2
15112 ID2 = IFT1
15113 ENDIF
15114 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15115 & PTLM1(4),0,0,0)
15116 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15117 & PTLM2(4),0,0,0)
15118 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15119 & IDTR,IDXTR,8)
15120 ELSEIF (KT.EQ.2) THEN
15121 DO 6 K=1,4
15122 PP1(K) = XTPO(1)*PPOM(K)
15123 PP2(K) = XTPO(2)*PPOM(K)
15124 PT1(K) = XTH(2)*PT(K)
15125 PT2(K) = XTH(1)*PT(K)
15126 6 CONTINUE
15127 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15128 XM1 = ZERO
15129 XM2 = ZERO
15130 IF (LCHK) THEN
15131 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15132 IF (IREJ1.NE.0) GOTO 9999
15133 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15134 IF (IREJ1.NE.0) GOTO 9999
15135 DO 7 K=1,4
15136 PP1(K) = P1(K)
15137 PT1(K) = P2(K)
15138 PP2(K) = P3(K)
15139 PT2(K) = P4(K)
15140 7 CONTINUE
15141 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15142 & PP1(4),0,0,8)
15143 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15144 & 0,0,8)
15145 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15146 & PP2(4),0,0,8)
15147 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15148 & 0,0,8)
15149 ELSE
15150 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15151 IF (IREJ1.NE.0) GOTO 9999
15152 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15153 IF (IREJ1.NE.0) GOTO 9999
15154 DO 8 K=1,4
15155 PP1(K) = P1(K)
15156 PT2(K) = P2(K)
15157 PP2(K) = P3(K)
15158 PT1(K) = P4(K)
15159 8 CONTINUE
15160 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15161 & PP1(4),0,0,8)
15162 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15163 & 0,0,8)
15164 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15165 & PP2(4),0,0,8)
15166 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15167 & 0,0,8)
15168 ENDIF
15169 NCSY = NCSY+1
15170 ELSE
15171 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15172 & 0,0,0)
15173 ENDIF
15174
15175 RETURN
15176
15177 9999 CONTINUE
15178 IRDIFF(2) = IRDIFF(2)+1
15179 IREJ = 1
15180 RETURN
15181 END
15182*$ CREATE DT_EVTFRG.FOR
15183*COPY DT_EVTFRG
15184*
15185*===evtfrg=============================================================*
15186*
15187 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15188
15189************************************************************************
15190* Hadronization of chains in DTEVT1. *
15191* *
15192* Input: *
15193* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15194* = 2 hadronization of DTUNUC-chains (id=88xxx) *
15195* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15196* hadronized with one PYEXEC call *
15197* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15198* with one PYEXEC call *
15199* Output: *
15200* NPYMEM number of entries in JETSET-common after hadronization *
15201* IREJ rejection flag *
15202* *
15203* This version dated 17.09.00 is written by S. Roesler *
15204************************************************************************
15205
15206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15207 SAVE
15208
15209 PARAMETER ( LINP = 10 ,
15210 & LOUT = 6 ,
15211 & LDAT = 9 )
15212
15213 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15214 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15215
15216 LOGICAL LACCEP
15217
15218 PARAMETER (MXJOIN=200)
15219
15220* event history
15221
15222 PARAMETER (NMXHKK=200000)
15223
15224 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15225 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15226 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15227
15228* extended event history
15229 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15230 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15231 & IHIST(2,NMXHKK)
15232
15233* flags for input different options
15234 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15235 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15236 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15237
15238* statistics
15239 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15240 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15241 & ICEVTG(8,0:30)
15242
15243* flags for diffractive interactions (DTUNUC 1.x)
15244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15245
15246* nucleon-nucleon event-generator
15247 CHARACTER*8 CMODEL
15248 LOGICAL LPHOIN
15249 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15250* phojet
15251
15252C model switches and parameters
15253 CHARACTER*8 MDLNA
15254 INTEGER ISWMDL,IPAMDL
15255 DOUBLE PRECISION PARMDL
15256 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15257* jetset
15258
15259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15260 PARAMETER (MAXLND=4000)
15261 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15262
15263 INTEGER PYK
15264
15265 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15266
15267 MODE = KMODE
15268 ISTSTG = 7
15269 IF (MODE.NE.1) ISTSTG = 8
15270 IREJ = 0
15271
15272 IP = 0
15273 ISH = 0
15274 INIEMC = 1
15275 NEND = NHKK
15276 NACCEP = 0
15277 IFRG = 0
15278 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15279 DO 10 I=NPOINT(3),NEND
15280* sr 14.02.00: seems to be not necessary anymore, commented
15281C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15282C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15283 LACCEP = .TRUE.
15284* pick up chains from dtevt1
15285 IDCHK = IDHKK(I)/10000
15286 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15287 IF (IDCHK.EQ.7) THEN
15288 IPJE = IDHKK(I)-IDCHK*10000
15289 IF (IPJE.NE.IFRG) THEN
15290 IFRG = IPJE
15291 IF (IFRG.GT.NFRG) GOTO 16
15292 ENDIF
15293 ELSE
15294 IPJE = 1
15295 IFRG = IFRG+1
15296 IF (IFRG.GT.NFRG) THEN
15297 NFRG = -1
15298 GOTO 16
15299 ENDIF
15300 ENDIF
15301* statistics counter
15302c IF (IDCH(I).LE.8)
15303c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15304c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15305* special treatment for small chains already corrected to hadrons
15306 IF (IDRES(I).NE.0) THEN
15307 IF (IDRES(I).EQ.11) THEN
15308 ID = IDXRES(I)
15309 ELSE
15310 ID = IDT_IPDGHA(IDXRES(I))
15311 ENDIF
15312 IF (LEMCCK) THEN
15313 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15314 & PHKK(4,I),INIEMC,IDUM,IDUM)
15315 INIEMC = 2
15316 ENDIF
15317 IP = IP+1
15318 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15319 P(IP,1) = PHKK(1,I)
15320 P(IP,2) = PHKK(2,I)
15321 P(IP,3) = PHKK(3,I)
15322 P(IP,4) = PHKK(4,I)
15323 P(IP,5) = PHKK(5,I)
15324 K(IP,1) = 1
15325 K(IP,2) = ID
15326 K(IP,3) = 0
15327 K(IP,4) = 0
15328 K(IP,5) = 0
15329 IHIST(2,I) = 10000*IPJE+IP
15330 IF (IHIST(1,I).LE.-100) THEN
15331 ISH = ISH+1
15332 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15333 ISJOIN(ISH) = I
15334 ENDIF
15335 N = IP
15336 IHISMO(IP) = I
15337 ELSE
15338 IJ = 0
15339 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15340 IF (LEMCCK) THEN
15341 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15342 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15343 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15344 INIEMC = 2
15345 ENDIF
15346 ID = IDHKK(KK)
15347 IF (ID.EQ.0) ID = 21
15348c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15349c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15350
15351c AMRQ = PYMASS(ID)
15352
15353c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15354c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15355c & (ABS(IDIFF).EQ.0)) THEN
15356cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15357c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15358c PHKK(4,KK) = PHKK(4,KK)+DELTA
15359c PTOT1 = PTOT-DELTA
15360c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15361c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15362c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15363c PHKK(5,KK) = AMRQ
15364c ENDIF
15365 IP = IP+1
15366 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15367 P(IP,1) = PHKK(1,KK)
15368 P(IP,2) = PHKK(2,KK)
15369 P(IP,3) = PHKK(3,KK)
15370 P(IP,4) = PHKK(4,KK)
15371 P(IP,5) = PHKK(5,KK)
15372 K(IP,1) = 1
15373 K(IP,2) = ID
15374 K(IP,3) = 0
15375 K(IP,4) = 0
15376 K(IP,5) = 0
15377 IHIST(2,KK) = 10000*IPJE+IP
15378 IF (IHIST(1,KK).LE.-100) THEN
15379 ISH = ISH+1
15380 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15381 ISJOIN(ISH) = KK
15382 ENDIF
15383 IJ = IJ+1
15384 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15385 IJOIN(IJ) = IP
15386 IHISMO(IP) = I
15387 11 CONTINUE
15388 N = IP
15389* join the two-parton system
15390
15391 CALL PYJOIN(IJ,IJOIN)
15392
15393 ENDIF
15394 IDHKK(I) = 99999
15395 ENDIF
15396 10 CONTINUE
15397 16 CONTINUE
15398 N = IP
15399
15400 IF (IP.GT.0) THEN
15401
15402* final state parton shower
15403 DO 136 NPJE=1,IPJE
15404 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15405 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15406 DO 130 K1=1,ISH
15407 IF (ISJOIN(K1).EQ.0) GOTO 130
15408 I = ISJOIN(K1)
15409 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15410 & GOTO 130
15411 IH1 = IHIST(2,I)/10000
15412 IF (IH1.NE.NPJE) GOTO 130
15413 IH1 = IHIST(2,I)-IH1*10000
15414 DO 135 K2=K1+1,ISH
15415 IF (ISJOIN(K2).EQ.0) GOTO 135
15416 II = ISJOIN(K2)
15417 IH2 = IHIST(2,II)/10000
15418 IF (IH2.NE.NPJE) GOTO 135
15419 IH2 = IHIST(2,II)-IH2*10000
15420 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15421 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15422 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15423
15424 RQLUN = MIN(PT1,PT2)
15425 CALL PYSHOW(IH1,IH2,RQLUN)
15426
15427 ISJOIN(K1) = 0
15428 ISJOIN(K2) = 0
15429 GOTO 130
15430 ENDIF
15431 135 CONTINUE
15432 130 CONTINUE
15433 ENDIF
15434 ENDIF
15435 136 CONTINUE
15436
15437 CALL DT_INITJS(MODE)
15438* hadronization
15439
15440 CALL PYEXEC
15441
15442 IF (MSTU(24).NE.0) THEN
15443 WRITE(LOUT,*) ' JETSET-reject at event',
15444 & NEVHKK,MSTU(24),KMODE
15445C CALL DT_EVTOUT(4)
15446
15447C CALL PYLIST(2)
15448
15449 GOTO 9999
15450 ENDIF
15451
15452* number of entries in LUJETS
15453
15454 NLINES = PYK(0,1)
15455
15456 NPYMEM = NLINES
15457
15458 DO 12 I=1,NLINES
15459 IFLG(I) = 0
15460 12 CONTINUE
15461
15462 DO 13 II=1,NLINES
15463
15464 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15465
15466* pick up mother resonance if possible and put it together with
15467* their decay-products into the common
15468 IDXMOR = K(II,3)
15469 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15470 KFMOR = K(IDXMOR,2)
15471 ISMOR = K(IDXMOR,1)
15472 ELSE
15473 KFMOR = 91
15474 ISMOR = 1
15475 ENDIF
15476 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15477 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15478 ID = K(IDXMOR,2)
15479 MO = IHISMO(PYK(IDXMOR,15))
15480 PX = PYP(IDXMOR,1)
15481 PY = PYP(IDXMOR,2)
15482 PZ = PYP(IDXMOR,3)
15483 PE = PYP(IDXMOR,4)
15484
15485 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15486 IFLG(IDXMOR) = 1
15487 MO = NHKK
15488 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15489 IF (PYK(JDAUG,7).EQ.1) THEN
15490 ID = PYK(JDAUG,8)
15491 PX = PYP(JDAUG,1)
15492 PY = PYP(JDAUG,2)
15493 PZ = PYP(JDAUG,3)
15494 PE = PYP(JDAUG,4)
15495
15496 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15497 IF (LEMCCK) THEN
15498 PX = -PYP(JDAUG,1)
15499 PY = -PYP(JDAUG,2)
15500 PZ = -PYP(JDAUG,3)
15501 PE = -PYP(JDAUG,4)
15502
15503 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15504 ENDIF
15505 IFLG(JDAUG) = 1
15506 ENDIF
15507 15 CONTINUE
15508 ELSE
15509* there was no mother resonance
15510 MO = IHISMO(PYK(II,15))
15511 ID = PYK(II,8)
15512 PX = PYP(II,1)
15513 PY = PYP(II,2)
15514 PZ = PYP(II,3)
15515 PE = PYP(II,4)
15516
15517 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15518 IF (LEMCCK) THEN
15519 PX = -PYP(II,1)
15520 PY = -PYP(II,2)
15521 PZ = -PYP(II,3)
15522 PE = -PYP(II,4)
15523
15524 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15525 ENDIF
15526 ENDIF
15527 ENDIF
15528 13 CONTINUE
15529 IF (LEMCCK) THEN
15530 CHKLEV = TINY1
15531 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15532C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15533 ENDIF
15534
15535* global energy-momentum & flavor conservation check
15536**sr 16.5. this check is skipped in case of phojet-treatment
15537 IF (MCGENE.EQ.1)
15538 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15539
15540* update statistics-counter for diffraction
15541c IF (IFLAGD.NE.0) THEN
15542c ICDIFF(1) = ICDIFF(1)+1
15543c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15544c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15545c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15546c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15547c ENDIF
15548
15549 ENDIF
15550
15551 RETURN
15552
15553 9999 CONTINUE
15554 IREJ = 1
15555 RETURN
15556 END
15557
15558*$ CREATE DT_DECAYS.FOR
15559*COPY DT_DECAYS
15560*
15561*===decay==============================================================*
15562*
15563 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15564
15565************************************************************************
15566* Resonance-decay. *
15567* This subroutine replaces DDECAY/DECHKK. *
15568* PIN(4) 4-momentum of resonance (input) *
15569* IDXIN BAMJET-index of resonance (input) *
15570* POUT(20,4) 4-momenta of decay-products (output) *
15571* IDXOUT(20) BAMJET-indices of decay-products (output) *
15572* NSEC number of secondaries (output) *
15573* Adopted from the original version DECHKK. *
15574* This version dated 09.01.95 is written by S. Roesler *
15575************************************************************************
15576
15577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15578 SAVE
15579
15580 PARAMETER ( LINP = 10 ,
15581 & LOUT = 6 ,
15582 & LDAT = 9 )
15583
15584 PARAMETER (TINY17=1.0D-17)
15585
15586* HADRIN: decay channel information
15587 PARAMETER (IDMAX9=602)
15588 CHARACTER*8 ZKNAME
15589 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15590
15591* particle properties (BAMJET index convention)
15592 CHARACTER*8 ANAME
15593 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15594 & IICH(210),IIBAR(210),K1(210),K2(210)
15595
15596* flags for input different options
15597 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15598 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15599 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15600
15601 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15602 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15603 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15604
15605* ISTAB = 1 strong and weak decays
15606* = 2 strong decays only
15607* = 3 strong decays, weak decays for charmed particles and tau
15608* leptons only
15609 DATA ISTAB /2/
15610
15611 IREJ = 0
15612 NSEC = 0
15613* put initial resonance to stack
15614 NSTK = 1
15615 IDXSTK(NSTK) = IDXIN
15616 DO 5 I=1,4
15617 PI(NSTK,I) = PIN(I)
15618 5 CONTINUE
15619
15620* store initial configuration for energy-momentum cons. check
15621 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15622 & PI(NSTK,4),1,IDUM,IDUM)
15623
15624 100 CONTINUE
15625* get particle from stack
15626 IDXI = IDXSTK(NSTK)
15627* skip stable particles
15628 IF (ISTAB.EQ.1) THEN
15629 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15630 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15631 ELSEIF (ISTAB.EQ.2) THEN
15632 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15633 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15634 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15635 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15636 IF ( IDXI.EQ.109) GOTO 10
15637 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15638 ELSEIF (ISTAB.EQ.3) THEN
15639 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15640 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15641 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15642 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15643 ENDIF
15644
15645* calculate direction cosines and Lorentz-parameter of decaying part.
15646 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15647 PTOT = MAX(PTOT,TINY17)
15648 DO 1 I=1,3
15649 DCOS(I) = PI(NSTK,I)/PTOT
15650 1 CONTINUE
15651 GAM = PI(NSTK,4)/AAM(IDXI)
15652 BGAM = PTOT/AAM(IDXI)
15653
15654* get decay-channel
15655 KCHAN = K1(IDXI)-1
15656 2 CONTINUE
15657 KCHAN = KCHAN+1
15658 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15659
15660* identities of secondaries
15661 IDX(1) = NZK(KCHAN,1)
15662 IDX(2) = NZK(KCHAN,2)
15663 IF (IDX(2).LT.1) GOTO 9999
15664 IDX(3) = NZK(KCHAN,3)
15665
15666* handle decay in rest system of decaying particle
15667 IF (IDX(3).EQ.0) THEN
15668* two-particle decay
15669 NDEC = 2
15670 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15671 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15672 & AAM(IDX(1)),AAM(IDX(2)))
15673 ELSE
15674* three-particle decay
15675 NDEC = 3
15676 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15677 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15678 & CODF(3),COFF(3),SIFF(3),
15679 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15680 ENDIF
15681 NSTK = NSTK-1
15682
15683* transform decay products back
15684 DO 3 I=1,NDEC
15685 NSTK = NSTK+1
15686 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15687 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15688 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15689* add particle to stack
15690 IDXSTK(NSTK) = IDX(I)
15691 DO 4 J=1,3
15692 PI(NSTK,J) = DCOSF(J)*PFF(I)
15693 4 CONTINUE
15694 3 CONTINUE
15695 GOTO 100
15696
15697 10 CONTINUE
15698* stable particle, put to output-arrays
15699 NSEC = NSEC+1
15700 DO 6 I=1,4
15701 POUT(NSEC,I) = PI(NSTK,I)
15702 6 CONTINUE
15703 IDXOUT(NSEC) = IDXSTK(NSTK)
15704* store secondaries for energy-momentum conservation check
15705 IF (LEMCCK)
15706 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15707 & -POUT(NSEC,4),2,IDUM,IDUM)
15708 NSTK = NSTK-1
15709 IF (NSTK.GT.0) GOTO 100
15710
15711* check energy-momentum conservation
15712 IF (LEMCCK) THEN
15713 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15714 IF (IREJ1.NE.0) GOTO 9999
15715 ENDIF
15716
15717 RETURN
15718
15719 9999 CONTINUE
15720 IREJ = 1
15721 RETURN
15722 END
15723
15724*$ CREATE DT_DECAY1.FOR
15725*COPY DT_DECAY1
15726*
15727*===decay1=============================================================*
15728*
15729 SUBROUTINE DT_DECAY1
15730
15731************************************************************************
15732* Decay of resonances stored in DTEVT1. *
15733* This version dated 20.01.95 is written by S. Roesler *
15734************************************************************************
15735
15736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15737 SAVE
15738
15739 PARAMETER ( LINP = 10 ,
15740 & LOUT = 6 ,
15741 & LDAT = 9 )
15742
15743* event history
15744
15745 PARAMETER (NMXHKK=200000)
15746
15747 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15748 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15749 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15750
15751* extended event history
15752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15754 & IHIST(2,NMXHKK)
15755
15756 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15757
15758 NEND = NHKK
15759C DO 1 I=NPOINT(5),NEND
15760 DO 1 I=NPOINT(4),NEND
15761 IF (ABS(ISTHKK(I)).EQ.1) THEN
15762 DO 2 K=1,4
15763 PIN(K) = PHKK(K,I)
15764 2 CONTINUE
15765 IDXIN = IDBAM(I)
15766 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15767 IF (NSEC.GT.1) THEN
15768 DO 3 N=1,NSEC
15769 IDHAD = IDT_IPDGHA(IDXOUT(N))
15770 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15771 & POUT(N,3),POUT(N,4),0,0,0)
15772 3 CONTINUE
15773 ENDIF
15774 ENDIF
15775 1 CONTINUE
15776
15777 RETURN
15778 END
15779
15780*$ CREATE DT_DECPI0.FOR
15781*COPY DT_DECPI0
15782*
15783*===decpi0=============================================================*
15784*
15785 SUBROUTINE DT_DECPI0
15786
15787************************************************************************
15788* Decay of pi0 handled with JETSET. *
15789* This version dated 18.02.96 is written by S. Roesler *
15790************************************************************************
15791
15792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15793 SAVE
15794
15795 PARAMETER ( LINP = 10 ,
15796 & LOUT = 6 ,
15797 & LDAT = 9 )
15798
15799 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15800
15801* event history
15802
15803 PARAMETER (NMXHKK=200000)
15804
15805 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15806 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15807 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15808
15809* extended event history
15810 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15811 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15812 & IHIST(2,NMXHKK)
15813
004932dd 15814 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 15815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15816 PARAMETER (MAXLND=4000)
15817 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15818
15819* flags for input different options
15820 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15821 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15822 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15823
15824 INTEGER PYCOMP,PYK
15825
15826 DIMENSION IHISMO(NMXHKK),P1(4)
15827
15828 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15829
15830 CALL DT_INITJS(2)
15831* allow pi0 decay
15832
15833 KC = PYCOMP(111)
15834
15835 MDCY(KC,1) = 1
15836
15837 NN = 0
15838 INI = 0
15839 DO 1 I=1,NHKK
15840 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15841 IF (INI.EQ.0) THEN
15842 INI = 1
15843 ELSE
15844 INI = 2
15845 ENDIF
15846 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15847 & PHKK(4,I),INI,IDUM,IDUM)
15848 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15849 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15850 COSTH = PHKK(3,I)/(PTOT+TINY10)
15851 IF (COSTH.GT.ONE) THEN
15852 THETA = ZERO
15853 ELSEIF (COSTH.LT.-ONE) THEN
15854 THETA = TWOPI/2.0D0
15855 ELSE
15856 THETA = ACOS(COSTH)
15857 ENDIF
15858 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15859 IF (PHKK(1,I).LT.0.0D0)
15860
15861 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15862
15863 ENER = PHKK(4,I)
15864 NN = NN+1
15865 KTEMP = MSTU(10)
15866 MSTU(10)= 1
15867 P(NN,5) = PHKK(5,I)
15868
15869 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15870
15871 MSTU(10) = KTEMP
15872 IHISMO(NN)= I
15873 ENDIF
15874 1 CONTINUE
15875 IF (NN.GT.0) THEN
15876
15877 CALL PYEXEC
15878
15879 NLINES = PYK(0,1)
15880
15881 DO 2 II=1,NLINES
15882
15883 IF (PYK(II,7).EQ.1) THEN
15884
15885 DO 3 KK=1,4
15886
15887 P1(KK) = PYP(II,KK)
15888
15889 3 CONTINUE
15890
15891 ID = PYK(II,8)
15892 MO = IHISMO(PYK(II,15))
15893
15894 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15895 IF (LEMCCK)
15896 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15897 & IDUM,IDUM)
15898*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15899 ISTHKK(MO) = -2
15900 ENDIF
15901 2 CONTINUE
15902 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15903 ENDIF
15904 MDCY(KC,1) = 0
15905
15906 RETURN
15907 END
15908
15909*$ CREATE DT_DTWOPD.FOR
15910*COPY DT_DTWOPD
15911*
15912*===dtwopd=============================================================*
15913*
15914 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15915 & COF2,SIF2,AM1,AM2)
15916
15917************************************************************************
15918* Two-particle decay. *
15919* UMO cm-energy of the decaying system (input) *
15920* AM1/AM2 masses of the decay products (input) *
15921* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15922* COD,COF,SIF direction cosines of the decay prod. (output) *
15923* Revised by S. Roesler, 20.11.95 *
15924************************************************************************
15925
15926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15927 SAVE
15928
15929 PARAMETER ( LINP = 10 ,
15930 & LOUT = 6 ,
15931 & LDAT = 9 )
15932
15933 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15934
15935 IF (UMO.LT.(AM1+AM2)) THEN
15936 WRITE(LOUT,1000) UMO,AM1,AM2
15937 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15938 & 3E12.3)
15939 STOP
15940 ENDIF
15941
15942 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15943 ECM2 = UMO-ECM1
15944 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15945 PCM2 = PCM1
15946 CALL DT_DSFECF(SIF1,COF1)
15947 COD1 = TWO*DT_RNDM(PCM2)-ONE
15948 COD2 = -COD1
15949 COF2 = -COF1
15950 SIF2 = -SIF1
15951
15952 RETURN
15953 END
15954
15955*$ CREATE DT_DTHREP.FOR
15956*COPY DT_DTHREP
15957*
15958*===dthrep=============================================================*
15959*
15960 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15961 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15962
15963************************************************************************
15964* Three-particle decay. *
15965* UMO cm-energy of the decaying system (input) *
15966* AM1/2/3 masses of the decay products (input) *
15967* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15968* COD,COF,SIF direction cosines of the decay prod. (output) *
15969* *
15970* Threpd89: slight revision by A. Ferrari *
15971* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15972* Revised by S. Roesler, 20.11.95 *
15973************************************************************************
15974
15975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15976 SAVE
15977
15978 PARAMETER ( LINP = 10 ,
15979 & LOUT = 6 ,
15980 & LDAT = 9 )
15981
15982 PARAMETER ( ANGLSQ = 2.5D-31 )
15983 PARAMETER ( AZRZRZ = 1.0D-30 )
15984 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15985 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15986 PARAMETER ( ONEONE = 1.D+00 )
15987 PARAMETER ( TWOTWO = 2.D+00 )
15988 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15989
15990 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15991
15992* flags for input different options
15993 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15994 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15995 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15996
15997 DIMENSION F(5),XX(5)
15998 DATA EPS /AZRZRZ/
15999
16000 UMOO=UMO+UMO
16001C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16002C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16003C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16004 UUMO=UMO
16005 AAM1=AM1
16006 AAM2=AM2
16007 AAM3=AM3
16008 GU=(AM2+AM3)**2
16009 GO=(UMO-AM1)**2
16010* UFAK=1.0000000000001D0
16011* IF (GU.GT.GO) UFAK=0.9999999999999D0
16012 IF (GU.GT.GO) THEN
16013 UFAK=ONEMNS
16014 ELSE
16015 UFAK=ONEPLS
16016 END IF
16017 OFAK=2.D0-UFAK
16018 GU=GU*UFAK
16019 GO=GO*OFAK
16020 DS2=(GO-GU)/99.D0
16021 AM11=AM1*AM1
16022 AM22=AM2*AM2
16023 AM33=AM3*AM3
16024 UMO2=UMO*UMO
16025 RHO2=0.D0
16026 S22=GU
16027 DO 124 I=1,100
16028 S21=S22
16029 S22=GU+(I-1.D0)*DS2
16030 RHO1=RHO2
16031 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16032 * (S22+EPS)
16033 IF(RHO2.LT.RHO1) GO TO 125
16034 124 CONTINUE
16035 125 S2SUP=(S22-S21)*.5D0+S21
16036 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16037 * (S2SUP+EPS)
16038 SUPRHO=SUPRHO*1.05D0
16039 XO=S21-DS2
16040 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16041 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16042 XX(1)=XO
16043 XX(3)=S22
16044 X1=(XO+S22)*0.5D0
16045 XX(2)=X1
16046 F(3)=RHO2
16047 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16048 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16049 DO 126 I=1,16
16050 X4=(XX(1)+XX(2))*0.5D0
16051 X5=(XX(2)+XX(3))*0.5D0
16052 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16053 * (X4+EPS)
16054 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16055 * (X5+EPS)
16056 XX(4)=X4
16057 XX(5)=X5
16058 DO 128 II=1,5
16059 IA=II
16060 DO 128 III=IA,5
16061 IF (F (II).GE.F (III)) GO TO 128
16062 FH=F(II)
16063 F(II)=F(III)
16064 F(III)=FH
16065 FH=XX(II)
16066 XX(II)=XX(III)
16067 XX(III)=FH
16068128 CONTINUE
16069 SUPRHO=F(1)
16070 S2SUP=XX(1)
16071 DO 129 II=1,3
16072 IA=II
16073 DO 129 III=IA,3
16074 IF (XX(II).GE.XX(III)) GO TO 129
16075 FH=F(II)
16076 F(II)=F(III)
16077 F(III)=FH
16078 FH=XX(II)
16079 XX(II)=XX(III)
16080 XX(III)=FH
16081129 CONTINUE
16082126 CONTINUE
16083 AM23=(AM2+AM3)**2
16084 ITH=0
16085 REDU=2.D0
16086 1 CONTINUE
16087 ITH=ITH+1
16088 IF (ITH.GT.200) REDU=-9.D0
16089 IF (ITH.GT.200) GO TO 400
16090 C=DT_RNDM(REDU)
16091* S2=AM23+C*((UMO-AM1)**2-AM23)
16092 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16093 Y=DT_RNDM(S2)
16094 Y=Y*SUPRHO
16095 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16096 IF(Y.GT.RHO) GO TO 1
16097C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16098 S1=DT_RNDM(S2)
16099 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16100 &RHO*.5D0
16101 S3=UMO2+AM11+AM22+AM33-S1-S2
16102 ECM1=(UMO2+AM11-S2)/UMOO
16103 ECM2=(UMO2+AM22-S3)/UMOO
16104 ECM3=(UMO2+AM33-S1)/UMOO
16105 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16106 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16107 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16108 CALL DT_DSFECF(SFE,CFE)
16109C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16110C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16111 PCM12 = PCM1 * PCM2
16112 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16113 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16114 GO TO 300
16115 200 CONTINUE
16116 UW=DT_RNDM(S1)
16117 COSTH=(UW-0.5D+00)*2.D+00
16118 300 CONTINUE
16119* IF(ABS(COSTH).GT.0.9999999999999999D0)
16120* &COSTH=SIGN(0.9999999999999999D0,COSTH)
16121 IF(ABS(COSTH).GT.ONEONE)
16122 &COSTH=SIGN(ONEONE,COSTH)
16123 IF (REDU.LT.1.D+00) RETURN
16124 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16125* IF(ABS(COSTH2).GT.0.9999999999999999D0)
16126* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16127 IF(ABS(COSTH2).GT.ONEONE)
16128 &COSTH2=SIGN(ONEONE,COSTH2)
16129 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16130 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16131 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16132 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16133C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16134C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16135C***THE DIRECTION OF PARTICLE 3
16136C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16137 CX11=-COSTH1
16138 CY11=SINTH1*CFE
16139 CZ11=SINTH1*SFE
16140 CX22=-COSTH2
16141 CY22=-SINTH2*CFE
16142 CZ22=-SINTH2*SFE
16143 CALL DT_DSFECF(SIF3,COF3)
16144 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16145 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16146 2 FORMAT(5F20.15)
16147 COD1=CX11*COD3+CZ11*SID3
16148 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16149 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16150 &CX11,CZ11
16151 SID1=SQRT(CHLP)
16152 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16153 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16154 COD2=CX22*COD3+CZ22*SID3
16155 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16156 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16157 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16158 400 CONTINUE
16159* === Energy conservation check: === *
16160 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16161* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16162* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16163* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16164 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16165 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16166 & + PCM3 * COF3 * SID3
16167 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16168 & + PCM3 * SIF3 * SID3
16169 EOCMPR = 1.D-12 * UMO
16170 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16171 & .GT. EOCMPR ) THEN
16172**sr 5.5.95 output-unit changed
16173 IF (IOULEV(1).GT.0) THEN
16174 WRITE(LOUT,*)
16175 & ' *** Threpd: energy/momentum conservation failure! ***',
16176 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16177 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16178 ENDIF
16179**
16180 END IF
16181 RETURN
16182 END
16183
16184*$ CREATE DT_DBKLAS.FOR
16185*COPY DT_DBKLAS
16186*
16187*===dbklas=============================================================*
16188*
16189 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16190
16191 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16192 SAVE
16193
16194 PARAMETER ( LINP = 10 ,
16195 & LOUT = 6 ,
16196 & LDAT = 9 )
16197
16198* quark-content to particle index conversion (DTUNUC 1.x)
16199 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16200 & IA08(6,21),IA10(6,21)
16201
16202 IF (I) 20,20,10
16203* baryons
16204 10 CONTINUE
16205 CALL DT_INDEXD(J,K,IND)
16206 I8 = IB08(I,IND)
16207 I10 = IB10(I,IND)
16208 IF (I8.LE.0) I8 = I10
16209 RETURN
16210* antibaryons
16211 20 CONTINUE
16212 II = IABS(I)
16213 JJ = IABS(J)
16214 KK = IABS(K)
16215 CALL DT_INDEXD(JJ,KK,IND)
16216 I8 = IA08(II,IND)
16217 I10 = IA10(II,IND)
16218 IF (I8.LE.0) I8 = I10
16219
16220 RETURN
16221 END
16222
16223*$ CREATE DT_INDEXD.FOR
16224*COPY DT_INDEXD
16225*
16226*===indexd=============================================================*
16227*
16228 SUBROUTINE DT_INDEXD(KA,KB,IND)
16229
16230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16231 SAVE
16232
16233 PARAMETER ( LINP = 10 ,
16234 & LOUT = 6 ,
16235 & LDAT = 9 )
16236
16237 KP = KA*KB
16238 KS = KA+KB
16239 IF (KP.EQ.1) IND=1
16240 IF (KP.EQ.2) IND=2
16241 IF (KP.EQ.3) IND=3
16242 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16243 IF (KP.EQ.5) IND=5
16244 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16245 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16246 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16247 IF (KP.EQ.8) IND=9
16248 IF (KP.EQ.10) IND=10
16249 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16250 IF (KP.EQ.9) IND=12
16251 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16252 IF (KP.EQ.15) IND=14
16253 IF (KP.EQ.18) IND=15
16254 IF (KP.EQ.16) IND=16
16255 IF (KP.EQ.20) IND=17
16256 IF (KP.EQ.24) IND=18
16257 IF (KP.EQ.25) IND=19
16258 IF (KP.EQ.30) IND=20
16259 IF (KP.EQ.36) IND=21
16260
16261 RETURN
16262 END
16263
16264*$ CREATE DT_DCHANT.FOR
16265*COPY DT_DCHANT
16266*
16267*===dchant=============================================================*
16268*
16269 SUBROUTINE DT_DCHANT
16270
16271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16272 SAVE
16273
16274 PARAMETER ( LINP = 10 ,
16275 & LOUT = 6 ,
16276 & LDAT = 9 )
16277
16278 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16279
16280* HADRIN: decay channel information
16281 PARAMETER (IDMAX9=602)
16282 CHARACTER*8 ZKNAME
16283 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16284
16285* particle properties (BAMJET index convention)
16286 CHARACTER*8 ANAME
16287 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16288 & IICH(210),IIBAR(210),K1(210),K2(210)
16289
16290 DIMENSION HWT(IDMAX9)
16291
16292* change of weights wt from absolut values into the sum of wt of a dec.
16293 DO 10 J=1,IDMAX9
16294 HWT(J) = ZERO
16295 10 CONTINUE
16296C DO 999 KKK=1,210
16297C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16298C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16299C & K1(KKK),K2(KKK)
16300C 999 CONTINUE
16301C STOP
16302 DO 30 I=1,210
16303 IK1 = K1(I)
16304 IK2 = K2(I)
16305 HV = ZERO
16306 DO 20 J=IK1,IK2
16307 HV = HV+WT(J)
16308 HWT(J) = HV
16309**sr 13.1.95
16310 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16311 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16312 20 CONTINUE
16313 30 CONTINUE
16314 DO 40 J=1,IDMAX9
16315 WT(J) = HWT(J)
16316 40 CONTINUE
16317
16318 RETURN
16319 END
16320
16321*$ CREATE DT_DDATAR.FOR
16322*COPY DT_DDATAR
16323*
16324*===ddatar=============================================================*
16325*
16326 SUBROUTINE DT_DDATAR
16327
16328 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16329 SAVE
16330
16331 PARAMETER ( LINP = 10 ,
16332 & LOUT = 6 ,
16333 & LDAT = 9 )
16334
16335 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16336
16337* quark-content to particle index conversion (DTUNUC 1.x)
16338 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16339 & IA08(6,21),IA10(6,21)
16340
16341 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16342
16343 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16344 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16345 & 128,129,14*0/
16346 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16347 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16348 & 121,122,14*0/
16349 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16350 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16351 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16352 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16353 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16354 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16355 & 0, 0, 0,140,137,138,146, 0, 0,142,
16356 & 139,147, 0, 0,145,148, 50*0/
16357 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16358 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16359 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16360 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16361 & 0, 0,104,105,107,164, 0, 0,106,108,
16362 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16363 & 0, 0, 0,161,162,164,167, 0, 0,163,
16364 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16365 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16366 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16367 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16368 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16369 & 0, 0, 99,100,102,150, 0, 0,101,103,
16370 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16371 & 0, 0, 0,152,149,150,158, 0, 0,154,
16372 & 151,159, 0, 0,157,160, 50*0/
16373 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16374 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16375 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16376 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16377 & 0, 0,110,111,113,174, 0, 0,112,114,
16378 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16379 & 0, 0, 0,171,172,174,177, 0, 0,173,
16380 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16381
16382 L=0
16383 DO 2 I=1,6
16384 DO 1 J=1,6
16385 L = L+1
16386 IMPS(I,J) = IP(L)
16387 IMVE(I,J) = IV(L)
16388 1 CONTINUE
16389 2 CONTINUE
16390 L=0
16391 DO 4 I=1,6
16392 DO 3 J=1,21
16393 L = L+1
16394 IB08(I,J) = IB(L)
16395 IB10(I,J) = IBB(L)
16396 IA08(I,J) = IA(L)
16397 IA10(I,J) = IAA(L)
16398 3 CONTINUE
16399 4 CONTINUE
16400C A1 = 0.88D0
16401C B1 = 3.0D0
16402C B2 = 3.0D0
16403C B3 = 8.0D0
16404C LT = 0
16405C LB = 0
16406C BET = 12.0D0
16407C AS = 0.25D0
16408C B8 = 0.33D0
16409C AME = 0.95D0
16410C DIQ = 0.375D0
16411C ISU = 4
16412
16413 RETURN
16414 END
16415
16416*$ CREATE DT_INITJS.FOR
16417*COPY DT_INITJS
16418*
16419*===initjs=============================================================*
16420*
16421 SUBROUTINE DT_INITJS(MODE)
16422
16423************************************************************************
16424* Initialize JETSET paramters. *
16425* MODE = 0 default settings *
16426* = 1 PHOJET settings *
16427* = 2 DTUNUC settings *
16428* This version dated 16.02.96 is written by S. Roesler *
16429* *
16430* Last change 27.12.2006 by S. Roesler. *
16431************************************************************************
16432
16433 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16434 SAVE
16435
16436 PARAMETER ( LINP = 10 ,
16437 & LOUT = 6 ,
16438 & LDAT = 9 )
16439
16440 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16441
16442 LOGICAL LFIRST,LFIRDT,LFIRPH
16443
16444* INCLUDE '(DIMPAR)'
16445* DIMPAR taken from FLUKA
16446 PARAMETER ( MXXRGN =20000 )
16447 PARAMETER ( MXXMDF = 710 )
16448 PARAMETER ( MXXMDE = 702 )
16449 PARAMETER ( MFSTCK =40000 )
16450 PARAMETER ( MESTCK = 100 )
16451 PARAMETER ( MOSTCK = 2000 )
16452 PARAMETER ( MXPRSN = 100 )
16453 PARAMETER ( MXPDPM = 800 )
16454 PARAMETER ( MXPSCS =30000 )
16455 PARAMETER ( MXGLWN = 300 )
16456 PARAMETER ( MXOUTU = 50 )
16457 PARAMETER ( NALLWP = 64 )
16458 PARAMETER ( NELEMX = 80 )
16459 PARAMETER ( MPDPDX = 18 )
16460 PARAMETER ( MXHTTR = 260 )
16461 PARAMETER ( MXSEAX = 20 )
16462 PARAMETER ( MXHTNC = MXSEAX + 1 )
16463 PARAMETER ( ICOMAX = 2400 )
16464 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16465 PARAMETER ( NSTBIS = 304 )
16466 PARAMETER ( NQSTIS = 46 )
16467 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16468 PARAMETER ( MXPABL = 120 )
16469 PARAMETER ( IDMAXP = 450 )
16470 PARAMETER ( IDMXDC = 2000 )
16471 PARAMETER ( MXMCIN = 410 )
16472 PARAMETER ( IHYPMX = 4 )
16473 PARAMETER ( MKBMX1 = 11 )
16474 PARAMETER ( MKBMX2 = 11 )
16475 PARAMETER ( MXIRRD = 2500 )
16476 PARAMETER ( MXTRDC = 1500 )
16477 PARAMETER ( NKTL = 17 )
16478 PARAMETER ( NBLNMX = 40000000 )
16479
16480* INCLUDE '(PART)'
16481* PART taken from FLUKA
16482 PARAMETER ( KPETA0 = 31 )
16483 PARAMETER ( KPRHOP = 32 )
16484 PARAMETER ( KPRHO0 = 33 )
16485 PARAMETER ( KPRHOM = 34 )
16486 PARAMETER ( KPOME0 = 35 )
16487 PARAMETER ( KPPHI0 = 96 )
16488 PARAMETER ( KPDEPP = 53 )
16489 PARAMETER ( KPDELP = 54 )
16490 PARAMETER ( KPDEL0 = 55 )
16491 PARAMETER ( KPDELM = 56 )
16492 PARAMETER ( KPN14P = 91 )
16493 PARAMETER ( KPN140 = 92 )
16494* Low mass diffraction partners:
16495 PARAMETER ( KDETA0 = 0 )
16496 PARAMETER ( KDRHOP = 0 )
16497 PARAMETER ( KDRHO0 = 210 )
16498 PARAMETER ( KDRHOM = 0 )
16499 PARAMETER ( KDOME0 = 210 )
16500 PARAMETER ( KDPHI0 = 210 )
16501 PARAMETER ( KDDEPP = 0 )
16502 PARAMETER ( KDDELP = 0 )
16503 PARAMETER ( KDDEL0 = 0 )
16504 PARAMETER ( KDDELM = 0 )
16505 PARAMETER ( KDN14P = 0 )
16506 PARAMETER ( KDN140 = 0 )
16507*
16508 CHARACTER*8 ANAME
16509 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16510 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16511 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16512 & ATXN14, ATMN14, RNRN14 (-10:10),
16513 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16514 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16515 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16516 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16517 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16518 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16519
16520 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16521 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
004932dd 16522 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 16523
16524* flags for particle decays
16525 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16526 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16527 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16528
16529* flags for input different options
16530 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16531 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16532 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16533
16534 INTEGER PYCOMP
16535
16536 DIMENSION IDXSTA(40)
16537 DATA IDXSTA
16538* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16539 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16540* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16541 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16542* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16543 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16544* Ksic0 aKsic+aKsic0 sig0 asig0
16545 & 4132,-4232,-4132, 3212,-3212, 5*0/
16546
16547 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16548
16549 IF (LFIRST) THEN
16550* save default settings
16551 PDEF1 = PARJ(1)
16552 PDEF2 = PARJ(2)
16553 PDEF3 = PARJ(3)
16554 PDEF5 = PARJ(5)
16555 PDEF6 = PARJ(6)
16556 PDEF7 = PARJ(7)
16557 PDEF18 = PARJ(18)
16558 PDEF19 = PARJ(19)
16559 PDEF21 = PARJ(21)
16560 PDEF42 = PARJ(42)
16561 MDEF12 = MSTJ(12)
16562* LUJETS / PYJETS array-dimensions
16563
16564 MSTU(4) = 4000
16565
16566* increase maximum number of JETSET-error prints
16567 MSTU(22) = 50000
16568* prevent particles decaying
16569 DO 1 I=1,35
16570 IF (I.LT.34) THEN
16571
16572 KC = PYCOMP(IDXSTA(I))
16573
16574 IF (KC.GT.0) THEN
16575 IF (I.EQ.2) THEN
16576* pi0 decay
16577C MDCY(KC,1) = 1
16578 MDCY(KC,1) = 0
16579**cr mode
16580C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16581C & (I.EQ.8).OR.(I.EQ.10)) THEN
16582C ELSEIF (I.EQ.4) THEN
16583C MDCY(KC,1) = 1
16584**
16585 ELSE
16586 MDCY(KC,1) = 0
16587 ENDIF
16588 ENDIF
16589 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16590
16591 KC = PYCOMP(IDXSTA(I))
16592
16593 IF (KC.GT.0) THEN
16594 MDCY(KC,1) = 0
16595 ENDIF
16596 ENDIF
16597 1 CONTINUE
16598*
16599
16600* as Fluka event-generator: allow only paprop particles to be stable
16601* and let all other particles decay (i.e. those with strong decays)
16602 IF (ITRSPT.EQ.1) THEN
16603 DO 5 I=1,IDMAXP
16604 IF (KPTOIP(I).NE.0) THEN
16605 IDPDG = MPDGHA(I)
16606
16607 KC = PYCOMP(IDPDG)
16608
16609 IF (KC.GT.0) THEN
16610 IF (MDCY(KC,1).EQ.1) THEN
16611 WRITE(LOUT,*)
16612 & ' DT_INITJS: Decay flag for FLUKA-',
16613 & 'transport : particle should not ',
16614 & 'decay : ',IDPDG,' ',ANAME(I)
16615 MDCY(KC,1) = 0
16616 ENDIF
16617 ENDIF
16618 ENDIF
16619 5 CONTINUE
16620 DO 6 KC=1,500
16621 IDPDG = KCHG(KC,4)
16622 KP = MCIHAD(IDPDG)
16623 IF (KP.GT.0) THEN
16624 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16625 & (ANAME(KP).NE.'BLANK ').AND.
16626 & (ANAME(KP).NE.'RNDFLV ')) THEN
16627 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16628 & 'transport: particle should decay ',
16629 & ': ',IDPDG,' ',ANAME(KP)
16630 MDCY(KC,1) = 1
16631 ENDIF
16632 ENDIF
16633 6 CONTINUE
16634 ENDIF
16635
16636*
16637* popcorn:
16638 IF (PDB.LE.ZERO) THEN
16639* no popcorn-mechanism
16640 MSTJ(12) = 1
16641 ELSE
16642 MSTJ(12) = 3
16643 PARJ(5) = PDB
16644 ENDIF
16645* set JETSET-parameter requested by input cards
16646 IF (NMSTU.GT.0) THEN
16647 DO 2 I=1,NMSTU
16648 MSTU(IMSTU(I)) = MSTUX(I)
16649 2 CONTINUE
16650 ENDIF
16651 IF (NMSTJ.GT.0) THEN
16652 DO 3 I=1,NMSTJ
16653 MSTJ(IMSTJ(I)) = MSTJX(I)
16654 3 CONTINUE
16655 ENDIF
16656 IF (NPARU.GT.0) THEN
16657 DO 4 I=1,NPARU
16658 PARU(IPARU(I)) = PARUX(I)
16659 4 CONTINUE
16660 ENDIF
16661 LFIRST = .FALSE.
16662 ENDIF
16663*
16664* PARJ(1) suppression of qq-aqaq pair prod. compared to
16665* q-aq pair prod. (default: 0.1)
16666* PARJ(2) strangeness suppression (default: 0.3)
16667* PARJ(3) extra suppression of strange diquarks (default: 0.4)
16668* PARJ(6) extra suppression of sas-pair shared by B and
16669* aB in BMaB (default: 0.5)
16670* PARJ(7) extra suppression of strange meson M in BMaB
16671* configuration (default: 0.5)
16672* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16673* PARJ(21) width sigma in Gaussian p_x, p_y transverse
16674* momentum distrib. for prim. hadrons (default: 0.35)
16675* PARJ(42) b-parameter for symmetric Lund-fragmentation
16676* function (default: 0.9 GeV^-2)
16677*
16678* PHOJET settings
16679 IF (MODE.EQ.1) THEN
16680* JETSET default
16681C PARJ(1) = PDEF1
16682C PARJ(2) = PDEF2
16683C PARJ(3) = PDEF3
16684C PARJ(6) = PDEF6
16685C PARJ(7) = PDEF7
16686C PARJ(18) = PDEF18
16687C PARJ(21) = PDEF21
16688C PARJ(42) = PDEF42
16689**sr 18.11.98 parameter tuning
16690C PARJ(1) = 0.092D0
16691C PARJ(2) = 0.25D0
16692C PARJ(3) = 0.45D0
16693C PARJ(19) = 0.3D0
16694C PARJ(21) = 0.45D0
16695C PARJ(42) = 1.0D0
16696**sr 28.04.99 parameter tuning (May 99 minor modifications)
16697 PARJ(1) = 0.085D0
16698 PARJ(2) = 0.26D0
16699 PARJ(3) = 0.8D0
16700 PARJ(11) = 0.38D0
16701 PARJ(18) = 0.3D0
16702 PARJ(19) = 0.4D0
16703 PARJ(21) = 0.36D0
16704 PARJ(41) = 0.3D0
16705 PARJ(42) = 0.86D0
16706 IF (NPARJ.GT.0) THEN
16707 DO 10 I=1,NPARJ
16708 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16709 10 CONTINUE
16710 ENDIF
16711 IF (LFIRPH) THEN
16712 WRITE(LOUT,'(1X,A)')
16713 & 'DT_INITJS: JETSET-parameter for PHOJET'
16714 CALL DT_JSPARA(0)
16715 LFIRPH = .FALSE.
16716 ENDIF
16717* DTUNUC settings
16718 ELSEIF (MODE.EQ.2) THEN
16719 IF (IFRAG(2).EQ.1) THEN
16720**sr parameters before 9.3.96
16721C PARJ(2) = 0.27D0
16722C PARJ(3) = 0.6D0
16723C PARJ(6) = 0.75D0
16724C PARJ(7) = 0.75D0
16725C PARJ(21) = 0.55D0
16726C PARJ(42) = 1.3D0
16727**sr 18.11.98 parameter tuning
16728C PARJ(1) = 0.05D0
16729C PARJ(2) = 0.27D0
16730C PARJ(3) = 0.4D0
16731C PARJ(19) = 0.2D0
16732C PARJ(21) = 0.45D0
16733C PARJ(42) = 1.0D0
16734**sr 28.04.99 parameter tuning
16735 PARJ(1) = 0.11D0
16736 PARJ(2) = 0.36D0
16737 PARJ(3) = 0.8D0
16738 PARJ(19) = 0.2D0
16739 PARJ(21) = 0.3D0
16740 PARJ(41) = 0.3D0
16741 PARJ(42) = 0.58D0
16742 IF (NPARJ.GT.0) THEN
16743 DO 20 I=1,NPARJ
16744 IF (IPARJ(I).LT.0) THEN
16745 IDX = ABS(IPARJ(I))
16746 PARJ(IDX) = PARJX(I)
16747 ENDIF
16748 20 CONTINUE
16749 ENDIF
16750 IF (LFIRDT) THEN
16751 WRITE(LOUT,'(1X,A)')
16752 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16753 CALL DT_JSPARA(0)
16754 LFIRDT = .FALSE.
16755 ENDIF
16756 ELSEIF (IFRAG(2).EQ.2) THEN
16757 PARJ(1) = 0.11D0
16758 PARJ(2) = 0.27D0
16759 PARJ(3) = 0.3D0
16760 PARJ(6) = 0.35D0
16761 PARJ(7) = 0.45D0
16762 PARJ(18) = 0.66D0
16763C PARJ(21) = 0.55D0
16764C PARJ(42) = 1.0D0
16765 PARJ(21) = 0.60D0
16766 PARJ(42) = 1.3D0
16767 ELSE
16768 PARJ(1) = PDEF1
16769 PARJ(2) = PDEF2
16770 PARJ(3) = PDEF3
16771 PARJ(6) = PDEF6
16772 PARJ(7) = PDEF7
16773 PARJ(18) = PDEF18
16774 PARJ(21) = PDEF21
16775 PARJ(42) = PDEF42
16776 ENDIF
16777 ELSE
16778 PARJ(1) = PDEF1
16779 PARJ(2) = PDEF2
16780 PARJ(3) = PDEF3
16781 PARJ(5) = PDEF5
16782 PARJ(6) = PDEF6
16783 PARJ(7) = PDEF7
16784 PARJ(18) = PDEF18
16785 PARJ(19) = PDEF19
16786 PARJ(21) = PDEF21
16787 PARJ(42) = PDEF42
16788 MSTJ(12) = MDEF12
16789 ENDIF
16790
16791 RETURN
16792 END
16793
16794*$ CREATE DT_JSPARA.FOR
16795*COPY DT_JSPARA
16796*
16797*===jspara=============================================================*
16798*
16799 SUBROUTINE DT_JSPARA(MODE)
16800
16801 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16802 SAVE
16803
16804 PARAMETER ( LINP = 10 ,
16805 & LOUT = 6 ,
16806 & LDAT = 9 )
16807
16808 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16809 & ONE=1.0D0,ZERO=0.0D0)
16810
16811 LOGICAL LFIRST
16812
16813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16814
16815 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16816
16817 DATA LFIRST /.TRUE./
16818
16819* save the default JETSET-parameter on the first call
16820 IF (LFIRST) THEN
16821 DO 1 I=1,200
16822 ISTU(I) = MSTU(I)
16823 QARU(I) = PARU(I)
16824 ISTJ(I) = MSTJ(I)
16825 QARJ(I) = PARJ(I)
16826 1 CONTINUE
16827 LFIRST = .FALSE.
16828 ENDIF
16829
16830 WRITE(LOUT,1000)
16831 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16832
16833* compare the default JETSET-parameter with the present values
16834 DO 2 I=1,200
16835 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16836 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16837C ISTU(I) = MSTU(I)
16838 ENDIF
16839 DIFF = ABS(PARU(I)-QARU(I))
16840 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16841 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16842C QARU(I) = PARU(I)
16843 ENDIF
16844 IF (MSTJ(I).NE.ISTJ(I)) THEN
16845 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16846C ISTJ(I) = MSTJ(I)
16847 ENDIF
16848 DIFF = ABS(PARJ(I)-QARJ(I))
16849 IF (DIFF.GE.1.0D-5) THEN
16850 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16851C QARJ(I) = PARJ(I)
16852 ENDIF
16853 2 CONTINUE
16854 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16855 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16856
16857 RETURN
16858 END
16859*$ CREATE DT_FOZOCA.FOR
16860*COPY DT_FOZOCA
16861*
16862*===fozoca=============================================================*
16863*
16864 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16865
16866************************************************************************
16867* This subroutine treats the complete FOrmation ZOne supressed intra- *
16868* nuclear CAscade. *
16869* LFZC = .true. cascade has been treated *
16870* = .false. cascade skipped *
16871* This is a completely revised version of the original FOZOKL. *
16872* This version dated 18.11.95 is written by S. Roesler *
16873************************************************************************
16874
16875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16876 SAVE
16877
16878 PARAMETER ( LINP = 10 ,
16879 & LOUT = 6 ,
16880 & LDAT = 9 )
16881
16882 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16883 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16884
16885 LOGICAL LSTART,LCAS,LFZC
16886
16887* event history
16888
16889 PARAMETER (NMXHKK=200000)
16890
16891 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16892 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16893 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16894
16895* extended event history
16896 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16897 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16898 & IHIST(2,NMXHKK)
16899
16900* rejection counter
16901 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16902 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16903 & IREXCI(3),IRDIFF(2),IRINC
16904
16905* properties of interacting particles
16906 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16907
16908* Glauber formalism: collision properties
16909 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16910 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16911
16912* flags for input different options
16913 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16914 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16915 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16916
16917* final state after intranuclear cascade step
16918 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16919
16920* parameter for intranuclear cascade
16921 LOGICAL LPAULI
16922 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16923
16924 DIMENSION NCWOUN(2)
16925
16926 DATA LSTART /.TRUE./
16927
16928 LFZC = .TRUE.
16929 IREJ = 0
16930
16931* skip cascade if hadron-hadron interaction or if supressed by user
16932 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16933* skip cascade if not all possible chains systems are hadronized
16934 DO 1 I=1,8
16935 IF (.NOT.LHADRO(I)) GOTO 9999
16936 1 CONTINUE
16937
16938 IF (LSTART) THEN
16939 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16940 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16941 & 'maximum of',I4,' generations',/,10X,'formation time ',
16942 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16943 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16944 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16945 1001 FORMAT(10X,'p_t dependent formation zone',/)
16946 1002 FORMAT(10X,'constant formation zone',/)
16947 LSTART = .FALSE.
16948 ENDIF
16949
16950* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16951* which may interact with final state particles are stored in a seperate
16952* array - here all proj./target nucleon-indices (just for simplicity)
16953 NOINC = 0
16954 DO 9 I=1,NPOINT(1)-1
16955 NOINC = NOINC+1
16956 IDXINC(NOINC) = I
16957 9 CONTINUE
16958
16959* initialize Pauli-principle treatment (find wounded nucleons)
16960 NWOUND(1) = 0
16961 NWOUND(2) = 0
16962 NCWOUN(1) = 0
16963 NCWOUN(2) = 0
16964 DO 2 J=1,NPOINT(1)
16965 DO 3 I=1,2
16966 IF (ISTHKK(J).EQ.10+I) THEN
16967 NWOUND(I) = NWOUND(I)+1
16968 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16969 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16970 ENDIF
16971 3 CONTINUE
16972 2 CONTINUE
16973
16974* modify nuclear potential for wounded nucleons
16975 IPRCL = IP -NWOUND(1)
16976 IPZRCL = IPZ-NCWOUN(1)
16977 ITRCL = IT -NWOUND(2)
16978 ITZRCL = ITZ-NCWOUN(2)
16979 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16980
16981 NSTART = NPOINT(4)
16982 NEND = NHKK
16983
16984 7 CONTINUE
16985 DO 8 I=NSTART,NEND
16986
16987 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16988* select nucleus the cascade starts first (proj. - 1, target - -1)
16989 NCAS = 1
16990* projectile/target with probab. 1/2
16991 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16992 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16993* in the nucleus with highest mass
16994 ELSEIF (INCMOD.EQ.2) THEN
16995 IF (IP.GT.IT) THEN
16996 NCAS = -NCAS
16997 ELSEIF (IP.EQ.IT) THEN
16998 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16999 ENDIF
17000* the nucleus the cascade starts first is requested to be the one
17001* moving in the direction of the secondary
17002 ELSEIF (INCMOD.EQ.3) THEN
17003 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17004 ENDIF
17005* check that the selected "nucleus" is not a hadron
17006 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17007 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
17008
17009* treat intranuclear cascade in the nucleus selected first
17010 LCAS = .FALSE.
17011 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17012 IF (IREJ1.NE.0) GOTO 9998
17013* treat intranuclear cascade in the other nucleus if this isn't a had.
17014 NCAS = -NCAS
17015 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17016 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17017 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17018 IF (IREJ1.NE.0) GOTO 9998
17019 ENDIF
17020
17021 ENDIF
17022
17023 8 CONTINUE
17024 NSTART = NEND+1
17025 NEND = NHKK
17026 IF (NSTART.LE.NEND) GOTO 7
17027
17028 RETURN
17029
17030 9998 CONTINUE
17031* reject this event
17032 IRINC = IRINC+1
17033 IREJ = 1
17034
17035 9999 CONTINUE
17036* intranucl. cascade not treated because of interaction properties or
17037* it is supressed by user or it was rejected or...
17038 LFZC = .FALSE.
17039* reset flag characterizing direction of motion in n-n-cms
17040**sr14-11-95
17041C DO 9990 I=NPOINT(5),NHKK
17042C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17043C9990 CONTINUE
17044
17045 RETURN
17046 END
17047
17048*$ CREATE DT_INUCAS.FOR
17049*COPY DT_INUCAS
17050*
17051*===inucas=============================================================*
17052*
17053 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17054
17055************************************************************************
17056* Formation zone supressed IntraNUclear CAScade for one final state *
17057* particle. *
17058* IT, IP mass numbers of target, projectile nuclei *
17059* IDXCAS index of final state particle in DTEVT1 *
17060* NCAS = 1 intranuclear cascade in projectile *
17061* = -1 intranuclear cascade in target *
17062* This version dated 18.11.95 is written by S. Roesler *
17063************************************************************************
17064
17065 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17066 SAVE
17067
17068 PARAMETER ( LINP = 10 ,
17069 & LOUT = 6 ,
17070 & LDAT = 9 )
17071
17072 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17073 & OHALF=0.5D0,ONE=1.0D0)
17074 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17075 PARAMETER (TWOPI=6.283185307179586454D+00)
17076 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17077
17078 LOGICAL LABSOR,LCAS
17079
17080* event history
17081
17082 PARAMETER (NMXHKK=200000)
17083
17084 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17085 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17086 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17087
17088* extended event history
17089 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17090 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17091 & IHIST(2,NMXHKK)
17092
17093* final state after inc step
17094 PARAMETER (MAXFSP=10)
17095 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17096
17097* flags for input different options
17098 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17099 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17100 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17101
17102* particle properties (BAMJET index convention)
17103 CHARACTER*8 ANAME
17104 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17105 & IICH(210),IIBAR(210),K1(210),K2(210)
17106
17107* Glauber formalism: collision properties
17108 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17109 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17110
17111* nuclear potential
17112 LOGICAL LFERMI
17113 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17114 & EBINDP(2),EBINDN(2),EPOT(2,210),
17115 & ETACOU(2),ICOUL,LFERMI
17116
17117* parameter for intranuclear cascade
17118 LOGICAL LPAULI
17119 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17120
17121* final state after intranuclear cascade step
17122 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17123
17124* nucleon-nucleon event-generator
17125 CHARACTER*8 CMODEL
17126 LOGICAL LPHOIN
17127 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17128
17129* statistics: residual nuclei
17130 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17131 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17132 & NINCST(2,4),NINCEV(2),
17133 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17134 & NRESPB(2),NRESCH(2),NRESEV(4),
17135 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17136 & NEVAFI(2,2)
17137
17138 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17139 & PCAS1(5),PNUC(5),BGTA(4),
17140 & BGCAS(2),GACAS(2),BECAS(2),
17141 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17142
17143 DATA PDIF /0.545D0/
17144
17145 IREJ = 0
17146
17147* update counter
17148 IF (NINCEV(1).NE.NEVHKK) THEN
17149 NINCEV(1) = NEVHKK
17150 NINCEV(2) = NINCEV(2)+1
17151 ENDIF
17152
17153* "BAMJET-index" of this hadron
17154 IDCAS = IDBAM(IDXCAS)
17155 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17156
17157* skip gammas, electrons, etc..
17158 IF (AAM(IDCAS).LT.TINY2) RETURN
17159
17160* Lorentz-trsf. into projectile rest system
17161 IF (IP.GT.1) THEN
17162 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17163 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17164 & PCAS(1,4),IDCAS,-2)
17165 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17166 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17167 IF (PCAS(1,5).GT.ZERO) THEN
17168 PCAS(1,5) = SQRT(PCAS(1,5))
17169 ELSE
17170 PCAS(1,5) = AAM(IDCAS)
17171 ENDIF
17172 DO 20 K=1,3
17173 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17174 20 CONTINUE
17175* Lorentz-parameters
17176* particle rest system --> projectile rest system
17177 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17178 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17179 BECAS(1) = BGCAS(1)/GACAS(1)
17180 ELSE
17181 DO 21 K=1,5
17182 PCAS(1,K) = ZERO
17183 IF (K.LE.3) COSCAS(1,K) = ZERO
17184 21 CONTINUE
17185 PTOCAS(1) = ZERO
17186 BGCAS(1) = ZERO
17187 GACAS(1) = ZERO
17188 BECAS(1) = ZERO
17189 ENDIF
17190* Lorentz-trsf. into target rest system
17191 IF (IT.GT.1) THEN
17192* LEPTO: final state particles are already in target rest frame
17193C IF (MCGENE.EQ.3) THEN
17194C PCAS(2,1) = PHKK(1,IDXCAS)
17195C PCAS(2,2) = PHKK(2,IDXCAS)
17196C PCAS(2,3) = PHKK(3,IDXCAS)
17197C PCAS(2,4) = PHKK(4,IDXCAS)
17198C ELSE
17199 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17200 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17201 & PCAS(2,4),IDCAS,-3)
17202C ENDIF
17203 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17204 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17205 IF (PCAS(2,5).GT.ZERO) THEN
17206 PCAS(2,5) = SQRT(PCAS(2,5))
17207 ELSE
17208 PCAS(2,5) = AAM(IDCAS)
17209 ENDIF
17210 DO 22 K=1,3
17211 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17212 22 CONTINUE
17213* Lorentz-parameters
17214* particle rest system --> target rest system
17215 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17216 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17217 BECAS(2) = BGCAS(2)/GACAS(2)
17218 ELSE
17219 DO 23 K=1,5
17220 PCAS(2,K) = ZERO
17221 IF (K.LE.3) COSCAS(2,K) = ZERO
17222 23 CONTINUE
17223 PTOCAS(2) = ZERO
17224 BGCAS(2) = ZERO
17225 GACAS(2) = ZERO
17226 BECAS(2) = ZERO
17227 ENDIF
17228
17229* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17230* potential (see CONUCL)
17231 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17232 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17233* impact parameter (the projectile moving along z)
17234 BIMPC(1) = ZERO
17235 BIMPC(2) = BIMPAC*FM2MM
17236
17237* get position of initial hadron in projectile/target rest-syst.
17238 DO 3 K=1,4
17239 VTXCAS(1,K) = WHKK(K,IDXCAS)
17240 VTXCAS(2,K) = VHKK(K,IDXCAS)
17241 3 CONTINUE
17242
17243 ICAS = 1
17244 I2 = 2
17245 IF (NCAS.EQ.-1) THEN
17246 ICAS = 2
17247 I2 = 1
17248 ENDIF
17249
17250 IF (PTOCAS(ICAS).LT.TINY10) THEN
17251 WRITE(LOUT,1000) PTOCAS
17252 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17253 & ' hadron ',/,20X,2E12.4)
17254 GOTO 9999
17255 ENDIF
17256
17257* reset spectator flags
17258 NSPE = 0
17259 IDXSPE(1) = 0
17260 IDXSPE(2) = 0
17261 IDSPE(1) = 0
17262 IDSPE(2) = 0
17263
17264* formation length (in fm)
17265C IF (LCAS) THEN
17266C DEL0 = ZERO
17267C ELSE
17268 DEL0 = TAUFOR*BGCAS(ICAS)
17269 IF (ITAUVE.EQ.1) THEN
17270 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17271 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17272 ENDIF
17273C ENDIF
17274* sample from exp(-del/del0)
17275 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17276* save formation time
17277 TAUSA1 = DEL1/BGCAS(ICAS)
17278 REL1 = TAUSA1*BGCAS(I2)
17279
17280 DEL = DEL1
17281 TAUSAM = DEL/BGCAS(ICAS)
17282 REL = TAUSAM*BGCAS(I2)
17283
17284* special treatment for negative particles unable to escape
17285* nuclear potential (implemented for ap, pi-, K- only)
17286 LABSOR = .FALSE.
17287 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17288* threshold energy = nuclear potential + Coulomb potential
17289* (nuclear potential for hadron-nucleus interactions only)
17290 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17291 IF (PCAS(ICAS,4).LT.ETHR) THEN
17292 DO 4 K=1,5
17293 PCAS1(K) = PCAS(ICAS,K)
17294 4 CONTINUE
17295* "absorb" negative particle in nucleus
17296 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17297 IF (IREJ1.NE.0) GOTO 9999
17298 IF (NSPE.GE.1) LABSOR = .TRUE.
17299 ENDIF
17300 ENDIF
17301
17302* if the initial particle has not been absorbed proceed with
17303* "normal" cascade
17304 IF (.NOT.LABSOR) THEN
17305
17306* calculate coordinates of hadron at the end of the formation zone
17307* transport-time and -step in the rest system where this step is
17308* treated
17309 DSTEP = DEL*FM2MM
17310 DTIME = DSTEP/BECAS(ICAS)
17311 RSTEP = REL*FM2MM
17312 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17313 RTIME = RSTEP/BECAS(I2)
17314 ELSE
17315 RTIME = ZERO
17316 ENDIF
17317* save step whithout considering the overlapping region
17318 DSTEP1 = DEL1*FM2MM
17319 DTIME1 = DSTEP1/BECAS(ICAS)
17320 RSTEP1 = REL1*FM2MM
17321 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17322 RTIME1 = RSTEP1/BECAS(I2)
17323 ELSE
17324 RTIME1 = ZERO
17325 ENDIF
17326* transport to the end of the formation zone in this system
17327 DO 5 K=1,3
17328 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17329 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17330 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17331 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17332 5 CONTINUE
17333 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17334 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17335 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17336 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17337
17338 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17339 XCAS = VTXCAS(ICAS,1)
17340 YCAS = VTXCAS(ICAS,2)
17341 XNCLTA = BIMPAC*FM2MM
17342 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17343 RNCLTA = (RTARG+RNUCLE)*FM2MM
17344C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17345C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17346C RNCLPR = (RPROJ)*FM2MM
17347C RNCLTA = (RTARG)*FM2MM
17348 RCASPR = SQRT( XCAS**2 +YCAS**2)
17349 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17350 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17351 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17352 ENDIF
17353 ENDIF
17354
17355* check if particle is already outside of the corresp. nucleus
17356 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17357 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17358 IF (RDIST.GE.RNUC(ICAS)) THEN
17359* here: IDCH is the generation of the final state part. starting
17360* with zero for hadronization products
17361* flag particles of generation 0 being outside the nuclei after
17362* formation time (to be used for excitation energy calculation)
17363 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17364 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17365 GOTO 9997
17366 ENDIF
17367 DIST = DLARGE
17368 DISTP = DLARGE
17369 DISTN = DLARGE
17370 IDXP = 0
17371 IDXN = 0
17372
17373* already here: skip particles being outside HADRIN "energy-window"
17374* to avoid wasting of time
17375 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17376 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17377 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17378C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17379C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17380C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17381C & E12.4,', above or below HADRIN-thresholds',I6)
17382 NSPE = 0
17383 GOTO 9997
17384 ENDIF
17385
17386 DO 7 IDXHKK=1,NOINC
17387 I = IDXINC(IDXHKK)
17388* scan DTEVT1 for unwounded or excited nucleons
17389 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17390 DO 8 K=1,3
17391 IF (ICAS.EQ.1) THEN
17392 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17393 ELSEIF (ICAS.EQ.2) THEN
17394 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17395 ENDIF
17396 8 CONTINUE
17397 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17398 & VTXDST(2)*COSCAS(ICAS,2)+
17399 & VTXDST(3)*COSCAS(ICAS,3)
17400* check if nucleon is situated in forward direction
17401 IF (POSNUC.GT.ZERO) THEN
17402* distance between hadron and this nucleon
17403 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17404 & VTXDST(3)**2)
17405* impact parameter
17406 BIMNU2 = DISTNU**2-POSNUC**2
17407 IF (BIMNU2.LT.ZERO) THEN
17408 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17409 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17410 & ' parameter ',/,20X,3E12.4)
17411 GOTO 7
17412 ENDIF
17413 BIMNU = SQRT(BIMNU2)
17414* maximum impact parameter to have interaction
17415 IDNUC = IDT_ICIHAD(IDHKK(I))
17416 IDNUC1 = IDT_MCHAD(IDNUC)
17417 IDCAS1 = IDT_MCHAD(IDCAS)
17418 DO 19 K=1,5
17419 PCAS1(K) = PCAS(ICAS,K)
17420 PNUC(K) = PHKK(K,I)
17421 19 CONTINUE
17422* Lorentz-parameter for trafo into rest-system of target
17423 DO 18 K=1,4
17424 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17425 18 CONTINUE
17426* transformation of projectile into rest-system of target
17427 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17428 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17429 & PPTOT,PX,PY,PZ,PE)
17430**
17431C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17432C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17433 DUMZER = ZERO
17434 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17435 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17436 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17437 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17438 SIGIN = SIGTOT-SIGEL-SIGAB
17439C SIGTOT = SIGIN+SIGEL+SIGAB
17440**
17441 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17442* check if interaction is possible
17443 IF (BIMNU.LE.BIMMAX) THEN
17444* get nucleon with smallest distance and kind of interaction
17445* (elastic/inelastic)
17446 IF (DISTNU.LT.DIST) THEN
17447 DIST = DISTNU
17448 BINT = BIMNU
17449 IF (IDNUC.NE.IDSPE(1)) THEN
17450 IDSPE(2) = IDSPE(1)
17451 IDXSPE(2) = IDXSPE(1)
17452 IDSPE(1) = IDNUC
17453 ENDIF
17454 IDXSPE(1) = I
17455 NSPE = 1
17456**sr
17457 SELA = SIGEL
17458 SABS = SIGAB
17459 STOT = SIGTOT
17460C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17461C SELA = SIGEL
17462C STOT = SIGIN+SIGEL
17463C ELSE
17464C SELA = SIGEL+0.75D0*SIGIN
17465C STOT = 0.25D0*SIGIN+SELA
17466C ENDIF
17467**
17468 ENDIF
17469 ENDIf
17470 ENDIF
17471 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17472 & VTXDST(3)**2)
17473 IDNUC = IDT_ICIHAD(IDHKK(I))
17474 IF (IDNUC.EQ.1) THEN
17475 IF (DISTNU.LT.DISTP) THEN
17476 DISTP = DISTNU
17477 IDXP = I
17478 POSP = POSNUC
17479 ENDIF
17480 ELSEIF (IDNUC.EQ.8) THEN
17481 IF (DISTNU.LT.DISTN) THEN
17482 DISTN = DISTNU
17483 IDXN = I
17484 POSN = POSNUC
17485 ENDIF
17486 ENDIF
17487 ENDIF
17488 7 CONTINUE
17489
17490* there is no nucleon for a secondary interaction
17491 IF (NSPE.EQ.0) GOTO 9997
17492
17493C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17494C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17495 IF (IDXSPE(2).EQ.0) THEN
17496 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17497C DO 80 K=1,3
17498C IF (ICAS.EQ.1) THEN
17499C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17500C ELSEIF (ICAS.EQ.2) THEN
17501C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17502C ENDIF
17503C 80 CONTINUE
17504C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17505C & VTXDST(3)**2)
17506C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17507 IDXSPE(2) = IDXN
17508 IDSPE(2) = 8
17509C ELSE
17510C STOT = STOT-SABS
17511C SABS = ZERO
17512C ENDIF
17513 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17514C DO 81 K=1,3
17515C IF (ICAS.EQ.1) THEN
17516C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17517C ELSEIF (ICAS.EQ.2) THEN
17518C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17519C ENDIF
17520C 81 CONTINUE
17521C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17522C & VTXDST(3)**2)
17523C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17524 IDXSPE(2) = IDXP
17525 IDSPE(2) = 1
17526C ELSE
17527C STOT = STOT-SABS
17528C SABS = ZERO
17529C ENDIF
17530 ELSE
17531 STOT = STOT-SABS
17532 SABS = ZERO
17533 ENDIF
17534 ENDIF
17535 RR = DT_RNDM(DIST)
17536 IF (RR.LT.SELA/STOT) THEN
17537 IPROC = 2
17538 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17539 IPROC = 3
17540 ELSE
17541 IPROC = 1
17542 ENDIF
17543
17544 DO 9 K=1,5
17545 PCAS1(K) = PCAS(ICAS,K)
17546 PNUC(K) = PHKK(K,IDXSPE(1))
17547 9 CONTINUE
17548 IF (IPROC.EQ.3) THEN
17549* 2-nucleon absorption of pion
17550 NSPE = 2
17551 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17552 IF (IREJ1.NE.0) GOTO 9999
17553 IF (NSPE.GE.1) LABSOR = .TRUE.
17554 ELSE
17555* sample secondary interaction
17556 IDNUC = IDBAM(IDXSPE(1))
17557 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17558 IF (IREJ1.EQ.1) GOTO 9999
17559 IF (IREJ1.GT.1) GOTO 9998
17560 ENDIF
17561 ENDIF
17562
17563* update arrays to include Pauli-principle
17564 DO 10 I=1,NSPE
17565 IF (NWOUND(ICAS).LE.299) THEN
17566 NWOUND(ICAS) = NWOUND(ICAS)+1
17567 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17568 ENDIF
17569 10 CONTINUE
17570
17571* dump initial hadron for energy-momentum conservation check
17572 IF (LEMCCK)
17573 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17574 & PCAS(ICAS,4),1,IDUM,IDUM)
17575
17576* dump final state particles into DTEVT1
17577
17578* check if Pauli-principle is fulfilled
17579 NPAULI = 0
17580 NWTMP(1) = NWOUND(1)
17581 NWTMP(2) = NWOUND(2)
17582 DO 111 I=1,NFSP
17583 NPAULI = 0
17584 J1 = 2
17585 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17586 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17587 DO 117 J=1,J1
17588 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17589 IF (J.EQ.1) THEN
17590 IDX = ICAS
17591 PE = PFSP(4,I)
17592 ELSE
17593 IDX = I2
17594 MODE = 1
17595 IF (IDX.EQ.1) MODE = -1
17596 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17597 ENDIF
17598* first check if cascade step is forbidden due to Pauli-principle
17599* (in case of absorpion this step is forced)
17600 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17601 & (IDFSP(I).EQ.8))) THEN
17602* get nuclear potential barrier
17603 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17604 IF (IDFSP(I).EQ.1) THEN
17605 POTLOW = POT-EBINDP(IDX)
17606 ELSE
17607 POTLOW = POT-EBINDN(IDX)
17608 ENDIF
17609* final state particle not able to escape nucleus
17610 IF (PE.LE.POTLOW) THEN
17611* check if there are wounded nucleons
17612 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17613 & EWOUND(IDX,NWOUND(IDX)))) THEN
17614 NPAULI = NPAULI+1
17615 NWOUND(IDX) = NWOUND(IDX)-1
17616 ELSE
17617* interaction prohibited by Pauli-principle
17618 NWOUND(1) = NWTMP(1)
17619 NWOUND(2) = NWTMP(2)
17620 GOTO 9997
17621 ENDIF
17622 ENDIF
17623 ENDIF
17624 117 CONTINUE
17625 111 CONTINUE
17626
17627 NPAULI = 0
17628 NWOUND(1) = NWTMP(1)
17629 NWOUND(2) = NWTMP(2)
17630
17631 DO 11 I=1,NFSP
17632
17633 IST = ISTHKK(IDXCAS)
17634
17635 NPAULI = 0
17636 J1 = 2
17637 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17638 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17639 DO 17 J=1,J1
17640 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17641 IDX = ICAS
17642 PE = PFSP(4,I)
17643 IF (J.EQ.2) THEN
17644 IDX = I2
17645 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17646 ENDIF
17647* first check if cascade step is forbidden due to Pauli-principle
17648* (in case of absorpion this step is forced)
17649 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17650 & (IDFSP(I).EQ.8))) THEN
17651* get nuclear potential barrier
17652 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17653 IF (IDFSP(I).EQ.1) THEN
17654 POTLOW = POT-EBINDP(IDX)
17655 ELSE
17656 POTLOW = POT-EBINDN(IDX)
17657 ENDIF
17658* final state particle not able to escape nucleus
17659 IF (PE.LE.POTLOW) THEN
17660* check if there are wounded nucleons
17661 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17662 & EWOUND(IDX,NWOUND(IDX)))) THEN
17663 NWOUND(IDX) = NWOUND(IDX)-1
17664 NPAULI = NPAULI+1
17665 IST = 14+IDX
17666 ELSE
17667* interaction prohibited by Pauli-principle
17668 NWOUND(1) = NWTMP(1)
17669 NWOUND(2) = NWTMP(2)
17670 GOTO 9997
17671 ENDIF
17672**sr
17673c ELSEIF (PE.LE.POT) THEN
17674cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17675cC NWOUND(IDX) = NWOUND(IDX)-1
17676c**
17677c NPAULI = NPAULI+1
17678c IST = 14+IDX
17679 ENDIF
17680 ENDIF
17681 17 CONTINUE
17682
17683* dump final state particles for energy-momentum conservation check
17684 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17685 & -PFSP(4,I),2,IDUM,IDUM)
17686
17687 PX = PFSP(1,I)
17688 PY = PFSP(2,I)
17689 PZ = PFSP(3,I)
17690 PE = PFSP(4,I)
17691 IF (ABS(IST).EQ.1) THEN
17692* transform particles back into n-n cms
17693* LEPTO: leave final state particles in target rest frame
17694C IF (MCGENE.EQ.3) THEN
17695C PFSP(1,I) = PX
17696C PFSP(2,I) = PY
17697C PFSP(3,I) = PZ
17698C PFSP(4,I) = PE
17699C ELSE
17700 IMODE = ICAS+1
17701 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702 & PFSP(4,I),IDFSP(I),IMODE)
17703C ENDIF
17704 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17705* target cascade but fsp got stuck in proj. --> transform it into
17706* proj. rest system
17707 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17708 & PFSP(4,I),IDFSP(I),-1)
17709 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17710* proj. cascade but fsp got stuck in target --> transform it into
17711* target rest system
17712 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17713 & PFSP(4,I),IDFSP(I),1)
17714 ENDIF
17715
17716* dump final state particles into DTEVT1
17717 IGEN = IDCH(IDXCAS)+1
17718 ID = IDT_IPDGHA(IDFSP(I))
17719 IXR = 0
17720 IF (LABSOR) IXR = 99
17721 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17722 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17723
17724* update the counter for particles which got stuck inside the nucleus
17725 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17726 NOINC = NOINC+1
17727 IDXINC(NOINC) = NHKK
17728 ENDIF
17729 IF (LABSOR) THEN
17730* in case of absorption the spatial treatment is an approximate
17731* solution anyway (the positions of the nucleons which "absorb" the
17732* cascade particle are not taken into consideration) therefore the
17733* particles are produced at the position of the cascade particle
17734 DO 12 K=1,4
17735 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17736 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17737 12 CONTINUE
17738 ELSE
17739* DDISTL - distance the cascade particle moves to the intera. point
17740* (the position where impact-parameter = distance to the interacting
17741* nucleon), DIST - distance to the interacting nucleon at the time of
17742* formation of the cascade particle, BINT - impact-parameter of this
17743* cascade-interaction
17744 DDISTL = SQRT(DIST**2-BINT**2)
17745 DTIME = DDISTL/BECAS(ICAS)
17746 DTIMEL = DDISTL/BGCAS(ICAS)
17747 RDISTL = DTIMEL*BGCAS(I2)
17748 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17749 RTIME = RDISTL/BECAS(I2)
17750 ELSE
17751 RTIME = ZERO
17752 ENDIF
17753* RDISTL, RTIME are this step and time in the rest system of the other
17754* nucleus
17755 DO 13 K=1,3
17756 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17757 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17758 13 CONTINUE
17759 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17760 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17761* position of particle production is half the impact-parameter to
17762* the interacting nucleon
17763 DO 14 K=1,3
17764 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17765 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17766 14 CONTINUE
17767* time of production of secondary = time of interaction
17768 WHKK(4,NHKK) = VTXCA1(1,4)
17769 VHKK(4,NHKK) = VTXCA1(2,4)
17770 ENDIF
17771
17772 11 CONTINUE
17773
17774* modify status and position of cascade particle (the latter for
17775* statistics reasons only)
17776 ISTHKK(IDXCAS) = 2
17777 IF (LABSOR) ISTHKK(IDXCAS) = 19
17778 IF (.NOT.LABSOR) THEN
17779 DO 15 K=1,4
17780 WHKK(K,IDXCAS) = VTXCA1(1,K)
17781 VHKK(K,IDXCAS) = VTXCA1(2,K)
17782 15 CONTINUE
17783 ENDIF
17784
17785 DO 16 I=1,NSPE
17786 IS = IDXSPE(I)
17787* dump interacting nucleons for energy-momentum conservation check
17788 IF (LEMCCK)
17789 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17790 & 2,IDUM,IDUM)
17791* modify entry for interacting nucleons
17792 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17793 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17794 IF (I.GE.2) THEN
17795 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17796 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17797 ENDIF
17798 16 CONTINUE
17799
17800* check energy-momentum conservation
17801 IF (LEMCCK) THEN
17802 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17803 IF (IREJ1.NE.0) GOTO 9999
17804 ENDIF
17805
17806* update counter
17807 IF (LABSOR) THEN
17808 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17809 ELSE
17810 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17811 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17812 ENDIF
17813
17814 RETURN
17815
17816 9997 CONTINUE
17817 9998 CONTINUE
17818* transport-step but no cascade step due to configuration (i.e. there
17819* is no nucleon for interaction etc.)
17820 IF (LCAS) THEN
17821 DO 100 K=1,4
17822C WHKK(K,IDXCAS) = VTXCAS(1,K)
17823C VHKK(K,IDXCAS) = VTXCAS(2,K)
17824 WHKK(K,IDXCAS) = VTXCA1(1,K)
17825 VHKK(K,IDXCAS) = VTXCA1(2,K)
17826 100 CONTINUE
17827 ENDIF
17828
17829C9998 CONTINUE
17830* no cascade-step because of configuration
17831* (i.e. hadron outside nucleus etc.)
17832 LCAS = .TRUE.
17833 RETURN
17834
17835 9999 CONTINUE
17836* rejection
17837 IREJ = 1
17838 RETURN
17839 END
17840
17841*$ CREATE DT_ABSORP.FOR
17842*COPY DT_ABSORP
17843*
17844*===absorp=============================================================*
17845*
17846 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17847
17848************************************************************************
17849* Two-nucleon absorption of antiprotons, pi-, and K-. *
17850* Antiproton absorption is handled by HADRIN. *
17851* The following channels for meson-absorption are considered: *
17852* pi- + p + p ---> n + p *
17853* pi- + p + n ---> n + n *
17854* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17855* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17856* K- + p + p ---> sigma- + n *
17857* IDCAS, PCAS identity, momentum of particle to be absorbed *
17858* NCAS = 1 intranuclear cascade in projectile *
17859* = -1 intranuclear cascade in target *
17860* NSPE number of spectator nucleons involved *
17861* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17862* Revised version of the original STOPIK written by HJM and J. Ranft. *
17863* This version dated 24.02.95 is written by S. Roesler *
17864************************************************************************
17865
17866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17867 SAVE
17868
17869 PARAMETER ( LINP = 10 ,
17870 & LOUT = 6 ,
17871 & LDAT = 9 )
17872
17873 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17874 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17875
17876* event history
17877
17878 PARAMETER (NMXHKK=200000)
17879
17880 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17881 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17882 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17883
17884* extended event history
17885 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17886 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17887 & IHIST(2,NMXHKK)
17888
17889* flags for input different options
17890 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17891 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17892 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17893
17894* final state after inc step
17895 PARAMETER (MAXFSP=10)
17896 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17897
17898* particle properties (BAMJET index convention)
17899 CHARACTER*8 ANAME
17900 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17901 & IICH(210),IIBAR(210),K1(210),K2(210)
17902
17903 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17904 & PTOT3P(4),BG3P(4),
17905 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17906
17907 IREJ = 0
17908 NFSP = 0
17909
17910* skip particles others than ap, pi-, K- for mode=0
17911 IF ((MODE.EQ.0).AND.
17912 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17913* skip particles others than pions for mode=1
17914* (2-nucleon absorption in intranuclear cascade)
17915 IF ((MODE.EQ.1).AND.
17916 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17917
17918 NUCAS = NCAS
17919 IF (NUCAS.EQ.-1) NUCAS = 2
17920
17921 IF (MODE.EQ.0) THEN
17922* scan spectator nucleons for nucleons being able to "absorb"
17923 NSPE = 0
17924 IDXSPE(1) = 0
17925 IDXSPE(2) = 0
17926 DO 1 I=1,NHKK
17927 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17928 NSPE = NSPE+1
17929 IDXSPE(NSPE) = I
17930 IDSPE(NSPE) = IDBAM(I)
17931 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17932 IF (NSPE.EQ.2) THEN
17933 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17934 & (IDSPE(2).EQ.8)) THEN
17935* there is no pi-+n+n channel
17936 NSPE = 1
17937 GOTO 1
17938 ELSE
17939 GOTO 2
17940 ENDIF
17941 ENDIF
17942 ENDIF
17943 1 CONTINUE
17944
17945 2 CONTINUE
17946 ENDIF
17947* transform excited projectile nucleons (status=15) into proj. rest s.
17948 DO 3 I=1,NSPE
17949 DO 4 K=1,5
17950 PSPE(I,K) = PHKK(K,IDXSPE(I))
17951 4 CONTINUE
17952 3 CONTINUE
17953
17954* antiproton absorption
17955 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17956 DO 5 K=1,5
17957 PSPE1(K) = PSPE(1,K)
17958 5 CONTINUE
17959 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17960 IF (IREJ1.NE.0) GOTO 9999
17961
17962* meson absorption
17963 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17964 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17965 IF (IDCAS.EQ.14) THEN
17966* pi- absorption
17967 IDFSP(1) = 8
17968 IDFSP(2) = 8
17969 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17970 ELSEIF (IDCAS.EQ.13) THEN
17971* pi+ absorption
17972 IDFSP(1) = 1
17973 IDFSP(2) = 1
17974 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17975 ELSEIF (IDCAS.EQ.23) THEN
17976* pi0 absorption
17977 IDFSP(1) = IDSPE(1)
17978 IDFSP(2) = IDSPE(2)
17979 ELSEIF (IDCAS.EQ.16) THEN
17980* K- absorption
17981 R = DT_RNDM(PCAS)
17982 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17983 IF (R.LT.ONETHI) THEN
17984 IDFSP(1) = 21
17985 IDFSP(2) = 8
17986 ELSEIF (R.LT.TWOTHI) THEN
17987 IDFSP(1) = 17
17988 IDFSP(2) = 1
17989 ELSE
17990 IDFSP(1) = 22
17991 IDFSP(2) = 1
17992 ENDIF
17993 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17994 IDFSP(1) = 20
17995 IDFSP(2) = 8
17996 ELSE
17997 IF (R.LT.ONETHI) THEN
17998 IDFSP(1) = 20
17999 IDFSP(2) = 1
18000 ELSEIF (R.LT.TWOTHI) THEN
18001 IDFSP(1) = 17
18002 IDFSP(2) = 8
18003 ELSE
18004 IDFSP(1) = 22
18005 IDFSP(2) = 8
18006 ENDIF
18007 ENDIF
18008 ENDIF
18009* dump initial particles for energy-momentum cons. check
18010 IF (LEMCCK) THEN
18011 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18012 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18013 & IDUM,IDUM)
18014 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18015 & IDUM,IDUM)
18016 ENDIF
18017* get Lorentz-parameter of 3 particle initial state
18018 DO 6 K=1,4
18019 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18020 6 CONTINUE
18021 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18022 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18023 DO 7 K=1,4
18024 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18025 7 CONTINUE
18026* 2-particle decay of the 3-particle compound system
18027 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18028 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18029 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18030 DO 8 I=1,2
18031 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18032 PX = PCMF(I)*COFF(I)*SDF
18033 PY = PCMF(I)*SIFF(I)*SDF
18034 PZ = PCMF(I)*CODF(I)
18035 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18036 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18037 & PFSP(4,I))
18038 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18039* check consistency of kinematics
18040 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18041 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18042 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18043 & ' tree-particle kinematics',/,20X,'id: ',I3,
18044 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18045 ENDIF
18046* dump final state particles for energy-momentum cons. check
18047 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18048 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18049 8 CONTINUE
18050 NFSP = 2
18051 IF (LEMCCK) THEN
18052 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18053 IF (IREJ1.NE.0) THEN
18054 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18055 & AM3P
18056 GOTO 9999
18057 ENDIF
18058 ENDIF
18059 ELSE
18060 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18061 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18062 & ' impossible',/,20X,'too few spectators (',I2,')')
18063 NSPE = 0
18064 ENDIF
18065
18066 RETURN
18067
18068 9999 CONTINUE
18069 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18070 IREJ = 1
18071 RETURN
18072 END
18073
18074*$ CREATE DT_HADRIN.FOR
18075*COPY DT_HADRIN
18076*
18077*===hadrin=============================================================*
18078*
18079 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18080
18081************************************************************************
18082* Interface to the HADRIN-routines for inelastic and elastic *
18083* scattering. *
18084* IDPR,PPR(5) identity, momentum of projectile *
18085* IDTA,PTA(5) identity, momentum of target *
18086* MODE = 1 inelastic interaction *
18087* = 2 elastic interaction *
18088* Revised version of the original FHAD. *
18089* This version dated 27.10.95 is written by S. Roesler *
18090************************************************************************
18091
18092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18093 SAVE
18094
18095 PARAMETER ( LINP = 10 ,
18096 & LOUT = 6 ,
18097 & LDAT = 9 )
18098
18099 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18100 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18101
18102 LOGICAL LCORR,LMSSG
18103
18104* flags for input different options
18105 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18106 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18107 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18108
18109* final state after inc step
18110 PARAMETER (MAXFSP=10)
18111 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18112
18113* particle properties (BAMJET index convention)
18114 CHARACTER*8 ANAME
18115 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18116 & IICH(210),IIBAR(210),K1(210),K2(210)
18117* output-common for DHADRI/ELHAIN
18118
18119* final state from HADRIN interaction
18120 PARAMETER (MAXFIN=10)
18121 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18122 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18123
18124 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18125 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18126
18127 DATA LMSSG /.TRUE./
18128
18129 IREJ = 0
18130 NFSP = 0
18131 KCORR = 0
18132 IMCORR(1) = 0
18133 IMCORR(2) = 0
18134 LCORR = .FALSE.
18135
18136* dump initial particles for energy-momentum cons. check
18137 IF (LEMCCK) THEN
18138 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18139 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18140 ENDIF
18141
18142 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18143 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18144 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18145 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18146 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18147 IF (LMSSG.AND.(IOULEV(3).GT.0))
18148 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18149 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18150 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18151 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18152 LMSSG = .FALSE.
18153 LCORR = .TRUE.
18154 ENDIF
18155
18156* convert initial state particles into particles which can be
18157* handled by HADRIN
18158 IDHPR = IDPR
18159 IDHTA = IDTA
18160 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18161 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18162 DO 1 K=1,4
18163 P1IN(K) = PPR(K)
18164 P2IN(K) = PTA(K)
18165 1 CONTINUE
18166 XM1 = AAM(IDHPR)
18167 XM2 = AAM(IDHTA)
18168 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18169 IF (IREJ1.GT.0) THEN
18170 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18171 GOTO 9999
18172 ENDIF
18173 DO 2 K=1,4
18174 PPR(K) = P1OUT(K)
18175 PTA(K) = P2OUT(K)
18176 2 CONTINUE
18177 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18178 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18179 ENDIF
18180
18181* Lorentz-parameter for trafo into rest-system of target
18182 DO 3 K=1,4
18183 BGTA(K) = PTA(K)/PTA(5)
18184 3 CONTINUE
18185* transformation of projectile into rest-system of target
18186 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18187 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18188 & PPR1(4))
18189
18190* direction cosines of projectile in target rest system
18191 CX = PPR1(1)/PPRTO1
18192 CY = PPR1(2)/PPRTO1
18193 CZ = PPR1(3)/PPRTO1
18194
18195* sample inelastic interaction
18196 IF (MODE.EQ.1) THEN
18197 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18198 IF (IRH.EQ.1) GOTO 9998
18199* sample elastic interaction
18200 ELSEIF (MODE.EQ.2) THEN
18201 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18202 IF (IREJ1.NE.0) THEN
18203 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18204 GOTO 9999
18205 ENDIF
18206 IF (IRH.EQ.1) GOTO 9998
18207 ELSE
18208 WRITE(LOUT,1001) MODE,INTHAD
18209 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18210 & I4,' (INTHAD =',I4,')')
18211 GOTO 9999
18212 ENDIF
18213
18214* transform final state particles back into Lab.
18215 DO 4 I=1,IRH
18216 NFSP = NFSP+1
18217 PX = CXRH(I)*PLRH(I)
18218 PY = CYRH(I)*PLRH(I)
18219 PZ = CZRH(I)*PLRH(I)
18220 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18221 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18222 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18223 IDFSP(NFSP) = ITRH(I)
18224 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18225 & PFSP(3,NFSP)**2
18226 IF (AMFSP2.LT.-TINY3) THEN
18227 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18228 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18229 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18230 & I2,') with negative mass^2',/,1X,5E12.4)
18231 GOTO 9999
18232 ELSE
18233 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18234 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18235 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18236 & PFSP(5,NFSP)
18237 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18238 & ' (id = ',I2,') with inconsistent mass',/,1X,
18239 & 2E12.4)
18240 KCORR = KCORR+1
18241 IF (KCORR.GT.2) GOTO 9999
18242 IMCORR(KCORR) = NFSP
18243 ENDIF
18244 ENDIF
18245* dump final state particles for energy-momentum cons. check
18246 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18247 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18248 4 CONTINUE
18249
18250* transform momenta on mass shell in case of inconsistencies in
18251* HADRIN
18252 IF (KCORR.GT.0) THEN
18253 IF (KCORR.EQ.2) THEN
18254 I1 = IMCORR(1)
18255 I2 = IMCORR(2)
18256 ELSE
18257 IF (IMCORR(1).EQ.1) THEN
18258 I1 = 1
18259 I2 = 2
18260 ELSE
18261 I1 = 1
18262 I2 = IMCORR(1)
18263 ENDIF
18264 ENDIF
18265 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18266 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18267 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18268 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18269 DO 5 K=1,4
18270 P1IN(K) = PFSP(K,I1)
18271 P2IN(K) = PFSP(K,I2)
18272 5 CONTINUE
18273 XM1 = AAM(IDFSP(I1))
18274 XM2 = AAM(IDFSP(I2))
18275 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18276 IF (IREJ1.GT.0) THEN
18277 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18278C GOTO 9999
18279 ENDIF
18280 DO 6 K=1,4
18281 PFSP(K,I1) = P1OUT(K)
18282 PFSP(K,I2) = P2OUT(K)
18283 6 CONTINUE
18284 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18285 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18286 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18287 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18288* dump final state particles for energy-momentum cons. check
18289 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18290 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18291 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18292 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18293 ENDIF
18294
18295* check energy-momentum conservation
18296 IF (LEMCCK) THEN
18297 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18298 IF (IREJ1.NE.0) GOTO 9999
18299 ENDIF
18300
18301 RETURN
18302
18303 9998 CONTINUE
18304 IREJ = 2
18305 RETURN
18306
18307 9999 CONTINUE
18308 IREJ = 1
18309 RETURN
18310 END
18311
18312*$ CREATE DT_HADCOL.FOR
18313*COPY DT_HADCOL
18314*
18315*===hadcol=============================================================*
18316*
18317 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18318
18319************************************************************************
18320* Interface to the HADRIN-routines for inelastic and elastic *
18321* scattering. This subroutine samples hadron-nucleus interactions *
18322* below DPM-threshold. *
18323* IDPROJ BAMJET-index of projectile hadron *
18324* PPN projectile momentum in target rest frame *
18325* IDXTAR DTEVT1-index of target nucleon undergoing *
18326* interaction with projectile hadron *
18327* This subroutine replaces HADHAD. *
18328* This version dated 5.5.95 is written by S. Roesler *
18329************************************************************************
18330
18331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18332 SAVE
18333
18334 PARAMETER ( LINP = 10 ,
18335 & LOUT = 6 ,
18336 & LDAT = 9 )
18337
18338 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18339
18340 LOGICAL LSTART
18341
18342* event history
18343
18344 PARAMETER (NMXHKK=200000)
18345
18346 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18347 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18348 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18349
18350* extended event history
18351 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18352 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18353 & IHIST(2,NMXHKK)
18354
18355* nuclear potential
18356 LOGICAL LFERMI
18357 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18358 & EBINDP(2),EBINDN(2),EPOT(2,210),
18359 & ETACOU(2),ICOUL,LFERMI
18360
18361* interface HADRIN-DPM
18362 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18363
18364* parameter for intranuclear cascade
18365 LOGICAL LPAULI
18366 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18367
18368* final state after inc step
18369 PARAMETER (MAXFSP=10)
18370 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18371
18372* particle properties (BAMJET index convention)
18373 CHARACTER*8 ANAME
18374 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18375 & IICH(210),IIBAR(210),K1(210),K2(210)
18376
18377 DIMENSION PPROJ(5),PNUC(5)
18378
18379 DATA LSTART /.TRUE./
18380
18381 IREJ = 0
18382
18383 NPOINT(1) = NHKK+1
18384
18385 TAUSAV = TAUFOR
18386**sr 6/9/01 commented
18387C TAUFOR = TAUFOR/2.0D0
18388**
18389 IF (LSTART) THEN
18390 WRITE(LOUT,1000)
18391 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18392 WRITE(LOUT,1001) TAUFOR
18393 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18394 & F5.1,' fm/c')
18395 LSTART = .FALSE.
18396 ENDIF
18397
18398 IDNUC = IDBAM(IDXTAR)
18399 IDNUC1 = IDT_MCHAD(IDNUC)
18400 IDPRO1 = IDT_MCHAD(IDPROJ)
18401
18402 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18403 IPROC = INTHAD
18404 ELSE
18405**
18406C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18407C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18408 DUMZER = ZERO
18409 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18410 SIGIN = SIGTOT-SIGEL
18411C SIGTOT = SIGIN+SIGEL
18412**
18413 IPROC = 1
18414 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18415 ENDIF
18416
18417 PPROJ(1) = ZERO
18418 PPROJ(2) = ZERO
18419 PPROJ(3) = PPN
18420 PPROJ(5) = AAM(IDPROJ)
18421 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18422 DO 1 K=1,5
18423 PNUC(K) = PHKK(K,IDXTAR)
18424 1 CONTINUE
18425
18426 ILOOP = 0
18427 2 CONTINUE
18428 ILOOP = ILOOP+1
18429 IF (ILOOP.GT.100) GOTO 9999
18430
18431 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18432 IF (IREJ1.EQ.1) GOTO 9999
18433
18434 IF (IREJ1.GT.1) THEN
18435* no interaction possible
18436* require Pauli blocking
18437 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18438 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18439 IF ((IIBAR(IDPROJ).NE.1).AND.
18440 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18441* store incoming particle as final state particle
18442 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18443 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18444 NPOINT(4) = NHKK
18445 ELSE
18446* require Pauli blocking for final state nucleons
18447 DO 4 I=1,NFSP
18448 IF ((IDFSP(I).EQ.1).AND.
18449 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18450 IF ((IDFSP(I).EQ.8).AND.
18451 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18452 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18453 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18454 4 CONTINUE
18455* store final state particles
18456 DO 5 I=1,NFSP
18457 IST = 1
18458 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18459 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18460 IDHAD = IDT_IPDGHA(IDFSP(I))
18461 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18462 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18463 & PCMS,ECMS,0,0,0)
18464 IF (I.EQ.1) NPOINT(4) = NHKK
18465 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18466 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18467 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18468 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18469 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18470 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18471 WHKK(3,NHKK) = WHKK(3,1)
18472 WHKK(4,NHKK) = WHKK(4,1)
18473 5 CONTINUE
18474 ENDIF
18475 TAUFOR = TAUSAV
18476 RETURN
18477
18478 9999 CONTINUE
18479 IREJ = 1
18480 TAUFOR = TAUSAV
18481 RETURN
18482 END
18483*$ CREATE DT_GETEMU.FOR
18484*COPY DT_GETEMU
18485*
18486*===getemu=============================================================*
18487*
18488 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18489
18490************************************************************************
18491* Sampling of emulsion component to be considered as target-nucleus. *
18492* This version dated 6.5.95 is written by S. Roesler. *
18493************************************************************************
18494
18495 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18496 SAVE
18497
18498 PARAMETER ( LINP = 10 ,
18499 & LOUT = 6 ,
18500 & LDAT = 9 )
18501
18502 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18503
18504 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18505
18506* emulsion treatment
18507 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18508 & NCOMPO,IEMUL
18509
18510* Glauber formalism: flags and parameters for statistics
18511 LOGICAL LPROD
18512 CHARACTER*8 CGLB
18513 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18514
18515 IF (MODE.EQ.0) THEN
18516 SUMFRA = ZERO
18517 RR = DT_RNDM(SUMFRA)
18518 IT = 0
18519 ITZ = 0
18520 DO 1 ICOMP=1,NCOMPO
18521 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18522 IF (SUMFRA.GT.RR) THEN
18523 IT = IEMUMA(ICOMP)
18524 ITZ = IEMUCH(ICOMP)
18525 KKMAT = ICOMP
18526 GOTO 2
18527 ENDIF
18528 1 CONTINUE
18529 2 CONTINUE
18530 IF (IT.LE.0) THEN
18531 WRITE(LOUT,'(1X,A,E12.3)')
18532 & 'Warning! norm. failure within emulsion fractions',
18533 & SUMFRA
18534 STOP
18535 ENDIF
18536 ELSEIF (MODE.EQ.1) THEN
18537 NDIFF = 10000
18538 DO 3 I=1,NCOMPO
18539 IDIFF = ABS(IT-IEMUMA(I))
18540 IF (IDIFF.LT.NDIFF) THEN
18541 KKMAT = I
18542 NDIFF = IDIFF
18543 ENDIF
18544 3 CONTINUE
18545 ELSE
18546 STOP 'DT_GETEMU'
18547 ENDIF
18548
18549* bypass for variable projectile/target/energy runs: the correct
18550* Glauber data will be always loaded on kkmat=1
18551 IF (IOGLB.EQ.100) THEN
18552 KKMAT = 1
18553 ENDIF
18554
18555 RETURN
18556 END
18557
18558*$ CREATE DT_NCLPOT.FOR
18559*COPY DT_NCLPOT
18560*
18561*===nclpot=============================================================*
18562*
18563 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18564
18565************************************************************************
18566* Calculation of Coulomb and nuclear potential for a given configurat. *
18567* IPZ, IP charge/mass number of proj. *
18568* ITZ, IT charge/mass number of targ. *
18569* AFERP,AFERT factors modifying proj./target pot. *
18570* if =0, FERMOD is used *
18571* MODE = 0 calculation of binding energy *
18572* = 1 pre-calculated binding energy is used *
18573* This version dated 16.11.95 is written by S. Roesler. *
18574* *
18575* Last change 28.12.2006 by S. Roesler. *
18576************************************************************************
18577
18578 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18579 SAVE
18580
18581 PARAMETER ( LINP = 10 ,
18582 & LOUT = 6 ,
18583 & LDAT = 9 )
18584
18585 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18586 & TINY10=1.0D-10)
18587
18588 LOGICAL LSTART
18589
18590* particle properties (BAMJET index convention)
18591 CHARACTER*8 ANAME
18592 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18593 & IICH(210),IIBAR(210),K1(210),K2(210)
18594
18595* nuclear potential
18596 LOGICAL LFERMI
18597 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18598 & EBINDP(2),EBINDN(2),EPOT(2,210),
18599 & ETACOU(2),ICOUL,LFERMI
18600
18601 DIMENSION IDXPOT(14)
18602* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18603 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18604* asig0 asig+ atet0 atet+
18605 & 100, 101, 102, 103/
18606
18607 DATA AN /0.4D0/
18608 DATA LSTART /.TRUE./
18609
18610 IF (MODE.EQ.0) THEN
18611 EBINDP(1) = ZERO
18612 EBINDN(1) = ZERO
18613 EBINDP(2) = ZERO
18614 EBINDN(2) = ZERO
18615 ENDIF
18616 AIP = DBLE(IP)
18617 AIPZ = DBLE(IPZ)
18618 AIT = DBLE(IT)
18619 AITZ = DBLE(ITZ)
18620
18621 FERMIP = AFERP
18622 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18623 FERMIT = AFERT
18624 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18625
18626* Fermi momenta and binding energy for projectile
18627 IF ((IP.GT.1).AND.LFERMI) THEN
18628 IF (MODE.EQ.0) THEN
18629C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18630C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18631 BIP = AIP -ONE
18632 BIPZ = AIPZ-ONE
18633
18634C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18635C & -ENERGY(AIP,AIPZ))
18636 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18637 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18638 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18639
18640 IF (AIP.LE.AIPZ) THEN
18641 EBINDN(1) = EBINDP(1)
18642 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18643 ELSE
18644
18645C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18646C & -ENERGY(AIP,AIPZ))
18647 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18648 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18649 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18650
18651 ENDIF
18652 ENDIF
18653 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18654 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18655 ELSE
18656 PFERMP(1) = ZERO
18657 PFERMN(1) = ZERO
18658 ENDIF
18659* effective nuclear potential for projectile
18660C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18661C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18662 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18663 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18664
18665* Fermi momenta and binding energy for target
18666 IF ((IT.GT.1).AND.LFERMI) THEN
18667 IF (MODE.EQ.0) THEN
18668C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18669C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18670 BIT = AIT -ONE
18671 BITZ = AITZ-ONE
18672
18673C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18674C & -ENERGY(AIT,AITZ))
18675 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18676 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18677 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18678
18679 IF (AIT.LE.AITZ) THEN
18680 EBINDN(2) = EBINDP(2)
18681 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18682 ELSE
18683
18684C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18685C & -ENERGY(AIT,AITZ))
18686 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18687 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18688 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18689
18690 ENDIF
18691 ENDIF
18692 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18693 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18694 ELSE
18695 PFERMP(2) = ZERO
18696 PFERMN(2) = ZERO
18697 ENDIF
18698* effective nuclear potential for target
18699C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18700C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18701 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18702 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18703
18704 DO 2 I=1,14
18705 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18706 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18707 2 CONTINUE
18708
18709* Coulomb energy
18710 ETACOU(1) = ZERO
18711 ETACOU(2) = ZERO
18712 IF (ICOUL.EQ.1) THEN
18713 IF (IP.GT.1)
18714 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18715 IF (IT.GT.1)
18716 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18717 ENDIF
18718
18719 IF (LSTART) THEN
18720 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18721 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18722 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18723 & FERMOD,ETACOU
18724 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18725 & ,' effects',/,12X,'---------------------------',
18726 & '----------------',/,/,38X,'projectile',
18727 & ' target',/,/,1X,'Mass number / charge',
18728 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18729 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18730 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18731 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18732 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18733 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18734 LSTART = .FALSE.
18735 ENDIF
18736
18737 RETURN
18738 END
18739
18740*$ CREATE DT_RESNCL.FOR
18741*COPY DT_RESNCL
18742*
18743*===resncl=============================================================*
18744*
18745 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18746
18747************************************************************************
18748* Treatment of residual nuclei and nuclear effects. *
18749* MODE = 1 initializations *
18750* = 2 treatment of final state *
18751* This version dated 16.11.95 is written by S. Roesler. *
18752* *
18753* Last change 05.01.2007 by S. Roesler. *
18754************************************************************************
18755
18756 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18757 SAVE
18758
18759 PARAMETER ( LINP = 10 ,
18760 & LOUT = 6 ,
18761 & LDAT = 9 )
18762
18763 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18764 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18765 & ONETHI=ONE/THREE)
18766 PARAMETER (AMUAMU = 0.93149432D0,
18767 & FM2MM = 1.0D-12,
18768 & RNUCLE = 1.12D0)
18769 PARAMETER ( EMVGEV = 1.0 D-03 )
18770 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18771 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18772 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18773 PARAMETER ( AMELCT = 0.51099906 D-03 )
18774 PARAMETER ( HLFHLF = 0.5D+00 )
18775 PARAMETER ( FERTHO = 14.33 D-09 )
18776 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18777 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18778 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18779
18780* event history
18781
18782 PARAMETER (NMXHKK=200000)
18783
18784 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18785 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18786 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18787
18788* extended event history
18789 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18790 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18791 & IHIST(2,NMXHKK)
18792
18793* particle properties (BAMJET index convention)
18794 CHARACTER*8 ANAME
18795 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18796 & IICH(210),IIBAR(210),K1(210),K2(210)
18797
18798* flags for input different options
18799 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18800 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18801 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18802
18803* nuclear potential
18804 LOGICAL LFERMI
18805 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18806 & EBINDP(2),EBINDN(2),EPOT(2,210),
18807 & ETACOU(2),ICOUL,LFERMI
18808
18809* properties of interacting particles
18810 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18811
18812* properties of photon/lepton projectiles
18813 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18814
18815* Lorentz-parameters of the current interaction
18816 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18817 & UMO,PPCM,EPROJ,PPROJ
18818
18819* treatment of residual nuclei: wounded nucleons
18820 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18821
18822* treatment of residual nuclei: 4-momenta
18823 LOGICAL LRCLPR,LRCLTA
18824 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18825 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18826
18827 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18828 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18829 & IDXCOR(15000),IDXOTH(NMXHKK)
18830
18831 GOTO (1,2) MODE
18832
18833*------- initializations
18834 1 CONTINUE
18835
18836* initialize arrays for residual nuclei
18837 DO 10 K=1,5
18838 IF (K.LE.4) THEN
18839 PFSP(K) = ZERO
18840 ENDIF
18841 PINIPR(K) = ZERO
18842 PINITA(K) = ZERO
18843 PRCLPR(K) = ZERO
18844 PRCLTA(K) = ZERO
18845 TRCLPR(K) = ZERO
18846 TRCLTA(K) = ZERO
18847 10 CONTINUE
18848 SCPOT = ONE
18849 NLOOP = 0
18850
18851* correction of projectile 4-momentum for effective target pot.
18852* and Coulomb-energy (in case of hadron-nucleus interaction only)
18853 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18854 EPNI = EPN
18855* Coulomb-energy:
18856* positively charged hadron - check energy for Coloumb pot.
18857 IF (IICH(IJPROJ).EQ.1) THEN
18858 THRESH = ETACOU(2)+AAM(IJPROJ)
18859 IF (EPNI.LE.THRESH) THEN
18860 WRITE(LOUT,1000)
18861 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18862 & ' below Coulomb threshold - event rejected',/)
18863 ISTHKK(1) = 1
18864 RETURN
18865 ENDIF
18866* negatively charged hadron - increase energy by Coulomb energy
18867 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18868 EPNI = EPNI+ETACOU(2)
18869 ENDIF
18870 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18871* Effective target potential
18872*sr 6.6. binding energy only (to avoid negative exc. energies)
18873C EPNI = EPNI+EPOT(2,IJPROJ)
18874 EBIPOT = EBINDP(2)
18875 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18876 & EBIPOT = EBINDN(2)
18877 EPNI = EPNI+ABS(EBIPOT)
18878* re-initialization of DTLTRA
18879 DUM1 = ZERO
18880 DUM2 = ZERO
18881 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18882 ENDIF
18883 ENDIF
18884
18885* projectile in n-n cms
18886 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18887 PMASS1 = AAM(IJPROJ)
18888C* VDM assumption
18889C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18890 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18891 PMASS2 = AAM(1)
18892 PM1 = SIGN(PMASS1**2,PMASS1)
18893 PM2 = SIGN(PMASS2**2,PMASS2)
18894 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18895 PINIPR(5) = PMASS1
18896 IF (PMASS1.GT.ZERO) THEN
18897 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18898 & *(PINIPR(4)+PINIPR(5)))
18899 ELSE
18900 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18901 ENDIF
18902 AIT = DBLE(IT)
18903 AITZ = DBLE(ITZ)
18904
18905C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18906 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18907
18908 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18909 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18910 PMASS1 = AAM(1)
18911 PMASS2 = AAM(IJTARG)
18912 PM1 = SIGN(PMASS1**2,PMASS1)
18913 PM2 = SIGN(PMASS2**2,PMASS2)
18914 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18915 PINITA(5) = PMASS2
18916 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18917 & *(PINITA(4)+PINITA(5)))
18918 AIP = DBLE(IP)
18919 AIPZ = DBLE(IPZ)
18920
18921C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18922 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18923
18924 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18925 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18926 AIP = DBLE(IP)
18927 AIPZ = DBLE(IPZ)
18928
18929C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18930 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18931
18932 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18933 AIT = DBLE(IT)
18934 AITZ = DBLE(ITZ)
18935
18936C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18937 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18938
18939 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18940 ENDIF
18941
18942 RETURN
18943
18944*------- treatment of final state
18945 2 CONTINUE
18946
18947 NLOOP = NLOOP+1
18948 IF (NLOOP.GT.1) SCPOT = 0.10D0
18949C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18950
18951 JPW = NPW
18952 JPCW = NPCW
18953 JTW = NTW
18954 JTCW = NTCW
18955 DO 40 K=1,4
18956 PFSP(K) = ZERO
18957 40 CONTINUE
18958
18959 NOB = 0
18960 NOM = 0
18961 DO 900 I=NPOINT(4),NHKK
18962 IDXOTH(I) = -1
18963 IF (ISTHKK(I).EQ.1) THEN
18964 IF (IDBAM(I).EQ.7) GOTO 900
18965 IPOT = 0
18966 IOTHER = 0
18967* particle moving into forward direction
18968 IF (PHKK(3,I).GE.ZERO) THEN
18969* most likely to be effected by projectile potential
18970 IPOT = 1
18971* there is no projectile nucleus, try target
18972 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18973 IPOT = 2
18974 IF (IP.GT.1) IOTHER = 1
18975* there is no target nucleus --> skip
18976 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18977 ENDIF
18978* particle moving into backward direction
18979 ELSE
18980* most likely to be effected by target potential
18981 IPOT = 2
18982* there is no target nucleus, try projectile
18983 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18984 IPOT = 1
18985 IF (IT.GT.1) IOTHER = 1
18986* there is no projectile nucleus --> skip
18987 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18988 ENDIF
18989 ENDIF
18990 IFLG = -IPOT
18991* nobam=3: particle is in overlap-region or neither inside proj. nor target
18992* =1: particle is not in overlap-region AND is inside target (2)
18993* =2: particle is not in overlap-region AND is inside projectile (1)
18994* flag particles which are inside the nucleus ipot but not in its
18995* overlap region
18996 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18997 IF (IDBAM(I).NE.0) THEN
18998* baryons: keep all nucleons and all others where flag is set
18999 IF (IIBAR(IDBAM(I)).NE.0) THEN
19000 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19001 & THEN
19002 NOB = NOB+1
19003 PMOMB(NOB) = PHKK(3,I)
19004 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
19005 & +1000000*IOTHER+I,IFLG)
19006 ENDIF
19007* mesons: keep only those mesons where flag is set
19008 ELSE
19009 IF (IFLG.GT.0) THEN
19010 NOM = NOM+1
19011 PMOMM(NOM) = PHKK(3,I)
19012 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19013 ENDIF
19014 ENDIF
19015 ENDIF
19016 ENDIF
19017 900 CONTINUE
19018*
19019* sort particles in the arrays according to increasing long. momentum
19020 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19021 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19022*
19023* shuffle indices into one and the same array according to the later
19024* sequence of correction
19025 NCOR = 0
19026 IF (IT.GT.1) THEN
19027 DO 910 I=1,NOB
19028 IF (PMOMB(I).GT.ZERO) GOTO 911
19029 NCOR = NCOR+1
19030 IDXCOR(NCOR) = IDXB(I)
19031 910 CONTINUE
19032 911 CONTINUE
19033 IF (IP.GT.1) THEN
19034 DO 912 J=1,NOB
19035 I = NOB+1-J
19036 IF (PMOMB(I).LT.ZERO) GOTO 913
19037 NCOR = NCOR+1
19038 IDXCOR(NCOR) = IDXB(I)
19039 912 CONTINUE
19040 913 CONTINUE
19041 ELSE
19042 DO 914 I=1,NOB
19043 IF (PMOMB(I).GT.ZERO) THEN
19044 NCOR = NCOR+1
19045 IDXCOR(NCOR) = IDXB(I)
19046 ENDIF
19047 914 CONTINUE
19048 ENDIF
19049 ELSE
19050 DO 915 J=1,NOB
19051 I = NOB+1-J
19052 NCOR = NCOR+1
19053 IDXCOR(NCOR) = IDXB(I)
19054 915 CONTINUE
19055 ENDIF
19056 DO 925 I=1,NOM
19057 IF (PMOMM(I).GT.ZERO) GOTO 926
19058 NCOR = NCOR+1
19059 IDXCOR(NCOR) = IDXM(I)
19060 925 CONTINUE
19061 926 CONTINUE
19062 DO 927 J=1,NOM
19063 I = NOM+1-J
19064 IF (PMOMM(I).LT.ZERO) GOTO 928
19065 NCOR = NCOR+1
19066 IDXCOR(NCOR) = IDXM(I)
19067 927 CONTINUE
19068 928 CONTINUE
19069*
19070C IF (NEVHKK.EQ.484) THEN
19071C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19072C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19073C WRITE(LOUT,9001) NOB,NOM,NCOR
19074C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19075C WRITE(LOUT,'(/,A)') ' baryons '
19076C DO 950 I=1,NOB
19077CC J = IABS(IDXB(I))
19078CC INDEX = J-IABS(J/10000000)*10000000
19079C IPOT = IABS(IDXB(I))/10000000
19080C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19081C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19082C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19083C 950 CONTINUE
19084C WRITE(LOUT,'(/,A)') ' mesons '
19085C DO 951 I=1,NOM
19086CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19087C IPOT = IABS(IDXM(I))/10000000
19088C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19089C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19090C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19091C 951 CONTINUE
19092C 9002 FORMAT(1X,4I14,E14.5)
19093C WRITE(LOUT,'(/,A)') ' all '
19094C DO 952 I=1,NCOR
19095CC J = IABS(IDXCOR(I))
19096CC INDEX = J-IABS(J/10000000)*10000000
19097CC IPOT = IABS(IDXCOR(I))/10000000
19098C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19099C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19100C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19101C 952 CONTINUE
19102C 9003 FORMAT(1X,4I14)
19103C ENDIF
19104*
19105 DO 20 ICOR=1,NCOR
19106 IPOT = IABS(IDXCOR(ICOR))/10000000
19107 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19108 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19109 IDXOTH(I) = 1
19110
19111 IDSEC = IDBAM(I)
19112
19113* reduction of particle momentum by corresponding nuclear potential
19114* (this applies only if Fermi-momenta are requested)
19115
19116 IF (LFERMI) THEN
19117
19118* Lorentz-transformation into the rest system of the selected nucleus
19119 IMODE = -IPOT-1
19120 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19121 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19122 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19123 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19124 JPMOD = 0
19125
19126 CHKLEV = TINY3
19127 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19128 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19129 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19130 IF (IOULEV(3).GT.0)
19131 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19132 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19133 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19134 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19135 GOTO 23
19136 ENDIF
19137
19138 DO 21 K=1,4
19139 PSEC0(K) = PSEC(K)
19140 21 CONTINUE
19141
19142* the correction for nuclear potential effects is applied to as many
19143* p/n as many nucleons were wounded; the momenta of other final state
19144* particles are corrected only if they materialize inside the corresp.
19145* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19146* = 3 part. outside proj. and targ., >=10 in overlapping region)
19147 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19148 IF (IPOT.EQ.1) THEN
19149 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19150* this is most likely a wounded nucleon
19151**test
19152C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19153C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19154C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19155C RAD = RNUCLE*DBLE(IP)**ONETHI
19156C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19157C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19158**
19159 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19160 JPW = JPW-1
19161 JPMOD = 1
19162 ELSE
19163* correct only if part. was materialized inside nucleus
19164* and if it is ouside the overlapping region
19165 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19166 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19167 JPMOD = 1
19168 ENDIF
19169 ENDIF
19170 ELSEIF (IPOT.EQ.2) THEN
19171 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19172* this is most likely a wounded nucleon
19173**test
19174C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19175C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19176C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19177C RAD = RNUCLE*DBLE(IT)**ONETHI
19178C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19179C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19180**
19181 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19182 JTW = JTW-1
19183 JPMOD = 1
19184 ELSE
19185* correct only if part. was materialized inside nucleus
19186 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19187 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19188 JPMOD = 1
19189 ENDIF
19190 ENDIF
19191 ENDIF
19192 ELSE
19193 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19194 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19195 JPMOD = 1
19196 ENDIF
19197 ENDIF
19198
19199 IF (NLOOP.EQ.1) THEN
19200* Coulomb energy correction:
19201* the treatment of Coulomb potential correction is similar to the
19202* one for nuclear potential
19203 IF (IDSEC.EQ.1) THEN
19204 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19205 JPCW = JPCW-1
19206 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19207 JTCW = JTCW-1
19208 ELSE
19209 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19210 ENDIF
19211 ELSE
19212 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19213 ENDIF
19214 IF (IICH(IDSEC).EQ.1) THEN
19215* pos. particles: check if they are able to escape Coulomb potential
19216 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19217 ISTHKK(I) = 14+IPOT
19218 IF (ISTHKK(I).EQ.15) THEN
19219 DO 26 K=1,4
19220 PHKK(K,I) = PSEC0(K)
19221 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19222 26 CONTINUE
19223 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19224 IF (IDSEC.EQ.1) NPCW = NPCW-1
19225 ELSEIF (ISTHKK(I).EQ.16) THEN
19226 DO 27 K=1,4
19227 PHKK(K,I) = PSEC0(K)
19228 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19229 27 CONTINUE
19230 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19231 IF (IDSEC.EQ.1) NTCW = NTCW-1
19232 ENDIF
19233 GOTO 20
19234 ENDIF
19235 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19236* neg. particles: decrease energy by Coulomb-potential
19237 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19238 JPMOD = 1
19239 ENDIF
19240 ENDIF
19241
19242 25 CONTINUE
19243
19244 IF (PSEC(4).LT.AMSEC) THEN
19245 IF (IOULEV(6).GT.0)
19246 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19247 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19248 & ' is not allowed to escape nucleus',/,
19249 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19250 & ' mass: ',E12.3)
19251 ISTHKK(I) = 14+IPOT
19252 IF (ISTHKK(I).EQ.15) THEN
19253 DO 28 K=1,4
19254 PHKK(K,I) = PSEC0(K)
19255 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19256 28 CONTINUE
19257 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19258 IF (IDSEC.EQ.1) NPCW = NPCW-1
19259 ELSEIF (ISTHKK(I).EQ.16) THEN
19260 DO 29 K=1,4
19261 PHKK(K,I) = PSEC0(K)
19262 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19263 29 CONTINUE
19264 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19265 IF (IDSEC.EQ.1) NTCW = NTCW-1
19266 ENDIF
19267 GOTO 20
19268 ENDIF
19269
19270 IF (JPMOD.EQ.1) THEN
19271 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19272* 4-momentum after correction for nuclear potential
19273 DO 22 K=1,3
19274 PSEC(K) = PSEC(K)*PSECN/PSECO
19275 22 CONTINUE
19276
19277* store recoil momentum from particles escaping the nuclear potentials
19278 DO 30 K=1,4
19279 IF (IPOT.EQ.1) THEN
19280 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19281 ELSEIF (IPOT.EQ.2) THEN
19282 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19283 ENDIF
19284 30 CONTINUE
19285
19286* transform momentum back into n-n cms
19287 IMODE = IPOT+1
19288 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19289 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19290 & IDSEC,IMODE)
19291 ENDIF
19292
19293 ENDIF
19294
19295 23 CONTINUE
19296 DO 31 K=1,4
19297 PFSP(K) = PFSP(K)+PHKK(K,I)
19298 31 CONTINUE
19299
19300 20 CONTINUE
19301
19302 DO 33 I=NPOINT(4),NHKK
19303 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19304 PFSP(1) = PFSP(1)+PHKK(1,I)
19305 PFSP(2) = PFSP(2)+PHKK(2,I)
19306 PFSP(3) = PFSP(3)+PHKK(3,I)
19307 PFSP(4) = PFSP(4)+PHKK(4,I)
19308 ENDIF
19309 33 CONTINUE
19310
19311 DO 34 K=1,5
19312 PRCLPR(K) = TRCLPR(K)
19313 PRCLTA(K) = TRCLTA(K)
19314 34 CONTINUE
19315
19316 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19317* hadron-nucleus interactions: get residual momentum from energy-
19318* momentum conservation
19319 DO 32 K=1,4
19320 PRCLPR(K) = ZERO
19321 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19322 32 CONTINUE
19323 ELSE
19324* nucleus-hadron, nucleus-nucleus: get residual momentum from
19325* accumulated recoil momenta of particles leaving the spectators
19326* transform accumulated recoil momenta of residual nuclei into
19327* n-n cms
19328 PZI = PRCLPR(3)
19329 PEI = PRCLPR(4)
19330 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19331 PZI = PRCLTA(3)
19332 PEI = PRCLTA(4)
19333 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19334C IF (IP.GT.1) THEN
19335 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19336 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19337C ENDIF
19338 IF (IT.GT.1) THEN
19339 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19340 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19341 ENDIF
19342 ENDIF
19343
19344* check momenta of residual nuclei
19345 IF (LEMCCK) THEN
19346 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19347 & 1,IDUM,IDUM)
19348 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19349 & 2,IDUM,IDUM)
19350 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19351 & 2,IDUM,IDUM)
19352 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19353 & 2,IDUM,IDUM)
19354 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19355**sr 19.12. changed to avoid output when used with phojet
19356C CHKLEV = TINY3
19357 CHKLEV = TINY1
19358 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19359C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19360C & CALL DT_EVTOUT(4)
19361 IF (IREJ1.GT.0) RETURN
19362 ENDIF
19363
19364 RETURN
19365 END
19366
19367*$ CREATE DT_SCN4BA.FOR
19368*COPY DT_SCN4BA
19369*
19370*===scn4ba=============================================================*
19371*
19372 SUBROUTINE DT_SCN4BA
19373
19374************************************************************************
19375* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19376* This version dated 12.12.95 is written by S. Roesler. *
19377************************************************************************
19378
19379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19380 SAVE
19381
19382 PARAMETER ( LINP = 10 ,
19383 & LOUT = 6 ,
19384 & LDAT = 9 )
19385
19386 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19387 & TINY10=1.0D-10)
19388
19389* event history
19390
19391 PARAMETER (NMXHKK=200000)
19392
19393 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19394 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19395 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19396
19397* extended event history
19398 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19399 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19400 & IHIST(2,NMXHKK)
19401
19402* particle properties (BAMJET index convention)
19403 CHARACTER*8 ANAME
19404 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19405 & IICH(210),IIBAR(210),K1(210),K2(210)
19406
19407* properties of interacting particles
19408 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19409
19410* nuclear potential
19411 LOGICAL LFERMI
19412 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19413 & EBINDP(2),EBINDN(2),EPOT(2,210),
19414 & ETACOU(2),ICOUL,LFERMI
19415
19416* treatment of residual nuclei: wounded nucleons
19417 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19418
19419* treatment of residual nuclei: 4-momenta
19420 LOGICAL LRCLPR,LRCLTA
19421 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19422 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19423
19424 DIMENSION PLAB(2,5),PCMS(4)
19425
19426 IREJ = 0
19427
19428* get number of wounded nucleons
19429 NPW = 0
19430 NPW0 = 0
19431 NPCW = 0
19432 NPSTCK = 0
19433 NTW = 0
19434 NTW0 = 0
19435 NTCW = 0
19436 NTSTCK = 0
19437
19438 ISGLPR = 0
19439 ISGLTA = 0
19440 LRCLPR = .FALSE.
19441 LRCLTA = .FALSE.
19442
19443C DO 2 I=1,NHKK
19444 DO 2 I=1,NPOINT(1)
19445* projectile nucleons wounded in primary interaction and in fzc
19446 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19447 NPW = NPW+1
19448 IPW(NPW) = I
19449 NPSTCK = NPSTCK+1
19450 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19451 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19452C IF (IP.GT.1) THEN
19453 DO 5 K=1,4
19454 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19455 5 CONTINUE
19456C ENDIF
19457* target nucleons wounded in primary interaction and in fzc
19458 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19459 NTW = NTW+1
19460 ITW(NTW) = I
19461 NTSTCK = NTSTCK+1
19462 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19463 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19464 IF (IT.GT.1) THEN
19465 DO 6 K=1,4
19466 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19467 6 CONTINUE
19468 ENDIF
19469 ELSEIF (ISTHKK(I).EQ.13) THEN
19470 ISGLPR = I
19471 ELSEIF (ISTHKK(I).EQ.14) THEN
19472 ISGLTA = I
19473 ENDIF
19474 2 CONTINUE
19475
19476 DO 11 I=NPOINT(4),NHKK
19477* baryons which are unable to escape the nuclear potential of proj.
19478 IF (ISTHKK(I).EQ.15) THEN
19479 ISGLPR = I
19480 NPSTCK = NPSTCK-1
19481 IF (IIBAR(IDBAM(I)).NE.0) THEN
19482 NPW = NPW-1
19483 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19484 ENDIF
19485 DO 7 K=1,4
19486 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19487 7 CONTINUE
19488* baryons which are unable to escape the nuclear potential of targ.
19489 ELSEIF (ISTHKK(I).EQ.16) THEN
19490 ISGLTA = I
19491 NTSTCK = NTSTCK-1
19492 IF (IIBAR(IDBAM(I)).NE.0) THEN
19493 NTW = NTW-1
19494 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19495 ENDIF
19496 DO 8 K=1,4
19497 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19498 8 CONTINUE
19499 ENDIF
19500 11 CONTINUE
19501
19502* residual nuclei so far
19503 IRESP = IP-NPSTCK
19504 IREST = IT-NTSTCK
19505
19506* ckeck for "residual nuclei" consisting of one nucleon only
19507* treat it as final state particle
19508 IF (IRESP.EQ.1) THEN
19509 ID = IDBAM(ISGLPR)
19510 IST = ISTHKK(ISGLPR)
19511 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19512 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19513 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19514 IF (IST.EQ.13) THEN
19515 ISTHKK(ISGLPR) = 11
19516 ELSE
19517 ISTHKK(ISGLPR) = 2
19518 ENDIF
19519 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19520 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19521 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19522 NOBAM(NHKK) = NOBAM(ISGLPR)
19523 JDAHKK(1,ISGLPR) = NHKK
19524 DO 21 K=1,4
19525 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19526 21 CONTINUE
19527 ENDIF
19528 IF (IREST.EQ.1) THEN
19529 ID = IDBAM(ISGLTA)
19530 IST = ISTHKK(ISGLTA)
19531 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19532 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19533 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19534 IF (IST.EQ.14) THEN
19535 ISTHKK(ISGLTA) = 12
19536 ELSE
19537 ISTHKK(ISGLTA) = 2
19538 ENDIF
19539 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19540 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19541 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19542 NOBAM(NHKK) = NOBAM(ISGLTA)
19543 JDAHKK(1,ISGLTA) = NHKK
19544 DO 22 K=1,4
19545 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19546 22 CONTINUE
19547 ENDIF
19548
19549* get nuclear potential corresp. to the residual nucleus
19550 IPRCL = IP -NPW
19551 IPZRCL = IPZ-NPCW
19552 ITRCL = IT -NTW
19553 ITZRCL = ITZ-NTCW
19554 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19555
19556* baryons unable to escape the nuclear potential are treated as
19557* excited nucleons (ISTHKK=15,16)
19558 DO 3 I=NPOINT(4),NHKK
19559 IF (ISTHKK(I).EQ.1) THEN
19560 ID = IDBAM(I)
19561 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19562* final state n and p not being outside of both nuclei are considered
19563 NPOTP = 1
19564 NPOTT = 1
19565 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19566 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19567* Lorentz-trsf. into proj. rest sys. for those being inside proj.
19568 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19569 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19570 & PLAB(1,4),ID,-2)
19571 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19572 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19573 & (PLAB(1,4)+PLABT) ))
19574 EKIN = PLAB(1,4)-PLAB(1,5)
19575 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19576 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19577 ENDIF
19578 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19579 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19580* Lorentz-trsf. into targ. rest sys. for those being inside targ.
19581 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19582 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19583 & PLAB(2,4),ID,-3)
19584 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19585 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19586 & (PLAB(2,4)+PLABT) ))
19587 EKIN = PLAB(2,4)-PLAB(2,5)
19588 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19589 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19590 ENDIF
19591 IF (PHKK(3,I).GE.ZERO) THEN
19592 ISTHKK(I) = NPOTT
19593 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19594 ELSE
19595 ISTHKK(I) = NPOTP
19596 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19597 ENDIF
19598 IF (ISTHKK(I).NE.1) THEN
19599 J = ISTHKK(I)-14
19600 DO 4 K=1,5
19601 PHKK(K,I) = PLAB(J,K)
19602 4 CONTINUE
19603 IF (ISTHKK(I).EQ.15) THEN
19604 NPW = NPW-1
19605 IF (ID.EQ.1) NPCW = NPCW-1
19606 DO 9 K=1,4
19607 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19608 9 CONTINUE
19609 ELSEIF (ISTHKK(I).EQ.16) THEN
19610 NTW = NTW-1
19611 IF (ID.EQ.1) NTCW = NTCW-1
19612 DO 10 K=1,4
19613 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19614 10 CONTINUE
19615 ENDIF
19616 ENDIF
19617 ENDIF
19618 ENDIF
19619 3 CONTINUE
19620
19621* again: get nuclear potential corresp. to the residual nucleus
19622 IPRCL = IP -NPW
19623 IPZRCL = IPZ-NPCW
19624 ITRCL = IT -NTW
19625 ITZRCL = ITZ-NTCW
19626c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19627cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19628c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19629C AFERP = 0.0D0
19630c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19631cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19632c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19633C AFERT = 0.0D0
19634C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19635C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19636C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19637C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19638 AFERP = FERMOD+0.1D0
19639 AFERT = FERMOD+0.1D0
19640
19641 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19642
19643 RETURN
19644 END
19645
19646*$ CREATE DT_FICONF.FOR
19647*COPY DT_FICONF
19648*
19649*===ficonf=============================================================*
19650*
19651 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19652
19653************************************************************************
19654* Treatment of FInal CONFiguration including evaporation, fission and *
19655* Fermi-break-up (for light nuclei only). *
19656* Adopted from the original routine FINALE and extended to residual *
19657* projectile nuclei. *
19658* This version dated 12.12.95 is written by S. Roesler. *
19659* *
19660* Last change 27.12.2006 by S. Roesler. *
19661************************************************************************
19662
19663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19664 SAVE
19665
19666 PARAMETER ( LINP = 10 ,
19667 & LOUT = 6 ,
19668 & LDAT = 9 )
19669
19670 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19671 PARAMETER (ANGLGB=5.0D-16)
19672
19673* event history
19674
19675 PARAMETER (NMXHKK=200000)
19676
19677 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19678 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19679 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19680
19681* extended event history
19682 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19683 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19684 & IHIST(2,NMXHKK)
19685
19686* rejection counter
19687 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19688 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19689 & IREXCI(3),IRDIFF(2),IRINC
19690
19691* central particle production, impact parameter biasing
19692 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19693
19694* particle properties (BAMJET index convention)
19695 CHARACTER*8 ANAME
19696 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19697 & IICH(210),IIBAR(210),K1(210),K2(210)
19698
19699* treatment of residual nuclei: 4-momenta
19700 LOGICAL LRCLPR,LRCLTA
19701 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19702 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19703
19704* treatment of residual nuclei: properties of residual nuclei
19705 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19706 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19707 & NTOTFI(2),NPROFI(2)
19708
19709* statistics: residual nuclei
19710 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19711 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19712 & NINCST(2,4),NINCEV(2),
19713 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19714 & NRESPB(2),NRESCH(2),NRESEV(4),
19715 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19716 & NEVAFI(2,2)
19717
19718* flags for input different options
19719 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19720 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19721 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19722
19723* INCLUDE '(DIMPAR)'
19724* DIMPAR taken from FLUKA
19725 PARAMETER ( MXXRGN =20000 )
19726 PARAMETER ( MXXMDF = 710 )
19727 PARAMETER ( MXXMDE = 702 )
19728 PARAMETER ( MFSTCK =40000 )
19729 PARAMETER ( MESTCK = 100 )
19730 PARAMETER ( MOSTCK = 2000 )
19731 PARAMETER ( MXPRSN = 100 )
19732 PARAMETER ( MXPDPM = 800 )
19733 PARAMETER ( MXPSCS =30000 )
19734 PARAMETER ( MXGLWN = 300 )
19735 PARAMETER ( MXOUTU = 50 )
19736 PARAMETER ( NALLWP = 64 )
19737 PARAMETER ( NELEMX = 80 )
19738 PARAMETER ( MPDPDX = 18 )
19739 PARAMETER ( MXHTTR = 260 )
19740 PARAMETER ( MXSEAX = 20 )
19741 PARAMETER ( MXHTNC = MXSEAX + 1 )
19742 PARAMETER ( ICOMAX = 2400 )
19743 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19744 PARAMETER ( NSTBIS = 304 )
19745 PARAMETER ( NQSTIS = 46 )
19746 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19747 PARAMETER ( MXPABL = 120 )
19748 PARAMETER ( IDMAXP = 450 )
19749 PARAMETER ( IDMXDC = 2000 )
19750 PARAMETER ( MXMCIN = 410 )
19751 PARAMETER ( IHYPMX = 4 )
19752 PARAMETER ( MKBMX1 = 11 )
19753 PARAMETER ( MKBMX2 = 11 )
19754 PARAMETER ( MXIRRD = 2500 )
19755 PARAMETER ( MXTRDC = 1500 )
19756 PARAMETER ( NKTL = 17 )
19757 PARAMETER ( NBLNMX = 40000000 )
19758
19759* INCLUDE '(GENSTK)'
19760* GENSTK taken from FLUKA
19761 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19762 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19763 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19764 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19765 & TVRECL, TVHEAV, TVBIND,
19766 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19767
19768* INCLUDE '(RESNUC)'
19769* RESNUC from FLUKA
19770 LOGICAL LRNFSS, LFRAGM
19771 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19772 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19773 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19774 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19775 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19776 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19777 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19778 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19779 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19780 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19781 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19782 & LRNFSS, LFRAGM
19783
19784 PARAMETER ( EMVGEV = 1.0 D-03 )
19785 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19786 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19787 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19788 PARAMETER ( AMELCT = 0.51099906 D-03 )
19789 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19790 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19791 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19792 & * 1.D-09 )
19793 PARAMETER ( HLFHLF = 0.5D+00 )
19794 PARAMETER ( FERTHO = 14.33 D-09 )
19795 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19796 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19797 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19798
19799* INCLUDE '(NUCDAT)'
19800* Taken from FLUKA
19801 PARAMETER ( AMUAMU = AMUGEV )
19802 PARAMETER ( AMPROT = AMPRTN )
19803 PARAMETER ( AMNEUT = AMNTRN )
19804 PARAMETER ( AMELEC = AMELCT )
19805 PARAMETER ( R0NUCL = 1.12 D+00 )
19806 PARAMETER ( RCCOUL = 1.7 D+00 )
19807 PARAMETER ( COULPR = COUGFM )
19808 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19809 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19810 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19811 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19812 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19813* Gammin : threshold for deexcitation gammas production, set to 1 keV
19814* (this means that up to 1 keV of energy unbalancing can occur
19815* during an event)
19816 PARAMETER ( GAMMIN = 1.0D-06 )
19817 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19818* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19819 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19820*
19821 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19822 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19823 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19824 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19825 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19826 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19827 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19828 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19829 & ELBNDE (0:110)
19830
19831* INCLUDE '(PAREVT)'
19832* Taken from FLUKA
19833 PARAMETER ( FRDIFF = 0.2D+00 )
19834 PARAMETER ( ETHSEA = 1.0D+00 )
19835*
19836 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19837 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19838 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19839 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19840 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19841 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19842 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19843 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19844 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19845 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19846
19847* INCLUDE '(FHEAVY)'
19848* Taken from FLUKA
19849 PARAMETER ( MXHEAV = 100 )
19850 PARAMETER ( KXHEAV = 30 )
19851 CHARACTER*8 ANHEAV
19852 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19853 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19854 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19855 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19856 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19857 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19858 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19859 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19860 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19861 COMMON / FHEAVC / ANHEAV (KXHEAV)
19862
19863* event flag
19864 COMMON /DTEVNO/ NEVENT,ICASCA
19865
19866 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19867 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19868 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19869
19870 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19871 LOGICAL LLCPOT
19872 DATA EXC,NEXC /520*ZERO,520*0/
19873 DATA EXPNUC /4.0D-3,4.0D-3/
19874
19875 IREJ = 0
19876 LRCLPR = .FALSE.
19877 LRCLTA = .FALSE.
19878
19879* skip residual nucleus treatment if not requested or in case
19880* of central collisions
19881 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19882
19883 DO 1 K=1,2
19884 IDPAR(K) = 0
19885 IDXPAR(K)= 0
19886 NTOT(K) = 0
19887 NTOTFI(K)= 0
19888 NPRO(K) = 0
19889 NPROFI(K)= 0
19890 NN(K) = 0
19891 NH(K) = 0
19892 NHPOS(K) = 0
19893 NQ(K) = 0
19894 EEXC(K) = ZERO
19895 MO1(K) = 0
19896 MO2(K) = 0
19897 DO 2 I=1,4
19898 VRCL(K,I) = ZERO
19899 WRCL(K,I) = ZERO
19900 2 CONTINUE
19901 1 CONTINUE
19902 NFSP = 0
19903 INUC(1) = IP
19904 INUC(2) = IT
19905
19906 DO 3 I=1,NHKK
19907
19908* number of final state particles
19909 IF (ABS(ISTHKK(I)).EQ.1) THEN
19910 NFSP = NFSP+1
19911 IDFSP = IDBAM(I)
19912 ENDIF
19913
19914* properties of remaining nucleon configurations
19915 KF = 0
19916 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19917 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19918 IF (KF.GT.0) THEN
19919 IF (MO1(KF).EQ.0) MO1(KF) = I
19920 MO2(KF) = I
19921* position of residual nucleus = average position of nucleons
19922 DO 4 K=1,4
19923 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19924 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19925 4 CONTINUE
19926* total number of particles contributing to each residual nucleus
19927 NTOT(KF) = NTOT(KF)+1
19928 IDTMP = IDBAM(I)
19929 IDXTMP = I
19930* total charge of residual nuclei
19931 NQ(KF) = NQ(KF)+IICH(IDTMP)
19932* number of protons
19933 IF (IDHKK(I).EQ.2212) THEN
19934 NPRO(KF) = NPRO(KF)+1
19935* number of neutrons
19936 ELSEIF (IDHKK(I).EQ.2112) THEN
19937 NN(KF) = NN(KF)+1
19938 ELSE
19939* number of baryons other than n, p
19940 IF (IIBAR(IDTMP).EQ.1) THEN
19941 NH(KF) = NH(KF)+1
19942 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19943 ELSE
19944* any other mesons (status set to 1)
19945C WRITE(LOUT,1002) KF,IDTMP
19946C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19947C & ' containing meson ',I4,', status set to 1')
19948 ISTHKK(I) = 1
19949 IDTMP = IDPAR(KF)
19950 IDXTMP = IDXPAR(KF)
19951 NTOT(KF) = NTOT(KF)-1
19952 ENDIF
19953 ENDIF
19954 IDPAR(KF) = IDTMP
19955 IDXPAR(KF) = IDXTMP
19956 ENDIF
19957 3 CONTINUE
19958
19959* reject elastic events (def: one final state particle = projectile)
19960 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19961 IREXCI(3) = IREXCI(3)+1
19962 GOTO 9999
19963C RETURN
19964 ENDIF
19965
19966* check if one nucleus disappeared..
19967C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19968C DO 5 K=1,4
19969C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19970C PRCLPR(K) = ZERO
19971C 5 CONTINUE
19972C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19973C DO 6 K=1,4
19974C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19975C PRCLTA(K) = ZERO
19976C 6 CONTINUE
19977C ENDIF
19978
19979 ICOR = 0
19980 INORCL = 0
19981 DO 7 I=1,2
19982 DO 8 K=1,4
19983* get the average of the nucleon positions
19984 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19985 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19986 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19987 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19988 8 CONTINUE
19989* mass number and charge of residual nuclei
19990 AIF(I) = DBLE(NTOT(I))
19991 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19992 IF (NTOT(I).GT.1) THEN
19993* masses of residual nuclei in ground state
19994
19995C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19996 AMRCL0(I) = AIF(I)*AMUC12
19997 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19998
19999* masses of residual nuclei
20000 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20001 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20002 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20003*
20004* M_res^2 < 0 : configuration not allowed
20005*
20006* a) re-calculate E_exc with scaled nuclear potential
20007* (conditional jump to label 9998)
20008* b) or reject event if N_loop(max) is exceeded
20009* (conditional jump to label 9999)
20010*
20011 IF (AMRCL(I).LE.ZERO) THEN
20012 IF (IOULEV(3).GT.0)
20013 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20014 & PRCL(I,4),NTOT
20015 1000 FORMAT(1X,'warning! negative excitation energy',/,
20016 & I4,4E15.4,2I4)
20017 AMRCL(I) = ZERO
20018 EEXC(I) = ZERO
20019 IF (NLOOP.LE.500) THEN
20020 GOTO 9998
20021 ELSE
20022 IREXCI(2) = IREXCI(2)+1
20023 GOTO 9999
20024 ENDIF
20025*
20026* 0 < M_res < M_res0 : mass below ground-state mass
20027*
20028* a) we had residual nuclei with mass N_tot and reasonable E_exc
20029* before- assign average E_exc of those configurations to this
20030* one ( Nexc(i,N_tot) > 0 )
20031* b) or (and this applies always if run in transport codes) go up
20032* one mass number and
20033* i) if mass now larger than proj/targ mass or if run in
20034* transport codes assign average E_exc per wounded nucleon
20035* x number of wounded nucleons (Inuc-Ntot)
20036* ii) or assign average E_exc of those configurations to this
20037* one ( Nexc(i,m) > 0 )
20038*
20039 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20040 & THEN
20041 M = MIN(NTOT(I),260)
20042 IF (NEXC(I,M).GT.0) THEN
20043 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20044 ELSE
20045 70 CONTINUE
20046 M = M+1
20047**sr corrected 27.12.06
20048* IF (M.GE.INUC(I)) THEN
20049* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20050 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20051 IF ( INUC (I) .GT. NTOT (I) ) THEN
20052 AMRCL(I) = AMRCL0(I)
20053 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20054 ELSE
20055 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20056 END IF
20057**
20058 ELSE
20059 IF (NEXC(I,M).GT.0) THEN
20060 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20061 ELSE
20062 GOTO 70
20063 ENDIF
20064 ENDIF
20065 ENDIF
20066 EEXC(I) = AMRCL(I)-AMRCL0(I)
20067 ICOR = ICOR+I
20068*
20069* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20070*
20071* a) re-calculate E_exc with scaled nuclear potential
20072* (conditional jump to label 9998)
20073* b) or reject event if N_loop(max) is exceeded
20074* (conditional jump to label 9999)
20075*
20076*
20077 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20078 IF (IOULEV(3).GT.0)
20079 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20080 1004 FORMAT(1X,'warning! too high excitation energy',/,
20081 & I4,1P,2E15.4,3I5)
20082 AMRCL(I) = ZERO
20083 EEXC(I) = ZERO
20084 IF (NLOOP.LE.500) THEN
20085 GOTO 9998
20086 ELSE
20087 IREXCI(2) = IREXCI(2)+1
20088 GOTO 9999
20089 ENDIF
20090*
20091* Otherwise (reasonable E_exc) :
20092* E_exc = M_res - M_res0
20093* in addition: calculate and save E_exc per wounded nucleon as
20094* well as E_exc in <E_exc> counter
20095*
20096 ELSE
20097* excitation energies of residual nuclei
20098 EEXC(I) = AMRCL(I)-AMRCL0(I)
20099**sr 27.12.06 new excitation energy correction by A.F.
20100*
20101* all parts with Ilcopt<3 commented since not used
20102*
20103* still to be done/decided:
20104* Increase Icor and put back both residual nuclei on mass shell
20105* with the exciting correction further below.
20106* For the moment the modification in the excitation energy is simply
20107* corrected by scaling the energy of the residual nucleus.
20108*
20109 LLCPOT = .TRUE.
20110 ILCOPT = 3
20111 IF ( LLCPOT ) THEN
20112 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20113 IF ( ILCOPT .LE. 2 ) THEN
20114C* Patch for Fermi momentum reduction correlated with impact parameter:
20115C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20116C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20117C AKPRHO = ONE - DLKPRH
20118C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20119C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20120C & 0.05D+00 )
20121C* REDORI = 0.75D+00
20122C* REDORI = ONE
20123C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20124 ELSE
20125 DLKPRH = ZERO
20126 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20127* Take out roughly one/half of the skin:
20128 RDCORE = RDCORE - 0.5D+00
20129 FRCFLL = RDCORE**3
20130 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20131 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20132 FRCFLL = ONE - PRSKIN
20133 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20134 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20135 END IF
20136 IF ( NNCHIT .GT. 0 ) THEN
20137C IF ( ILCOPT .EQ. 1 ) THEN
20138C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20139C DO 1220 NCH = 1, 10
20140C ETAETA = ( ONE - SKINRH**INUC(I)
20141C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20142C & * ( ONE - SKINRH ) )
20143C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20144C & * ( ONE - FRCFLL) * SKINRH )
20145C SKINRH = SKINRH * ( ONE + ETAETA )
20146C 1220 CONTINUE
20147C PRSKIN = SKINRH**(NNCHIT-1)
20148C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20149C PRSKIN = ONE - FRCFLL
20150C END IF
20151 REDCTN = ZERO
20152 DO 1230 NCH = 1, NNCHIT
20153 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20154 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20155 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20156 ELSE
20157 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20158 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20159 END IF
20160 REDCTN = REDCTN + PRFRMI**2
20161 1230 CONTINUE
20162 REDCTN = REDCTN / DBLE (NNCHIT)
20163 ELSE
20164 REDCTN = 0.5D+00
20165 END IF
20166 EEXC (I) = EEXC (I) * REDCTN / REDORI
20167 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20168 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20169 END IF
20170**
20171 IF (ICASCA.EQ.0) THEN
20172 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20173 M = MIN(NTOT(I),260)
20174 EXC(I,M) = EXC(I,M)+EEXC(I)
20175 NEXC(I,M) = NEXC(I,M)+1
20176 ENDIF
20177 ENDIF
20178 ELSEIF (NTOT(I).EQ.1) THEN
20179 WRITE(LOUT,1003) I
20180 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20181 GOTO 9999
20182 ELSE
20183 AMRCL0(I) = ZERO
20184 AMRCL(I) = ZERO
20185 EEXC(I) = ZERO
20186 INORCL = INORCL+I
20187 ENDIF
20188 7 CONTINUE
20189
20190 PRCLPR(5) = AMRCL(1)
20191 PRCLTA(5) = AMRCL(2)
20192
20193 IF (ICOR.GT.0) THEN
20194 IF (INORCL.EQ.0) THEN
20195* one or both residual nuclei consist of one nucleon only, transform
20196* this nucleon on mass shell
20197 DO 9 K=1,4
20198 P1IN(K) = PRCL(1,K)
20199 P2IN(K) = PRCL(2,K)
20200 9 CONTINUE
20201 XM1 = AMRCL(1)
20202 XM2 = AMRCL(2)
20203 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20204 IF (IREJ1.GT.0) THEN
20205 WRITE(LOUT,*) 'ficonf-mashel rejection'
20206 GOTO 9999
20207 ENDIF
20208 DO 10 K=1,4
20209 PRCL(1,K) = P1OUT(K)
20210 PRCL(2,K) = P2OUT(K)
20211 PRCLPR(K) = P1OUT(K)
20212 PRCLTA(K) = P2OUT(K)
20213 10 CONTINUE
20214 PRCLPR(5) = AMRCL(1)
20215 PRCLTA(5) = AMRCL(2)
20216 ELSE
20217 IF (IOULEV(3).GT.0)
20218 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20219 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20220 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20221 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20222 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20223 & ' correction',/,11X,'at event',I8,
20224 & ', nucleon config. 1:',2I4,' 2:',2I4,
20225 & 2(/,11X,3E12.3))
20226 IF (NLOOP.LE.500) THEN
20227 GOTO 9998
20228 ELSE
20229 IREXCI(1) = IREXCI(1)+1
20230 ENDIF
20231 ENDIF
20232 ENDIF
20233
20234* update counter
20235C IF (NRESEV(1).NE.NEVHKK) THEN
20236C NRESEV(1) = NEVHKK
20237C NRESEV(2) = NRESEV(2)+1
20238C ENDIF
20239 NRESEV(2) = NRESEV(2)+1
20240 DO 15 I=1,2
20241 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20242 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20243 NRESTO(I) = NRESTO(I)+NTOT(I)
20244 NRESPR(I) = NRESPR(I)+NPRO(I)
20245 NRESNU(I) = NRESNU(I)+NN(I)
20246 NRESBA(I) = NRESBA(I)+NH(I)
20247 NRESPB(I) = NRESPB(I)+NHPOS(I)
20248 NRESCH(I) = NRESCH(I)+NQ(I)
20249 15 CONTINUE
20250
20251* evaporation
20252 IF (LEVPRT) THEN
20253 DO 13 I=1,2
20254* initialize evaporation counter
20255 EEXCFI(I) = ZERO
20256 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20257 & (EEXC(I).GT.ZERO)) THEN
20258* put residual nuclei into DTEVT1
20259 IDRCL = 80000
20260 JMASS = INT( AIF(I))
20261 JCHAR = INT(AIZF(I))
20262* the following patch is required to transmit the correct excitation
20263* energy to Eventd
20264 IF (ITRSPT.EQ.1) THEN
20265 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20266 & (IOULEV(3).GT.0))
20267 & WRITE(LOUT,*)
20268 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20269 & AMRCL(I),AMRCL0(I),EEXC(I)
20270 PRCL0 = PRCL(I,4)
20271 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20272 & +PRCL(I,3)**2)
20273 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20274 WRITE(LOUT,*)
20275 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20276 ENDIF
20277 ENDIF
20278 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20279 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20280**sr 22.6.97
20281 NOBAM(NHKK) = I
20282**
20283 DO 14 J=1,4
20284 VHKK(J,NHKK) = VRCL(I,J)
20285 WHKK(J,NHKK) = WRCL(I,J)
20286 14 CONTINUE
20287* interface to evaporation module - fill final residual nucleus into
20288* common FKRESN
20289* fill resnuc only if code is not used as event generator in Fluka
20290 IF (ITRSPT.NE.1) THEN
20291 PXRES = PRCL(I,1)
20292 PYRES = PRCL(I,2)
20293 PZRES = PRCL(I,3)
20294 IBRES = NPRO(I)+NN(I)+NH(I)
20295 ICRES = NPRO(I)+NHPOS(I)
20296 ANOW = DBLE(IBRES)
20297 ZNOW = DBLE(ICRES)
20298 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20299* ground state mass of the residual nucleus (should be equal to AM0T)
20300
20301 AMNRES = AMRCL0(I)
20302 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20303
20304* common FKFINU
20305 TV = ZERO
20306* kinetic energy of residual nucleus
20307 TVRECL = PRCL(I,4)-AMRCL(I)
20308* excitation energy of residual nucleus
20309 TVCMS = EEXC(I)
20310 PTOLD = PTRES
20311 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20312 & 2.0D0*(AMMRES+TVCMS))))
20313 IF (PTOLD.LT.ANGLGB) THEN
20314 CALL DT_RACO(PXRES,PYRES,PZRES)
20315 PTOLD = ONE
20316 ENDIF
20317 PXRES = PXRES*PTRES/PTOLD
20318 PYRES = PYRES*PTRES/PTOLD
20319 PZRES = PZRES*PTRES/PTOLD
20320* zero counter of secondaries from evaporation
20321 NP = 0
20322* evaporation
20323 WE = ONE
20324
20325 NPHEAV = 0
20326 LRNFSS = .FALSE.
20327 LFRAGM = .FALSE.
20328 CALL EVEVAP(WE)
20329
20330* put evaporated particles and residual nuclei to DTEVT1
20331 MO = NHKK
20332 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20333 ENDIF
20334 EEXCFI(I) = EXCITF
20335 EXCEVA(I) = EXCEVA(I)+EXCITF
20336 ENDIF
20337 13 CONTINUE
20338 ENDIF
20339
20340 RETURN
20341
20342C9998 IREXCI(1) = IREXCI(1)+1
20343 9998 IREJ = IREJ+1
20344 9999 CONTINUE
20345 LRCLPR = .TRUE.
20346 LRCLTA = .TRUE.
20347 IREJ = IREJ+1
20348 RETURN
20349 END
20350
20351*$ CREATE DT_EVA2HE.FOR
20352*COPY DT_EVA2HE
20353* *
20354*====eva2he============================================================*
20355* *
20356 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20357
20358************************************************************************
20359* Interface between common's of evaporation module (FKFINU,FKFHVY) *
20360* and DTEVT1. *
20361* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20362* EEXCF exitation energy of residual nucleus after evaporation *
20363* IRCL = 1 projectile residual nucleus *
20364* = 2 target residual nucleus *
20365* This version dated 19.04.95 is written by S. Roesler. *
20366* *
20367* Last change 27.12.2006 by S. Roesler. *
20368************************************************************************
20369
20370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20371 SAVE
20372
20373 PARAMETER ( LINP = 10 ,
20374 & LOUT = 6 ,
20375 & LDAT = 9 )
20376
20377 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20378
20379* event history
20380
20381 PARAMETER (NMXHKK=200000)
20382
20383 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20384 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20385 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20386* Note: DTEVT2 - special use for heavy fragments !
20387* (IDRES(I) = mass number, IDXRES(I) = charge)
20388
20389* extended event history
20390 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20391 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20392 & IHIST(2,NMXHKK)
20393
20394* particle properties (BAMJET index convention)
20395 CHARACTER*8 ANAME
20396 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20397 & IICH(210),IIBAR(210),K1(210),K2(210)
20398
20399* flags for input different options
20400 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20401 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20402 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20403
20404* statistics: residual nuclei
20405 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20406 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20407 & NINCST(2,4),NINCEV(2),
20408 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20409 & NRESPB(2),NRESCH(2),NRESEV(4),
20410 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20411 & NEVAFI(2,2)
20412
20413* treatment of residual nuclei: properties of residual nuclei
20414 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20415 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20416 & NTOTFI(2),NPROFI(2)
20417
20418* INCLUDE '(DIMPAR)'
20419* Taken from FLUKA
20420 PARAMETER ( MXXRGN =20000 )
20421 PARAMETER ( MXXMDF = 710 )
20422 PARAMETER ( MXXMDE = 702 )
20423 PARAMETER ( MFSTCK =40000 )
20424 PARAMETER ( MESTCK = 100 )
20425 PARAMETER ( MOSTCK = 2000 )
20426 PARAMETER ( MXPRSN = 100 )
20427 PARAMETER ( MXPDPM = 800 )
20428 PARAMETER ( MXPSCS =30000 )
20429 PARAMETER ( MXGLWN = 300 )
20430 PARAMETER ( MXOUTU = 50 )
20431 PARAMETER ( NALLWP = 64 )
20432 PARAMETER ( NELEMX = 80 )
20433 PARAMETER ( MPDPDX = 18 )
20434 PARAMETER ( MXHTTR = 260 )
20435 PARAMETER ( MXSEAX = 20 )
20436 PARAMETER ( MXHTNC = MXSEAX + 1 )
20437 PARAMETER ( ICOMAX = 2400 )
20438 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20439 PARAMETER ( NSTBIS = 304 )
20440 PARAMETER ( NQSTIS = 46 )
20441 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20442 PARAMETER ( MXPABL = 120 )
20443 PARAMETER ( IDMAXP = 450 )
20444 PARAMETER ( IDMXDC = 2000 )
20445 PARAMETER ( MXMCIN = 410 )
20446 PARAMETER ( IHYPMX = 4 )
20447 PARAMETER ( MKBMX1 = 11 )
20448 PARAMETER ( MKBMX2 = 11 )
20449 PARAMETER ( MXIRRD = 2500 )
20450 PARAMETER ( MXTRDC = 1500 )
20451 PARAMETER ( NKTL = 17 )
20452 PARAMETER ( NBLNMX = 40000000 )
20453
20454* INCLUDE '(GENSTK)'
20455* Taken from FLUKA
20456 PARAMETER ( MXP = MXPSCS )
20457*
20458 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20459 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20460 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20461 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20462 & TVRECL, TVHEAV, TVBIND,
20463 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20464
20465* INCLUDE '(RESNUC)'
20466 LOGICAL LRNFSS, LFRAGM
20467 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20468 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20469 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20470 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20471 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20472 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20473 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20474 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20475 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20476 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20477 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20478 & LRNFSS, LFRAGM
20479* Taken from FLUKA
20480
20481* INCLUDE '(FHEAVY)'
20482* Taken from FLUKA
20483 PARAMETER ( MXHEAV = 100 )
20484 PARAMETER ( KXHEAV = 30 )
20485 CHARACTER*8 ANHEAV
20486 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20487 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20488 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20489 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20490 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20491 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20492 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20493 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20494 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20495 COMMON / FHEAVC / ANHEAV (KXHEAV)
20496
20497 DIMENSION IPTOKP(39)
20498 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20499 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20500 & 100, 101, 97, 102, 98, 103, 109, 115 /
20501
20502 IREJ = 0
20503
20504* skip if evaporation package is not included
20505 IF (.NOT.LEVAPO) RETURN
20506
20507* update counter
20508 IF (NRESEV(3).NE.NEVHKK) THEN
20509 NRESEV(3) = NEVHKK
20510 NRESEV(4) = NRESEV(4)+1
20511 ENDIF
20512
20513 IF (LEMCCK)
20514 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20515 & IDUM,IDUM)
20516* mass number/charge of residual nucleus before evaporation
20517 IBTOT = IDRES(MO)
20518 IZTOT = IDXRES(MO)
20519
20520* protons/neutrons/gammas
20521 DO 1 I=1,NP
20522 PX = CXR(I)*PLR(I)
20523 PY = CYR(I)*PLR(I)
20524 PZ = CZR(I)*PLR(I)
20525 ID = IPTOKP(KPART(I))
20526 IDPDG = IDT_IPDGHA(ID)
20527 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20528 & (2.0D0*MAX(TKI(I),TINY10))
20529 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20530 WRITE(LOUT,1000) ID,AM,AAM(ID)
20531 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20532 & 'particle',I3,2E10.3)
20533 ENDIF
20534 PE = TKI(I)+AM
20535 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20536 NOBAM(NHKK) = IRCL
20537 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20538 IBTOT = IBTOT-IIBAR(ID)
20539 IZTOT = IZTOT-IICH(ID)
20540 1 CONTINUE
20541
20542* heavy fragments
20543 DO 2 I=1,NPHEAV
20544 PX = CXHEAV(I)*PHEAVY(I)
20545 PY = CYHEAV(I)*PHEAVY(I)
20546 PZ = CZHEAV(I)*PHEAVY(I)
20547 IDHEAV = 80000
20548 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20549 & (2.0D0*MAX(TKHEAV(I),TINY10))
20550 PE = TKHEAV(I)+AM
20551 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20552 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20553 NOBAM(NHKK) = IRCL
20554 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20555 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20556 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20557 2 CONTINUE
20558
20559 IF (IBRES.GT.0) THEN
20560* residual nucleus after evaporation
20561 IDNUC = 80000
20562 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20563 & IBRES,ICRES,0)
20564 NOBAM(NHKK) = IRCL
20565 ENDIF
20566 EEXCF = TVCMS
20567 NTOTFI(IRCL) = IBRES
20568 NPROFI(IRCL) = ICRES
20569 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20570 IBTOT = IBTOT-IBRES
20571 IZTOT = IZTOT-ICRES
20572
20573* count events with fission
20574 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20575 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20576
20577* energy-momentum conservation check
20578 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20579C IF (IREJ.GT.0) THEN
20580C CALL DT_EVTOUT(4)
20581C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20582C ENDIF
20583* baryon-number/charge conservation check
20584 IF (IBTOT+IZTOT.NE.0) THEN
20585 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20586 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20587 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20588 ENDIF
20589
20590 RETURN
20591 END
20592
20593*$ CREATE DT_EBIND.FOR
20594*COPY DT_EBIND
20595*
20596*===ebind==============================================================*
20597*
20598 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20599
20600************************************************************************
20601* Binding energy for nuclei. *
20602* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20603* IA mass number *
20604* IZ atomic number *
20605* This version dated 5.5.95 is updated by S. Roesler. *
20606************************************************************************
20607
20608 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20609 SAVE
20610
20611 PARAMETER ( LINP = 10 ,
20612 & LOUT = 6 ,
20613 & LDAT = 9 )
20614
20615 PARAMETER (ZERO=0.0D0)
20616
20617 DATA A1, A2, A3, A4, A5
20618 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20619
20620 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20621 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20622 DT_EBIND = ZERO
20623 RETURN
20624 ENDIF
20625 AA = IA
20626 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20627 & -A4*(IA-2*IZ)**2/AA
20628 IF (MOD(IA,2).EQ.1) THEN
20629 IA5 = 0
20630 ELSEIF (MOD(IZ,2).EQ.1) THEN
20631 IA5 = 1
20632 ELSE
20633 IA5 = -1
20634 ENDIF
20635 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20636
20637 RETURN
20638 END
20639
20640************************************************************************
20641* *
20642* DPMJET 3.0: cross section routines *
20643* *
20644************************************************************************
20645*
20646*
20647* SUBROUTINE DT_SHNDIF
20648* diffractive cross sections (all energies)
20649* SUBROUTINE DT_PHOXS
20650* total and inel. cross sections from PHOJET interpol. tables
20651* SUBROUTINE DT_XSHN
20652* total and el. cross sections for all energies
20653* SUBROUTINE DT_SIHNAB
20654* pion 2-nucleon absorption cross sections
20655* SUBROUTINE DT_SIGEMU
20656* cross section for target "compounds"
20657* SUBROUTINE DT_SIGGA
20658* photon nucleus cross sections
20659* SUBROUTINE DT_SIGGAT
20660* photon nucleus cross sections from tables
20661* SUBROUTINE DT_SANO
20662* anomalous hard photon-nucleon cross sections from tables
20663* SUBROUTINE DT_SIGGP
20664* photon nucleon cross sections
20665* SUBROUTINE DT_SIGVEL
20666* quasi-elastic vector meson prod. cross sections
20667* DOUBLE PRECISION FUNCTION DT_SIGVP
20668* sigma_VN(tilde)
20669* DOUBLE PRECISION FUNCTION DT_RRM2
20670* DOUBLE PRECISION FUNCTION DT_RM2
20671* DOUBLE PRECISION FUNCTION DT_SAM2
20672* SUBROUTINE DT_CKMT
20673* SUBROUTINE DT_CKMTX
20674* SUBROUTINE DT_PDF0
20675* SUBROUTINE DT_CKMTQ0
20676* SUBROUTINE DT_CKMTDE
20677* SUBROUTINE DT_CKMTPR
20678* FUNCTION DT_CKMTFF
20679*
20680* SUBROUTINE DT_FLUINI
20681* total nucleon cross section fluctuation treatment
20682*
20683* SUBROUTINE DT_SIGTBL
20684* pre-tabulation of low-energy elastic x-sec. using SIHNEL
20685* SUBROUTINE DT_XSTABL
20686* service routines
20687*
20688*
20689*$ CREATE DT_SHNDIF.FOR
20690*COPY DT_SHNDIF
20691*
20692*===shndif===============================================================*
20693*
20694 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20695
20696**********************************************************************
20697* Single diffractive hadron-nucleon cross sections *
20698* S.Roesler 14/1/93 *
20699* *
20700* The cross sections are calculated from extrapolated single *
20701* diffractive antiproton-proton cross sections (DTUJET92) using *
20702* scaling relations between total and single diffractive cross *
20703* sections. *
20704**********************************************************************
20705
20706 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20707 SAVE
20708 PARAMETER (ZERO=0.0D0)
20709
20710* particle properties (BAMJET index convention)
20711 CHARACTER*8 ANAME
20712 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20713 & IICH(210),IIBAR(210),K1(210),K2(210)
20714*
20715 CSD1 = 4.201483727D0
20716 CSD4 = -0.4763103556D-02
20717 CSD5 = 0.4324148297D0
20718*
20719 CHMSD1 = 0.8519297242D0
20720 CHMSD4 = -0.1443076599D-01
20721 CHMSD5 = 0.4014954567D0
20722*
20723 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20724 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20725*
20726 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20727 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20728 FRAC = SHMSD/SDIAPP
20729*
20730 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20731 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20732 & 10, 10, 20, 20, 20) KPROJ
20733*
20734 10 CONTINUE
20735*---------------------------- p - p , n - p , sigma0+- - p ,
20736* Lambda - p
20737 CSD1 = 6.004476070D0
20738 CSD4 = -0.1257784606D-03
20739 CSD5 = 0.2447335720D0
20740 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20741 SIGDIH = FRAC*SIGDIF
20742 RETURN
20743*
20744 20 CONTINUE
20745*
20746 KPSCAL = 2
20747 KTSCAL = 1
20748C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20749 DUMZER = ZERO
20750 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20751 F = SDIAPP/SIGTO
20752 KT = 1
20753C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20754 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20755 SIGDIF = SIGTO*F
20756 SIGDIH = FRAC*SIGDIF
20757 RETURN
20758*
20759 999 CONTINUE
20760*-------------------------- leptons..
20761 SIGDIF = 1.D-10
20762 SIGDIH = 1.D-10
20763 RETURN
20764 END
20765
20766*$ CREATE DT_PHOXS.FOR
20767*COPY DT_PHOXS
20768*
20769*===phoxs================================================================*
20770*
20771 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20772
20773************************************************************************
20774* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20775* interpolation tables. *
20776* This version dated 05.11.97 is written by S. Roesler *
20777************************************************************************
20778
20779 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20780 SAVE
20781
20782 PARAMETER ( LINP = 10 ,
20783 & LOUT = 6 ,
20784 & LDAT = 9 )
20785
20786 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20787 PARAMETER (TWOPI = 6.283185307179586454D+00,
20788 & PI = TWOPI/TWO,
20789 & GEV2MB = 0.38938D0)
20790
20791 LOGICAL LFIRST
20792 DATA LFIRST /.TRUE./
20793
20794* nucleon-nucleon event-generator
20795 CHARACTER*8 CMODEL
20796 LOGICAL LPHOIN
20797 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20798
20799* particle properties (BAMJET index convention)
20800 CHARACTER*8 ANAME
20801 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20802 & IICH(210),IIBAR(210),K1(210),K2(210)
20803
20804**PHOJET105a
20805C PARAMETER (IEETAB=10)
20806C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20807**PHOJET110
20808
20809C energy-interpolation table
20810 INTEGER IEETA2
20811 PARAMETER ( IEETA2 = 20 )
20812 INTEGER ISIMAX
20813 DOUBLE PRECISION SIGTAB,SIGECM
20814 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20815**
20816
20817 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20818 WRITE(LOUT,*) MCGENE
20819 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20820 STOP
20821 ENDIF
20822
20823 IF (ECM.LE.ZERO) THEN
20824 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20825 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20826 ENDIF
20827
20828 IF (MODE.EQ.1) THEN
20829* DL
20830 DELDL = 0.0808D0
20831 EPSDL = -0.4525D0
20832 S = ECM*ECM
20833 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20834 ALPHAP= 0.25D0
20835 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20836 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20837 SINE = STOT-SIGEL
20838 SDIF1 = ZERO
20839 ELSE
20840* Phojet
20841 IP = 1
20842 IF(ECM.LE.SIGECM(IP,1)) THEN
20843 I1 = 1
20844 I2 = 1
20845 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20846 DO 1 I=2,ISIMAX
20847 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20848 1 CONTINUE
20849 2 CONTINUE
20850 I1 = I-1
20851 I2 = I
20852 ELSE
20853 IF (LFIRST) THEN
20854 WRITE(LOUT,'(/1X,A,2E12.3)')
20855 & 'PHOXS: warning! energy above initialization limit (',
20856 & ECM,SIGECM(IP,ISIMAX)
20857 LFIRST = .FALSE.
20858 ENDIF
20859 I1 = ISIMAX
20860 I2 = ISIMAX
20861 ENDIF
20862 FAC2 = ZERO
20863 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20864 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20865 FAC1 = ONE-FAC2
20866 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20867 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20868 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20869 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20870 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20871 ENDIF
20872
20873 RETURN
20874 END
20875
20876*$ CREATE DT_XSHN.FOR
20877*COPY DT_XSHN
20878*
20879*===xshn===============================================================*
20880*
20881 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20882
20883************************************************************************
20884* Total and elastic hadron-nucleon cross section. *
20885* Below 500GeV cross sections are based on the '98 data compilation *
20886* of the PDG. At higher energies PHOJET results are used (patched to *
20887* the low energy data at 500GeV). *
20888* IP projectile index (BAMJET numbering scheme) *
20889* (should be in the range 1..25) *
20890* IT target index (BAMJET numbering scheme) *
20891* (1 = proton, 8 = neutron) *
20892* PL laboratory momentum *
20893* ECM cm. energy (ignored if PL>0) *
20894* STOT total cross section *
20895* SELA elastic cross section *
20896* Last change: 24.4.99 by S. Roesler *
20897************************************************************************
20898
20899 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20900 SAVE
20901
20902 PARAMETER ( LINP = 10 ,
20903 & LOUT = 6 ,
20904 & LDAT = 9 )
20905
20906 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20907
20908 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20909 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20910 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20911
20912 LOGICAL LFIRST
20913
20914* particle properties (BAMJET index convention)
20915 CHARACTER*8 ANAME
20916 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20917 & IICH(210),IIBAR(210),K1(210),K2(210)
20918
20919* nucleon-nucleon event-generator
20920 CHARACTER*8 CMODEL
20921 LOGICAL LPHOIN
20922 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20923**PHOJET105a
20924C PARAMETER (IEETAB=10)
20925C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20926**PHOJET110
20927
20928C energy-interpolation table
20929 INTEGER IEETA2
20930 PARAMETER ( IEETA2 = 20 )
20931 INTEGER ISIMAX
20932 DOUBLE PRECISION SIGTAB,SIGECM
20933 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20934
20935 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20936 DIMENSION IDXDAT(25,2)
20937*
20938 DATA APL /
20939 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20940 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20941 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20942 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20943 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20944 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20945 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20946*
20947* total cross sections:
20948* p p
20949 DATA (ASIGTO(1,K),K=1,NPOINT) /
20950 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20951 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20952 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20953 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20954 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20955 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20956 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20957* pbar p
20958 DATA (ASIGTO(2,K),K=1,NPOINT) /
20959 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20960 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20961 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20962 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20963 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20964 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20965 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20966* n p
20967 DATA (ASIGTO(3,K),K=1,NPOINT) /
20968 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20969 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20970 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20971 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20972 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20973 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20974 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20975* pi+ p
20976 DATA (ASIGTO(4,K),K=1,NPOINT) /
20977 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20978 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20979 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20980 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20981 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20982 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20983 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20984* pi- p
20985 DATA (ASIGTO(5,K),K=1,NPOINT) /
20986 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20987 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20988 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20989 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20990 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20991 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20992 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20993* K+ p
20994 DATA (ASIGTO(6,K),K=1,NPOINT) /
20995 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20996 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20997 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20998 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20999 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21000 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21001 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21002* K- p
21003 DATA (ASIGTO(7,K),K=1,NPOINT) /
21004 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21005 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21006 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21007 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21008 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21009 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21010 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21011* K+ n
21012 DATA (ASIGTO(8,K),K=1,NPOINT) /
21013 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21014 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21015 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21016 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21017 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21018 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21019 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21020* K- n
21021 DATA (ASIGTO(9,K),K=1,NPOINT) /
21022 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21023 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21024 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21025 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21026 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21027 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21028 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21029* Lambda p
21030 DATA (ASIGTO(10,K),K=1,NPOINT) /
21031 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21032 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21033 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21034 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21035 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21036 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21037 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21038*
21039* elastic cross sections:
21040* p p
21041 DATA (ASIGEL(1,K),K=1,NPOINT) /
21042 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21043 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21044 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21045 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21046 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21047 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21048 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21049* pbar p
21050 DATA (ASIGEL(2,K),K=1,NPOINT) /
21051 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21052 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21053 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21054 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21055 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21056 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21057 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21058* n p
21059 DATA (ASIGEL(3,K),K=1,NPOINT) /
21060 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21061 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21062 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21063 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21064 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21065 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21066 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21067* pi+ p
21068 DATA (ASIGEL(4,K),K=1,NPOINT) /
21069 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21070 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21071 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21072 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21073 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21074 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21075 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21076* pi- p
21077 DATA (ASIGEL(5,K),K=1,NPOINT) /
21078 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21079 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21080 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21081 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21082 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21083 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21084 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21085* K+ p
21086 DATA (ASIGEL(6,K),K=1,NPOINT) /
21087 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21088 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21089 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21090 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21091 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21092 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21093 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21094* K- p
21095 DATA (ASIGEL(7,K),K=1,NPOINT) /
21096 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21097 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21098 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21099 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21100 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21101 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21102 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21103* K+ n
21104 DATA (ASIGEL(8,K),K=1,NPOINT) /
21105 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21106 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21107 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21108 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21109 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21110 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21111 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21112* K- n
21113 DATA (ASIGEL(9,K),K=1,NPOINT) /
21114 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21115 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21116 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21117 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21118 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21119 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21120 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21121* Lambda p
21122 DATA (ASIGEL(10,K),K=1,NPOINT) /
21123 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21124 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21125 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21126 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21127 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21128 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21129 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21130
21131 DATA (IDXDAT(K,1),K=1,25) /
21132 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21133 & 1, 3,45, 8, 9/
21134 DATA (IDXDAT(K,2),K=1,25) /
21135 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21136 & 3, 1,45, 6, 7/
21137
21138 DATA LFIRST /.TRUE./
21139
21140 IF (LFIRST) THEN
21141 APLABL = LOG10(PLABLO)
21142 APLABH = LOG10(PLABHI)
21143 APTHRE = LOG10(PTHRE)
21144 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21145 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21146 DUM0 = ZERO
21147 PHOPLA = PLABHI
21148 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21149 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21150 IF (MCGENE.EQ.2) THEN
21151 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21152 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21153 ELSE
21154 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21155 ENDIF
21156 ELSE
21157 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21158 ENDIF
21159 PHOSEL = PHOSTO-PHOSIN
21160 APHOST = LOG10(PHOSTO)
21161 APHOSE = LOG10(PHOSEL)
21162 LFIRST = .FALSE.
21163 ENDIF
21164 STOT = ZERO
21165 SELA = ZERO
21166 PLAB = PL
21167 ECMS = ECM
21168 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21169 WRITE(LOUT,1000) IP,IT
21170 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21171 & 'proj/target',2I4)
21172 STOP
21173 ENDIF
21174
21175 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21176 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21177 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21178 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21179 WRITE(LOUT,1001) PLAB,ECMS
21180 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21181 STOP
21182 ENDIF
21183
21184* index of spectrum
21185 IDXP = IP
21186 IF (IP.GT.25) THEN
21187 IF (AAM(IP).GT.ZERO) THEN
21188 IF (ABS(IIBAR(IP)).GT.0) THEN
21189 IDXP = 1
21190 ELSE
21191 IDXP = 13
21192 ENDIF
21193 ELSE
21194 IDXP = 7
21195 ENDIF
21196 ENDIF
21197 IDXT = 1
21198 IF (IT.EQ.8) IDXT = 2
21199 IDXS = IDXDAT(IDXP,IDXT)
21200 IF (IDXS.EQ.0) RETURN
21201
21202* compute momentum bin indices
21203 IF (PLAB.LT.PLABLO) THEN
21204 IDX0 = 1
21205 IDX1 = 1
21206 ELSEIF (PLAB.GE.PLABHI) THEN
21207 IDX0 = NPOINT
21208 IDX1 = NPOINT
21209 ELSE
21210 APLAB = LOG10(PLAB)
21211 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21212 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21213 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21214 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21215 ENDIF
21216 IDX1 = IDX0+1
21217 ENDIF
21218
21219* interpolate cross section
21220 IF (IDXS.GT.10) THEN
21221 IDXS1 = IDXS/10
21222 IDXS2 = IDXS-10*IDXS1
21223 IF (IDX0.EQ.IDX1) THEN
21224 IF (IDX0.EQ.1) THEN
21225 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21226 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21227 ELSE
21228 DUM0 = ZERO
21229 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21230 PHOSEL = PHOSTO-PHOSIN
21231 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21232 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21233 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21234 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21235 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21236 ASELA = 0.5D0*(ASELA1+ASELA2)
21237 ENDIF
21238 ELSE
21239 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21240 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21241 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21242 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21243 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21244 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21245 ASELA1 = ASIGEL(IDXS1,IDX0)+
21246 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21247 ASELA2 = ASIGEL(IDXS2,IDX0)+
21248 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21249 ASELA = 0.5D0*(ASELA1+ASELA2)
21250 ENDIF
21251 ELSE
21252 IF (IDX0.EQ.IDX1) THEN
21253 IF (IDX0.EQ.1) THEN
21254 ASTOT = ASIGTO(IDXS,IDX0)
21255 ASELA = ASIGEL(IDXS,IDX0)
21256 ELSE
21257 DUM0 = ZERO
21258 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21259 PHOSEL = PHOSTO-PHOSIN
21260 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21261 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21262 ENDIF
21263 ELSE
21264 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21265 ASTOT = ASIGTO(IDXS,IDX0)+
21266 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21267 ASELA = ASIGEL(IDXS,IDX0)+
21268 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21269 ENDIF
21270 ENDIF
21271 STOT = 10.0D0**ASTOT
21272 SELA = 10.0D0**ASELA
21273
21274 RETURN
21275 END
21276
21277*$ CREATE DT_SIHNAB.FOR
21278*COPY DT_SIHNAB
21279*
21280*===sihnab===============================================================*
21281*
21282 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21283
21284**********************************************************************
21285* Pion 2-nucleon absorption cross sections. *
21286* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21287* taken from Ritchie PRC 28 (1983) 926 ) *
21288* This version dated 18.05.96 is written by S. Roesler *
21289**********************************************************************
21290
21291 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21292 SAVE
21293 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21294 PARAMETER (AMPR = 938.0D0,
21295 & AMPI = 140.0D0,
21296 & AMDE = TWO*AMPR,
21297 & A = -1.2D0,
21298 & B = 3.5D0,
21299 & C = 7.4D0,
21300 & D = 5600.0D0,
21301 & ER = 2136.0D0)
21302
21303 SIGABS = ZERO
21304 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21305 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21306 PTOT = PLAB*1.0D3
21307 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21308 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21309 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21310 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21311* approximate 3N-abs., I=1-abs. etc.
21312 SIGABS = SIGABS/0.40D0
21313* pi0-absorption (rough approximation!!)
21314 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21315
21316 RETURN
21317 END
21318
21319*$ CREATE DT_SIGEMU.FOR
21320*COPY DT_SIGEMU
21321*
21322*===sigemu=============================================================*
21323*
21324 SUBROUTINE DT_SIGEMU
21325
21326************************************************************************
21327* Combined cross section for target compounds. *
21328* This version dated 6.4.98 is written by S. Roesler *
21329************************************************************************
21330
21331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21332 SAVE
21333
21334 PARAMETER ( LINP = 10 ,
21335 & LOUT = 6 ,
21336 & LDAT = 9 )
21337
21338 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21339 & OHALF=0.5D0,ONE=1.0D0)
21340
21341 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21342
21343* Glauber formalism: cross sections
21344 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21345 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21346 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21347 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21348 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21349 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21350 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21351 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21352 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21353 & BSLOPE,NEBINI,NQBINI
21354
21355* emulsion treatment
21356 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21357 & NCOMPO,IEMUL
21358
21359* nucleon-nucleon event-generator
21360 CHARACTER*8 CMODEL
21361 LOGICAL LPHOIN
21362 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21363
21364 IF (MCGENE.NE.4) THEN
21365 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21366 WRITE(LOUT,'(15X,A)') '-----------------------'
21367 ENDIF
21368 DO 1 IE=1,NEBINI
21369 DO 2 IQ=1,NQBINI
21370 SIGTOT = ZERO
21371 SIGELA = ZERO
21372 SIGQEP = ZERO
21373 SIGQET = ZERO
21374 SIGQE2 = ZERO
21375 SIGPRO = ZERO
21376 SIGDEL = ZERO
21377 SIGDQE = ZERO
21378 ERRTOT = ZERO
21379 ERRELA = ZERO
21380 ERRQEP = ZERO
21381 ERRQET = ZERO
21382 ERRQE2 = ZERO
21383 ERRPRO = ZERO
21384 ERRDEL = ZERO
21385 ERRDQE = ZERO
21386 IF (NCOMPO.GT.0) THEN
21387 DO 3 IC=1,NCOMPO
21388 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21389 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21390 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21391 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21392 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21393 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21394 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21395 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21396 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21397 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21398 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21399 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21400 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21401 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21402 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21403 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21404 3 CONTINUE
21405 ERRTOT = SQRT(ERRTOT)
21406 ERRELA = SQRT(ERRELA)
21407 ERRQEP = SQRT(ERRQEP)
21408 ERRQET = SQRT(ERRQET)
21409 ERRQE2 = SQRT(ERRQE2)
21410 ERRPRO = SQRT(ERRPRO)
21411 ERRDEL = SQRT(ERRDEL)
21412 ERRDQE = SQRT(ERRDQE)
21413 ELSE
21414 SIGTOT = XSTOT(IE,IQ,1)
21415 SIGELA = XSELA(IE,IQ,1)
21416 SIGQEP = XSQEP(IE,IQ,1)
21417 SIGQET = XSQET(IE,IQ,1)
21418 SIGQE2 = XSQE2(IE,IQ,1)
21419 SIGPRO = XSPRO(IE,IQ,1)
21420 SIGDEL = XSDEL(IE,IQ,1)
21421 SIGDQE = XSDQE(IE,IQ,1)
21422 ERRTOT = XETOT(IE,IQ,1)
21423 ERRELA = XEELA(IE,IQ,1)
21424 ERRQEP = XEQEP(IE,IQ,1)
21425 ERRQET = XEQET(IE,IQ,1)
21426 ERRQE2 = XEQE2(IE,IQ,1)
21427 ERRPRO = XEPRO(IE,IQ,1)
21428 ERRDEL = XEDEL(IE,IQ,1)
21429 ERRDQE = XEDQE(IE,IQ,1)
21430 ENDIF
21431 IF (MCGENE.NE.4) THEN
21432 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21433 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21434 WRITE(LOUT,1001) SIGTOT,ERRTOT
21435 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21436 WRITE(LOUT,1002) SIGELA,ERRELA
21437 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21438 WRITE(LOUT,1003) SIGQEP,ERRQEP
21439 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21440 & F11.5,' mb')
21441 WRITE(LOUT,1004) SIGQET,ERRQET
21442 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21443 & F11.5,' mb')
21444 WRITE(LOUT,1005) SIGQE2,ERRQE2
21445 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21446 & ' +-',F11.5,' mb')
21447 WRITE(LOUT,1006) SIGPRO,ERRPRO
21448 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21449 WRITE(LOUT,1007) SIGDEL,ERRDEL
21450 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21451 WRITE(LOUT,1008) SIGDQE,ERRDQE
21452 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21453 ENDIF
21454
21455 2 CONTINUE
21456 1 CONTINUE
21457
21458 RETURN
21459 END
21460
21461*$ CREATE DT_SIGGA.FOR
21462*COPY DT_SIGGA
21463*
21464*===sigga==============================================================*
21465*
21466 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21467
21468************************************************************************
21469* Total/inelastic photon-nucleus cross sections. *
21470* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21471* production runs !!!! *
21472* This version dated 27.03.96 is written by S. Roesler *
21473************************************************************************
21474
21475 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21476 SAVE
21477
21478 PARAMETER ( LINP = 10 ,
21479 & LOUT = 6 ,
21480 & LDAT = 9 )
21481
21482 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21483 & OHALF=0.5D0,ONE=1.0D0)
21484 PARAMETER (AMPROT = 0.938D0)
21485
21486 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21487
21488* Glauber formalism: cross sections
21489 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21490 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21491 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21492 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21493 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21494 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21495 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21496 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21497 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21498 & BSLOPE,NEBINI,NQBINI
21499
21500 NT = NTI
21501 X = XI
21502 Q2 = Q2I
21503 ECM = ECMI
21504 XNU = XNUI
21505 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21506 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21507 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21508 STOT = XSTOT(1,1,1)
21509 ETOT = XETOT(1,1,1)
21510 SIN = XSPRO(1,1,1)
21511 EIN = XEPRO(1,1,1)
21512
21513 RETURN
21514 END
21515
21516*$ CREATE DT_SIGGAT.FOR
21517*COPY DT_SIGGAT
21518*
21519*===siggat=============================================================*
21520*
21521 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21522
21523************************************************************************
21524* Total/inelastic photon-nucleus cross sections. *
21525* Uses pre-tabulated cross section. *
21526* This version dated 29.07.96 is written by S. Roesler *
21527************************************************************************
21528
21529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21530 SAVE
21531
21532 PARAMETER ( LINP = 10 ,
21533 & LOUT = 6 ,
21534 & LDAT = 9 )
21535
21536 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21537 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21538
21539 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21540
21541* Glauber formalism: cross sections
21542 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21543 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21544 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21545 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21546 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21547 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21548 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21549 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21550 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21551 & BSLOPE,NEBINI,NQBINI
21552
21553 NTARG = ABS(NT)
21554 I1 = 1
21555 I2 = 1
21556 RATE = ONE
21557 IF (NEBINI.GT.1) THEN
21558 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21559 I1 = NEBINI
21560 I2 = NEBINI
21561 RATE = ONE
21562 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21563 DO 1 I=2,NEBINI
21564 IF (ECMI.LT.ECMNN(I)) THEN
21565 I1 = I-1
21566 I2 = I
21567 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21568 GOTO 2
21569 ENDIF
21570 1 CONTINUE
21571 2 CONTINUE
21572 ENDIF
21573 ENDIF
21574 J1 = 1
21575 J2 = 1
21576 RATQ = ONE
21577 IF (NQBINI.GT.1) THEN
21578 IF (Q2I.GE.Q2G(NQBINI)) THEN
21579 J1 = NQBINI
21580 J2 = NQBINI
21581 RATQ = ONE
21582 ELSEIF (Q2I.GT.Q2G(1)) THEN
21583 DO 3 I=2,NQBINI
21584 IF (Q2I.LT.Q2G(I)) THEN
21585 J1 = I-1
21586 J2 = I
21587 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21588 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21589C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21590 GOTO 4
21591 ENDIF
21592 3 CONTINUE
21593 4 CONTINUE
21594 ENDIF
21595 ENDIF
21596
21597 STOT = XSTOT(I1,J1,NTARG)+
21598 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21599 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21600 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21601 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21602
21603 RETURN
21604 END
21605
21606*$ CREATE DT_SANO.FOR
21607*COPY DT_SANO
21608*
21609*===sigano=============================================================*
21610*
21611 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21612
21613************************************************************************
21614* This version dated 31.07.96 is written by S. Roesler *
21615************************************************************************
21616
21617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21618 SAVE
21619
21620 PARAMETER ( LINP = 10 ,
21621 & LOUT = 6 ,
21622 & LDAT = 9 )
21623
21624 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21625 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21626 PARAMETER (NE = 8)
21627
21628* VDM parameter for photon-nucleus interactions
21629 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21630
21631* properties of interacting particles
21632 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21633
21634 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21635 DATA ECMANO /
21636 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21637 & 0.100D+04,0.200D+04,0.500D+04
21638 & /
21639* fixed cut (3 GeV/c)
21640 DATA FRAANO /
21641 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21642 & 0.062D+00,0.054D+00,0.042D+00
21643 & /
21644 DATA SIGHRD /
21645 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21646 & 3.3086D-01,7.6255D-01,2.1319D+00
21647 & /
21648* running cut (based on obsolete Phojet-caluclations, bugs..)
21649C DATA FRAANO /
21650C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21651C & 0.167E+00,0.150E+00,0.131E+00
21652C & /
21653C DATA SIGHRD /
21654C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21655C & 2.5736E-01,4.5593E-01,8.2550E-01
21656C & /
21657
21658 DT_SANO = ZERO
21659 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21660 J1 = 0
21661 J2 = 0
21662 RATE = ONE
21663 IF (ECM.GE.ECMANO(NE)) THEN
21664 J1 = NE
21665 J2 = NE
21666 ELSEIF (ECM.GT.ECMANO(1)) THEN
21667 DO 1 IE=2,NE
21668 IF (ECM.LT.ECMANO(IE)) THEN
21669 J1 = IE-1
21670 J2 = IE
21671 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21672 GOTO 2
21673 ENDIF
21674 1 CONTINUE
21675 2 CONTINUE
21676 ENDIF
21677 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21678 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21679 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21680 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21681 ENDIF
21682
21683 RETURN
21684 END
21685
21686*$ CREATE DT_SIGGP.FOR
21687*COPY DT_SIGGP
21688*
21689*===siggp==============================================================*
21690*
21691 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21692
21693************************************************************************
21694* Total/inelastic photon-nucleon cross sections. *
21695* This version dated 30.04.96 is written by S. Roesler *
21696************************************************************************
21697
21698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21699 SAVE
21700
21701 PARAMETER ( LINP = 10 ,
21702 & LOUT = 6 ,
21703 & LDAT = 9 )
21704
21705 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21706 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21707 & PI = TWOPI/TWO,
21708 & GEV2MB = 0.38938D0,
21709 & ALPHEM = ONE/137.0D0)
21710
21711* particle properties (BAMJET index convention)
21712 CHARACTER*8 ANAME
21713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21714 & IICH(210),IIBAR(210),K1(210),K2(210)
21715
21716* VDM parameter for photon-nucleus interactions
21717 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21718
21719**PHOJET105a
21720C CHARACTER*8 MDLNA
21721C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21722C PARAMETER (IEETAB=10)
21723C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21724**PHOJET110
21725
21726C model switches and parameters
21727 CHARACTER*8 MDLNA
21728 INTEGER ISWMDL,IPAMDL
21729 DOUBLE PRECISION PARMDL
21730 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21731
21732C energy-interpolation table
21733 INTEGER IEETA2
21734 PARAMETER ( IEETA2 = 20 )
21735 INTEGER ISIMAX
21736 DOUBLE PRECISION SIGTAB,SIGECM
21737 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21738**
21739
21740C PARAMETER (NPOINT=80)
21741 PARAMETER (NPOINT=16)
21742 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21743
21744 STOT = ZERO
21745 SINE = ZERO
21746 SDIR = ZERO
21747
21748 W2 = ECMI**2
21749 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21750 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21751 Q2 = Q2I
21752 X = XI
21753* photoprod.
21754 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21755 Q2 = 0.0001D0
21756 X = Q2/(W2+Q2-AAM(1)**2)
21757* DIS
21758 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21759 X = Q2/(W2+Q2-AAM(1)**2)
21760 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21761 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21762 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21763 W2 = Q2*(ONE-X)/X+AAM(1)**2
21764 ELSE
21765 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21766 STOP
21767 ENDIF
21768 ECM = SQRT(W2)
21769
21770 IF (MODEGA.EQ.1) THEN
21771 SCALE = SQRT(Q2)
21772 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21773 & IDPDF)
21774C W = SQRT(W2)
21775
21776C ALLMF2 = PHO_ALLM97(Q2,W)
21777
21778C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21779 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21780 SINE = ZERO
21781 SDIR = ZERO
21782 ELSEIF (MODEGA.EQ.2) THEN
21783 IF (INTRGE(1).EQ.1) THEN
21784 AMLO2 = (3.0D0*AAM(13))**2
21785 ELSEIF (INTRGE(1).EQ.2) THEN
21786 AMLO2 = AAM(33)**2
21787 ELSE
21788 AMLO2 = AAM(96)**2
21789 ENDIF
21790 IF (INTRGE(2).EQ.1) THEN
21791 AMHI2 = W2/TWO
21792 ELSEIF (INTRGE(2).EQ.2) THEN
21793 AMHI2 = W2/4.0D0
21794 ELSE
21795 AMHI2 = W2
21796 ENDIF
21797 AMHI20 = (ECM-AAM(1))**2
21798 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21799 XAMLO = LOG( AMLO2+Q2 )
21800 XAMHI = LOG( AMHI2+Q2 )
21801**PHOJET105a
21802C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21803**PHOJET112
21804
21805 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21806
21807**
21808 SUM = ZERO
21809 DO 1 J=1,NPOINT
21810 AM2 = EXP(ABSZX(J))-Q2
21811 IF (AM2.LT.16.0D0) THEN
21812 R = TWO
21813 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21814 R = 10.0D0/3.0D0
21815 ELSE
21816 R = 11.0D0/3.0D0
21817 ENDIF
21818C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21819 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21820 & * (ONE+EPSPOL*Q2/AM2)
21821 SUM = SUM+WEIGHT(J)*FAC
21822 1 CONTINUE
21823 SINE = SUM
21824 SDIR = DT_SIGVP(X,Q2)
21825 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21826 SDIR = SDIR/(0.588D0+RL2+Q2)
21827C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21828 ELSEIF (MODEGA.EQ.3) THEN
21829 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21830 ELSEIF (MODEGA.EQ.4) THEN
21831* load cross sections from PHOJET interpolation table
21832 IP = 1
21833 IF(ECM.LE.SIGECM(IP,1)) THEN
21834 I1 = 1
21835 I2 = 1
21836 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21837 DO 2 I=2,ISIMAX
21838 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21839 2 CONTINUE
21840 3 CONTINUE
21841 I1 = I-1
21842 I2 = I
21843 ELSE
21844 WRITE(LOUT,'(/1X,A,2E12.3)')
21845 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21846 I1 = ISIMAX
21847 I2 = ISIMAX
21848 ENDIF
21849 FAC2 = ZERO
21850 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21851 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21852 FAC1 = ONE-FAC2
21853* cross section dependence on photon virtuality
21854 FSUP1 = ZERO
21855 DO 4 I=1,3
21856 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21857 & /(1.D0+Q2/PARMDL(30+I))**2
21858 4 CONTINUE
21859 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21860 FAC1 = FAC1*FSUP1
21861 FAC2 = FAC2*FSUP1
21862 FSUP2 = 1.0D0
21863 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21864 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21865 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21866**re:
21867 STOT = STOT-SDIR
21868**
21869 SDIR = SDIR/(FSUP1*FSUP2)
21870**re:
21871 STOT = STOT+SDIR
21872**
21873 ENDIF
21874
21875 RETURN
21876 END
21877
21878*$ CREATE DT_SIGVEL.FOR
21879*COPY DT_SIGVEL
21880*
21881*===sigvel=============================================================*
21882*
21883 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21884
21885************************************************************************
21886* Cross section for elastic vector meson production *
21887* This version dated 10.05.96 is written by S. Roesler *
21888************************************************************************
21889
21890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21891 SAVE
21892
21893 PARAMETER ( LINP = 10 ,
21894 & LOUT = 6 ,
21895 & LDAT = 9 )
21896
21897 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21898 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21899 & PI = TWOPI/TWO,
21900 & GEV2MB = 0.38938D0,
21901 & ALPHEM = ONE/137.0D0)
21902
21903* particle properties (BAMJET index convention)
21904 CHARACTER*8 ANAME
21905 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21906 & IICH(210),IIBAR(210),K1(210),K2(210)
21907
21908* VDM parameter for photon-nucleus interactions
21909 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21910
21911 W2 = ECMI**2
21912 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21913 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21914 Q2 = Q2I
21915 X = XI
21916* photoprod.
21917 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21918 Q2 = 0.0001D0
21919 X = Q2/(W2+Q2-AAM(1)**2)
21920* DIS
21921 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21922 X = Q2/(W2+Q2-AAM(1)**2)
21923 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21924 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21925 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21926 W2 = Q2*(ONE-X)/X+AAM(1)**2
21927 ELSE
21928 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21929 STOP
21930 ENDIF
21931 ECM = SQRT(W2)
21932
21933 AMV = AAM(IDXV)
21934 AMV2 = AMV**2
21935
21936 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21937 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21938 ROSH = 0.1D0
21939 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21940 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21941
21942 IF (IDXV.EQ.33) THEN
21943 COUPL = 0.00365D0
21944 ELSE
21945 STOP
21946 ENDIF
21947 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21948 SIG2 = SELVP
21949 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21950 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21951
21952 RETURN
21953 END
21954
21955*$ CREATE DT_SIGVP.FOR
21956*COPY DT_SIGVP
21957*
21958*===sigvp==============================================================*
21959*
21960 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21961
21962************************************************************************
21963* sigma_Vp *
21964************************************************************************
21965
21966 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21967 SAVE
21968
21969 PARAMETER ( LINP = 10 ,
21970 & LOUT = 6 ,
21971 & LDAT = 9 )
21972
21973 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21974 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21975 & PI = TWOPI/TWO,
21976 & GEV2MB = 0.38938D0,
21977 & AMPROT = 0.938D0,
21978 & ALPHEM = ONE/137.0D0)
21979
21980* VDM parameter for photon-nucleus interactions
21981 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21982
21983 X = XI
21984 Q2 = Q2I
21985 IF (XI.LE.ZERO) X = 0.0001D0
21986 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21987
21988 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21989
21990 SCALE = SQRT(Q2)
21991 IF (MODEGA.EQ.1) THEN
21992 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21993 & IDPDF)
21994C W = ECM
21995
21996C ALLMF2 = PHO_ALLM97(Q2,W)
21997
21998C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21999C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22000C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22001 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22002 ELSEIF (MODEGA.EQ.4) THEN
22003 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22004C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22005 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22006 ELSE
22007 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22008 ENDIF
22009
22010 RETURN
22011
22012 END
22013
22014*$ CREATE DT_RRM2.FOR
22015*COPY DT_RRM2
22016*
22017*===RRM2===============================================================*
22018*
22019 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22020
22021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22022 SAVE
22023
22024 PARAMETER ( LINP = 10 ,
22025 & LOUT = 6 ,
22026 & LDAT = 9 )
22027
22028 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22029 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22030 & PI = TWOPI/TWO,
22031 & GEV2MB = 0.38938D0)
22032
22033* particle properties (BAMJET index convention)
22034 CHARACTER*8 ANAME
22035 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22036 & IICH(210),IIBAR(210),K1(210),K2(210)
22037
22038* VDM parameter for photon-nucleus interactions
22039 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22040
22041 S = Q2*(ONE-X)/X+AAM(1)**2
22042 ECM = SQRT(S)
22043
22044 IF (INTRGE(1).EQ.1) THEN
22045 AMLO2 = (3.0D0*AAM(13))**2
22046 ELSEIF (INTRGE(1).EQ.2) THEN
22047 AMLO2 = AAM(33)**2
22048 ELSE
22049 AMLO2 = AAM(96)**2
22050 ENDIF
22051 IF (INTRGE(2).EQ.1) THEN
22052 AMHI2 = S/TWO
22053 ELSEIF (INTRGE(2).EQ.2) THEN
22054 AMHI2 = S/4.0D0
22055 ELSE
22056 AMHI2 = S
22057 ENDIF
22058 AMHI20 = (ECM-AAM(1))**2
22059 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22060
22061 AM1C2 = 16.0D0
22062 AM2C2 = 121.0D0
22063 IF (AMHI2.LE.AM1C2) THEN
22064 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22065 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22066 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22067 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22068 ELSE
22069 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22070 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22071 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22072 ENDIF
22073
22074 RETURN
22075 END
22076
22077*$ CREATE DT_RM2.FOR
22078*COPY DT_RM2
22079*
22080*===RM2================================================================*
22081*
22082 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22083
22084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22085 SAVE
22086
22087 PARAMETER ( LINP = 10 ,
22088 & LOUT = 6 ,
22089 & LDAT = 9 )
22090
22091 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22092 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22093 & PI = TWOPI/TWO,
22094 & GEV2MB = 0.38938D0)
22095
22096* VDM parameter for photon-nucleus interactions
22097 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22098
22099 IF (RL2.LE.ZERO) THEN
22100 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22101 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22102 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22103 ELSE
22104 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22105 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22106 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22107 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22108 & +EPSPOL*(
22109 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22110 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22111 ENDIF
22112
22113 RETURN
22114 END
22115
22116*$ CREATE DT_SAM2.FOR
22117*COPY DT_SAM2
22118*
22119*===SAM2===============================================================*
22120*
22121 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22122
22123 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22124 SAVE
22125
22126 PARAMETER ( LINP = 10 ,
22127 & LOUT = 6 ,
22128 & LDAT = 9 )
22129
22130 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22131 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22132 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22133 & PI = TWOPI/TWO,
22134 & GEV2MB = 0.38938D0)
22135
22136* particle properties (BAMJET index convention)
22137 CHARACTER*8 ANAME
22138 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22139 & IICH(210),IIBAR(210),K1(210),K2(210)
22140
22141* VDM parameter for photon-nucleus interactions
22142 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22143
22144 S = ECM**2
22145 IF (INTRGE(1).EQ.1) THEN
22146 AMLO2 = (3.0D0*AAM(13))**2
22147 ELSEIF (INTRGE(1).EQ.2) THEN
22148 AMLO2 = AAM(33)**2
22149 ELSE
22150 AMLO2 = AAM(96)**2
22151 ENDIF
22152 IF (INTRGE(2).EQ.1) THEN
22153 AMHI2 = S/TWO
22154 ELSEIF (INTRGE(2).EQ.2) THEN
22155 AMHI2 = S/4.0D0
22156 ELSE
22157 AMHI2 = S
22158 ENDIF
22159 AMHI20 = (ECM-AAM(1))**2
22160 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22161
22162 AM1C2 = 16.0D0
22163 AM2C2 = 121.0D0
22164 YLO = LOG(AMLO2+Q2)
22165 YC1 = LOG(AM1C2+Q2)
22166 YC2 = LOG(AM2C2+Q2)
22167 YHI = LOG(AMHI2+Q2)
22168 IF (AMHI2.LE.AM1C2) THEN
22169 FACHI = TWO
22170 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22171 FACHI = TENTRD
22172 ELSE
22173 FACHI = ELVTRD
22174 ENDIF
22175
22176 1 CONTINUE
22177 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22178 IF (YSAM2.LE.YC1) THEN
22179 FAC = TWO
22180 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22181 FAC = TENTRD
22182 ELSE
22183 FAC = ELVTRD
22184 ENDIF
22185 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22186 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22187 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22188
22189 DT_SAM2 = EXP(YSAM2)-Q2
22190
22191 RETURN
22192 END
22193
22194*$ CREATE DT_CKMT.FOR
22195*COPY DT_CKMT
22196*
22197*===ckmt===============================================================*
22198*
22199 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22200 & F2,IPAR)
22201
22202************************************************************************
22203* This version dated 31.01.96 is written by S. Roesler *
22204************************************************************************
22205
22206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22207 SAVE
22208
22209 PARAMETER ( LINP = 10 ,
22210 & LOUT = 6 ,
22211 & LDAT = 9 )
22212
22213 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22214
22215 PARAMETER (Q02 = 2.0D0,
22216 & DQ2 = 10.05D0,
22217 & Q12 = Q02+DQ2)
22218
22219 DIMENSION PD(-6:6),SEA(3),VAL(2)
22220
22221 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22222 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22223 ADQ2 = LOG10(Q12)-LOG10(Q02)
22224 F2P = (F2Q1-F2Q0)/ADQ2
22225 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22226 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22227 F2PP = (F2PQ1-F2PQ0)/ADQ2
22228 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22229
22230 Q2 = MAX(SCALE**2.0D0,TINY10)
22231 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22232 IF (Q2.LT.Q02) THEN
22233 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22234 UPV = VAL(1)
22235 DNV = VAL(2)
22236 USEA = SEA(1)
22237 DSEA = SEA(2)
22238 STR = SEA(3)
22239 CHM = 0.0D0
22240 BOT = 0.0D0
22241 TOP = 0.0D0
22242 GL = GLU
22243 ELSE
22244 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22245 F2 = F2*SMOOTH
22246 UPV = PD(2)-PD(3)
22247 DNV = PD(1)-PD(3)
22248 USEA = PD(3)
22249 DSEA = PD(3)
22250 STR = PD(3)
22251 CHM = PD(4)
22252 BOT = PD(5)
22253 TOP = PD(6)
22254 GL = PD(0)
22255C UPV = UPV*SMOOTH
22256C DNV = DNV*SMOOTH
22257C USEA = USEA*SMOOTH
22258C DSEA = DSEA*SMOOTH
22259C STR = STR*SMOOTH
22260C CHM = CHM*SMOOTH
22261C GL = GL*SMOOTH
22262 ENDIF
22263
22264 RETURN
22265 END
22266C
22267
22268*$ CREATE DT_CKMTX.FOR
22269*COPY DT_CKMTX
22270 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22271C**********************************************************************
22272C
22273C PDF based on Regge theory, evolved with .... by ....
22274C
22275C input: IPAR 2212 proton (not installed)
22276C 45 Pomeron
22277C 100 Deuteron
22278C
22279C output: PD(-6:6) x*f(x) parton distribution functions
22280C (PDFLIB convention: d = PD(1), u = PD(2) )
22281C
22282C**********************************************************************
22283
22284 SAVE
22285 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22286
22287 PARAMETER ( LINP = 10 ,
22288 & LOUT = 6 ,
22289 & LDAT = 9 )
22290
22291 DIMENSION QQ(7)
22292C
22293 Q2=SNGL(SCALE2)
22294 Q1S=Q2
22295 XX=SNGL(X)
22296C QCD lambda for evolution
22297 OWLAM = 0.23D0
22298 OWLAM2=OWLAM**2
22299C Q0**2 for evolution
22300 Q02 = 2.D0
22301C
22302C
22303C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22304C q(6)=x*charm, q(7)=x*gluon
22305C
22306 SB=0.
22307 IF(Q2-Q02) 1,1,2
22308 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22309 1 CONTINUE
22310 IF(IPAR.EQ.2212) THEN
22311 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22312 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22313 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22314 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22315 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22316 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22317 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22318C ELSEIF (IPAR.EQ.45) THEN
22319C CALL CKMTPO(1,0,XX,SB,QQ(1))
22320C CALL CKMTPO(2,0,XX,SB,QQ(2))
22321C CALL CKMTPO(3,0,XX,SB,QQ(3))
22322C CALL CKMTPO(4,0,XX,SB,QQ(4))
22323C CALL CKMTPO(5,0,XX,SB,QQ(5))
22324C CALL CKMTPO(8,0,XX,SB,QQ(6))
22325C CALL CKMTPO(7,0,XX,SB,QQ(7))
22326 ELSEIF (IPAR.EQ.100) THEN
22327 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22328 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22329 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22330 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22331 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22332 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22333 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22334 ELSE
22335 WRITE(LOUT,'(1X,A,I4,A)')
22336 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22337 STOP
22338 ENDIF
22339C
22340 PD(-6) = 0.D0
22341 PD(-5) = 0.D0
22342 PD(-4) = DBLE(QQ(6))
22343 PD(-3) = DBLE(QQ(3))
22344 PD(-2) = DBLE(QQ(4))
22345 PD(-1) = DBLE(QQ(5))
22346 PD(0) = DBLE(QQ(7))
22347 PD(1) = DBLE(QQ(2))
22348 PD(2) = DBLE(QQ(1))
22349 PD(3) = DBLE(QQ(3))
22350 PD(4) = DBLE(QQ(6))
22351 PD(5) = 0.D0
22352 PD(6) = 0.D0
22353 IF(IPAR.EQ.45) THEN
22354 CDN = (PD(1)-PD(-1))/2.D0
22355 CUP = (PD(2)-PD(-2))/2.D0
22356 PD(-1) = PD(-1) + CDN
22357 PD(-2) = PD(-2) + CUP
22358 PD(1) = PD(-1)
22359 PD(2) = PD(-2)
22360 ENDIF
22361 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22362 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22363 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22364 END
22365C
22366
22367*$ CREATE DT_PDF0.FOR
22368*COPY DT_PDF0
22369*
22370*===pdf0===============================================================*
22371*
22372 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22373
22374************************************************************************
22375* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22376* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22377* IPAR = 2212 proton *
22378* = 100 deuteron *
22379* This version dated 31.01.96 is written by S. Roesler *
22380************************************************************************
22381
22382 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22383 SAVE
22384
22385 PARAMETER ( LINP = 10 ,
22386 & LOUT = 6 ,
22387 & LDAT = 9 )
22388
22389 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22390
22391 PARAMETER (
22392 & AA = 0.1502D0,
22393 & BBDEU = 1.2D0,
22394 & BUD = 0.754D0,
22395 & BDD = 0.4495D0,
22396 & BUP = 1.2064D0,
22397 & BDP = 0.1798D0,
22398 & DELTA0 = 0.07684D0,
22399 & D = 1.117D0,
22400 & C = 3.5489D0,
22401 & A = 0.2631D0,
22402 & B = 0.6452D0,
22403 & ALPHAR = 0.415D0,
22404 & E = 0.1D0
22405 & )
22406
22407 PARAMETER (NPOINT=16)
22408C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22409 DIMENSION SEA(3),VAL(2)
22410
22411 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22412 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22413* proton, deuteron
22414 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22415 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22416 SEA(1) = 0.75D0*SEA0
22417 SEA(2) = SEA(1)
22418 SEA(3) = SEA(1)
22419 VAL(1) = 9.0D0/4.0D0*VALU0
22420 VAL(2) = 9.0D0*VALD0
22421 GLU0 = SEA(1)/(1.0D0-X)
22422 F2 = SEA0+VALU0+VALD0
22423 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22424 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22425 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22426 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22427 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22428 STOP
22429 ENDIF
22430**PHOJET105a
22431C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22432**PHOJET112
22433
22434C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22435
22436**
22437C SUMQ = ZERO
22438C SUMG = ZERO
22439C DO 1 J=1,NPOINT
22440C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22441C VALU0 = 9.0D0/4.0D0*VALU0
22442C VALD0 = 9.0D0*VALD0
22443C SEA0 = 0.75D0*SEA0
22444C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22445C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22446C 1 CONTINUE
22447C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22448 ELSE
22449 WRITE(LOUT,'(1X,A,I4,A)')
22450 & 'PDF0: IPAR =',IPAR,' not implemented!'
22451 STOP
22452 ENDIF
22453
22454 RETURN
22455 END
22456
22457*$ CREATE DT_CKMTQ0.FOR
22458*COPY DT_CKMTQ0
22459*
22460*===ckmtq0=============================================================*
22461*
22462 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22463
22464************************************************************************
22465* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22466* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22467* IPAR = 2212 proton *
22468* = 100 deuteron *
22469* This version dated 31.01.96 is written by S. Roesler *
22470************************************************************************
22471
22472 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22473 SAVE
22474
22475 PARAMETER ( LINP = 10 ,
22476 & LOUT = 6 ,
22477 & LDAT = 9 )
22478
22479 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22480
22481 PARAMETER (
22482 & AA = 0.1502D0,
22483 & BBDEU = 1.2D0,
22484 & BUD = 0.754D0,
22485 & BDD = 0.4495D0,
22486 & BUP = 1.2064D0,
22487 & BDP = 0.1798D0,
22488 & DELTA0 = 0.07684D0,
22489 & D = 1.117D0,
22490 & C = 3.5489D0,
22491 & A = 0.2631D0,
22492 & B = 0.6452D0,
22493 & ALPHAR = 0.415D0,
22494 & E = 0.1D0
22495 & )
22496
22497 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22498 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22499* proton, deuteron
22500 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22501 IF (IPAR.EQ.2212) THEN
22502 BU = BUP
22503 BD = BDP
22504 ELSE
22505 BU = BUD
22506 BD = BDD
22507 ENDIF
22508 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22509 & (Q2/(Q2+A))**(1.0D0+DELTA)
22510 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22511 & (Q2/(Q2+B))**(ALPHAR)
22512 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22513 & (Q2/(Q2+B))**(ALPHAR)
22514 ELSE
22515 WRITE(LOUT,'(1X,A,I4,A)')
22516 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22517 STOP
22518 ENDIF
22519 RETURN
22520 END
22521C
22522C
22523
22524*$ CREATE DT_CKMTDE.FOR
22525*COPY DT_CKMTDE
22526 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22527C
22528C**********************************************************************
22529C Deuteron - PDFs
22530C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22531C ANS = PDF(I)
22532C This version by S. Roesler, 30.01.96
22533C**********************************************************************
22534
22535 SAVE
22536 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22537 EQUIVALENCE (GF(1,1,1),DL(1))
22538 DATA DELTA/.13/
22539C
22540 DATA (DL(K),K= 1, 85) /
22541 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22542 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22543 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22544 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22545 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22546 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22547 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22548 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22549 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22550 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22551 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22552 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22553 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22554 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22555 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22556 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22557 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22558 DATA (DL(K),K= 86, 170) /
22559 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22560 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22561 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22562 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22563 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22564 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22565 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22566 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22567 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22568 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22569 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22570 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22571 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22572 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22573 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22574 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22575 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22576 DATA (DL(K),K= 171, 255) /
22577 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22578 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22579 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22580 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22581 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22582 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22583 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22584 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22585 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22586 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22587 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22588 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22589 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22590 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22591 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22592 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22593 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22594 DATA (DL(K),K= 256, 340) /
22595 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22596 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22597 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22598 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22599 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22600 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22601 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22602 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22603 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22604 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22605 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22606 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22607 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22608 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22609 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22610 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22611 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22612 DATA (DL(K),K= 341, 425) /
22613 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22614 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22615 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22616 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22617 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22618 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22619 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22620 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22621 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22622 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22623 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22624 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22625 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22626 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22627 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22628 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22629 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22630 DATA (DL(K),K= 426, 510) /
22631 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22632 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22633 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22634 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22635 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22636 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22637 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22638 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22639 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22640 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22641 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22642 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22643 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22644 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22645 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22646 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22647 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22648 DATA (DL(K),K= 511, 595) /
22649 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22650 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22651 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22652 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22653 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22654 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22655 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22656 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22657 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22658 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22659 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22660 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22661 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22662 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22663 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22664 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22665 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22666 DATA (DL(K),K= 596, 680) /
22667 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22668 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22669 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22670 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22671 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22672 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22673 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22674 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22675 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22676 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22677 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22678 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22679 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22680 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22681 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22682 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22683 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22684 DATA (DL(K),K= 681, 765) /
22685 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22686 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22687 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22688 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22689 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22690 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22691 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22692 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22693 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22694 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22695 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22696 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22697 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22698 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22699 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22700 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22701 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22702 DATA (DL(K),K= 766, 850) /
22703 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22704 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22705 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22706 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22707 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22708 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22709 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22710 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22711 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22712 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22713 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22714 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22715 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22716 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22717 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22718 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22719 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22720 DATA (DL(K),K= 851, 935) /
22721 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22722 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22723 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22724 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22725 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22726 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22727 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22728 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22729 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22730 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22731 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22732 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22733 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22734 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22735 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22736 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22737 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22738 DATA (DL(K),K= 936, 1020) /
22739 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22740 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22741 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22742 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22743 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22745 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22746 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22747 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22748 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22749 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22750 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22751 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22752 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22753 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22754 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22755 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22756 DATA (DL(K),K= 1021, 1105) /
22757 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22758 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22759 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22760 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22761 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22762 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22763 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22764 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22765 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22766 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22767 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22768 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22769 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22770 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22771 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22772 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22773 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22774 DATA (DL(K),K= 1106, 1190) /
22775 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22776 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22777 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22778 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22779 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22780 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22781 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22782 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22783 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22784 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22785 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22786 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22787 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22788 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22789 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22790 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22791 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22792 DATA (DL(K),K= 1191, 1275) /
22793 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22794 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22795 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22796 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22797 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22798 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22799 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22800 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22801 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22802 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22803 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22804 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22805 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22806 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22807 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22808 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22809 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22810 DATA (DL(K),K= 1276, 1360) /
22811 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22813 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22814 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22815 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22816 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22817 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22818 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22819 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22820 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22821 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22822 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22823 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22824 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22825 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22826 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22827 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22828 DATA (DL(K),K= 1361, 1445) /
22829 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22830 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22831 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22832 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22833 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22834 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22835 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22836 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22837 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22838 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22839 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22840 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22841 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22842 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22843 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22844 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22845 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22846 DATA (DL(K),K= 1446, 1530) /
22847 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22848 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22849 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22850 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22851 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22852 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22853 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22854 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22855 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22856 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22857 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22858 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22859 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22860 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22861 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22862 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22863 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22864 DATA (DL(K),K= 1531, 1615) /
22865 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22866 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22867 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22868 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22869 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22870 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22871 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22872 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22873 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22874 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22875 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22876 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22880 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22881 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22882 DATA (DL(K),K= 1616, 1700) /
22883 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22884 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22885 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22886 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22887 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22888 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22889 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22890 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22891 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22892 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22893 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22894 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22895 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22896 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22897 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22898 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22899 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22900 DATA (DL(K),K= 1701, 1785) /
22901 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22902 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22903 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22904 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22905 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22914 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22915 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22916 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22917 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22918 DATA (DL(K),K= 1786, 1870) /
22919 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22920 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22921 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22922 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22923 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22924 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22925 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22926 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22927 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22928 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22929 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22930 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22931 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22932 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22933 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22934 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22935 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22936 DATA (DL(K),K= 1871, 1955) /
22937 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22938 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22939 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22948 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22949 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22950 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22951 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22952 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22953 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22954 DATA (DL(K),K= 1956, 2040) /
22955 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22956 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22957 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22958 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22959 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22960 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22961 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22962 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22963 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22964 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22965 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22966 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22967 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22968 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22969 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22970 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22971 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22972 DATA (DL(K),K= 2041, 2125) /
22973 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22982 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22983 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22984 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22985 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22986 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22987 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22988 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22989 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22990 DATA (DL(K),K= 2126, 2210) /
22991 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22992 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22993 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22994 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22995 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22996 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22997 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22998 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22999 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23000 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23001 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23002 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23003 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23004 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23005 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23006 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23008 DATA (DL(K),K= 2211, 2295) /
23009 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23016 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23017 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23018 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23019 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23020 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23021 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23022 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23023 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23024 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23025 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23026 DATA (DL(K),K= 2296, 2380) /
23027 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23028 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23029 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23030 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23031 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23032 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23033 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23034 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23035 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23036 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23037 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23038 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23039 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23040 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23044 DATA (DL(K),K= 2381, 2465) /
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23048 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23049 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23050 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23051 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23052 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23053 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23054 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23055 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23056 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23057 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23058 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23059 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23060 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23061 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23062 DATA (DL(K),K= 2466, 2550) /
23063 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23064 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23065 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23066 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23067 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23068 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23069 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23070 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23071 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23072 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23073 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23074 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23075 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23080 DATA (DL(K),K= 2551, 2635) /
23081 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23084 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23085 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23086 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23087 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23088 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23089 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23090 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23091 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23092 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23093 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23094 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23095 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23096 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23097 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23098 DATA (DL(K),K= 2636, 2720) /
23099 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23100 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23101 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23102 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23103 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23104 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23105 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23106 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23107 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23108 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23111 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23112 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23116 DATA (DL(K),K= 2721, 2805) /
23117 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23118 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23119 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23120 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23121 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23122 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23123 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23124 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23125 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23126 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23127 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23128 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23129 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23130 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23131 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23132 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23133 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23134 DATA (DL(K),K= 2806, 2890) /
23135 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23136 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23137 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23138 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23139 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23140 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23141 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23142 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23146 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23147 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23151 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23152 DATA (DL(K),K= 2891, 2975) /
23153 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23154 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23155 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23156 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23157 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23158 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23159 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23160 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23161 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23162 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23163 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23164 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23165 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23166 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23167 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23168 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23169 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23170 DATA (DL(K),K= 2976, 3060) /
23171 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23172 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23173 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23174 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23175 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23176 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23185 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23186 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23187 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23188 DATA (DL(K),K= 3061, 3145) /
23189 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23190 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23191 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23192 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23193 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23194 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23195 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23196 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23197 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23198 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23199 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23200 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23201 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23202 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23203 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23204 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23205 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23206 DATA (DL(K),K= 3146, 3230) /
23207 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23208 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23209 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23210 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23219 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23220 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23221 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23222 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23223 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23224 DATA (DL(K),K= 3231, 3315) /
23225 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23226 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23227 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23228 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23229 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23230 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23231 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23232 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23233 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23234 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23235 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23236 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23237 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23238 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23239 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23240 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23241 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23242 DATA (DL(K),K= 3316, 3400) /
23243 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23244 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23253 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23254 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23255 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23256 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23257 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23258 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23259 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23260 DATA (DL(K),K= 3401, 3485) /
23261 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23262 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23263 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23264 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23265 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23266 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23267 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23268 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23269 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23270 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23271 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23272 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23273 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23274 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23275 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23276 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23277 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23278 DATA (DL(K),K= 3486, 3570) /
23279 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23287 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23288 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23289 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23290 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23291 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23292 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23293 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23294 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23295 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23296 DATA (DL(K),K= 3571, 3655) /
23297 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23298 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23299 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23300 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23301 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23302 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23303 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23304 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23305 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23306 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23307 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23308 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23309 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23310 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23311 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23314 DATA (DL(K),K= 3656, 3740) /
23315 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23321 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23322 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23323 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23324 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23325 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23326 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23327 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23328 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23329 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23330 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23331 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23332 DATA (DL(K),K= 3741, 3825) /
23333 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23334 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23335 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23336 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23337 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23338 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23339 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23340 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23341 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23342 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23343 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23344 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23345 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23350 DATA (DL(K),K= 3826, 3910) /
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23355 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23356 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23357 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23358 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23359 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23360 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23361 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23362 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23363 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23364 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23365 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23366 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23367 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23368 DATA (DL(K),K= 3911, 3995) /
23369 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23370 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23371 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23372 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23373 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23374 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23375 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23376 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23377 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23378 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23379 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23381 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23386 DATA (DL(K),K= 3996, 4000) /
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23388C
23389 ANS = 0.
23390 IF (X.GT.0.9985) RETURN
23391 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23392C
23393 IS = S/DELTA+1
23394 IS1 = IS+1
23395 DO 1 L=1,25
23396 KL = L+NDRV*25
23397 F1(L) = GF(I,IS,KL)
23398 F2(L) = GF(I,IS1,KL)
23399 1 CONTINUE
23400 A1 = DT_CKMTFF(X,F1)
23401 A2 = DT_CKMTFF(X,F2)
23402C A1=ALOG(A1)
23403C A2=ALOG(A2)
23404 S1 = (IS-1)*DELTA
23405 S2 = S1+DELTA
23406 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23407C ANS=EXP(ANS)
23408 RETURN
23409 END
23410C
23411C
23412
23413*$ CREATE DT_CKMTPR.FOR
23414*COPY DT_CKMTPR
23415 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23416C
23417C**********************************************************************
23418C Proton - PDFs
23419C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23420C ANS = PDF(I)
23421C This version by S. Roesler, 31.01.96
23422C**********************************************************************
23423
23424 SAVE
23425 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23426 EQUIVALENCE (GF(1,1,1),DL(1))
23427 DATA DELTA/.10/
23428C
23429 DATA (DL(K),K= 1, 85) /
23430 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23431 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23432 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23433 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23434 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23435 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23436 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23437 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23438 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23439 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23440 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23441 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23442 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23443 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23444 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23445 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23446 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23447 DATA (DL(K),K= 86, 170) /
23448 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23449 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23450 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23451 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23452 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23453 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23454 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23455 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23456 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23457 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23458 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23459 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23460 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23461 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23462 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23464 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23465 DATA (DL(K),K= 171, 255) /
23466 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23467 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23468 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23469 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23470 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23471 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23472 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23473 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23474 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23475 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23476 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23477 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23478 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23479 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23480 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23481 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23482 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23483 DATA (DL(K),K= 256, 340) /
23484 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23485 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23486 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23487 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23488 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23489 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23490 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23491 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23492 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23493 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23494 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23495 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23496 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23498 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23499 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23500 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23501 DATA (DL(K),K= 341, 425) /
23502 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23503 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23504 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23505 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23506 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23507 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23508 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23509 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23510 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23511 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23512 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23513 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23514 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23515 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23516 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23517 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23518 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23519 DATA (DL(K),K= 426, 510) /
23520 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23521 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23522 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23523 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23524 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23525 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23526 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23527 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23528 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23529 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23532 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23533 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23534 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23535 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23536 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23537 DATA (DL(K),K= 511, 595) /
23538 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23539 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23540 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23541 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23542 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23543 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23544 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23545 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23546 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23547 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23548 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23549 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23550 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23551 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23552 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23553 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23554 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23555 DATA (DL(K),K= 596, 680) /
23556 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23557 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23558 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23559 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23560 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23561 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23562 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23563 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23566 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23567 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23568 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23569 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23570 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23571 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23572 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23573 DATA (DL(K),K= 681, 765) /
23574 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23575 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23576 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23577 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23578 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23579 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23580 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23581 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23582 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23583 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23584 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23585 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23586 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23587 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23588 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23589 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23590 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23591 DATA (DL(K),K= 766, 850) /
23592 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23593 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23594 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23595 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23596 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23597 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23600 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23601 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23602 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23603 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23604 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23605 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23606 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23607 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23608 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23609 DATA (DL(K),K= 851, 935) /
23610 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23611 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23612 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23613 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23614 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23615 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23616 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23617 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23618 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23619 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23620 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23621 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23622 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23623 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23624 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23625 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23626 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23627 DATA (DL(K),K= 936, 1020) /
23628 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23629 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23630 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23631 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23634 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23635 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23636 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23637 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23638 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23639 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23640 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23641 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23642 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23643 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23644 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23645 DATA (DL(K),K= 1021, 1105) /
23646 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23647 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23648 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23649 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23650 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23651 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23652 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23653 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23654 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23655 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23656 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23657 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23658 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23659 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23660 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23661 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23662 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23663 DATA (DL(K),K= 1106, 1190) /
23664 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23665 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23666 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23668 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23669 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23670 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23671 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23672 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23673 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23674 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23675 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23676 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23677 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23678 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23679 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23680 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23681 DATA (DL(K),K= 1191, 1275) /
23682 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23683 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23684 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23685 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23686 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23687 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23688 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23689 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23690 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23691 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23692 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23693 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23694 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23695 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23696 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23697 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23698 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23699 DATA (DL(K),K= 1276, 1360) /
23700 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23701 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23702 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23703 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23704 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23705 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23706 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23707 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23708 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23709 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23710 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23711 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23712 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23713 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23714 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23715 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23716 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23717 DATA (DL(K),K= 1361, 1445) /
23718 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23719 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23720 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23721 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23722 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23723 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23724 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23725 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23726 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23727 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23728 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23729 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23730 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23731 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23732 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23733 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23735 DATA (DL(K),K= 1446, 1530) /
23736 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23737 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23738 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23739 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23740 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23741 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23742 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23743 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23744 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23745 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23746 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23747 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23748 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23749 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23750 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23751 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23752 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23753 DATA (DL(K),K= 1531, 1615) /
23754 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23755 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23756 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23757 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23758 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23759 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23760 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23761 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23762 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23763 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23764 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23765 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23766 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23767 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23768 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23769 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23770 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23771 DATA (DL(K),K= 1616, 1700) /
23772 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23773 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23774 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23775 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23776 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23777 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23778 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23779 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23780 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23781 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23782 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23783 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23784 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23785 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23786 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23787 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23788 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23789 DATA (DL(K),K= 1701, 1785) /
23790 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23791 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23792 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23793 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23794 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23795 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23796 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23797 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23798 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23799 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23800 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23801 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23802 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23803 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23804 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23805 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23806 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23807 DATA (DL(K),K= 1786, 1870) /
23808 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23809 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23810 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23811 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23812 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23813 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23814 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23815 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23816 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23817 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23818 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23819 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23820 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23821 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23822 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23823 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23824 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23825 DATA (DL(K),K= 1871, 1955) /
23826 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23827 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23828 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23829 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23830 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23831 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23832 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23833 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23834 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23835 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23836 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23837 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23838 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23839 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23840 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23841 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23842 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23843 DATA (DL(K),K= 1956, 2040) /
23844 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23845 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23846 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23847 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23848 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23849 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23850 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23851 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23852 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23853 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23854 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23855 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23856 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23857 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23858 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23859 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23860 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23861 DATA (DL(K),K= 2041, 2125) /
23862 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23863 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23864 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23865 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23866 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23867 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23868 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23869 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23870 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23871 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23872 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23873 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23874 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23875 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23876 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23877 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23878 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23879 DATA (DL(K),K= 2126, 2210) /
23880 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23881 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23882 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23883 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23884 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23885 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23886 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23887 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23888 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23889 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23890 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23891 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23892 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23893 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23894 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23895 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23896 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23897 DATA (DL(K),K= 2211, 2295) /
23898 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23899 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23900 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23901 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23902 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23903 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23904 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23905 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23906 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23907 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23908 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23909 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23910 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23911 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23912 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23913 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23914 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23915 DATA (DL(K),K= 2296, 2380) /
23916 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23917 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23918 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23919 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23920 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23921 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23922 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23923 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23924 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23925 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23926 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23927 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23928 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23929 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23930 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23931 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23932 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23933 DATA (DL(K),K= 2381, 2465) /
23934 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23935 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23936 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23937 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23938 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23939 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23940 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23941 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23942 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23943 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23944 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23945 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23946 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23947 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23948 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23949 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23950 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23951 DATA (DL(K),K= 2466, 2550) /
23952 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23953 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23954 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23955 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23956 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23957 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23958 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23959 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23960 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23961 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23962 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23963 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23964 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23965 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23966 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23967 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23968 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23969 DATA (DL(K),K= 2551, 2635) /
23970 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23971 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23972 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23973 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23974 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23975 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23976 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23977 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23978 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23979 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23980 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23981 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23982 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23983 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23984 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23985 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23986 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23987 DATA (DL(K),K= 2636, 2720) /
23988 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23989 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23990 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23991 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23992 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23993 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23994 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23995 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23996 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23997 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23998 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23999 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24000 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24001 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24002 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24003 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24004 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24005 DATA (DL(K),K= 2721, 2805) /
24006 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24007 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24008 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24009 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24010 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24011 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24012 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24013 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24014 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24015 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24016 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24017 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24018 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24019 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24020 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24021 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24022 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24023 DATA (DL(K),K= 2806, 2890) /
24024 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24025 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24026 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24027 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24028 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24029 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24030 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24031 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24032 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24033 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24034 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24035 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24036 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24037 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24038 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24039 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24040 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24041 DATA (DL(K),K= 2891, 2975) /
24042 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24043 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24044 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24045 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24046 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24047 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24048 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24049 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24050 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24051 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24052 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24053 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24054 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24055 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24056 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24057 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24058 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24059 DATA (DL(K),K= 2976, 3060) /
24060 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24061 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24062 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24063 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24064 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24065 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24066 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24067 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24068 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24069 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24070 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24071 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24072 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24073 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24074 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24075 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24076 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24077 DATA (DL(K),K= 3061, 3145) /
24078 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24079 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24080 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24081 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24082 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24083 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24084 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24085 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24086 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24087 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24088 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24089 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24090 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24091 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24092 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24093 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24094 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24095 DATA (DL(K),K= 3146, 3230) /
24096 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24097 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24098 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24099 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24100 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24101 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24102 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24103 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24104 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24105 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24106 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24107 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24108 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24109 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24110 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24111 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24112 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24113 DATA (DL(K),K= 3231, 3315) /
24114 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24115 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24116 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24117 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24118 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24119 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24120 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24121 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24122 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24123 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24124 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24125 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24126 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24127 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24128 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24129 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24130 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24131 DATA (DL(K),K= 3316, 3400) /
24132 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24133 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24134 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24135 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24136 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24137 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24138 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24139 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24140 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24141 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24142 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24143 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24144 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24145 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24146 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24147 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24148 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24149 DATA (DL(K),K= 3401, 3485) /
24150 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24151 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24152 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24153 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24154 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24155 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24156 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24157 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24158 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24159 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24160 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24161 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24162 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24163 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24164 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24165 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24166 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24167 DATA (DL(K),K= 3486, 3570) /
24168 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24169 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24170 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24171 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24172 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24173 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24174 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24175 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24176 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24177 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24178 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24179 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24180 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24181 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24182 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24183 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24184 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24185 DATA (DL(K),K= 3571, 3655) /
24186 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24187 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24188 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24189 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24190 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24191 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24192 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24193 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24194 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24195 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24196 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24197 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24198 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24199 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24200 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24201 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24202 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24203 DATA (DL(K),K= 3656, 3740) /
24204 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24205 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24206 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24207 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24208 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24209 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24210 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24211 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24212 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24213 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24214 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24215 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24216 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24217 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24218 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24219 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24220 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24221 DATA (DL(K),K= 3741, 3825) /
24222 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24223 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24224 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24225 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24226 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24227 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24228 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24229 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24230 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24231 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24232 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24233 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24234 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24235 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24236 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24237 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24238 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24239 DATA (DL(K),K= 3826, 3910) /
24240 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24241 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24242 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24243 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24244 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24245 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24246 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24247 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24248 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24249 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24250 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24251 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24252 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24253 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24254 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24255 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24256 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24257 DATA (DL(K),K= 3911, 3995) /
24258 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24259 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24260 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24261 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24262 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24263 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24264 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24265 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24266 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24267 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24268 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24269 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24270 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24271 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24272 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24273 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24274 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24275 DATA (DL(K),K= 3996, 4000) /
24276 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24277C
24278 ANS = 0.
24279 IF (X.GT.0.9985) RETURN
24280 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24281C
24282 IS = S/DELTA+1
24283 IS1 = IS+1
24284 DO 1 L=1,25
24285 KL = L+NDRV*25
24286 F1(L) = GF(I,IS,KL)
24287 F2(L) = GF(I,IS1,KL)
24288 1 CONTINUE
24289 A1 = DT_CKMTFF(X,F1)
24290 A2 = DT_CKMTFF(X,F2)
24291C A1=ALOG(A1)
24292C A2=ALOG(A2)
24293 S1 = (IS-1)*DELTA
24294 S2 = S1+DELTA
24295 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24296C ANS=EXP(ANS)
24297 RETURN
24298 END
24299C
24300
24301*$ CREATE DT_CKMTFF.FOR
24302*COPY DT_CKMTFF
24303 FUNCTION DT_CKMTFF(X,FVL)
24304C**********************************************************************
24305C
24306C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24307C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24308C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24309C IN MAIN ROUTINE.
24310C
24311C**********************************************************************
24312
24313 SAVE
24314 DIMENSION FVL(25),XGRID(25)
24315 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24316 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24317C
24318 DT_CKMTFF=0.
24319 DO 1 I=1,NX
24320 IF(X.LT.XGRID(I)) GO TO 2
24321 1 CONTINUE
24322 2 I=I-1
24323 IF(I.EQ.0) THEN
24324 I=I+1
24325 ELSE IF(I.GT.23) THEN
24326 I=23
24327 ENDIF
24328 J=I+1
24329 K=J+1
24330 AXI=LOG(XGRID(I))
24331 BXI=LOG(1.-XGRID(I))
24332 AXJ=LOG(XGRID(J))
24333 BXJ=LOG(1.-XGRID(J))
24334 AXK=LOG(XGRID(K))
24335 BXK=LOG(1.-XGRID(K))
24336 FI=LOG(ABS(FVL(I)) +1.E-15)
24337 FJ=LOG(ABS(FVL(J)) +1.E-16)
24338 FK=LOG(ABS(FVL(K)) +1.E-17)
24339 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24340 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24341 $ BXI))/DET
24342 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24343 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24344 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24345 1RETURN
24346C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24347C WRITE(6,2001) X,FVL
24348C 2001 FORMAT(8E12.4)
24349C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24350C ENDIF
24351 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24352 RETURN
24353 END
24354
24355*$ CREATE DT_FLUINI.FOR
24356*COPY DT_FLUINI
24357*
24358*===fluini=============================================================*
24359*
24360 SUBROUTINE DT_FLUINI
24361
24362************************************************************************
24363* Initialisation of the nucleon-nucleon cross section fluctuation *
24364* treatment. The original version by J. Ranft. *
24365* This version dated 21.04.95 is revised by S. Roesler. *
24366************************************************************************
24367
24368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24369 SAVE
24370
24371 PARAMETER ( LINP = 10 ,
24372 & LOUT = 6 ,
24373 & LDAT = 9 )
24374
24375 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24376
24377 PARAMETER ( A = 0.1D0,
24378 & B = 0.893D0,
24379 & OM = 1.1D0,
24380 & N = 6,
24381 & DX = 0.003D0)
24382
24383* n-n cross section fluctuations
24384 PARAMETER (NBINS = 1000)
24385 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24386 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24387
24388 WRITE(LOUT,1000)
24389 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24390 & 'treated')
24391
24392 FLUSU = ZERO
24393 FLUSUU = ZERO
24394
24395 DO 1 I=1,NBINS
24396 X = DBLE(I)*DX
24397 FLUIX(I) = X
24398 FLUS = ((X-B)/(OM*B))**N
24399 IF (FLUS.LE.20.0D0) THEN
24400 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24401 ELSE
24402 FLUSI(I) = ZERO
24403 ENDIF
24404 FLUSU = FLUSU+FLUSI(I)
24405 1 CONTINUE
24406 DO 2 I=1,NBINS
24407 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24408 FLUSI(I) = FLUSUU
24409 2 CONTINUE
24410
24411C WRITE(LOUT,1001)
24412C1001 FORMAT(1X,'FLUCTUATIONS')
24413C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24414
24415 DO 3 I=1,NBINS
24416 AF = DBLE(I)*0.001D0
24417 DO 4 J=1,NBINS
24418 IF (AF.LE.FLUSI(J)) THEN
24419 FLUIXX(I) = FLUIX(J)
24420 GOTO 5
24421 ENDIF
24422 4 CONTINUE
24423 5 CONTINUE
24424 3 CONTINUE
24425 FLUIXX(1) = FLUIX(1)
24426 FLUIXX(NBINS) = FLUIX(NBINS)
24427
24428 RETURN
24429 END
24430
24431*$ CREATE DT_SIGTBL.FOR
24432*COPY DT_SIGTBL
24433*
24434*===sigtab=============================================================*
24435*
24436 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24437
24438************************************************************************
24439* This version dated 18.11.95 is written by S. Roesler *
24440************************************************************************
24441
24442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24443 SAVE
24444
24445 PARAMETER ( LINP = 10 ,
24446 & LOUT = 6 ,
24447 & LDAT = 9 )
24448
24449 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24450 & OHALF=0.5D0,ONE=1.0D0)
24451 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24452
24453 LOGICAL LINIT
24454
24455* particle properties (BAMJET index convention)
24456 CHARACTER*8 ANAME
24457 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24458 & IICH(210),IIBAR(210),K1(210),K2(210)
24459
24460 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24461 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24462 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24463 & 0, 0, 5/
24464 DATA LINIT /.FALSE./
24465
24466* precalculation and tabulation of elastic cross sections
24467 IF (ABS(MODE).EQ.1) THEN
24468 IF (MODE.EQ.1)
24469 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24470 PLABLX = LOG10(PLO)
24471 PLABHX = LOG10(PHI)
24472 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24473 DO 1 I=1,NBINS+1
24474 PLAB = PLABLX+DBLE(I-1)*DPLAB
24475 PLAB = 10**PLAB
24476 DO 2 IPROJ=1,23
24477 IDX = IDSIG(IPROJ)
24478 IF (IDX.GT.0) THEN
24479C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24480C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24481 DUMZER = ZERO
24482 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24483 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24484 ENDIF
24485 2 CONTINUE
24486 IF (MODE.EQ.1) THEN
24487 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24488 & (SIGEN(IDX,I),IDX=1,5)
24489 1000 FORMAT(F5.1,10F7.2)
24490 ENDIF
24491 1 CONTINUE
24492 IF (MODE.EQ.1) CLOSE(LDAT)
24493 LINIT = .TRUE.
24494 ELSE
24495 SIGE = -ONE
24496 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24497 & .AND.(PTOT.LE.PHI) ) THEN
24498 IDX = IDSIG(JP)
24499 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24500 PLABX = LOG10(PTOT)
24501 IF (PLABX.LE.PLABLX) THEN
24502 I1 = 1
24503 I2 = 1
24504 ELSEIF (PLABX.GE.PLABHX) THEN
24505 I1 = NBINS+1
24506 I2 = NBINS+1
24507 ELSE
24508 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24509 I2 = I1+1
24510 ENDIF
24511 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24512 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24513 PBIN = PLAB2X-PLAB1X
24514 IF (PBIN.GT.TINY10) THEN
24515 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24516 ELSE
24517 RATX = ZERO
24518 ENDIF
24519 IF (JT.EQ.1) THEN
24520 SIG1 = SIGEP(IDX,I1)
24521 SIG2 = SIGEP(IDX,I2)
24522 ELSE
24523 SIG1 = SIGEN(IDX,I1)
24524 SIG2 = SIGEN(IDX,I2)
24525 ENDIF
24526 SIGE = SIG1+RATX*(SIG2-SIG1)
24527 ENDIF
24528 ENDIF
24529 ENDIF
24530
24531 RETURN
24532 END
24533
24534*$ CREATE DT_XSTABL.FOR
24535*COPY DT_XSTABL
24536*
24537*===xstabl=============================================================*
24538*
24539 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24540
24541 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24542 SAVE
24543
24544 PARAMETER ( LINP = 10 ,
24545 & LOUT = 6 ,
24546 & LDAT = 9 )
24547
24548 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24549 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24550 LOGICAL LLAB,LELOG,LQLOG
24551
24552* particle properties (BAMJET index convention)
24553 CHARACTER*8 ANAME
24554 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24555 & IICH(210),IIBAR(210),K1(210),K2(210)
24556
24557* properties of interacting particles
24558 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24559
24560 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24561
24562* Glauber formalism: cross sections
24563 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24564 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24565 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24566 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24567 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24568 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24569 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24570 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24571 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24572 & BSLOPE,NEBINI,NQBINI
24573
24574* emulsion treatment
24575 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24576 & NCOMPO,IEMUL
24577
24578 DIMENSION WHAT(6)
24579
24580 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24581 ELO = ABS(WHAT(1))
24582 EHI = ABS(WHAT(2))
24583 IF (ELO.GT.EHI) ELO = EHI
24584 LELOG = WHAT(3).LT.ZERO
24585 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24586 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24587 IF (LELOG) THEN
24588 AELO = LOG10(ELO)
24589 AEHI = LOG10(EHI)
24590 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24591 ENDIF
24592 Q2LO = WHAT(4)
24593 Q2HI = WHAT(5)
24594 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24595 LQLOG = WHAT(6).LT.ZERO
24596 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24597 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24598 IF (LQLOG) THEN
24599 AQ2LO = LOG10(Q2LO)
24600 AQ2HI = LOG10(Q2HI)
24601 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24602 ENDIF
24603
24604 IF ( ELO.EQ. EHI) NEBINS = 0
24605 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24606
24607 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24608 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24609 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24610 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24611 & ' A_p = ',I3,' A_t = ',I3,/)
24612
24613C IF (IJPROJ.NE.7) THEN
24614 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24615* normalize fractions of emulsion components
24616 IF (NCOMPO.GT.0) THEN
24617 SUMFRA = ZERO
24618 DO 10 I=1,NCOMPO
24619 SUMFRA = SUMFRA+EMUFRA(I)
24620 10 CONTINUE
24621 IF (SUMFRA.GT.ZERO) THEN
24622 DO 11 I=1,NCOMPO
24623 EMUFRA(I) = EMUFRA(I)/SUMFRA
24624 11 CONTINUE
24625 ENDIF
24626 ENDIF
24627C ELSE
24628C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24629C ENDIF
24630 DO 1 I=1,NEBINS+1
24631 IF (LELOG) THEN
24632 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24633 ELSE
24634 E = ELO+DBLE(I-1)*DEBINS
24635 ENDIF
24636 DO 2 J=1,NQBINS+1
24637 IF (LQLOG) THEN
24638 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24639 ELSE
24640 Q2 = Q2LO+DBLE(J-1)*DQBINS
24641 ENDIF
24642c IF (IJPROJ.NE.7) THEN
24643 IF (LLAB) THEN
24644 PLAB = ZERO
24645 ECM = ZERO
24646 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24647 ELSE
24648 ECM = E
24649 ENDIF
24650 XI = ZERO
24651 Q2I = ZERO
24652 IF (IJPROJ.EQ.7) Q2I = Q2
24653 IF (NCOMPO.GT.0) THEN
24654 DO 20 IC=1,NCOMPO
24655 IIT = IEMUMA(IC)
24656 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24657 20 CONTINUE
24658 ELSE
24659 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24660C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24661 ENDIF
24662 IF (NCOMPO.GT.0) THEN
24663 XTOT = ZERO
24664 ETOT = ZERO
24665 XELA = ZERO
24666 EELA = ZERO
24667 XQEP = ZERO
24668 EQEP = ZERO
24669 XQET = ZERO
24670 EQET = ZERO
24671 XQE2 = ZERO
24672 EQE2 = ZERO
24673 XPRO = ZERO
24674 EPRO = ZERO
24675 XPRO1= ZERO
24676 XDEL = ZERO
24677 EDEL = ZERO
24678 XDQE = ZERO
24679 EDQE = ZERO
24680 DO 21 IC=1,NCOMPO
24681 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24682 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24683 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24684 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24685 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24686 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24687 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24688 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24689 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24690 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24691 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24692 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24693 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24694 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24695 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24696 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24697 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24698 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24699 & -XSQE2(1,1,IC)
24700 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24701 21 CONTINUE
24702 ETOT = SQRT(ETOT)
24703 EELA = SQRT(EELA)
24704 EQEP = SQRT(EQEP)
24705 EQET = SQRT(EQET)
24706 EQE2 = SQRT(EQE2)
24707 EPRO = SQRT(EPRO)
24708 EDEL = SQRT(EDEL)
24709 EDQE = SQRT(EDQE)
24710 WRITE(LOUT,'(8E9.3)')
24711 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24712C WRITE(LOUT,'(4E9.3)')
24713C & E,XDEL,XDQE,XDEL+XDQE
24714 ELSE
24715 WRITE(LOUT,'(11E10.3)')
24716 & E,
24717 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24718 & XSQE2(1,1,1),XSPRO(1,1,1),
24719 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24720 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24721 & XSDEL(1,1,1)+XSDQE(1,1,1)
24722C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24723C & XSDEL(1,1,1)+XSDQE(1,1,1)
24724 ENDIF
24725c ELSE
24726c IF (LLAB) THEN
24727c IF (IT.GT.1) THEN
24728c IF (IXSQEL.EQ.0) THEN
24729cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24730cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24731c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24732c & STOT,ETOT,SIN,EIN,STOT0)
24733c IF (IRATIO.EQ.1) THEN
24734c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24735cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24736cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24737c*!! save cross sections
24738c STOTA = STOT
24739c ETOTA = ETOT
24740c STOTP = STGP
24741c*!!
24742c STOT = STOT/(DBLE(IT)*STGP)
24743c SIN = SIN/(DBLE(IT)*SIGP)
24744c STOT0 = STGP
24745c ETOT = ZERO
24746c EIN = ZERO
24747c ENDIF
24748c ELSE
24749c WRITE(LOUT,*)
24750c & ' XSTABL: qel. xs. not implemented for nuclei'
24751c STOP
24752c ENDIF
24753c ELSE
24754c ETOT = ZERO
24755c EIN = ZERO
24756c STOT0= ZERO
24757c IF (IXSQEL.EQ.0) THEN
24758c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24759c ELSE
24760c SIN = ZERO
24761c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24762c ENDIF
24763c ENDIF
24764c ELSE
24765c IF (IT.GT.1) THEN
24766c IF (IXSQEL.EQ.0) THEN
24767c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24768c & STOT,ETOT,SIN,EIN,STOT0)
24769c IF (IRATIO.EQ.1) THEN
24770c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24771c*!! save cross sections
24772c STOTA = STOT
24773c ETOTA = ETOT
24774c STOTP = STGP
24775c*!!
24776c STOT = STOT/(DBLE(IT)*STGP)
24777c SIN = SIN/(DBLE(IT)*SIGP)
24778c STOT0 = STGP
24779c ETOT = ZERO
24780c EIN = ZERO
24781c ENDIF
24782c ELSE
24783c WRITE(LOUT,*)
24784c & ' XSTABL: qel. xs. not implemented for nuclei'
24785c STOP
24786c ENDIF
24787c ELSE
24788c ETOT = ZERO
24789c EIN = ZERO
24790c STOT0= ZERO
24791c IF (IXSQEL.EQ.0) THEN
24792c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24793c ELSE
24794c SIN = ZERO
24795c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24796c ENDIF
24797c ENDIF
24798c ENDIF
24799cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24800cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24801cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24802c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24803c ENDIF
24804 2 CONTINUE
24805 1 CONTINUE
24806
24807 RETURN
24808 END
24809
24810*$ CREATE DT_TESTXS.FOR
24811*COPY DT_TESTXS
24812*
24813*===testxs=============================================================*
24814*
24815 SUBROUTINE DT_TESTXS
24816
24817 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24818 SAVE
24819
24820 DIMENSION XSTOT(26,2),XSELA(26,2)
24821
24822 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24823 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24824 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24825 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24826 DUMECM = 0.0D0
24827 PLABL = 0.01D0
24828 PLABH = 10000.0D0
24829 NBINS = 120
24830 APLABL = LOG10(PLABL)
24831 APLABH = LOG10(PLABH)
24832 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24833 DO 1 I=1,NBINS+1
24834 ADP = APLABL+DBLE(I-1)*ADPLAB
24835 P = 10.0D0**ADP
24836 DO 2 J=1,26
24837 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24838 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24839 2 CONTINUE
24840 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24841 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24842 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24843 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24844 1 CONTINUE
24845 1000 FORMAT(F8.3,26F9.3)
24846
24847 RETURN
24848 END
24849************************************************************************
24850* *
24851* DTUNUC 2.0: library routines *
24852* processed by S. Roesler, 6.5.95 *
24853* *
24854************************************************************************
24855*
24856* 1) Handling of parton momenta
24857* SUBROUTINE MASHEL
24858* SUBROUTINE DFERMI
24859*
24860* 2) Handling of parton flavors and particle indices
24861* INTEGER FUNCTION IPDG2B
24862* INTEGER FUNCTION IB2PDG
24863* INTEGER FUNCTION IQUARK
24864* INTEGER FUNCTION IBJQUA
24865* INTEGER FUNCTION ICIHAD
24866* INTEGER FUNCTION IPDGHA
24867* INTEGER FUNCTION MCHAD
24868* SUBROUTINE FLAHAD
24869*
24870* 3) Energy-momentum and quantum number conservation check routines
24871* SUBROUTINE EMC1
24872* SUBROUTINE EMC2
24873* SUBROUTINE EVTEMC
24874* SUBROUTINE EVTFLC
24875* SUBROUTINE EVTCHG
24876*
24877* 4) Transformations
24878* SUBROUTINE LTINI
24879* SUBROUTINE LTRANS
24880* SUBROUTINE LTNUC
24881* SUBROUTINE DALTRA
24882* SUBROUTINE DTRAFO
24883* SUBROUTINE STTRAN
24884* SUBROUTINE MYTRAN
24885* SUBROUTINE LT2LAO
24886* SUBROUTINE LT2LAB
24887*
24888* 5) Sampling from distributions
24889* INTEGER FUNCTION NPOISS
24890* DOUBLE PRECISION FUNCTION SAMPXB
24891* DOUBLE PRECISION FUNCTION SAMPEX
24892* DOUBLE PRECISION FUNCTION SAMSQX
24893* DOUBLE PRECISION FUNCTION BETREJ
24894* DOUBLE PRECISION FUNCTION DGAMRN
24895* DOUBLE PRECISION FUNCTION DBETAR
24896* SUBROUTINE RANNOR
24897* SUBROUTINE DPOLI
24898* SUBROUTINE DSFECF
24899* SUBROUTINE RACO
24900*
24901* 6) Special functions, algorithms and service routines
24902* DOUBLE PRECISION FUNCTION YLAMB
24903* SUBROUTINE SORT
24904* SUBROUTINE SORT1
24905* SUBROUTINE DT_XTIME
24906*
24907* 7) Random number generator package
24908* DOUBLE PRECISION FUNCTION DT_RNDM
24909* SUBROUTINE DT_RNDMST
24910* SUBROUTINE DT_RNDMIN
24911* SUBROUTINE DT_RNDMOU
24912* SUBROUTINE DT_RNDMTE
24913*
24914************************************************************************
24915* *
24916* 1) Handling of parton momenta *
24917* *
24918************************************************************************
24919*$ CREATE DT_MASHEL.FOR
24920*COPY DT_MASHEL
24921*
24922*===mashel=============================================================*
24923*
24924 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24925
24926************************************************************************
24927* *
24928* rescaling of momenta of two partons to put both *
24929* on mass shell *
24930* *
24931* input: PA1,PA2 input momentum vectors *
24932* XM1,2 desired masses of particles afterwards *
24933* P1,P2 changed momentum vectors *
24934* *
24935* The original version is written by R. Engel. *
24936* This version dated 12.12.94 is modified by S. Roesler. *
24937************************************************************************
24938
24939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24940 SAVE
24941
24942 PARAMETER ( LINP = 10 ,
24943 & LOUT = 6 ,
24944 & LDAT = 9 )
24945
24946 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24947
24948 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24949
24950 IREJ = 0
24951
24952* Lorentz transformation into system CMS
24953 PX = PA1(1)+PA2(1)
24954 PY = PA1(2)+PA2(2)
24955 PZ = PA1(3)+PA2(3)
24956 EE = PA1(4)+PA2(4)
24957 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24958 XMS = (EE-XPTOT)*(EE+XPTOT)
24959 IF(XMS.LT.(XM1+XM2)**2) THEN
24960C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24961 GOTO 9999
24962 ENDIF
24963 XMS = SQRT(XMS)
24964 BGX = PX/XMS
24965 BGY = PY/XMS
24966 BGZ = PZ/XMS
24967 GAM = EE/XMS
24968 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24969 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24970* rotation angles
24971 COD = P1(3)/PTOT1
24972C SID = SQRT((ONE-COD)*(ONE+COD))
24973 PPT = SQRT(P1(1)**2+P1(2)**2)
24974 SID = PPT/PTOT1
24975 COF = ONE
24976 SIF = ZERO
24977 IF(PTOT1*SID.GT.TINY10) THEN
24978 COF = P1(1)/(SID*PTOT1)
24979 SIF = P1(2)/(SID*PTOT1)
24980 ANORF = SQRT(COF*COF+SIF*SIF)
24981 COF = COF/ANORF
24982 SIF = SIF/ANORF
24983 ENDIF
24984* new CM momentum and energies (for masses XM1,XM2)
24985 XM12 = SIGN(XM1**2,XM1)
24986 XM22 = SIGN(XM2**2,XM2)
24987 SS = XMS**2
24988 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24989 EE1 = SQRT(XM12+PCMP**2)
24990 EE2 = XMS-EE1
24991* back rotation
24992 MODE = 1
24993 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24994 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24995 & PTOT1,P1(1),P1(2),P1(3),P1(4))
24996 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24997 & PTOT2,P2(1),P2(2),P2(3),P2(4))
24998* check consistency
24999 DEL = XMS*0.0001D0
25000 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25001 IDEV = 1
25002 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25003 IDEV = 2
25004 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25005 IDEV = 3
25006 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25007 IDEV = 4
25008 ELSE
25009 IDEV = 0
25010 ENDIF
25011 IF (IDEV.NE.0) THEN
25012 WRITE(LOUT,'(/1X,A,I3)')
25013 & 'MASHEL: inconsistent transformation',IDEV
25014 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25015 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25016 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25017 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25018 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25019 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25020 ENDIF
25021 RETURN
25022
25023 9999 CONTINUE
25024 IREJ = 1
25025 RETURN
25026 END
25027
25028*$ CREATE DT_DFERMI.FOR
25029*COPY DT_DFERMI
25030*
25031*===dfermi=============================================================*
25032*
25033 SUBROUTINE DT_DFERMI(GPART)
25034
25035************************************************************************
25036* Find largest of three random numbers. *
25037************************************************************************
25038
25039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25040 SAVE
25041
25042 DIMENSION G(3)
25043
25044 DO 10 I=1,3
25045 G(I)=DT_RNDM(GPART)
25046 10 CONTINUE
25047 IF (G(3).LT.G(2)) GOTO 40
25048 IF (G(3).LT.G(1)) GOTO 30
25049 GPART = G(3)
25050 20 RETURN
25051 30 GPART = G(1)
25052 GOTO 20
25053 40 IF (G(2).LT.G(1)) GOTO 30
25054 GPART = G(2)
25055 GOTO 20
25056
25057 END
25058
25059************************************************************************
25060* *
25061* 2) Handling of parton flavors and particle indices *
25062* *
25063************************************************************************
25064*$ CREATE IDT_IPDG2B.FOR
25065*COPY IDT_IPDG2B
25066*
25067*===ipdg2b=============================================================*
25068*
25069 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25070
25071************************************************************************
25072* *
25073* conversion of quark numbering scheme *
25074* *
25075* input: PDG parton numbering *
25076* for diquarks: NN number of the constituent quark *
25077* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25078* *
25079* output: BAMJET particle codes *
25080* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25081* 2 d 8 a-d -2 a-d *
25082* 3 s 9 a-s -3 a-s *
25083* 4 c 10 a-c -4 a-c *
25084* *
25085* This is a modified version of ICONV2 written by R. Engel. *
25086* This version dated 13.12.94 is written by S. Roesler. *
25087************************************************************************
25088
25089 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25090 SAVE
25091
25092 PARAMETER ( LINP = 10 ,
25093 & LOUT = 6 ,
25094 & LDAT = 9 )
25095
25096 IDA = ABS(ID)
25097* diquarks
25098 IF (IDA.GT.6) THEN
25099 KF = 3
25100 IF (IDA.GE.1000) KF = 4
25101 IDA = IDA/(10**(KF-NN))
25102 IDA = MOD(IDA,10)
25103 ENDIF
25104* exchange up and dn quarks
25105 IF (IDA.EQ.1) THEN
25106 IDA = 2
25107 ELSEIF (IDA.EQ.2) THEN
25108 IDA = 1
25109 ENDIF
25110* antiquarks
25111 IF (ID.LT.0) THEN
25112 IF (MODE.EQ.1) THEN
25113 IDA = IDA+6
25114 ELSE
25115 IDA = -IDA
25116 ENDIF
25117 ENDIF
25118 IDT_IPDG2B = IDA
25119
25120 RETURN
25121 END
25122
25123*$ CREATE IDT_IB2PDG.FOR
25124*COPY IDT_IB2PDG
25125*
25126*===ib2pdg=============================================================*
25127*
25128 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25129
25130************************************************************************
25131* *
25132* conversion of quark numbering scheme *
25133* *
25134* input: BAMJET particle codes *
25135* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25136* 2 d 8 a-d -2 a-d *
25137* 3 s 9 a-s -3 a-s *
25138* 4 c 10 a-c -4 a-c *
25139* *
25140* output: PDG parton numbering *
25141* *
25142* This version dated 13.12.94 is written by S. Roesler. *
25143************************************************************************
25144
25145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25146 SAVE
25147
25148 PARAMETER ( LINP = 10 ,
25149 & LOUT = 6 ,
25150 & LDAT = 9 )
25151
25152 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25153 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25154 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25155 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25156 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25157
25158 IDA = ID1
25159 IDB = ID2
25160 IF (MODE.EQ.1) THEN
25161 IF (ID1.GT.6) IDA = -(ID1-6)
25162 IF (ID2.GT.6) IDB = -(ID2-6)
25163 ENDIF
25164 IF (ID2.EQ.0) THEN
25165 IDT_IB2PDG = IHKKQ(IDA)
25166 ELSE
25167 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25168 ENDIF
25169
25170 RETURN
25171 END
25172
25173*$ CREATE IDT_IQUARK.FOR
25174*COPY IDT_IQUARK
25175*
25176*===ipdgqu=============================================================*
25177*
25178 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25179
25180************************************************************************
25181* *
25182* quark contents according to PDG conventions *
25183* (random selection in case of quark mixing) *
25184* *
25185* input: IDBAMJ BAMJET particle code *
25186* K 1..3 quark number *
25187* *
25188* output: 1 d (anti --> neg.) *
25189* 2 u *
25190* 3 s *
25191* 4 c *
25192* *
25193* This version written by R. Engel. *
25194************************************************************************
25195
25196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25197 SAVE
25198
25199 IQ = IDT_IBJQUA(K,IDBAMJ)
25200* quark-antiquark
25201 IF (IQ.GT.6) THEN
25202 IQ = 6-IQ
25203 ENDIF
25204* exchange of up and down
25205 IF (ABS(IQ).EQ.1) THEN
25206 IQ = SIGN(2,IQ)
25207 ELSEIF (ABS(IQ).EQ.2) THEN
25208 IQ = SIGN(1,IQ)
25209 ENDIF
25210 IDT_IQUARK = IQ
25211
25212 RETURN
25213 END
25214
25215*$ CREATE IDT_IBJQUA.FOR
25216*COPY IDT_IBJQUA
25217*
25218*===ibamq==============================================================*
25219*
25220 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25221
25222************************************************************************
25223* *
25224* quark contents according to BAMJET conventions *
25225* (random selection in case of quark mixing) *
25226* *
25227* input: IDBAMJ BAMJET particle code *
25228* K 1..3 quark number *
25229* *
25230* output: 1 u 7 u bar *
25231* 2 d 8 d bar *
25232* 3 s 9 s bar *
25233* 4 c 10 c bar *
25234* *
25235* This version written by R. Engel. *
25236************************************************************************
25237
25238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25239 SAVE
25240
25241 DIMENSION ITAB(3,210)
25242 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25243 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25244 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25245 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25246*sr 10.1.94
25247C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25248 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25249*
25250 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25251*sr 10.1.94
25252C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25253 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25254*sr 10.1.94
25255C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25256 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25257*
25258 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25259 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25260 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25261 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25262 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25263 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25264 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25265 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25266 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25267 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25268 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25269 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25270 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25271 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25272 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25274 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25275 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25276 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25277 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25278 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25279 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25280 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25281 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25282 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25283 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25284 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25285 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25286 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25287 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25288 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25289 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25290 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25291 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25292 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25293 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25294 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25295 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25296 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25297 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25298 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25299 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25300 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25301 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25302 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25303 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25304 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25305 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25306 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25307 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25308 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25309 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25310 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25311 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25312 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25313 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25314 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25315 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25316 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25317 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25318 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25319 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25320 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25321 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25322 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25323 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25324 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25325 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25326 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25327 DATA IDOLD /0/
25328
25329 ONE = 1.0D0
25330 IF (ITAB(1,IDBAMJ).LE.200) THEN
25331 ID = ITAB(K,IDBAMJ)
25332 ELSE
25333 IF(IDOLD.NE.IDBAMJ) THEN
25334 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25335 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25336 ELSE
25337 IDOLD = 0
25338 ENDIF
25339 ID = ITAB(K,IT)
25340 ENDIF
25341 IDOLD = IDBAMJ
25342 IDT_IBJQUA = ID
25343
25344 RETURN
25345 END
25346
25347*$ CREATE IDT_ICIHAD.FOR
25348*COPY IDT_ICIHAD
25349*
25350*===icihad=============================================================*
25351*
25352 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25353
25354************************************************************************
25355* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25356* This is a completely new version dated 25.10.95. *
25357* Renamed to be not in conflict with the modified PHOJET-version *
25358************************************************************************
25359
25360 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25361 SAVE
25362
25363* hadron index conversion (BAMJET <--> PDG)
25364 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25365 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25366 & IAMCIN(210)
25367
25368 IDT_ICIHAD = 0
25369 KPDG = ABS(MCIND)
25370 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25371 IF (MCIND.LT.0) THEN
25372 JSIGN = 1
25373 ELSE
25374 JSIGN = 2
25375 ENDIF
25376 IF (KPDG.GE.10000) THEN
25377 DO 1 I=1,19
25378 IDT_ICIHAD = IBAM5(JSIGN,I)
25379 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25380 IDT_ICIHAD = 0
25381 1 CONTINUE
25382 ELSEIF (KPDG.GE.1000) THEN
25383 DO 2 I=1,29
25384 IDT_ICIHAD = IBAM4(JSIGN,I)
25385 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25386 IDT_ICIHAD = 0
25387 2 CONTINUE
25388 ELSEIF (KPDG.GE.100) THEN
25389 DO 3 I=1,22
25390 IDT_ICIHAD = IBAM3(JSIGN,I)
25391 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25392 IDT_ICIHAD = 0
25393 3 CONTINUE
25394 ELSEIF (KPDG.GE.10) THEN
25395 DO 4 I=1,7
25396 IDT_ICIHAD = IBAM2(JSIGN,I)
25397 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25398 IDT_ICIHAD = 0
25399 4 CONTINUE
25400 ENDIF
25401 5 CONTINUE
25402
25403 RETURN
25404 END
25405
25406*$ CREATE IDT_IPDGHA.FOR
25407*COPY IDT_IPDGHA
25408*
25409*===ipdgha=============================================================*
25410*
25411 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25412
25413************************************************************************
25414* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25415* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25416* Renamed to be not in conflict with the modified PHOJET-version *
25417************************************************************************
25418
25419 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25420 SAVE
25421
25422* hadron index conversion (BAMJET <--> PDG)
25423 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25424 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25425 & IAMCIN(210)
25426
25427 IDT_IPDGHA = IAMCIN(MCIND)
25428
25429 RETURN
25430 END
25431
25432*$ CREATE DT_FLAHAD.FOR
25433*COPY DT_FLAHAD
25434*
25435*===flahad=============================================================*
25436*
25437 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25438
25439************************************************************************
25440* sampling of FLAvor composition for HADrons/photons *
25441* ID BAMJET-id of hadron *
25442* IF1,2,3 flavor content *
25443* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25444* Note: - u,d numbering as in BAMJET *
25445* - ID .le. 30 !! *
25446* This version dated 12.03.96 is written by S. Roesler *
25447************************************************************************
25448
25449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25450 SAVE
25451
25452* auxiliary common for reggeon exchange (DTUNUC 1.x)
25453 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25454 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25455 & IQTCHR(-6:6),MQUARK(3,39)
25456
25457 DIMENSION JSEL(3,6)
25458 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25459
25460 ONE = 1.0D0
25461 IF (ID.EQ.7) THEN
25462* photon (charge dependent flavour sampling)
25463 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25464 IF (K.LE.4) THEN
25465 IF1 = 2
25466 IF2 = -2
25467 ELSE IF(K.EQ.5) THEN
25468 IF1 = 1
25469 IF2 = -1
25470 ELSE
25471 IF1 = 3
25472 IF2 = -3
25473 ENDIF
25474 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25475 K = IF1
25476 IF1 = IF2
25477 IF2 = K
25478 ENDIF
25479 IF3 = 0
25480 ELSE
25481* hadron
25482 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25483 IF1 = MQUARK(JSEL(1,IX),ID)
25484 IF2 = MQUARK(JSEL(2,IX),ID)
25485 IF3 = MQUARK(JSEL(3,IX),ID)
25486 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25487 IF1 = IF3
25488 IF3 = 0
25489 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25490 IF2 = IF3
25491 IF3 = 0
25492 ENDIF
25493 ENDIF
25494
25495 RETURN
25496 END
25497
25498*$ CREATE IDT_MCHAD.FOR
25499*COPY IDT_MCHAD
25500*
25501*===mchad==============================================================*
25502*
25503 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25504
25505************************************************************************
25506* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25507* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25508* *
25509* Last change 28.12.2006 by S. Roesler. *
25510************************************************************************
25511
25512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25513 SAVE
25514
25515 DIMENSION ITRANS(210)
25516 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25517 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25518 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25519 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25520 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25521 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25522 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25523
25524 IF ( ITDTU .GT. 0 ) THEN
25525 IDT_MCHAD = ITRANS(ITDTU)
25526 ELSE
25527 IDT_MCHAD = -1
25528 END IF
25529
25530 RETURN
25531 END
25532
25533************************************************************************
25534* *
25535* 3) Energy-momentum and quantum number conservation check routines *
25536* *
25537************************************************************************
25538*$ CREATE DT_EMC1.FOR
25539*COPY DT_EMC1
25540*
25541*===emc1===============================================================*
25542*
25543 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25544
25545************************************************************************
25546* This version dated 15.12.94 is written by S. Roesler *
25547************************************************************************
25548
25549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25550 SAVE
25551
25552 PARAMETER ( LINP = 10 ,
25553 & LOUT = 6 ,
25554 & LDAT = 9 )
25555
25556 PARAMETER (TINY10=1.0D-10)
25557
25558 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25559
25560 IREJ = 0
25561
25562 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25563 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25564
25565 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25566 IF (MODE.EQ.1) THEN
25567 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25568 ELSEIF (MODE.EQ.2) THEN
25569 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25570 ENDIF
25571 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25572 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25573 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25574 ELSEIF (MODE.LT.0) 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 ENDIF
25584
25585 IF (ABS(MODE).EQ.3) THEN
25586 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25587 IF (IREJ1.NE.0) GOTO 9999
25588 ENDIF
25589 RETURN
25590
25591 9999 CONTINUE
25592 IREJ = 1
25593 RETURN
25594 END
25595
25596*$ CREATE DT_EMC2.FOR
25597*COPY DT_EMC2
25598*
25599*===emc2===============================================================*
25600*
25601 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25602 & MODE,IPOS,IREJ)
25603
25604************************************************************************
25605* MODE = 1 energy-momentum cons. check *
25606* = 2 flavor-cons. check *
25607* = 3 energy-momentum & flavor cons. check *
25608* = 4 energy-momentum & charge cons. check *
25609* = 5 energy-momentum & flavor & charge cons. check *
25610* This version dated 16.01.95 is written by S. Roesler *
25611************************************************************************
25612
25613 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25614 SAVE
25615
25616 PARAMETER ( LINP = 10 ,
25617 & LOUT = 6 ,
25618 & LDAT = 9 )
25619
25620 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25621
25622* event history
25623
25624 PARAMETER (NMXHKK=200000)
25625
25626 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25627 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25628 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25629
25630* extended event history
25631 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25632 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25633 & IHIST(2,NMXHKK)
25634
25635 IREJ = 0
25636 IREJ1 = 0
25637 IREJ2 = 0
25638 IREJ3 = 0
25639
25640 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25641 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25642 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25644 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25645 DO 1 I=1,NHKK
25646 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25647 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25648 & (ISTHKK(I).EQ.IP5)) THEN
25649 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25650 & .OR.(MODE.EQ.5))
25651 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25652 & 2,IDUM,IDUM)
25653 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25654 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25655 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25656 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25657 ENDIF
25658 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25659 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25660 & (ISTHKK(I).EQ.IN5)) THEN
25661 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25662 & .OR.(MODE.EQ.5))
25663 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25664 & 2,IDUM,IDUM)
25665 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25666 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25667 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25668 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25669 ENDIF
25670 1 CONTINUE
25671 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25672 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25673 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25674 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25675 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25676 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25677
25678 RETURN
25679
25680 9999 CONTINUE
25681 IREJ = 1
25682 RETURN
25683 END
25684
25685*$ CREATE DT_EVTEMC.FOR
25686*COPY DT_EVTEMC
25687*
25688*===evtemc=============================================================*
25689*
25690 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25691
25692************************************************************************
25693* This version dated 13.12.94 is written by S. Roesler *
25694************************************************************************
25695
25696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25697 SAVE
25698
25699 PARAMETER ( LINP = 10 ,
25700 & LOUT = 6 ,
25701 & LDAT = 9 )
25702
25703 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25704 & ZERO=0.0D0)
25705
25706* event history
25707
25708 PARAMETER (NMXHKK=200000)
25709
25710 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25711 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25712 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25713
25714* flags for input different options
25715 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25716 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25717 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25718
25719 IREJ = 0
25720
25721 MODE = IMODE
25722 CHKLEV = TINY10
25723 IF (MODE.EQ.4) THEN
25724 CHKLEV = TINY2
25725 MODE = 3
25726 ELSEIF (MODE.EQ.5) THEN
25727 CHKLEV = TINY1
25728 MODE = 3
25729 ELSEIF (MODE.EQ.-1) THEN
25730 CHKLEV = EIO
25731 MODE = 3
25732 ENDIF
25733
25734 IF (ABS(MODE).EQ.3) THEN
25735 PXDEV = PX
25736 PYDEV = PY
25737 PZDEV = PZ
25738 EDEV = E
25739 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25740 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25741 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25742 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25743 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25744 & ' event ',NEVHKK,
25745 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25746 PX = 0.0D0
25747 PY = 0.0D0
25748 PZ = 0.0D0
25749 E = 0.0D0
25750 GOTO 9999
25751 ENDIF
25752 PX = 0.0D0
25753 PY = 0.0D0
25754 PZ = 0.0D0
25755 E = 0.0D0
25756 RETURN
25757 ENDIF
25758
25759 IF (MODE.EQ.1) THEN
25760 PX = 0.0D0
25761 PY = 0.0D0
25762 PZ = 0.0D0
25763 E = 0.0D0
25764 ENDIF
25765
25766 PX = PX+PXIO
25767 PY = PY+PYIO
25768 PZ = PZ+PZIO
25769 E = E+EIO
25770
25771 RETURN
25772
25773 9999 CONTINUE
25774 IREJ = 1
25775 RETURN
25776 END
25777
25778*$ CREATE DT_EVTFLC.FOR
25779*COPY DT_EVTFLC
25780*
25781*===evtflc=============================================================*
25782*
25783 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25784
25785************************************************************************
25786* Flavor conservation check. *
25787* ID identity of particle *
25788* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25789* = 2 ID for particle/resonance in BAMJET numbering scheme *
25790* = 3 ID for particle/resonance in PDG numbering scheme *
25791* MODE = 1 initialization and add ID *
25792* =-1 initialization and subtract ID *
25793* = 2 add ID *
25794* =-2 subtract ID *
25795* = 3 check flavor cons. *
25796* IPOS flag to give position of call of EVTFLC to output *
25797* unit in case of violation *
25798* This version dated 10.01.95 is written by S. Roesler *
25799************************************************************************
25800
25801 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25802 SAVE
25803
25804 PARAMETER ( LINP = 10 ,
25805 & LOUT = 6 ,
25806 & LDAT = 9 )
25807
25808 PARAMETER (TINY10=1.0D-10)
25809
25810 IREJ = 0
25811
25812 IF (MODE.EQ.3) THEN
25813 IF (IFL.NE.0) THEN
25814 WRITE(LOUT,'(1X,A,I3,A,I3)')
25815 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25816 & ' ! IFL = ',IFL
25817 IFL = 0
25818 GOTO 9999
25819 ENDIF
25820 IFL = 0
25821 RETURN
25822 ENDIF
25823
25824 IF (MODE.EQ.1) IFL = 0
25825 IF (ID.EQ.0) RETURN
25826
25827 IF (ID1.EQ.1) THEN
25828 IDD = ABS(ID)
25829 NQ = 1
25830 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25831 IF (IDD.GE.1000) NQ = 3
25832 DO 1 I=1,NQ
25833 IFBAM = IDT_IPDG2B(ID,I,2)
25834 IF (ABS(IFBAM).EQ.1) THEN
25835 IFBAM = SIGN(2,IFBAM)
25836 ELSEIF (ABS(IFBAM).EQ.2) THEN
25837 IFBAM = SIGN(1,IFBAM)
25838 ENDIF
25839 IF (MODE.GT.0) THEN
25840 IFL = IFL+IFBAM
25841 ELSE
25842 IFL = IFL-IFBAM
25843 ENDIF
25844 1 CONTINUE
25845 RETURN
25846 ENDIF
25847
25848 IDD = ID
25849 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25850 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25851 DO 2 I=1,3
25852 IF (MODE.GT.0) THEN
25853 IFL = IFL+IDT_IQUARK(I,IDD)
25854 ELSE
25855 IFL = IFL-IDT_IQUARK(I,IDD)
25856 ENDIF
25857 2 CONTINUE
25858 ENDIF
25859 RETURN
25860
25861 9999 CONTINUE
25862 IREJ = 1
25863 RETURN
25864 END
25865
25866*$ CREATE DT_EVTCHG.FOR
25867*COPY DT_EVTCHG
25868*
25869*===evtchg=============================================================*
25870*
25871 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25872
25873************************************************************************
25874* Charge conservation check. *
25875* ID identity of particle (PDG-numbering scheme) *
25876* MODE = 1 initialization *
25877* =-2 subtract ID-charge *
25878* = 2 add ID-charge *
25879* = 3 check charge cons. *
25880* IPOS flag to give position of call of EVTCHG to output *
25881* unit in case of violation *
25882* This version dated 10.01.95 is written by S. Roesler *
25883* Last change: s.r. 21.01.01 *
25884************************************************************************
25885
25886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25887 SAVE
25888
25889 PARAMETER ( LINP = 10 ,
25890 & LOUT = 6 ,
25891 & LDAT = 9 )
25892
25893* event history
25894
25895 PARAMETER (NMXHKK=200000)
25896
25897 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25898 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25899 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25900
25901* particle properties (BAMJET index convention)
25902 CHARACTER*8 ANAME
25903 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25904 & IICH(210),IIBAR(210),K1(210),K2(210)
25905
25906 IREJ = 0
25907
25908 IF (MODE.EQ.1) THEN
25909 ICH = 0
25910 IBAR = 0
25911 RETURN
25912 ENDIF
25913
25914 IF (MODE.EQ.3) THEN
25915 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25916 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25917 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25918 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25919 ICH = 0
25920 IBAR = 0
25921 GOTO 9999
25922 ENDIF
25923 ICH = 0
25924 IBAR = 0
25925 RETURN
25926 ENDIF
25927
25928 IF (ID.EQ.0) RETURN
25929
25930 IDD = IDT_ICIHAD(ID)
25931* modification 21.1.01: use intrinsic phojet-functions to determine charge
25932* and baryon number
25933C IF (IDD.GT.0) THEN
25934C IF (MODE.EQ.2) THEN
25935C ICH = ICH+IICH(IDD)
25936C IBAR = IBAR+IIBAR(IDD)
25937C ELSEIF (MODE.EQ.-2) THEN
25938C ICH = ICH-IICH(IDD)
25939C IBAR = IBAR-IIBAR(IDD)
25940C ENDIF
25941C ELSE
25942C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25943C CALL DT_EVTOUT(4)
25944C STOP
25945C ENDIF
25946 IF (MODE.EQ.2) THEN
25947 ICH = ICH+IPHO_CHR3(ID,1)/3
25948 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25949 ELSEIF (MODE.EQ.-2) THEN
25950 ICH = ICH-IPHO_CHR3(ID,1)/3
25951 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25952 ENDIF
25953
25954 RETURN
25955
25956 9999 CONTINUE
25957 IREJ = 1
25958 RETURN
25959 END
25960
25961************************************************************************
25962* *
25963* 4) Transformations *
25964* *
25965************************************************************************
25966*$ CREATE DT_LTINI.FOR
25967*COPY DT_LTINI
25968*
25969*===ltini==============================================================*
25970*
25971 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25972
25973************************************************************************
25974* Initializations of Lorentz-transformations, calculation of Lorentz- *
25975* parameters. *
25976* This version dated 13.11.95 is written by S. Roesler. *
25977************************************************************************
25978
25979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25980 SAVE
25981
25982 PARAMETER ( LINP = 10 ,
25983 & LOUT = 6 ,
25984 & LDAT = 9 )
25985
25986 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25987 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25988
25989* Lorentz-parameters of the current interaction
25990 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25991 & UMO,PPCM,EPROJ,PPROJ
25992
25993* properties of photon/lepton projectiles
25994 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25995
25996* particle properties (BAMJET index convention)
25997 CHARACTER*8 ANAME
25998 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25999 & IICH(210),IIBAR(210),K1(210),K2(210)
26000
26001* nucleon-nucleon event-generator
26002 CHARACTER*8 CMODEL
26003 LOGICAL LPHOIN
26004 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26005
26006 Q2 = VIRT
26007 IDP = IDPR
26008 IF (MCGENE.NE.3) THEN
26009* lepton-projectiles and PHOJET: initialize real photon instead
26010 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26011 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26012 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26013 IDP = 7
26014 Q2 = ZERO
26015 ENDIF
26016 ENDIF
26017 IDT = IDTA
26018 EPN = EPN0
26019 PPN = PPN0
26020 ECM = ECM0
26021 AMP = AAM(IDP)-SQRT(ABS(Q2))
26022 AMT = AAM(IDT)
26023 AMP2 = SIGN(AMP**2,AMP)
26024 AMT2 = AMT**2
26025 IF (ECM0.GT.ZERO) THEN
26026 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26027 IF (AMP2.GT.ZERO) THEN
26028 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26029 ELSE
26030 PPN = SQRT(EPN**2-AMP2)
26031 ENDIF
26032 ELSE
26033 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26034 IF (IDP.EQ.7) EPN = ABS(EPN)
26035 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26036 IF (AMP2.GT.ZERO) THEN
26037 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26038 ELSE
26039 PPN = SQRT(EPN**2-AMP2)
26040 ENDIF
26041 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26042 IF (AMP2.GT.ZERO) THEN
26043 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26044 ELSE
26045 EPN = SQRT(PPN**2+AMP2)
26046 ENDIF
26047 ENDIF
26048 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26049 ENDIF
26050 UMO = ECM
26051 EPROJ = EPN
26052 PPROJ = PPN
26053 IF (AMP2.GT.ZERO) THEN
26054 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26055 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26056 ELSE
26057 ETARG = TINY10
26058 PTARG = TINY10
26059 ENDIF
26060* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26061 IF (IDP.EQ.7) THEN
26062 PGAMM(1) = ZERO
26063 PGAMM(2) = ZERO
26064 AMGAM = AMP
26065 AMGAM2 = AMP2
26066 IF (ECM0.GT.ZERO) THEN
26067 S = ECM0**2
26068 ELSE
26069 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26070 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26071 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26072 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26073 ENDIF
26074 ENDIF
26075 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26076 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26077 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26078 IF (MODE.EQ.1) THEN
26079 PNUCL(1) = ZERO
26080 PNUCL(2) = ZERO
26081 PNUCL(3) = -PGAMM(3)
26082 PNUCL(4) = SQRT(S)-PGAMM(4)
26083 ENDIF
26084 ENDIF
26085 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26086 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26087 PLEPT0(1) = ZERO
26088 PLEPT0(2) = ZERO
26089* neglect lepton masses
26090C AMLPT2 = AAM(IDPR)**2
26091 AMLPT2 = ZERO
26092*
26093 IF (ECM0.GT.ZERO) THEN
26094 S = ECM0**2
26095 ELSE
26096 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26097 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26098 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26099 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26100 ENDIF
26101 ENDIF
26102 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26103 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26104 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26105 PNUCL(1) = ZERO
26106 PNUCL(2) = ZERO
26107 PNUCL(3) = -PLEPT0(3)
26108 PNUCL(4) = SQRT(S)-PLEPT0(4)
26109 ENDIF
26110* Lorentz-parameter for transformation Lab. - projectile rest system
26111 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26112 GALAB = TINY10
26113 BGLAB = TINY10
26114 BLAB = TINY10
26115 ELSE
26116 GALAB = EPROJ/AMP
26117 BGLAB = PPROJ/AMP
26118 BLAB = BGLAB/GALAB
26119 ENDIF
26120* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26121 IF (IDP.EQ.7) THEN
26122 GACMS(1) = TINY10
26123 BGCMS(1) = TINY10
26124 ELSE
26125 GACMS(1) = (ETARG+AMP)/UMO
26126 BGCMS(1) = PTARG/UMO
26127 ENDIF
26128* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26129 GACMS(2) = (EPROJ+AMT)/UMO
26130 BGCMS(2) = PPROJ/UMO
26131 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26132
26133 EPN0 = EPN
26134 PPN0 = PPN
26135 ECM0 = ECM
26136
26137 RETURN
26138 END
26139
26140*$ CREATE DT_LTRANS.FOR
26141*COPY DT_LTRANS
26142*
26143*===ltrans=============================================================*
26144*
26145 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26146
26147************************************************************************
26148* Lorentz-transformations. *
26149* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26150* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26151* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26152* This version dated 01.11.95 is written by S. Roesler. *
26153************************************************************************
26154
26155 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26156 SAVE
26157
26158 PARAMETER ( LINP = 10 ,
26159 & LOUT = 6 ,
26160 & LDAT = 9 )
26161
26162 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26163
26164 PARAMETER (SQTINF=1.0D+15)
26165
26166* particle properties (BAMJET index convention)
26167 CHARACTER*8 ANAME
26168 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26169 & IICH(210),IIBAR(210),K1(210),K2(210)
26170
26171 PXO = PXI
26172 PYO = PYI
26173 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26174
26175* check particle mass for consistency (numerical rounding errors)
26176 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26177 AMO2 = (PEO-PO)*(PEO+PO)
26178 AMORQ2 = AAM(ID)**2
26179 AMDIF2 = ABS(AMO2-AMORQ2)
26180 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26181 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26182 PEO = PEO+DELTA
26183 PO1 = PO -DELTA
26184 PXO = PXO*PO1/PO
26185 PYO = PYO*PO1/PO
26186 PZO = PZO*PO1/PO
26187C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26188 ENDIF
26189
26190 RETURN
26191 END
26192
26193*$ CREATE DT_LTNUC.FOR
26194*COPY DT_LTNUC
26195*
26196*===ltnuc==============================================================*
26197*
26198 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26199
26200************************************************************************
26201* Lorentz-transformations. *
26202* PIN longitudnal momentum (input) *
26203* EIN energy (input) *
26204* POUT transformed long. momentum (output) *
26205* EOUT transformed energy (output) *
26206* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26207* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26208* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26209* This version dated 01.11.95 is written by S. Roesler. *
26210************************************************************************
26211
26212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26213 SAVE
26214
26215 PARAMETER ( LINP = 10 ,
26216 & LOUT = 6 ,
26217 & LDAT = 9 )
26218
26219 PARAMETER (ZERO=0.0D0)
26220
26221* Lorentz-parameters of the current interaction
26222 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26223 & UMO,PPCM,EPROJ,PPROJ
26224
26225 BDUM1 = ZERO
26226 BDUM2 = ZERO
26227 PDUM1 = ZERO
26228 PDUM2 = ZERO
26229 IF (ABS(MODE).EQ.1) THEN
26230 BG = -SIGN(BGLAB,DBLE(MODE))
26231 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26232 & DUM1,DUM2,DUM3,POUT,EOUT)
26233 ELSEIF (ABS(MODE).EQ.2) THEN
26234 BG = SIGN(BGCMS(1),DBLE(MODE))
26235 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26236 & DUM1,DUM2,DUM3,POUT,EOUT)
26237 ELSEIF (ABS(MODE).EQ.3) THEN
26238 BG = -SIGN(BGCMS(2),DBLE(MODE))
26239 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26240 & DUM1,DUM2,DUM3,POUT,EOUT)
26241 ELSE
26242 WRITE(LOUT,1000) MODE
26243 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26244 EOUT = EIN
26245 POUT = PIN
26246 ENDIF
26247
26248 RETURN
26249 END
26250
26251*$ CREATE DT_DALTRA.FOR
26252*COPY DT_DALTRA
26253*
26254*===daltra=============================================================*
26255*
26256 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26257
26258************************************************************************
26259* Arbitrary Lorentz-transformation. *
26260* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26261************************************************************************
26262
26263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26264 SAVE
26265 PARAMETER (ONE=1.0D0)
26266
26267 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26268 PE = EP/(GA+ONE)+EC
26269 PX = PCX+BGX*PE
26270 PY = PCY+BGY*PE
26271 PZ = PCZ+BGZ*PE
26272 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26273 E = GA*EC+EP
26274
26275 RETURN
26276 END
26277
26278*$ CREATE DT_DTRAFO.FOR
26279*COPY DT_DTRAFO
26280*
26281*====dtrafo============================================================*
26282*
26283 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26284 & PL,CXL,CYL,CZL,EL)
26285
26286C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26287
26288 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26289 SAVE
26290
26291 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26292 SID = SQRT(1.D0-COD*COD)
26293 PLX = P*SID*COF
26294 PLY = P*SID*SIF
26295 PCMZ = P*COD
26296 PLZ = GAM*PCMZ+BGAM*ECM
26297 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26298 EL = GAM*ECM+BGAM*PCMZ
26299C ROTATION INTO THE ORIGINAL DIRECTION
26300 COZ = PLZ/PL
26301 SIZ = SQRT(1.D0-COZ**2)
26302 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26303
26304 RETURN
26305 END
26306
26307*$ CREATE DT_STTRAN.FOR
26308*COPY DT_STTRAN
26309*
26310*====sttran============================================================*
26311*
26312 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26313
26314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26315 SAVE
26316 DATA ANGLSQ/1.D-30/
26317************************************************************************
26318* VERSION BY J. RANFT *
26319* LEIPZIG *
26320* *
26321* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26322* *
26323* INPUT VARIABLES: *
26324* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26325* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26326* ANGLE OF "SCATTERING" *
26327* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26328* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26329* OF "SCATTERING" *
26330* *
26331* OUTPUT VARIABLES: *
26332* X,Y,Z = NEW DIRECTION COSINES *
26333* *
26334* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26335************************************************************************
26336*
26337*
26338* Changed by A. Ferrari
26339*
26340* IF (ABS(XO)-0.0001D0) 1,1,2
26341* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26342* 3 CONTINUE
26343 A = XO**2 + YO**2
26344 IF ( A .LT. ANGLSQ ) THEN
26345 X=SDE*CFE
26346 Y=SDE*SFE
26347 Z=CDE*ZO
26348 ELSE
26349 XI=SDE*CFE
26350 YI=SDE*SFE
26351 ZI=CDE
26352 A=SQRT(A)
26353 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26354 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26355 Z=A*YI+ZO*ZI
26356 ENDIF
26357
26358 RETURN
26359 END
26360
26361*$ CREATE DT_MYTRAN.FOR
26362*COPY DT_MYTRAN
26363*
26364*===mytran=============================================================*
26365*
26366 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26367
26368************************************************************************
26369* This subroutine rotates the coordinate frame *
26370* a) theta around y *
26371* b) phi around z if IMODE = 1 *
26372* *
26373* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26374* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26375* z' 0 0 1 -sin(th) 0 cos(th) z *
26376* *
26377* and vice versa if IMODE = 0. *
26378* This version dated 5.4.94 is based on the original version DTRAN *
26379* by J. Ranft and is written by S. Roesler. *
26380************************************************************************
26381
26382 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26383 SAVE
26384
26385 PARAMETER ( LINP = 10 ,
26386 & LOUT = 6 ,
26387 & LDAT = 9 )
26388
26389 IF (IMODE.EQ.1) THEN
26390 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26391 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26392 Z=-SDE *XO +CDE *ZO
26393 ELSE
26394 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26395 Y= -SFE*XO+CFE*YO
26396 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26397 ENDIF
26398 RETURN
26399 END
26400
26401*$ CREATE DT_LT2LAO.FOR
26402*COPY DT_LT2LAO
26403*
26404*===lt2lab=============================================================*
26405*
26406 SUBROUTINE DT_LT2LAO
26407
26408************************************************************************
26409* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26410* for final state particles/fragments defined in nucleon-nucleon-cms *
26411* and transforms them back to the lab. *
26412* This version dated 16.11.95 is written by S. Roesler *
26413************************************************************************
26414
26415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26416 SAVE
26417
26418 PARAMETER ( LINP = 10 ,
26419 & LOUT = 6 ,
26420 & LDAT = 9 )
26421
26422* event history
26423
26424 PARAMETER (NMXHKK=200000)
26425
26426 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26427 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26428 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26429
26430* extended event history
26431 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26432 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26433 & IHIST(2,NMXHKK)
26434
26435 NEND = NHKK
26436 NPOINT(5) = NHKK+1
26437 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26438 DO 1 I=NPOINT(4),NEND
26439C DO 1 I=1,NEND
26440 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26441 & (ISTHKK(I).EQ.1001)) THEN
26442 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26443 NOB = NOBAM(I)
26444 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26445 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26446 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26447 ISTHKK(I) = 3*ISTHKK(I)
26448 NOBAM(NHKK) = NOB
26449 ELSE
26450 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26451 ISTHKK(I) = SIGN(3,ISTHKK(I))
26452 ENDIF
26453 JDAHKK(1,I) = NHKK
26454 ENDIF
26455 1 CONTINUE
26456
26457 RETURN
26458 END
26459
26460*$ CREATE DT_LT2LAB.FOR
26461*COPY DT_LT2LAB
26462*
26463*===lt2lab=============================================================*
26464*
26465 SUBROUTINE DT_LT2LAB
26466
26467************************************************************************
26468* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26469* for final state particles/fragments defined in nucleon-nucleon-cms *
26470* and transforms them to the lab. *
26471* This version dated 07.01.96 is written by S. Roesler *
26472************************************************************************
26473
26474 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26475 SAVE
26476
26477 PARAMETER ( LINP = 10 ,
26478 & LOUT = 6 ,
26479 & LDAT = 9 )
26480
26481* event history
26482
26483 PARAMETER (NMXHKK=200000)
26484
26485 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26486 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26487 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26488
26489* extended event history
26490 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26491 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26492 & IHIST(2,NMXHKK)
26493
26494 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26495 DO 1 I=NPOINT(4),NHKK
26496 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26497 & (ISTHKK(I).EQ.1001)) THEN
26498 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26499 PHKK(3,I) = PZ
26500 PHKK(4,I) = PE
26501 ENDIF
26502 1 CONTINUE
26503
26504 RETURN
26505 END
26506
26507************************************************************************
26508* *
26509* 5) Sampling from distributions *
26510* *
26511************************************************************************
26512*$ CREATE IDT_NPOISS.FOR
26513*COPY IDT_NPOISS
26514*
26515*===npoiss=============================================================*
26516*
26517 INTEGER FUNCTION IDT_NPOISS(AVN)
26518
26519************************************************************************
26520* Sample according to Poisson distribution with Poisson parameter AVN. *
26521* The original version written by J. Ranft. *
26522* This version dated 11.1.95 is written by S. Roesler. *
26523************************************************************************
26524
26525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26526 SAVE
26527
26528 PARAMETER ( LINP = 10 ,
26529 & LOUT = 6 ,
26530 & LDAT = 9 )
26531
26532 EXPAVN = EXP(-AVN)
26533 K = 1
26534 A = 1.0D0
26535
26536 10 CONTINUE
26537 A = DT_RNDM(A)*A
26538 IF (A.GE.EXPAVN) THEN
26539 K = K+1
26540 GOTO 10
26541 ENDIF
26542 IDT_NPOISS = K-1
26543
26544 RETURN
26545 END
26546
26547*$ CREATE DT_SAMPXB.FOR
26548*COPY DT_SAMPXB
26549*
26550*===sampxb=============================================================*
26551*
26552 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26553
26554************************************************************************
26555* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26556* Processed by S. Roesler, 6.5.95 *
26557************************************************************************
26558
26559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26560 SAVE
26561 PARAMETER (TWO=2.0D0)
26562
26563 A1 = LOG(X1+SQRT(X1**2+B**2))
26564 A2 = LOG(X2+SQRT(X2**2+B**2))
26565 AN = A2-A1
26566 A = AN*DT_RNDM(A1)+A1
26567 BB = EXP(A)
26568 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26569
26570 RETURN
26571 END
26572
26573*$ CREATE DT_SAMPEX.FOR
26574*COPY DT_SAMPEX
26575*
26576*===sampex=============================================================*
26577*
26578 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26579
26580************************************************************************
26581* Sampling from f(x)=1./x between x1 and x2. *
26582* Processed by S. Roesler, 6.5.95 *
26583************************************************************************
26584
26585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26586 SAVE
26587 PARAMETER (ONE=1.0D0)
26588
26589 R = DT_RNDM(X1)
26590 AL1 = LOG(X1)
26591 AL2 = LOG(X2)
26592 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26593
26594 RETURN
26595 END
26596
26597*$ CREATE DT_SAMSQX.FOR
26598*COPY DT_SAMSQX
26599*
26600*===samsqx=============================================================*
26601*
26602 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26603
26604************************************************************************
26605* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26606* Processed by S. Roesler, 6.5.95 *
26607************************************************************************
26608
26609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26610 SAVE
26611 PARAMETER (ONE=1.0D0)
26612
26613 R = DT_RNDM(X1)
26614 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26615
26616 RETURN
26617 END
26618
26619*$ CREATE DT_SAMPLW.FOR
26620*COPY DT_SAMPLW
26621*
26622*===samplw=============================================================*
26623*
26624 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26625
26626************************************************************************
26627* Sampling from f(x)=1/x^b between x_min and x_max. *
26628* S. Roesler, 18.4.98 *
26629************************************************************************
26630
26631 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26632 SAVE
26633 PARAMETER (ONE=1.0D0)
26634
26635 R = DT_RNDM(B)
26636 IF (B.EQ.ONE) THEN
26637 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26638 ELSE
26639 ONEMB = ONE-B
26640 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26641 ENDIF
26642
26643 RETURN
26644 END
26645
26646*$ CREATE DT_BETREJ.FOR
26647*COPY DT_BETREJ
26648*
26649*===betrej=============================================================*
26650*
26651 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26652
26653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26654 SAVE
26655
26656 PARAMETER ( LINP = 10 ,
26657 & LOUT = 6 ,
26658 & LDAT = 9 )
26659
26660 PARAMETER (ONE=1.0D0)
26661
26662 IF (XMIN.GE.XMAX)THEN
26663 WRITE (LOUT,500) XMIN,XMAX
26664 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26665 STOP
26666 ENDIF
26667
26668 10 CONTINUE
26669 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26670 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26671 YY = BETMAX*DT_RNDM(XX)
26672 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26673 IF (YY.GT.BETXX) GOTO 10
26674 DT_BETREJ = XX
26675
26676 RETURN
26677 END
26678
26679*$ CREATE DT_DGAMRN.FOR
26680*COPY DT_DGAMRN
26681*
26682*===dgamrn=============================================================*
26683*
26684 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26685
26686************************************************************************
26687* Sampling from Gamma-distribution. *
26688* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26689* Processed by S. Roesler, 6.5.95 *
26690************************************************************************
26691
26692 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26693 SAVE
26694 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26695
26696 NCOU = 0
26697 N = INT(ETA)
26698 F = ETA-DBLE(N)
26699 IF (F.EQ.ZERO) GOTO 20
26700 10 R = DT_RNDM(F)
26701 NCOU = NCOU+1
26702 IF (NCOU.GE.11) GOTO 20
26703 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26704 YYY = LOG(DT_RNDM(R)+TINY9)/F
26705 IF (ABS(YYY).GT.50.0D0) GOTO 20
26706 Y = EXP(YYY)
26707 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26708 GOTO 40
26709 20 Y = 0.0D0
26710 GOTO 50
26711 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26712 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26713 40 IF (N.EQ.0) GOTO 70
26714 50 Z = 1.0D0
26715 DO 60 I = 1,N
26716 60 Z = Z*DT_RNDM(Z)
26717 Y = Y-LOG(Z+TINY9)
26718 70 DT_DGAMRN = Y/ALAM
26719
26720 RETURN
26721 END
26722
26723*$ CREATE DT_DBETAR.FOR
26724*COPY DT_DBETAR
26725*
26726*===dbetar=============================================================*
26727*
26728 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26729
26730************************************************************************
26731* Sampling from Beta -distribution between 0.0 and 1.0 *
26732* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26733* Processed by S. Roesler, 6.5.95 *
26734************************************************************************
26735
26736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26737 SAVE
26738
26739 Y = DT_DGAMRN(1.0D0,GAM)
26740 Z = DT_DGAMRN(1.0D0,ETA)
26741 DT_DBETAR = Y/(Y+Z)
26742
26743 RETURN
26744 END
26745
26746*$ CREATE DT_RANNOR.FOR
26747*COPY DT_RANNOR
26748*
26749*===rannor=============================================================*
26750*
26751 SUBROUTINE DT_RANNOR(X,Y)
26752
26753************************************************************************
26754* Sampling from Gaussian distribution. *
26755* Processed by S. Roesler, 6.5.95 *
26756************************************************************************
26757
26758 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26759 SAVE
26760 PARAMETER (TINY10=1.0D-10)
26761
26762 CALL DT_DSFECF(SFE,CFE)
26763 V = MAX(TINY10,DT_RNDM(X))
26764 A = SQRT(-2.D0*LOG(V))
26765 X = A*SFE
26766 Y = A*CFE
26767
26768 RETURN
26769 END
26770
26771*$ CREATE DT_DPOLI.FOR
26772*COPY DT_DPOLI
26773*
26774*===dpoli==============================================================*
26775*
26776 SUBROUTINE DT_DPOLI(CS,SI)
26777
26778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26779 SAVE
26780
26781 U = DT_RNDM(CS)
26782 CS = DT_RNDM(U)
26783 IF (U.LT.0.5D0) CS=-CS
26784 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26785
26786 RETURN
26787 END
26788
26789*$ CREATE DT_DSFECF.FOR
26790*COPY DT_DSFECF
26791*
26792*===dsfecf=============================================================*
26793*
26794 SUBROUTINE DT_DSFECF(SFE,CFE)
26795
26796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26797 SAVE
26798 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26799
26800 1 CONTINUE
26801 X = DT_RNDM(SFE)
26802 Y = DT_RNDM(X)
26803 XX = X*X
26804 YY = Y*Y
26805 XY = XX+YY
26806 IF (XY.GT.ONE) GOTO 1
26807 CFE = (XX-YY)/XY
26808 SFE = TWO*X*Y/XY
26809 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26810 RETURN
26811 END
26812
26813*$ CREATE DT_RACO.FOR
26814*COPY DT_RACO
26815*
26816*===raco===============================================================*
26817*
26818 SUBROUTINE DT_RACO(WX,WY,WZ)
26819
26820************************************************************************
26821* Direction cosines of random uniform (isotropic) direction in three *
26822* dimensional space *
26823* Processed by S. Roesler, 20.11.95 *
26824************************************************************************
26825
26826 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26827 SAVE
26828 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26829
26830 10 CONTINUE
26831 X = TWO*DT_RNDM(WX)-ONE
26832 Y = DT_RNDM(X)
26833 X2 = X*X
26834 Y2 = Y*Y
26835 IF (X2+Y2.GT.ONE) GOTO 10
26836
26837 CFE = (X2-Y2)/(X2+Y2)
26838 SFE = TWO*X*Y/(X2+Y2)
26839* z = 1/2 [ 1 + cos (theta) ]
26840 Z = DT_RNDM(X)
26841* 1/2 sin (theta)
26842 WZ = SQRT(Z*(ONE-Z))
26843 WX = TWO*WZ*CFE
26844 WY = TWO*WZ*SFE
26845 WZ = TWO*Z-ONE
26846
26847 RETURN
26848 END
26849
26850************************************************************************
26851* *
26852* 6) Special functions, algorithms and service routines *
26853* *
26854************************************************************************
26855*$ CREATE DT_YLAMB.FOR
26856*COPY DT_YLAMB
26857*
26858*===ylamb==============================================================*
26859*
26860 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26861
26862************************************************************************
26863* *
26864* auxiliary function for three particle decay mode *
26865* (standard LAMBDA**(1/2) function) *
26866* *
26867* Adopted from an original version written by R. Engel. *
26868* This version dated 12.12.94 is written by S. Roesler. *
26869************************************************************************
26870
26871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26872 SAVE
26873
26874 YZ = Y-Z
26875 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26876 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26877 DT_YLAMB = SQRT(XLAM)
26878
26879 RETURN
26880 END
26881
26882*$ CREATE DT_SORT.FOR
26883*COPY DT_SORT
26884*
26885*===sort1==============================================================*
26886*
26887 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26888
26889************************************************************************
26890* This subroutine sorts entries in A in increasing/decreasing order *
26891* of A(3,i). *
26892* MODE = 1 increasing in A(3,i=1..N) *
26893* = 2 decreasing in A(3,i=1..N) *
26894* This version dated 21.04.95 is revised by S. Roesler *
26895************************************************************************
26896
26897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26898 SAVE
26899
26900 DIMENSION A(3,N)
26901
26902 M = I1
26903 10 CONTINUE
26904 M = I1-1
26905 IF (M.LE.0) RETURN
26906 L = 0
26907 DO 20 I=I0,M
26908 J = I+1
26909 IF (MODE.EQ.1) THEN
26910 IF (A(3,I).LE.A(3,J)) GOTO 20
26911 ELSE
26912 IF (A(3,I).GE.A(3,J)) GOTO 20
26913 ENDIF
26914 B = A(3,I)
26915 C = A(1,I)
26916 D = A(2,I)
26917 A(3,I) = A(3,J)
26918 A(2,I) = A(2,J)
26919 A(1,I) = A(1,J)
26920 A(3,J) = B
26921 A(1,J) = C
26922 A(2,J) = D
26923 L = 1
26924 20 CONTINUE
26925 IF (L.EQ.1) GOTO 10
26926
26927 RETURN
26928 END
26929
26930*$ CREATE DT_SORT1.FOR
26931*COPY DT_SORT1
26932*
26933*===sort1==============================================================*
26934*
26935 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26936
26937************************************************************************
26938* This subroutine sorts entries in A in increasing/decreasing order *
26939* of A(i). *
26940* MODE = 1 increasing in A(i=1..N) *
26941* = 2 decreasing in A(i=1..N) *
26942* This version dated 21.04.95 is revised by S. Roesler *
26943************************************************************************
26944
26945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26946 SAVE
26947
26948 DIMENSION A(N),IDX(N)
26949
26950 M = I1
26951 10 CONTINUE
26952 M = I1-1
26953 IF (M.LE.0) RETURN
26954 L = 0
26955 DO 20 I=I0,M
26956 J = I+1
26957 IF (MODE.EQ.1) THEN
26958 IF (A(I).LE.A(J)) GOTO 20
26959 ELSE
26960 IF (A(I).GE.A(J)) GOTO 20
26961 ENDIF
26962 B = A(I)
26963 A(I) = A(J)
26964 A(J) = B
26965 IX = IDX(I)
26966 IDX(I) = IDX(J)
26967 IDX(J) = IX
26968 L = 1
26969 20 CONTINUE
26970 IF (L.EQ.1) GOTO 10
26971
26972 RETURN
26973 END
26974
26975*$ CREATE DT_XTIME.FOR
26976*COPY DT_XTIME
26977*
26978*===xtime==============================================================*
26979*
26980 SUBROUTINE DT_XTIME
26981
26982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26983 SAVE
26984
26985 PARAMETER ( LINP = 10 ,
26986 & LOUT = 6 ,
26987 & LDAT = 9 )
26988
26989 CHARACTER DAT*9,TIM*11
26990
26991 DAT = ' '
26992 TIM = ' '
26993C CALL GETDAT(IYEAR,IMONTH,IDAY)
26994C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26995
26996C CALL DATE(DAT)
26997C CALL TIME(TIM)
26998C WRITE(LOUT,1000) DAT,TIM
26999 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27000
27001 RETURN
27002 END
27003
27004************************************************************************
27005* *
27006* 7) Random number generator package *
27007* *
27008* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27009* SERVICE ROUTINES. *
27010* THE ALGORITHM IS FROM *
27011* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27012* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27013* IMPLEMENTATION BY K. HAHN DEC. 88, *
27014* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27015* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27016* THE PERIOD IS ABOUT 2**144, *
27017* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27018* THE PACKAGE CONTAINS *
27019* FUNCTION DT_RNDM(I) : GENERATOR *
27020* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27021* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27022* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27023* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27024*--- *
27025* FUNCTION DT_RNDM(I) *
27026* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27027* I - DUMMY VARIABLE, NOT USED *
27028* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27029* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27030* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27031* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27032* 12,34,56 ARE THE STANDARD VALUES *
27033* NB1 MUST BE IN 1..168 *
27034* 78 IS THE STANDARD VALUE *
27035* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27036* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27037* AS AFTER THE LAST DT_RNDMOU CALL ) *
27038* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27039* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27040* TAKES SEED FROM GENERATOR *
27041* U(97),C,CD,CM,I,J - SEED VALUES *
27042* SUBROUTINE DT_RNDMTE(IO) *
27043* TEST OF THE GENERATOR *
27044* IO - DEFINES OUTPUT *
27045* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27046* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27047* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27048* SAME STATUS *
27049* AS BEFORE CALL OF DT_RNDMTE *
27050************************************************************************
27051*$ CREATE DT_RNDM.FOR
27052*COPY DT_RNDM
27053*
27054*===rndm===============================================================*
27055*
27056c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27057c$$$
27058c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27059c$$$ SAVE
27060c$$$
27061c$$$* counter of calls to random number generator
27062c$$$* uncomment if needed
27063c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27064c$$$C LOGICAL LFIRST
27065c$$$C DATA LFIRST /.TRUE./
27066c$$$
27067c$$$* counter of calls to random number generator
27068c$$$* uncomment if needed
27069c$$$C IF (LFIRST) THEN
27070c$$$C IRNCT0 = 0
27071c$$$C IRNCT1 = 0
27072c$$$C LFIRST = .FALSE.
27073c$$$C ENDIF
27074c$$$
27075c$$$ DT_RNDM = FLRNDM(VDUMMY)
27076c$$$* counter of calls to random number generator
27077c$$$* uncomment if needed
27078c$$$C IRNCT1 = IRNCT1+1
27079c$$$
27080c$$$ RETURN
27081c$$$ END
27082c$$$
27083c$$$*$ CREATE DT_RNDMST.FOR
27084c$$$*COPY DT_RNDMST
27085c$$$*
27086c$$$*===rndmst=============================================================*
27087c$$$*
27088c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27089c$$$
27090c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27091c$$$ SAVE
27092c$$$
27093c$$$* random number generator
27094c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27095c$$$
27096c$$$ MA1 = NA1
27097c$$$ MA2 = NA2
27098c$$$ MA3 = NA3
27099c$$$ MB1 = NB1
27100c$$$ I = 97
27101c$$$ J = 33
27102c$$$ DO 20 II2 = 1,97
27103c$$$ S = 0
27104c$$$ T = 0.5D0
27105c$$$ DO 10 II1 = 1,24
27106c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27107c$$$ MA1 = MA2
27108c$$$ MA2 = MA3
27109c$$$ MA3 = MAT
27110c$$$ MB1 = MOD(53*MB1+1,169)
27111c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27112c$$$ 10 T = 0.5D0*T
27113c$$$ 20 U(II2) = S
27114c$$$ C = 362436.0D0/16777216.0D0
27115c$$$ CD = 7654321.0D0/16777216.0D0
27116c$$$ CM = 16777213.0D0/16777216.0D0
27117c$$$ RETURN
27118c$$$ END
27119c$$$
27120c$$$*$ CREATE DT_RNDMIN.FOR
27121c$$$*COPY DT_RNDMIN
27122c$$$*
27123c$$$*===rndmin=============================================================*
27124c$$$*
27125c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27126c$$$
27127c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27128c$$$ SAVE
27129c$$$
27130c$$$* random number generator
27131c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27132c$$$
27133c$$$ DIMENSION UIN(97)
27134c$$$
27135c$$$ DO 10 KKK = 1,97
27136c$$$ 10 U(KKK) = UIN(KKK)
27137c$$$ C = CIN
27138c$$$ CD = CDIN
27139c$$$ CM = CMIN
27140c$$$ I = IIN
27141c$$$ J = JIN
27142c$$$
27143c$$$ RETURN
27144c$$$ END
27145c$$$
27146c$$$*$ CREATE DT_RNDMOU.FOR
27147c$$$*COPY DT_RNDMOU
27148c$$$*
27149c$$$*===rndmou=============================================================*
27150c$$$*
27151c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27152c$$$
27153c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27154c$$$ SAVE
27155c$$$
27156c$$$* random number generator
27157c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27158c$$$
27159c$$$ DIMENSION UOUT(97)
27160c$$$
27161c$$$ DO 10 KKK = 1,97
27162c$$$ 10 UOUT(KKK) = U(KKK)
27163c$$$ COUT = C
27164c$$$ CDOUT = CD
27165c$$$ CMOUT = CM
27166c$$$ IOUT = I
27167c$$$ JOUT = J
27168c$$$
27169c$$$ RETURN
27170c$$$ END
27171c$$$
27172c$$$*$ CREATE DT_RNDMTE.FOR
27173c$$$*COPY DT_RNDMTE
27174c$$$*
27175c$$$*===rndmte=============================================================*
27176c$$$*
27177c$$$ SUBROUTINE DT_RNDMTE(IO)
27178c$$$
27179c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27180c$$$ SAVE
27181c$$$
27182c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27183c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27184c$$$ +8354498.D0, 10633180.D0/
27185c$$$
27186c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27187c$$$ CALL DT_RNDMST(12,34,56,78)
27188c$$$ DO 10 II1 = 1,20000
27189c$$$ 10 XX = DT_RNDM(XX)
27190c$$$ SD = 0.0D0
27191c$$$ DO 20 II2 = 1,6
27192c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27193c$$$ D(II2) = X(II2)-U(II2)
27194c$$$ 20 SD = SD+D(II2)
27195c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27196c$$$**sr 24.01.95
27197c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27198c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27199c$$$C WRITE(6,1000)
27200c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27201c$$$ & ' passed')
27202c$$$ ENDIF
27203c$$$**
27204c$$$ RETURN
27205c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27206c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27207c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27208c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27209c$$$ END
27210*
27211*$ CREATE PHO_RNDM.FOR
27212*COPY PHO_RNDM
27213*
27214*===pho_rndm===========================================================*
27215*
27216 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27217
27218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27219 SAVE
27220
27221 PHO_RNDM = DT_RNDM(DUMMY)
27222
27223 RETURN
27224 END
27225
27226*$ CREATE PYR.FOR
27227*COPY PYR
27228*
27229*===pyr================================================================*
27230*
27231 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27232
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234 SAVE
27235
27236 DUMMY = DBLE(IDUMMY)
27237 PYR = DT_RNDM(DUMMY)
27238
27239 RETURN
27240 END
27241*$ CREATE DT_TITLE.FOR
27242*COPY DT_TITLE
27243*
27244*===title==============================================================*
27245*
27246 SUBROUTINE DT_TITLE
27247
27248 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27249 SAVE
27250
27251 PARAMETER ( LINP = 10 ,
27252 & LOUT = 6 ,
27253 & LDAT = 9 )
27254
27255 CHARACTER*6 CVERSI
27256 CHARACTER*11 CCHANG
27257 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27258
27259 CALL DT_XTIME
27260 WRITE(LOUT,1000) CVERSI,CCHANG
27261 1000 FORMAT(1X,'+-------------------------------------------------',
27262 & '----------------------+',/,
27263 & 1X,'|',71X,'|',/,
27264 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27265 & 1X,'|',71X,'|',/,
27266 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27267 & 1X,'|',71X,'|',/,
27268 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27269 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27270 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27271C & 1X,'|',71X,'|',/,
27272C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27273C & 17X,'|',/,
27274 & 1X,'|',71X,'|',/,
27275 & 1X,'+-------------------------------------------------',
27276 & '----------------------+',/,
27277 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27278 & 'Stefan.Roesler@cern.ch |',/,
27279 & 1X,'+-------------------------------------------------',
27280 & '----------------------+',/)
27281
27282 RETURN
27283 END
27284
27285*$ CREATE DT_EVTINI.FOR
27286*COPY DT_EVTINI
27287*
27288*===evtini=============================================================*
27289*
27290 SUBROUTINE DT_EVTINI
27291
27292************************************************************************
27293* Initialization of DTEVT1. *
27294* This version dated 15.01.94 is written by S. Roesler *
27295************************************************************************
27296
27297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27298 SAVE
27299
27300 PARAMETER ( LINP = 10 ,
27301 & LOUT = 6 ,
27302 & LDAT = 9 )
27303
27304* event history
27305
27306 PARAMETER (NMXHKK=200000)
27307
27308 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27309 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27310 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27311
27312* extended event history
27313 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27314 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27315 & IHIST(2,NMXHKK)
27316
27317* event flag
27318 COMMON /DTEVNO/ NEVENT,ICASCA
27319
27320 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27321
27322* emulsion treatment
27323 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27324 & NCOMPO,IEMUL
27325
27326* initialization of DTEVT1/DTEVT2
27327 NEND = NHKK
27328 IF (NEVENT.EQ.1) NEND = NMXHKK
27329 NHKK = 0
27330 NEVHKK = NEVENT
27331 DO 1 I=1,NEND
27332 ISTHKK(I) = 0
27333 IDHKK(I) = 0
27334 JMOHKK(1,I) = 0
27335 JMOHKK(2,I) = 0
27336 JDAHKK(1,I) = 0
27337 JDAHKK(2,I) = 0
27338 IDRES(I) = 0
27339 IDXRES(I) = 0
27340 NOBAM(I) = 0
27341 IDCH(I) = 0
27342 IHIST(1,I) = 0
27343 IHIST(2,I) = 0
27344 DO 2 J=1,4
27345 PHKK(J,I) = 0.0D0
27346 VHKK(J,I) = 0.0D0
27347 WHKK(J,I) = 0.0D0
27348 2 CONTINUE
27349 PHKK(5,I) = 0.0D0
27350 1 CONTINUE
27351 DO 3 I=1,10
27352 NPOINT(I) = 0
27353 3 CONTINUE
27354 CALL DT_CHASTA(-1)
27355
27356C* initialization of DTLTRA
27357C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27358
27359 RETURN
27360 END
27361
27362*$ CREATE DT_STATIS.FOR
27363*COPY DT_STATIS
27364*
27365*===statis=============================================================*
27366*
27367 SUBROUTINE DT_STATIS(MODE)
27368
27369************************************************************************
27370* Initialization and output of run-statistics. *
27371* MODE = 1 initialization *
27372* = 2 output *
27373* This version dated 23.01.94 is written by S. Roesler *
27374************************************************************************
27375
27376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27377 SAVE
27378
27379 PARAMETER ( LINP = 10 ,
27380 & LOUT = 6 ,
27381 & LDAT = 9 )
27382
27383 PARAMETER (TINY3=1.0D-3)
27384
27385* statistics
27386 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27387 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27388 & ICEVTG(8,0:30)
27389
27390* rejection counter
27391 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27392 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27393 & IREXCI(3),IRDIFF(2),IRINC
27394
27395* central particle production, impact parameter biasing
27396 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27397
27398* various options for treatment of partons (DTUNUC 1.x)
27399* (chain recombination, Cronin,..)
27400 LOGICAL LCO2CR,LINTPT
27401 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27402 & LCO2CR,LINTPT
27403
27404* nucleon-nucleon event-generator
27405 CHARACTER*8 CMODEL
27406 LOGICAL LPHOIN
27407 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27408
27409* flags for particle decays
27410 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27411 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27412 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27413
27414* diquark-breaking mechanism
27415 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27416
27417 DIMENSION PP(4),PT(4)
27418
27419 GOTO (1,2) MODE
27420
27421* initialization
27422 1 CONTINUE
27423
27424* initialize statistics counter
27425 ICREQU = 0
27426 ICSAMP = 0
27427 ICCPRO = 0
27428 ICDPR = 0
27429 ICDTA = 0
27430 ICRJSS = 0
27431 ICVV2S = 0
27432 DO 10 I=1,9
27433 ICRES(I) = 0
27434 ICCHAI(1,I) = 0
27435 ICCHAI(2,I) = 0
27436 10 CONTINUE
27437* initialize rejection counter
27438 IRPT = 0
27439 IRHHA = 0
27440 LOMRES = 0
27441 LOBRES = 0
27442 IRFRAG = 0
27443 IREVT = 0
27444 IRRES(1) = 0
27445 IRRES(2) = 0
27446 IRCHKI(1) = 0
27447 IRCHKI(2) = 0
27448 IRCRON(1) = 0
27449 IRCRON(2) = 0
27450 IRCRON(3) = 0
27451 IRDIFF(1) = 0
27452 IRDIFF(2) = 0
27453 IRINC = 0
27454 DO 11 I=1,5
27455 ICDIFF(I) = 0
27456 11 CONTINUE
27457 DO 12 I=1,8
27458 DO 13 J=0,30
27459 ICEVTG(I,J) = 0
27460 13 CONTINUE
27461 12 CONTINUE
27462
27463 RETURN
27464
27465* output
27466 2 CONTINUE
27467
27468* statistics counter
27469 WRITE(LOUT,1000)
27470 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27471 & 28X,'---------------------')
004932dd 27472 IF (ICREQU.GT.0) THEN
7b076c76 27473 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27474 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27475 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27476 & 'event',11X,F9.1)
004932dd 27477 ENDIF
7b076c76 27478 IF (ICDIFF(1).NE.0) THEN
27479 WRITE(LOUT,1009) ICDIFF
27480 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27481 & 'low mass high mass',/,24X,'single diffraction',
27482 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27483 ENDIF
004932dd 27484 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
7b076c76 27485 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27486 & DBLE(ICSAMP)/DBLE(ICCPRO)
27487 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27488 & ' of sampled Glauber-events per event',9X,F9.1,/,
27489 & 2X,'fraction of production cross section',21X,F10.6)
27490 ENDIF
004932dd 27491 IF (ICSAMP.GT.0) THEN
7b076c76 27492 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27493 & DBLE(ICDTA)/DBLE(ICSAMP)
27494 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27495 & ' nucleons after x-sampling',2(4X,F6.2))
004932dd 27496 ENDIF
7b076c76 27497
27498 IF (MCGENE.EQ.1) THEN
004932dd 27499 IF (ICSAMP.GT.0) THEN
7b076c76 27500 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27501 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27502 & ' event',3X,F9.1)
27503 IF (ISICHA.EQ.1) THEN
27504 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27505 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27506 & 'of single chains per event',13X,F9.1)
27507 ENDIF
004932dd 27508 ENDIF
27509 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
7b076c76 27510 WRITE(LOUT,1006)
27511 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27512 & 23X,'mean number of chains mean number of chains',/,
27513 & 23X,'sampled hadronized having mass of a reso.')
27514 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27515 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27516 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27517 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27518 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27519 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27520 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27521 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27522 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27523 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27524 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27525 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27526 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27527 WRITE(LOUT,1008)
27528 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27529 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27530 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27531 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27532 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27533 & DBLE(IRHHA)/DBLE(ICREQU),
27534 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27535 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27536 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27537 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27538 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27539 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27540 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27541 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27542 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27543 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27544 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27545 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27546 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27547 & F7.2,/,1X,'Total no. of rej.',
27548 & ' in chain-systems treatment (GETCSY)',/,43X,
27549 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27550 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27551 & 1X,'Total no. of rej. in DPM-treatment of one event',
27552 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27553 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27554 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27555 & 'IREXCI(3) = ',I5,/)
004932dd 27556 ENDIF
7b076c76 27557 ELSEIF (MCGENE.EQ.2) THEN
27558 WRITE(LOUT,1010) ELOJET
27559 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27560 & F4.1,' GeV')
27561 WRITE(LOUT,1011)
27562 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27563 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27564 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27565 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27566 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27567 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27568 & ((ICEVTG(I,J),I=1,8),J=3,7),
27569 & ((ICEVTG(I,J),I=1,8),J=19,21),
27570 & (ICEVTG(I,8),I=1,8),
27571 & ((ICEVTG(I,J),I=1,8),J=22,24),
27572 & (ICEVTG(I,9),I=1,8),
27573 & ((ICEVTG(I,J),I=1,8),J=25,28),
27574 & ((ICEVTG(I,J),I=1,8),J=10,18)
27575 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27576 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27577 & ' no-dif.',8I8,/,
27578 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27579 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27580 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27581 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27582 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27583 & ' hi-lo ',8I8,/,
27584 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27585 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27586 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27587 WRITE(LOUT,1013)
27588 1013 FORMAT(/,1X,'2. chain system statistics -',
27589 & ' mean numbers per evt:',/,30X,'---------------------',
27590 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
004932dd 27591 IF (ICSAMP.GT.0) THEN
7b076c76 27592 WRITE(LOUT,1014)
27593 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27594 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27595 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27596 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27597 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27598 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27599 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27600 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27601 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27602 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27603 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27604 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27605 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
004932dd 27606 ENDIF
7b076c76 27607 WRITE(LOUT,1015)
27608 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
004932dd 27609 IF (ICSAMP.GT.0) THEN
7b076c76 27610 WRITE(LOUT,1016)
27611 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27612 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27613 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27614 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27615 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27616 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27617 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27618 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27619 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27620 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27621 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27622 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27623 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
004932dd 27624 ENDIF
7b076c76 27625
27626 ENDIF
27627 CALL DT_CHASTA(1)
27628
27629 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27630 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27631 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27632 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27633 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27634 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27635 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27636 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27637 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27638 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27639 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27640 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27641 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27642 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27643 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27644 & DBRKA(3,1),DBRKA(3,2),
27645 & DBRKA(3,3),DBRKA(3,4)
27646 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27647 & DBRKR(3,1),DBRKR(3,2),
27648 & DBRKR(3,3),DBRKR(3,4)
27649 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27650 & DBRKA(3,5),DBRKA(3,6),
27651 & DBRKA(3,7),DBRKA(3,8)
27652 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27653 & DBRKR(3,5),DBRKR(3,6),
27654 & DBRKR(3,7),DBRKR(3,8)
27655 ENDIF
27656
27657 FAC = 1.0D0
27658 IF (MCGENE.EQ.2) THEN
27659
27660C CALL PHO_PHIST(-2,SIGMAX)
27661 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27662
27663 ENDIF
27664
27665 CALL DT_XTIME
27666
27667 RETURN
27668 END
27669
27670*$ CREATE DT_EVTOUT.FOR
27671*COPY DT_EVTOUT
27672*
27673*===evtout=============================================================*
27674*
27675 SUBROUTINE DT_EVTOUT(MODE)
27676
27677************************************************************************
27678* MODE = 1 plot content of complete DTEVT1 to out. unit *
27679* 3 plot entries of extended DTEVT1 (DTEVT2) *
27680* 4 plot entries of DTEVT1 and DTEVT2 *
27681* This version dated 11.12.94 is written by S. Roesler *
27682************************************************************************
27683
27684 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27685 SAVE
27686
27687 PARAMETER ( LINP = 10 ,
27688 & LOUT = 6 ,
27689 & LDAT = 9 )
27690
27691* event history
27692
27693 PARAMETER (NMXHKK=200000)
27694
27695 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27696 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27697 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27698
27699 DIMENSION IRANGE(NMXHKK)
27700
27701 IF (MODE.EQ.2) RETURN
27702
27703 CALL DT_EVTPLO(IRANGE,MODE)
27704
27705 RETURN
27706 END
27707
27708*$ CREATE DT_EVTPLO.FOR
27709*COPY DT_EVTPLO
27710*
27711*===evtplo=============================================================*
27712*
27713 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27714
27715************************************************************************
27716* MODE = 1 plot content of complete DTEVT1 to out. unit *
27717* 2 plot entries of DTEVT1 given by IRANGE *
27718* 3 plot entries of extended DTEVT1 (DTEVT2) *
27719* 4 plot entries of DTEVT1 and DTEVT2 *
27720* 5 plot rejection counter *
27721* This version dated 11.12.94 is written by S. Roesler *
27722************************************************************************
27723
27724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27725 SAVE
27726
27727 PARAMETER ( LINP = 10 ,
27728 & LOUT = 6 ,
27729 & LDAT = 9 )
27730
27731 CHARACTER*16 CHAU
27732
27733* event history
27734
27735 PARAMETER (NMXHKK=200000)
27736
27737 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27738 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27739 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27740
27741* extended event history
27742 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27743 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27744 & IHIST(2,NMXHKK)
27745
27746* rejection counter
27747 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27748 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27749 & IREXCI(3),IRDIFF(2),IRINC
27750
27751 DIMENSION IRANGE(NMXHKK)
27752
27753 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27754 WRITE(LOUT,1000)
27755 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27756 & 15X,' --------------------------',/,/,
27757 & ' ST ID M1 M2 D1 D2 PX PY',
27758 & ' PZ E M',/)
27759 DO 1 I=1,NHKK
27760 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27761 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27762 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27763 & PHKK(5,I)
27764C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27765C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27766C & PHKK(3,I),PHKK(4,I)
27767C WRITE(LOUT,'(4E15.4)')
27768C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27769 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27770 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27771 1 CONTINUE
27772 WRITE(LOUT,*)
27773C DO 4 I=1,NHKK
27774C WRITE(LOUT,1006) I,ISTHKK(I),
27775C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27776C & WHKK(2,I),WHKK(3,I)
27777C1006 FORMAT(1X,I4,I6,6E10.3)
27778C 4 CONTINUE
27779 ENDIF
27780
27781 IF (MODE.EQ.2) THEN
27782 WRITE(LOUT,1000)
27783 NC = 0
27784 2 CONTINUE
27785 NC = NC+1
27786 IF (IRANGE(NC).EQ.-100) GOTO 9999
27787 I = IRANGE(NC)
27788 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27789 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27790 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27791 & PHKK(5,I)
27792 GOTO 2
27793 ENDIF
27794
27795 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27796 WRITE(LOUT,1002)
27797 1002 FORMAT(/,1X,'EVTPLO:',14X,
27798 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27799 & 15X,' -----------------------------------',/,/,
27800 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27801 & ' NOBAM IDCH M',/)
27802 DO 3 I=1,NHKK
27803C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27804 KF = IDHKK(I)
27805 IDCHK = KF/10000
27806 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27807 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27808
27809 CALL PYNAME(KF,CHAU)
27810
27811 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27812 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27813 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27814 & PHKK(5,I),CHAU
27815 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27816C ENDIF
27817 3 CONTINUE
27818 ENDIF
27819
27820 IF (MODE.EQ.5) THEN
27821 WRITE(LOUT,1004)
27822 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27823 & 15X,' --------------------------',/)
27824 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27825 & IRSEA,IRCRON
27826 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27827 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27828 & 1X,'IREMC = ',10I5,/,
27829 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27830 ENDIF
27831
27832 9999 RETURN
27833 END
27834
27835*$ CREATE DT_EVTPUT.FOR
27836*COPY DT_EVTPUT
27837*
27838*===evtput=============================================================*
27839*
27840 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27841
27842 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27843 SAVE
27844
27845 PARAMETER ( LINP = 10 ,
27846 & LOUT = 6 ,
27847 & LDAT = 9 )
27848
27849 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27850 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27851
27852* event history
27853
27854 PARAMETER (NMXHKK=200000)
27855
27856 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27857 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27858 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27859
27860* extended event history
27861 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27862 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27863 & IHIST(2,NMXHKK)
27864
27865* Lorentz-parameters of the current interaction
27866 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27867 & UMO,PPCM,EPROJ,PPROJ
27868
27869* particle properties (BAMJET index convention)
27870 CHARACTER*8 ANAME
27871 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27872 & IICH(210),IIBAR(210),K1(210),K2(210)
27873
27874C IF (MODE.GT.100) THEN
27875C WRITE(LOUT,'(1X,A,I5,A,I5)')
27876C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27877C NHKK = NHKK-MODE+100
27878C RETURN
27879C ENDIF
27880 MO1 = M1
27881 MO2 = M2
27882 NHKK = NHKK+1
27883
27884 IF (NHKK.GT.NMXHKK) THEN
27885 WRITE(LOUT,1000) NHKK
27886 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27887 & '! program execution stopped..')
27888 STOP
27889 ENDIF
27890 IF (M1.LT.0) MO1 = NHKK+M1
27891 IF (M2.LT.0) MO2 = NHKK+M2
27892 ISTHKK(NHKK) = IST
27893 IDHKK(NHKK) = ID
27894 JMOHKK(1,NHKK) = MO1
27895 JMOHKK(2,NHKK) = MO2
27896 JDAHKK(1,NHKK) = 0
27897 JDAHKK(2,NHKK) = 0
27898 IDRES(NHKK) = IDR
27899 IDXRES(NHKK) = IDXR
27900 IDCH(NHKK) = IDC
27901** here we need to do something..
27902 IF (ID.EQ.88888) THEN
27903 IDMO1 = ABS(IDHKK(MO1))
27904 IDMO2 = ABS(IDHKK(MO2))
27905 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27906 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27907 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27908 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27909 ELSE
27910 NOBAM(NHKK) = 0
27911 ENDIF
27912 IDBAM(NHKK) = IDT_ICIHAD(ID)
27913 IF (MO1.GT.0) THEN
27914 IF (JDAHKK(1,MO1).NE.0) THEN
27915 JDAHKK(2,MO1) = NHKK
27916 ELSE
27917 JDAHKK(1,MO1) = NHKK
27918 ENDIF
27919 ENDIF
27920 IF (MO2.GT.0) THEN
27921 IF (JDAHKK(1,MO2).NE.0) THEN
27922 JDAHKK(2,MO2) = NHKK
27923 ELSE
27924 JDAHKK(1,MO2) = NHKK
27925 ENDIF
27926 ENDIF
27927C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27928C PTOT = SQRT(PX**2+PY**2+PZ**2)
27929C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27930C AMRQ = AAM(IDBAM(NHKK))
27931C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27932C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27933C & (PTOT.GT.ZERO)) THEN
27934C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27935CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27936C E = E+DELTA
27937C PTOT1 = PTOT-DELTA
27938C PX = PX*PTOT1/PTOT
27939C PY = PY*PTOT1/PTOT
27940C PZ = PZ*PTOT1/PTOT
27941C ENDIF
27942C ENDIF
27943 PHKK(1,NHKK) = PX
27944 PHKK(2,NHKK) = PY
27945 PHKK(3,NHKK) = PZ
27946 PHKK(4,NHKK) = E
27947 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27948 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27949 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27950 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27951 ELSE
27952 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27953C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27954C & WRITE(LOUT,'(1X,A,G10.3)')
27955C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27956 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27957 ENDIF
27958 IDCHK = ID/10000
27959 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27960* special treatment for chains:
27961* z coordinate of chain in Lab = pos. of target nucleon
27962* time of chain-creation in Lab = time of passage of projectile
27963* nucleus at pos. of taget nucleus
27964C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27965C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27966 VHKK(1,NHKK) = VHKK(1,MO2)
27967 VHKK(2,NHKK) = VHKK(2,MO2)
27968 VHKK(3,NHKK) = VHKK(3,MO2)
27969 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27970C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27971C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27972 WHKK(1,NHKK) = WHKK(1,MO1)
27973 WHKK(2,NHKK) = WHKK(2,MO1)
27974 WHKK(3,NHKK) = WHKK(3,MO1)
27975 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27976 ELSE
27977 IF (MO1.GT.0) THEN
27978 DO 1 I=1,4
27979 VHKK(I,NHKK) = VHKK(I,MO1)
27980 WHKK(I,NHKK) = WHKK(I,MO1)
27981 1 CONTINUE
27982 ELSE
27983 DO 2 I=1,4
27984 VHKK(I,NHKK) = ZERO
27985 WHKK(I,NHKK) = ZERO
27986 2 CONTINUE
27987 ENDIF
27988 ENDIF
27989
27990 RETURN
27991 END
27992
27993*$ CREATE DT_CHASTA.FOR
27994*COPY DT_CHASTA
27995*
27996*===chasta=============================================================*
27997*
27998 SUBROUTINE DT_CHASTA(MODE)
27999
28000************************************************************************
28001* This subroutine performs CHAin STAtistics and checks sequence of *
28002* partons in dtevt1 and sorts them with projectile partons coming *
28003* first if necessary. *
28004* *
28005* This version dated 8.5.00 is written by S. Roesler. *
28006************************************************************************
28007
28008 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28009 SAVE
28010
28011 PARAMETER ( LINP = 10 ,
28012 & LOUT = 6 ,
28013 & LDAT = 9 )
28014
28015 CHARACTER*5 CCHTYP
28016
28017* event history
28018
28019 PARAMETER (NMXHKK=200000)
28020
28021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28024
28025* extended event history
28026 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28027 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28028 & IHIST(2,NMXHKK)
28029
28030* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28031 PARAMETER (MAXCHN=10000)
28032 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28033
28034 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28035 & CCHTYP(9),ICHSTA(10),ITOT(10)
28036 DATA ICHCFG /1800*0/
28037 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28038 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28039 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28040 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28041 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28042 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28043 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28044 & 'ad aq',' d ad','ad d ',' g g '/
28045*
28046* initialization
28047*
28048 IF (MODE.EQ.-1) THEN
28049 NCHAIN = 0
28050*
28051* loop over DTEVT1 and analyse chain configurations
28052*
28053 ELSEIF (MODE.EQ.0) THEN
28054 DO 21 IDX=NPOINT(3),NHKK
28055 IDCHK = IDHKK(IDX)/10000
28056 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28057 & (IDHKK(IDX).NE.80000).AND.
28058 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28059 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28060 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28061 & ' at entry ',IDX
28062 GOTO 21
28063 ENDIF
28064*
28065 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28066 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28067 IMO1 = IST1/10
28068 IMO1 = IST1-10*IMO1
28069 IMO2 = IST2/10
28070 IMO2 = IST2-10*IMO2
28071* swop parton entries if necessary since we need projectile partons
28072* to come first in the common
28073 IF (IMO1.GT.IMO2) THEN
28074 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28075 DO 22 K=1,NPTN/2
28076 I0 = JMOHKK(1,IDX)-1+K
28077 I1 = JMOHKK(2,IDX)+1-K
28078 ITMP = ISTHKK(I0)
28079 ISTHKK(I0) = ISTHKK(I1)
28080 ISTHKK(I1) = ITMP
28081 ITMP = IDHKK(I0)
28082 IDHKK(I0) = IDHKK(I1)
28083 IDHKK(I1) = ITMP
28084 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28085 & JDAHKK(1,JMOHKK(1,I0)) = I1
28086 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28087 & JDAHKK(2,JMOHKK(1,I0)) = I1
28088 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28089 & JDAHKK(1,JMOHKK(2,I0)) = I1
28090 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28091 & JDAHKK(2,JMOHKK(2,I0)) = I1
28092 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28093 & JDAHKK(1,JMOHKK(1,I1)) = I0
28094 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28095 & JDAHKK(2,JMOHKK(1,I1)) = I0
28096 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28097 & JDAHKK(1,JMOHKK(2,I1)) = I0
28098 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28099 & JDAHKK(2,JMOHKK(2,I1)) = I0
28100 ITMP = JMOHKK(1,I0)
28101 JMOHKK(1,I0) = JMOHKK(1,I1)
28102 JMOHKK(1,I1) = ITMP
28103 ITMP = JMOHKK(2,I0)
28104 JMOHKK(2,I0) = JMOHKK(2,I1)
28105 JMOHKK(2,I1) = ITMP
28106 ITMP = JDAHKK(1,I0)
28107 JDAHKK(1,I0) = JDAHKK(1,I1)
28108 JDAHKK(1,I1) = ITMP
28109 ITMP = JDAHKK(2,I0)
28110 JDAHKK(2,I0) = JDAHKK(2,I1)
28111 JDAHKK(2,I1) = ITMP
28112 DO 23 J=1,4
28113 RTMP1 = PHKK(J,I0)
28114 RTMP2 = VHKK(J,I0)
28115 RTMP3 = WHKK(J,I0)
28116 PHKK(J,I0) = PHKK(J,I1)
28117 VHKK(J,I0) = VHKK(J,I1)
28118 WHKK(J,I0) = WHKK(J,I1)
28119 PHKK(J,I1) = RTMP1
28120 VHKK(J,I1) = RTMP2
28121 WHKK(J,I1) = RTMP3
28122 23 CONTINUE
28123 RTMP1 = PHKK(5,I0)
28124 PHKK(5,I0) = PHKK(5,I1)
28125 PHKK(5,I1) = RTMP1
28126 ITMP = IDRES(I0)
28127 IDRES(I0) = IDRES(I1)
28128 IDRES(I1) = ITMP
28129 ITMP = IDXRES(I0)
28130 IDXRES(I0) = IDXRES(I1)
28131 IDXRES(I1) = ITMP
28132 ITMP = NOBAM(I0)
28133 NOBAM(I0) = NOBAM(I1)
28134 NOBAM(I1) = ITMP
28135 ITMP = IDBAM(I0)
28136 IDBAM(I0) = IDBAM(I1)
28137 IDBAM(I1) = ITMP
28138 ITMP = IDCH(I0)
28139 IDCH(I0) = IDCH(I1)
28140 IDCH(I1) = ITMP
28141 ITMP = IHIST(1,I0)
28142 IHIST(1,I0) = IHIST(1,I1)
28143 IHIST(1,I1) = ITMP
28144 ITMP = IHIST(2,I0)
28145 IHIST(2,I0) = IHIST(2,I1)
28146 IHIST(2,I1) = ITMP
28147 22 CONTINUE
28148 ENDIF
28149 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28150 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28151*
28152* parton 1 (projectile side)
28153 IF (IST1.EQ.21) THEN
28154 IDX1 = 1
28155 ELSEIF (IST1.EQ.22) THEN
28156 IDX1 = 2
28157 ELSEIF (IST1.EQ.31) THEN
28158 IDX1 = 3
28159 ELSEIF (IST1.EQ.32) THEN
28160 IDX1 = 4
28161 ELSEIF (IST1.EQ.41) THEN
28162 IDX1 = 5
28163 ELSEIF (IST1.EQ.42) THEN
28164 IDX1 = 6
28165 ELSEIF (IST1.EQ.51) THEN
28166 IDX1 = 7
28167 ELSEIF (IST1.EQ.52) THEN
28168 IDX1 = 8
28169 ELSEIF (IST1.EQ.61) THEN
28170 IDX1 = 9
28171 ELSEIF (IST1.EQ.62) THEN
28172 IDX1 = 10
28173 ELSE
28174c WRITE(LOUT,*)
28175c & ' CHASTA: unknown parton status flag (',
28176c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28177 GOTO 21
28178 ENDIF
28179 ID = IDHKK(JMOHKK(1,IDX))
28180 IF (ABS(ID).LE.4) THEN
28181 IF (ID.GT.0) THEN
28182 ITYP1 = 1
28183 ELSE
28184 ITYP1 = 2
28185 ENDIF
28186 ELSEIF (ABS(ID).GE.1000) THEN
28187 IF (ID.GT.0) THEN
28188 ITYP1 = 3
28189 ELSE
28190 ITYP1 = 4
28191 ENDIF
28192 ELSEIF (ID.EQ.21) THEN
28193 ITYP1 = 5
28194 ELSE
28195 WRITE(LOUT,*)
28196 & ' CHASTA: inconsistent parton identity (',
28197 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28198 GOTO 21
28199 ENDIF
28200*
28201* parton 2 (target side)
28202 IF (IST2.EQ.21) THEN
28203 IDX2 = 1
28204 ELSEIF (IST2.EQ.22) THEN
28205 IDX2 = 2
28206 ELSEIF (IST2.EQ.31) THEN
28207 IDX2 = 3
28208 ELSEIF (IST2.EQ.32) THEN
28209 IDX2 = 4
28210 ELSEIF (IST2.EQ.41) THEN
28211 IDX2 = 5
28212 ELSEIF (IST2.EQ.42) THEN
28213 IDX2 = 6
28214 ELSEIF (IST2.EQ.51) THEN
28215 IDX2 = 7
28216 ELSEIF (IST2.EQ.52) THEN
28217 IDX2 = 8
28218 ELSEIF (IST2.EQ.61) THEN
28219 IDX2 = 9
28220 ELSEIF (IST2.EQ.62) THEN
28221 IDX2 = 10
28222 ELSE
28223c WRITE(LOUT,*)
28224c & ' CHASTA: unknown parton status flag (',
28225c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28226 GOTO 21
28227 ENDIF
28228 ID = IDHKK(JMOHKK(2,IDX))
28229 IF (ABS(ID).LE.4) THEN
28230 IF (ID.GT.0) THEN
28231 ITYP2 = 1
28232 ELSE
28233 ITYP2 = 2
28234 ENDIF
28235 ELSEIF (ABS(ID).GE.1000) THEN
28236 IF (ID.GT.0) THEN
28237 ITYP2 = 3
28238 ELSE
28239 ITYP2 = 4
28240 ENDIF
28241 ELSEIF (ID.EQ.21) THEN
28242 ITYP2 = 5
28243 ELSE
28244 WRITE(LOUT,*)
28245 & ' CHASTA: inconsistent parton identity (',
28246 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28247 GOTO 21
28248 ENDIF
28249*
28250* fill counter
28251 ITYPE = ICHTYP(ITYP1,ITYP2)
28252 IF (ITYPE.NE.0) THEN
28253 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28254 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28255 ICHCFG(IDX1,IDX2,ITYPE,2) =
28256 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28257
28258 NCHAIN = NCHAIN+1
28259 IF (NCHAIN.GT.MAXCHN) THEN
28260 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28261 & NCHAIN,MAXCHN
28262 STOP
28263 ENDIF
28264 IDXCHN(1,NCHAIN) = IDX
28265 IDXCHN(2,NCHAIN) = ITYPE
28266 ELSE
28267 WRITE(LOUT,*)
28268 & ' CHASTA: inconsistent chain at entry ',IDX
28269 GOTO 21
28270 ENDIF
28271 ENDIF
28272 21 CONTINUE
28273*
28274* write statistics to output unit
28275*
28276 ELSEIF (MODE.EQ.1) THEN
28277 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28278 DO 31 I=1,10
28279 WRITE(LOUT,'(/,2A)')
28280 & ' -----------------------------------------',
28281 & '------------------------------------'
28282 WRITE(LOUT,'(2A)')
28283 & ' p\\t 21 22 31 32 41',
28284 & ' 42 51 52 61 62'
28285 WRITE(LOUT,'(2A)')
28286 & ' -----------------------------------------',
28287 & '------------------------------------'
28288 DO 32 J=1,10
28289 ITOT(J) = 0
28290 DO 33 K=1,9
28291 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28292 33 CONTINUE
28293 32 CONTINUE
28294 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28295 DO 34 K=1,9
28296 ISUM = 0
28297 DO 35 J=1,10
28298 ISUM = ISUM+ICHCFG(I,J,K,1)
28299 35 CONTINUE
28300 IF (ISUM.GT.0)
28301 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28302 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28303 34 CONTINUE
28304C WRITE(LOUT,'(2A)')
28305C & ' -----------------------------------------',
28306C & '-------------------------------'
28307 31 CONTINUE
28308*
28309 ELSE
28310 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28311 STOP
28312 ENDIF
28313
28314 RETURN
28315 END
28316*$ CREATE PHO_PHIST.FOR
28317*COPY PHO_PHIST
28318*
28319*===pohist=============================================================*
28320*
28321 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28322
28323 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28324 SAVE
28325
28326 PARAMETER ( LINP = 10 ,
28327 & LOUT = 6 ,
28328 & LDAT = 9 )
28329
28330 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28331
28332* Glauber formalism: cross sections
28333 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28334 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28335 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28336 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28337 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28338 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28339 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28340 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28341 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28342 & BSLOPE,NEBINI,NQBINI
28343
28344 ILAB = 0
28345 IF (IMODE.EQ.10) THEN
28346 IMODE = 1
28347 ILAB = 1
28348 ENDIF
28349 IF (ABS(IMODE).LT.1000) THEN
28350* PHOJET-statistics
28351C CALL POHISX(IMODE,WEIGHT)
28352 IF (IMODE.EQ.-1) THEN
28353 MODE = 1
28354 XSTOT(1,1,1) = WEIGHT
28355 ENDIF
28356 IF (IMODE.EQ. 1) MODE = 2
28357 IF (IMODE.EQ.-2) MODE = 3
28358 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28359C IF (MODE.EQ.3) WRITE(LOUT,*)
28360C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28361 CALL DT_HISTOG(MODE)
28362 CALL DT_USRHIS(MODE)
28363 ELSE
28364* DTUNUC-statistics
28365 MODE = IMODE/1000
28366C IF (MODE.EQ.3) WRITE(LOUT,*)
28367C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28368 CALL DT_HISTOG(MODE)
28369 CALL DT_USRHIS(MODE)
28370 ENDIF
28371
28372 RETURN
28373 END
28374
28375*$ CREATE DT_SWPPHO.FOR
28376*COPY DT_SWPPHO
28377*
28378*===swppho=============================================================*
28379*
28380 SUBROUTINE DT_SWPPHO(ILAB)
28381
28382 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28383 SAVE
28384
28385 PARAMETER ( LINP = 10 ,
28386 & LOUT = 6 ,
28387 & LDAT = 9 )
28388
28389 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28390
28391 LOGICAL LSTART
28392
28393* event history
28394
28395 PARAMETER (NMXHKK=200000)
28396
28397 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28398 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28399 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28400
28401* extended event history
28402 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28403 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28404 & IHIST(2,NMXHKK)
28405
28406* flags for input different options
28407 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28408 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28409 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28410
28411* properties of photon/lepton projectiles
28412 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28413
28414**PHOJET105a
28415C PARAMETER (NMXHEP=2000)
28416C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28417C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28418C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28419C COMMON /PLASAV/ PLAB
28420**PHOJET110
28421C standard particle data interface
28422 INTEGER NMXHEP
28423
28424 PARAMETER (NMXHEP=4000)
28425
28426 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28427 DOUBLE PRECISION PHEP,VHEP
28428 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28429 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28430 & VHEP(4,NMXHEP)
28431C extension to standard particle data interface (PHOJET specific)
28432 INTEGER IMPART,IPHIST,ICOLOR
28433 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28434
28435C global event kinematics and particle IDs
28436 INTEGER IFPAP,IFPAB
28437 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28438 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28439**
28440 DATA ICOUNT/0/
28441
28442 DATA LSTART /.TRUE./
28443
28444C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28445 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28446 UMO = ECM
28447 ELA = ZERO
28448 PLA = ZERO
28449 IDP = IDT_ICIHAD(IFPAP(1))
28450 IDT = IDT_ICIHAD(IFPAP(2))
28451 VIRT = PVIRT(1)
28452 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28453 PLAB = PLA
28454 LSTART = .FALSE.
28455 ENDIF
28456
28457 NHKK = 0
28458 ICOUNT = ICOUNT+1
28459C NEVHKK = NEVHEP
28460 NEVHKK = ICOUNT
28461 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28462 DO 1 I=3,NHEP
28463 IF (ISTHEP(I).EQ.1) THEN
28464 NHKK = NHKK+1
28465 ISTHKK(NHKK) = 1
28466 IDHKK(NHKK) = IDHEP(I)
28467 JMOHKK(1,NHKK) = 0
28468 JMOHKK(2,NHKK) = 0
28469 JDAHKK(1,NHKK) = 0
28470 JDAHKK(2,NHKK) = 0
28471 DO 2 K=1,4
28472 PHKK(K,NHKK) = PHEP(K,I)
28473 VHKK(K,NHKK) = ZERO
28474 WHKK(K,NHKK) = ZERO
28475 2 CONTINUE
28476 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28477 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28478 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28479 PHKK(5,NHKK) = PHEP(5,I)
28480 IDRES(NHKK) = 0
28481 IDXRES(NHKK) = 0
28482 NOBAM(NHKK) = 0
28483 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28484 IDCH(NHKK) = 0
28485 ENDIF
28486 1 CONTINUE
28487
28488 RETURN
28489 END
28490
28491*$ CREATE DT_HISTOG.FOR
28492*COPY DT_HISTOG
28493*
28494*===histog=============================================================*
28495*
28496 SUBROUTINE DT_HISTOG(MODE)
28497
28498************************************************************************
28499* This version dated 25.03.96 is written by S. Roesler *
28500************************************************************************
28501
28502 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28503 SAVE
28504
28505 PARAMETER ( LINP = 10 ,
28506 & LOUT = 6 ,
28507 & LDAT = 9 )
28508
28509 LOGICAL LFSP,LRNL
28510
28511* event history
28512
28513 PARAMETER (NMXHKK=200000)
28514
28515 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28516 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28517 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28518
28519* extended event history
28520 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28521 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28522 & IHIST(2,NMXHKK)
28523
28524* event flag used for histograms
28525 COMMON /DTNORM/ ICEVT,IEVHKK
28526
28527* flags for activated histograms
28528 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28529
28530 IEVHKK = NEVHKK
28531 GOTO (1,2,3) MODE
28532
28533*------------------------------------------------------------------
28534* initialization
28535 1 CONTINUE
28536 ICEVT = 0
28537 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28538 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28539
28540 RETURN
28541*------------------------------------------------------------------
28542* filling of histogram with event-record
28543 2 CONTINUE
28544 ICEVT = ICEVT+1
28545
28546 DO 20 I=1,NHKK
28547 CALL DT_SWPFSP(I,LFSP,LRNL)
28548 IF (LFSP) THEN
28549 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28550 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28551 ENDIF
28552 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28553 20 CONTINUE
28554 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28555
28556 RETURN
28557*------------------------------------------------------------------
28558* output
28559 3 CONTINUE
28560 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28561 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28562
28563 RETURN
28564 END
28565
28566*$ CREATE DT_SWPFSP.FOR
28567*COPY DT_SWPFSP
28568*
28569*===swpfsp=============================================================*
28570*
28571 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28572
28573 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28574 SAVE
28575 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28576 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28577 & PI =TWOPI/TWO,
28578 & BOG =TWOPI/360.0D0)
28579
28580* event history
28581
28582 PARAMETER (NMXHKK=200000)
28583
28584 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28585 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28586 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28587
28588* extended event history
28589 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28590 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28591 & IHIST(2,NMXHKK)
28592
28593* particle properties (BAMJET index convention)
28594 CHARACTER*8 ANAME
28595 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28596 & IICH(210),IIBAR(210),K1(210),K2(210)
28597
28598* Lorentz-parameters of the current interaction
28599 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28600 & UMO,PPCM,EPROJ,PPROJ
28601
28602* flags for input different options
28603 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28604 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28605 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28606
28607* INCLUDE '(DIMPAR)'
28608* Taken from FLUKA
28609 PARAMETER ( MXXRGN =20000 )
28610 PARAMETER ( MXXMDF = 710 )
28611 PARAMETER ( MXXMDE = 702 )
28612 PARAMETER ( MFSTCK =40000 )
28613 PARAMETER ( MESTCK = 100 )
28614 PARAMETER ( MOSTCK = 2000 )
28615 PARAMETER ( MXPRSN = 100 )
28616 PARAMETER ( MXPDPM = 800 )
28617 PARAMETER ( MXPSCS =30000 )
28618 PARAMETER ( MXGLWN = 300 )
28619 PARAMETER ( MXOUTU = 50 )
28620 PARAMETER ( NALLWP = 64 )
28621 PARAMETER ( NELEMX = 80 )
28622 PARAMETER ( MPDPDX = 18 )
28623 PARAMETER ( MXHTTR = 260 )
28624 PARAMETER ( MXSEAX = 20 )
28625 PARAMETER ( MXHTNC = MXSEAX + 1 )
28626 PARAMETER ( ICOMAX = 2400 )
28627 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28628 PARAMETER ( NSTBIS = 304 )
28629 PARAMETER ( NQSTIS = 46 )
28630 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28631 PARAMETER ( MXPABL = 120 )
28632 PARAMETER ( IDMAXP = 450 )
28633 PARAMETER ( IDMXDC = 2000 )
28634 PARAMETER ( MXMCIN = 410 )
28635 PARAMETER ( IHYPMX = 4 )
28636 PARAMETER ( MKBMX1 = 11 )
28637 PARAMETER ( MKBMX2 = 11 )
28638 PARAMETER ( MXIRRD = 2500 )
28639 PARAMETER ( MXTRDC = 1500 )
28640 PARAMETER ( NKTL = 17 )
28641 PARAMETER ( NBLNMX = 40000000 )
28642
28643* INCLUDE '(PAREVT)'
28644* Taken from FLUKA
28645 PARAMETER ( FRDIFF = 0.2D+00 )
28646 PARAMETER ( ETHSEA = 1.0D+00 )
28647*
28648 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28649 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28650 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28651 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28652 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28653 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28654 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28655 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28656 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28657 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28658
28659* temporary storage for one final state particle
28660 LOGICAL LFRAG,LGREY,LBLACK
28661 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28662 & SINTHE,COSTHE,THETA,THECMS,
28663 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28664 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28665 & LFRAG,LGREY,LBLACK
28666
28667 LOGICAL LFSP,LRNL
28668
28669 LFSP = .FALSE.
28670 LRNL = .FALSE.
28671 ISTRNL = 1000
28672 MULDEF = 1
28673 IF (LEVPRT) ISTRNL = 1001
28674
28675 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28676 IST = ISTHKK(IDX)
28677 IDPDG = IDHKK(IDX)
28678 LFRAG = .FALSE.
28679 IF (IDHKK(IDX).LT.80000) THEN
28680 IDBJT = IDBAM(IDX)
28681 IBARY = IIBAR(IDBJT)
28682 ICHAR = IICH(IDBJT)
28683 AMASS = AAM(IDBJT)
28684 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28685 IDBJT = 0
28686 IBARY = IDRES(IDX)
28687 ICHAR = IDXRES(IDX)
28688 AMASS = PHKK(5,IDX)
28689 INUT = IBARY-ICHAR
28690 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28691 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28692 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28693 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28694 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28695 ELSE
28696 GOTO 9999
28697 ENDIF
28698 PE = PHKK(4,IDX)
28699 PX = PHKK(1,IDX)
28700 PY = PHKK(2,IDX)
28701 PZ = PHKK(3,IDX)
28702 PT2 = PX**2+PY**2
28703 PT = SQRT(PT2)
28704 PTOT = SQRT(PT2+PZ**2)
28705 SINTHE = PT/MAX(PTOT,TINY14)
28706 COSTHE = PZ/MAX(PTOT,TINY14)
28707 IF (COSTHE.GT.ONE) THEN
28708 THETA = ZERO
28709 ELSEIF (COSTHE.LT.-ONE) THEN
28710 THETA = TWOPI/2.0D0
28711 ELSE
28712 THETA = ACOS(COSTHE)
28713 ENDIF
28714 EKIN = PE-AMASS
28715**sr 15.4.96 new E_t-definition
28716 IF (IBARY.GT.0) THEN
28717 ET = EKIN*SINTHE
28718 ELSEIF (IBARY.LT.0) THEN
28719 ET = (EKIN+TWO*AMASS)*SINTHE
28720 ELSE
28721 ET = PE*SINTHE
28722 ENDIF
28723**
28724 XLAB = PZ/MAX(PPROJ,TINY14)
28725C XLAB = PE/MAX(EPROJ,TINY14)
28726 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28727 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28728 PPLUS = PE+PZ
28729 PMINUS = PE-PZ
28730 IF (PMINUS.GT.TINY14) THEN
28731 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28732 ELSE
28733 YY = 100.0D0
28734 ENDIF
28735 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28736 ETA = -LOG(TAN(THETA/TWO))
28737 ELSE
28738 ETA = 100.0D0
28739 ENDIF
28740 IF (IFRAME.EQ.1) THEN
28741 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28742 PPLUS = EECMS+PZCMS
28743 PMINUS = EECMS-PZCMS
28744 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28745 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28746 ELSE
28747 YYCMS = 100.0D0
28748 ENDIF
28749 PTOTCM = SQRT(PT2+PZCMS**2)
28750 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28751 IF (COSTH.GT.ONE) THEN
28752 THECMS = ZERO
28753 ELSEIF (COSTH.LT.-ONE) THEN
28754 THECMS = TWOPI/2.0D0
28755 ELSE
28756 THECMS = ACOS(COSTH)
28757 ENDIF
28758 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28759 ETACMS = -LOG(TAN(THECMS/TWO))
28760 ELSE
28761 ETACMS = 100.0D0
28762 ENDIF
28763 XF = PZCMS/MAX(PPCM,TINY14)
28764 THECMS = THECMS/BOG
28765 ELSE
28766 PZCMS = PZ
28767 EECMS = PE
28768 YYCMS = YY
28769 ETACMS = ETA
28770 XF = XLAB
28771 THECMS = THETA/BOG
28772 ENDIF
28773 THETA = THETA/BOG
28774
28775* set flag for "grey/black"
28776 LGREY = .FALSE.
28777 LBLACK = .FALSE.
28778 EK = EKIN
28779 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28780 IF (MULDEF.EQ.1) THEN
28781* EMU01-Def.
28782 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28783 & (EK.LE.375.0D-3) ).OR.
28784 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28785 & (EK.LE. 56.0D-3) ).OR.
28786 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28787 & (EK.LE. 56.0D-3) ).OR.
28788 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28789 & (EK.LE.198.0D-3) ).OR.
28790 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28791 & (EK.LE.198.0D-3) ).OR.
28792 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28793 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28794 & (IDBJT.NE.16).AND.
28795 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28796 & LGREY = .TRUE.
28797 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28798 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28799 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28800 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28801 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28802 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28803 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28804 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28805 & LBLACK = .TRUE.
28806 ELSE
28807* common Def.
28808 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28809 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28810 ENDIF
28811 LFSP = .TRUE.
28812 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28813 IST = ISTHKK(IDX)
28814 IDPDG = IDHKK(IDX)
28815 LFRAG = .TRUE.
28816 IDBJT = 0
28817 IBARY = IDRES(IDX)
28818 ICHAR = IDXRES(IDX)
28819 AMASS = PHKK(5,IDX)
28820 PE = PHKK(4,IDX)
28821 PX = PHKK(1,IDX)
28822 PY = PHKK(2,IDX)
28823 PZ = PHKK(3,IDX)
28824 PT2 = PX**2+PY**2
28825 PT = SQRT(PT2)
28826 PTOT = SQRT(PT2+PZ**2)
28827 SINTHE = PT/MAX(PTOT,TINY14)
28828 COSTHE = PZ/MAX(PTOT,TINY14)
28829 IF (COSTHE.GT.ONE) THEN
28830 THETA = ZERO
28831 ELSEIF (COSTHE.LT.-ONE) THEN
28832 THETA = TWOPI/2.0D0
28833 ELSE
28834 THETA = ACOS(COSTHE)
28835 ENDIF
28836 EKIN = PE-AMASS
28837**sr 15.4.96 new E_t-definition
28838C ET = PE*SINTHE
28839 ET = EKIN*SINTHE
28840**
28841 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28842 ETA = -LOG(TAN(THETA/TWO))
28843 ELSE
28844 ETA = 100.0D0
28845 ENDIF
28846 THETA = THETA/BOG
28847 LRNL = .TRUE.
28848 ENDIF
28849
28850 9999 CONTINUE
28851 RETURN
28852 END
28853
28854*$ CREATE DT_HIMULT.FOR
28855*COPY DT_HIMULT
28856*
28857*===himult=============================================================*
28858*
28859 SUBROUTINE DT_HIMULT(MODE)
28860
28861************************************************************************
28862* Tables of average energies/multiplicities. *
28863* This version dated 30.08.2000 is written by S. Roesler *
28864************************************************************************
28865
28866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28867 SAVE
28868
28869 PARAMETER ( LINP = 10 ,
28870 & LOUT = 6 ,
28871 & LDAT = 9 )
28872
28873 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28874
28875 PARAMETER (SWMEXP=1.7D0)
28876
28877 CHARACTER*8 ANAMEH(4)
28878
28879* particle properties (BAMJET index convention)
28880 CHARACTER*8 ANAME
28881 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28882 & IICH(210),IIBAR(210),K1(210),K2(210)
28883
28884* temporary storage for one final state particle
28885 LOGICAL LFRAG,LGREY,LBLACK
28886 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28887 & SINTHE,COSTHE,THETA,THECMS,
28888 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28889 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28890 & LFRAG,LGREY,LBLACK
28891
28892* event flag used for histograms
28893 COMMON /DTNORM/ ICEVT,IEVHKK
28894
28895* Lorentz-parameters of the current interaction
28896 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28897 & UMO,PPCM,EPROJ,PPROJ
28898
28899 PARAMETER (NOPART=210)
28900 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28901 & AVPT(4,NOPART),IAVPT(4,NOPART)
28902 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28903
28904 GOTO (1,2,3) MODE
28905
28906*------------------------------------------------------------------
28907* initialization
28908 1 CONTINUE
28909 DO 10 I=1,NOPART
28910 DO 11 J=1,4
28911 AVMULT(J,I) = ZERO
28912 AVE(J,I) = ZERO
28913 AVSWM(J,I) = ZERO
28914 AVPT(J,I) = ZERO
28915 IAVPT(J,I) = 0
28916 11 CONTINUE
28917 10 CONTINUE
28918
28919 RETURN
28920
28921*------------------------------------------------------------------
28922* filling of histogram with event-record
28923 2 CONTINUE
28924 IF (PE.LT.0.0D0) THEN
28925 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28926 RETURN
28927 ENDIF
28928 IF (.NOT.LFRAG) THEN
28929 IVEL = 2
28930 IF (LGREY) IVEL = 3
28931 IF (LBLACK) IVEL = 4
28932 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28933 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28934 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28935 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28936 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28937 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28938 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28939 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28940 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28941 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28942 IF (IDBJT.LT.116) THEN
28943* total energy, multiplicity
28944 AVE(1,30) = AVE(1,30) +PE
28945 AVE(IVEL,30) = AVE(IVEL,30)+PE
28946 AVPT(1,30) = AVPT(1,30) +PT
28947 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28948 IAVPT(1,30) = IAVPT(1,30) +1
28949 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28950 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28951 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28952 AVMULT(1,30) = AVMULT(1,30) +ONE
28953 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28954* charged energy, multiplicity
28955 IF (ICHAR.LT.0) THEN
28956 AVE(1,26) = AVE(1,26) +PE
28957 AVE(IVEL,26) = AVE(IVEL,26)+PE
28958 AVPT(1,26) = AVPT(1,26) +PT
28959 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28960 IAVPT(1,26) = IAVPT(1,26) +1
28961 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28962 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28963 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28964 AVMULT(1,26) = AVMULT(1,26) +ONE
28965 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28966 ENDIF
28967 IF (ICHAR.NE.0) THEN
28968 AVE(1,27) = AVE(1,27) +PE
28969 AVE(IVEL,27) = AVE(IVEL,27)+PE
28970 AVPT(1,27) = AVPT(1,27) +PT
28971 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28972 IAVPT(1,27) = IAVPT(1,27) +1
28973 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28974 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28975 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28976 AVMULT(1,27) = AVMULT(1,27) +ONE
28977 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28978 ENDIF
28979 ENDIF
28980 ENDIF
28981
28982 RETURN
28983
28984*------------------------------------------------------------------
28985* output
28986 3 CONTINUE
28987 WRITE(LOUT,3000)
28988 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28989 & 29X,'---------------------',/)
28990 IF (MULDEF.EQ.1) THEN
28991 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28992 ELSE
28993 BETGRE = 0.7D0
28994 BETBLC = 0.23D0
28995 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28996 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
28997 & ,F4.2,' black: beta < ',F4.2,/)
28998 ENDIF
28999 WRITE(LOUT,3003) SWMEXP
29000 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29001 & 13X,'| total fast',
29002C & ' grey black K f(',F3.1,')',/,1X,
29003 & ' grey black <pt> f(',F3.1,')',/,1X,
29004 & '------------+--------------',
29005 & '-------------------------------------------------')
29006 DO 30 I=1,NOPART
29007 DO 31 J=1,4
29008 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29009 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29010 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29011 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29012 31 CONTINUE
29013 IF (I.LE.115) THEN
29014 WRITE(LOUT,3004) ANAME(I),I,
29015 & AVMULT(1,I),AVMULT(2,I),
29016 & AVMULT(3,I),AVMULT(4,I),
29017C & AVE(1,I),AVSWM(1,I)
29018 & AVPT(1,I),AVSWM(1,I)
29019 ELSEIF (I.LE.119) THEN
29020 WRITE(LOUT,3004) ANAMEH(I-115),I,
29021 & AVMULT(1,I),AVMULT(2,I),
29022 & AVMULT(3,I),AVMULT(4,I),
29023C & AVE(1,I),AVSWM(1,I)
29024 & AVPT(1,I),AVSWM(1,I)
29025 ENDIF
29026 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29027 30 CONTINUE
29028**temporary
29029C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29030C & AVMULT(3,27)+AVMULT(4,27)
29031**
29032
29033 RETURN
29034 END
29035
29036*$ CREATE DT_HISTAT.FOR
29037*COPY DT_HISTAT
29038*
29039*===histat=============================================================*
29040*
29041 SUBROUTINE DT_HISTAT(IDX,MODE)
29042
29043************************************************************************
29044* This version dated 26.02.96 is written by S. Roesler *
29045* *
29046* Last change 27.12.2006 by S. Roesler. *
29047************************************************************************
29048
29049 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29050 SAVE
29051
29052 PARAMETER ( LINP = 10 ,
29053 & LOUT = 6 ,
29054 & LDAT = 9 )
29055
29056 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29057 PARAMETER (NDIM=199)
29058
29059* event history
29060
29061 PARAMETER (NMXHKK=200000)
29062
29063 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29064 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29065 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29066
29067* extended event history
29068 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29069 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29070 & IHIST(2,NMXHKK)
29071
29072* particle properties (BAMJET index convention)
29073 CHARACTER*8 ANAME
29074 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29075 & IICH(210),IIBAR(210),K1(210),K2(210)
29076
29077 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29078
29079* Glauber formalism: cross sections
29080 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29081 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29082 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29083 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29084 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29085 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29086 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29087 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29088 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29089 & BSLOPE,NEBINI,NQBINI
29090
29091* emulsion treatment
29092 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29093 & NCOMPO,IEMUL
29094
29095* properties of interacting particles
29096 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29097
29098* rejection counter
29099 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29100 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29101 & IREXCI(3),IRDIFF(2),IRINC
29102
29103* statistics: residual nuclei
29104 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29105 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29106 & NINCST(2,4),NINCEV(2),
29107 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29108 & NRESPB(2),NRESCH(2),NRESEV(4),
29109 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29110 & NEVAFI(2,2)
29111
29112* parameter for intranuclear cascade
29113 LOGICAL LPAULI
29114 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29115
29116* INCLUDE '(DIMPAR)'
29117* Taken from FLUKA
29118 PARAMETER ( MXXRGN =20000 )
29119 PARAMETER ( MXXMDF = 710 )
29120 PARAMETER ( MXXMDE = 702 )
29121 PARAMETER ( MFSTCK =40000 )
29122 PARAMETER ( MESTCK = 100 )
29123 PARAMETER ( MOSTCK = 2000 )
29124 PARAMETER ( MXPRSN = 100 )
29125 PARAMETER ( MXPDPM = 800 )
29126 PARAMETER ( MXPSCS =30000 )
29127 PARAMETER ( MXGLWN = 300 )
29128 PARAMETER ( MXOUTU = 50 )
29129 PARAMETER ( NALLWP = 64 )
29130 PARAMETER ( NELEMX = 80 )
29131 PARAMETER ( MPDPDX = 18 )
29132 PARAMETER ( MXHTTR = 260 )
29133 PARAMETER ( MXSEAX = 20 )
29134 PARAMETER ( MXHTNC = MXSEAX + 1 )
29135 PARAMETER ( ICOMAX = 2400 )
29136 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29137 PARAMETER ( NSTBIS = 304 )
29138 PARAMETER ( NQSTIS = 46 )
29139 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29140 PARAMETER ( MXPABL = 120 )
29141 PARAMETER ( IDMAXP = 450 )
29142 PARAMETER ( IDMXDC = 2000 )
29143 PARAMETER ( MXMCIN = 410 )
29144 PARAMETER ( IHYPMX = 4 )
29145 PARAMETER ( MKBMX1 = 11 )
29146 PARAMETER ( MKBMX2 = 11 )
29147 PARAMETER ( MXIRRD = 2500 )
29148 PARAMETER ( MXTRDC = 1500 )
29149 PARAMETER ( NKTL = 17 )
29150 PARAMETER ( NBLNMX = 40000000 )
29151
29152* INCLUDE '(PAREVT)'
29153* Taken from FLUKA
29154 PARAMETER ( FRDIFF = 0.2D+00 )
29155 PARAMETER ( ETHSEA = 1.0D+00 )
29156*
29157 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29158 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29159 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29160 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29161 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29162 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29163 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29164 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29165 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29166 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29167
29168* INCLUDE '(FRBKCM)'
29169* Taken from FLUKA
29170* Maximum number of fragments to be emitted:
29171 PARAMETER ( MXFFBK = 6 )
29172 PARAMETER ( MXZFBK = 10 )
29173 PARAMETER ( MXNFBK = 12 )
29174 PARAMETER ( MXAFBK = 16 )
29175 PARAMETER ( MXASST = 25 )
29176 PARAMETER ( NXAFBK = MXAFBK + 1 )
29177 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29178 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29179 PARAMETER ( MXPSST = 700 )
29180* Maximum number of pre-computed break-up combinations
29181 PARAMETER ( MXPPFB = 42500 )
29182* Maximum number of break-up combinations, including special
29183* run-time ones:
29184 PARAMETER ( MXPSFB = 43000 )
29185* Base for J multiplicity encoding:
29186 PARAMETER ( IBFRBK = 73 )
29187* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29188* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29189* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29190* --> Ibfrbk^(Jpwfbx+1) < 2100000000
29191 PARAMETER ( JPWFBX = 4 )
29192 LOGICAL LFRMBK, LNCMSS
29193 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29194 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29195 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29196 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29197 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29198 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29199 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29200 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29201 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29202 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29203
29204* INCLUDE '(EVAFLG)'
29205* Taken from FLUKA
29206 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29207 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29208 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29209 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29210 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29211 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29212 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29213 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29214 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29215 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29216 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29217 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29218
29219* temporary storage for one final state particle
29220 LOGICAL LFRAG,LGREY,LBLACK
29221 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29222 & SINTHE,COSTHE,THETA,THECMS,
29223 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29224 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29225 & LFRAG,LGREY,LBLACK
29226
29227* event flag used for histograms
29228 COMMON /DTNORM/ ICEVT,IEVHKK
29229
29230* statistics: double-Pomeron exchange
29231 COMMON /DTFLG2/ INTFLG,IPOPO
29232
29233 DIMENSION EMUSAM(NCOMPX)
29234
29235 CHARACTER*13 CMSG(3)
29236 DATA CMSG /'not requested','not requested','not requested'/
29237
29238 GOTO (1,2,3,4,5) MODE
29239
29240*------------------------------------------------------------------
29241* initialization
29242 1 CONTINUE
29243* emulsion treatment
29244 IF (NCOMPO.GT.0) THEN
29245 DO 10 I=1,NCOMPX
29246 EMUSAM(I) = ZERO
29247 10 CONTINUE
29248 ENDIF
29249* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29250 NINCGE = 0
29251 DO 11 I=1,2
29252 EXCDPM(I) = ZERO
29253 EXCDPM(I+2) = ZERO
29254 EXCEVA(I) = ZERO
29255 NINCWO(I) = 0
29256 NINCEV(I) = 0
29257 NRESTO(I) = 0
29258 NRESPR(I) = 0
29259 NRESNU(I) = 0
29260 NRESBA(I) = 0
29261 NRESPB(I) = 0
29262 NRESCH(I) = 0
29263 NRESEV(I) = 0
29264 NRESEV(I+2) = 0
29265 NEVAGA(I) = 0
29266 NEVAHT(I) = 0
29267 NEVAFI(1,I) = 0
29268 NEVAFI(2,I) = 0
29269 DO 12 J=1,6
29270 IF (J.LE.2) NINCHR(I,J) = 0
29271 IF (J.LE.3) NINCCO(I,J) = 0
29272 IF (J.LE.4) NINCST(I,J) = 0
29273 NEVA(I,J) = 0
29274 12 CONTINUE
29275 DO 13 J=1,210
29276 NEVAHY(1,I,J) = 0
29277 NEVAHY(2,I,J) = 0
29278 13 CONTINUE
29279 11 CONTINUE
29280 MAXGEN = 0
29281**dble Po statistics.
29282 KPOPO = 0
29283
29284 RETURN
29285*------------------------------------------------------------------
29286* filling of histogram with event-record
29287 2 CONTINUE
29288 IF (IST.EQ.-1) THEN
29289 IF (.NOT.LFRAG) THEN
29290 IF (IDPDG.EQ.2212) THEN
29291 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29292 ELSEIF (IDPDG.EQ.2112) THEN
29293 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29294 ELSEIF (IDPDG.EQ.22) THEN
29295 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29296 ELSEIF (IDPDG.EQ.80000) THEN
29297 IF (IDBJT.EQ.116) THEN
29298 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29299 ELSEIF (IDBJT.EQ.117) THEN
29300 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29301 ELSEIF (IDBJT.EQ.118) THEN
29302 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29303 ELSEIF (IDBJT.EQ.119) THEN
29304 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29305 ENDIF
29306 ENDIF
29307 ELSE
29308* heavy fragments (here: fission products only)
29309 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29310 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29311 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29312 ENDIF
29313 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29314 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29315 ENDIF
29316
29317 RETURN
29318*------------------------------------------------------------------
29319* output
29320 3 CONTINUE
29321
29322**dble Po statistics.
29323C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29324C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29325C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29326
29327* emulsion treatment
29328 IF (NCOMPO.GT.0) THEN
29329 WRITE(LOUT,3000)
29330 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29331 & 22X,'----------------------------',/,/,19X,
29332 & 'mass charge fraction',/,39X,
29333 & 'input treated',/)
29334 DO 30 I=1,NCOMPO
29335 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29336 & EMUSAM(I)/DBLE(ICEVT)
29337 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29338 30 CONTINUE
29339 ENDIF
29340
29341* i.n.c. statistics: output
29342 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29343 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29344 & 22X,'---------------------------------',/,/,1X,
29345 & 'no. of events for normalization: (accepted final events,',
29346 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29347 & /,1X,'no. of rejected events due to intranuclear',
29348 & ' cascade',15X,I6,/)
29349 ICEV = MAX(ICEVT,1)
29350 ICEV1 = ICEV
29351 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29352 WRITE(LOUT,3002)
29353 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29354 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29355 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29356 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29357 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29358 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29359 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29360 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29361 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29362 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29363 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29364 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29365 & /,1X,'maximum no. of generations treated (maximum allowed:'
29366 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29367 & ' interactions in proj./ target (mean per evt1)',
29368 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29369 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29370 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29371 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29372 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29373 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29374 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29375 & 'evaporation',/,22X,'-----------------------------',
29376 & '------------',/,/,1X,'no. of events for normal.: ',
29377 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29378 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29379 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29380
29381 WRITE(LOUT,3004)
29382 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29383 ICEV = MAX(NRESEV(2),1)
29384 WRITE(LOUT,3005)
29385 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29386 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29387 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29388 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29389 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29390 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29391 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29392 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29393 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29394 & 'proj. / target',/,/,8X,'total number of particles',15X,
29395 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29396 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29397 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29398 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29399 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29400
29401* evaporation / fission / fragmentation statistics: output
29402 ICEV = MAX(NRESEV(2),1)
29403 ICEV1 = MAX(NRESEV(4),1)
29404 NTEVA1 =
29405 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29406 NTEVA2 =
29407 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29408 IF (LEVPRT) THEN
29409
29410 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29411
29412 IF (LFRMBK) CMSG(2) = 'requested '
29413 IF (LDEEXG) CMSG(3) = 'requested '
29414 WRITE(LOUT,3006)
29415 & CMSG,
29416 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29417 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29418 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29419 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29420 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29421 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29422 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29423 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29424 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29425 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29426 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29427 & 'deexcitation:',2X,A13,/,/,
29428 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29429 & 'proj. / target',/,/,8X,'total number of evap. particles',
29430 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29431 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29432 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29433 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29434 & 'heavy fragments',25X,2F9.3,/)
29435
29436 IF (IEVFSS.EQ.1) THEN
29437
29438 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29439 & NEVAFI(2,1),NEVAFI(2,2),
29440 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29441 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29442 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29443 & 12X,'out of which fission occured',8X,2I9,/,
29444 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29445 ENDIF
29446
29447C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29448
29449C WRITE(LOUT,3008)
29450C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29451C & ' proj. / target',/)
29452C DO 31 I=1,210
29453C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29454C WRITE(LOUT,3009) I,
29455C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29456C3009 FORMAT(38X,I3,3X,2E12.3)
29457C ENDIF
29458C 31 CONTINUE
29459C WRITE(LOUT,3010)
29460C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29461C & ' proj. / target',/)
29462C DO 32 I=1,210
29463C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29464C WRITE(LOUT,3011) I,
29465C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29466C3011 FORMAT(38X,I3,3X,2E12.3)
29467C ENDIF
29468C 32 CONTINUE
29469C WRITE(LOUT,*)
29470C ENDIF
29471 ELSE
29472 WRITE(LOUT,3012)
29473 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29474 & 'Evaporation: not requested',/)
29475 ENDIF
29476
29477 RETURN
29478*------------------------------------------------------------------
29479* filling of histogram with event-record
29480 4 CONTINUE
29481* emulsion treatment
29482 IF (NCOMPO.GT.0) THEN
29483 DO 40 I=1,NCOMPO
29484 IF (IT.EQ.IEMUMA(I)) THEN
29485 EMUSAM(I) = EMUSAM(I)+ONE
29486 ENDIF
29487 40 CONTINUE
29488 ENDIF
29489 NINCGE = NINCGE+MAXGEN
29490 MAXGEN = 0
29491**dble Po statistics.
29492 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29493
29494 RETURN
29495*------------------------------------------------------------------
29496* filling of histogram with event-record
29497 5 CONTINUE
29498 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29499 IB = IIBAR(IDBAM(IDX))
29500 IC = IICH(IDBAM(IDX))
29501 J = ISTHKK(IDX)-14
29502 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29503 NINCST(J,1) = NINCST(J,1)+1
29504 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29505 NINCST(J,2) = NINCST(J,2)+1
29506 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29507 NINCST(J,3) = NINCST(J,3)+1
29508 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29509 NINCST(J,4) = NINCST(J,4)+1
29510 ENDIF
29511 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29512 NINCWO(1) = NINCWO(1)+1
29513 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29514 NINCWO(2) = NINCWO(2)+1
29515 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29516 IB = IDRES(IDX)
29517 IC = IDXRES(IDX)
29518 IF (IC.GT.0) THEN
29519 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29520 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29521 ENDIF
29522 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29523 ENDIF
29524
29525 RETURN
29526 END
29527*$ CREATE DT_NEWHGR.FOR
29528*COPY DT_NEWHGR
29529*
29530*===newhgr=============================================================*
29531*
29532 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29533
29534************************************************************************
29535* *
29536* Histogram initialization. *
29537* *
29538* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29539* XLIM3 bin size *
29540* IBIN > 0 number of bins in equidistant lin. binning *
29541* = -1 reset histograms *
29542* < -1 |IBIN| number of bins in equidistant log. *
29543* binning or log. binning in user def. struc. *
29544* XLIMB(*) user defined bin structure *
29545* *
29546* The bin structure is sensitive to *
29547* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29548* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29549* XLIMB, IBIN if XLIM3 < 0 *
29550* *
29551* *
29552* output: IREFN histogram index *
29553* (= -1 for inconsistent histogr. request) *
29554* *
29555* This subroutine is based on a original version by R. Engel. *
29556* This version dated 22.4.95 is written by S. Roesler. *
29557************************************************************************
29558
29559 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29560 SAVE
29561
29562 PARAMETER ( LINP = 10 ,
29563 & LOUT = 6 ,
29564 & LDAT = 9 )
29565
29566 LOGICAL LSTART
29567
29568 PARAMETER (ZERO = 0.0D0,
29569 & TINY = 1.0D-10)
29570
29571 DIMENSION XLIMB(*)
29572
29573* histograms
29574
29575 PARAMETER (NHIS=150, NDIM=250)
29576
29577 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29578 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29579
29580* auxiliary common for histograms
29581 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29582
29583 DATA LSTART /.TRUE./
29584
29585* reset histogram counter
29586 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29587 IHISL = 0
29588 IF (IBIN.EQ.-1) RETURN
29589 LSTART = .FALSE.
29590 ENDIF
29591
29592 IHIS = IHISL+1
29593* check for maximum number of allowed histograms
29594 IF (IHIS.GT.NHIS) THEN
29595 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29596 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29597 & I4,') exceeds array size (',I4,')',/,21X,
29598 & 'histogram',I3,' skipped!')
29599 GOTO 9999
29600 ENDIF
29601
29602 IREFN = IHIS
29603 IBINS(IHIS) = ABS(IBIN)
29604* check requested number of bins
29605 IF (IBINS(IHIS).GE.NDIM) THEN
29606 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29607 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29608 & I3,') exceeds array size (',I3,')',/,21X,
29609 & 'and will be reset to ',I3)
29610 IBINS(IHIS) = NDIM
29611 ENDIF
29612 IF (IBINS(IHIS).EQ.0) THEN
29613 WRITE(LOUT,1001) IBIN,IHIS
29614 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29615 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29616 GOTO 9999
29617 ENDIF
29618
29619* initialize arrays
29620 DO 1 I=1,NDIM
29621 DO 2 K=1,3
29622 HIST(K,IHIS,I) = ZERO
29623 HIST(K+3,IHIS,I) = ZERO
29624 TMPHIS(K,IHIS,I) = ZERO
29625 2 CONTINUE
29626 HIST(7,IHIS,I) = ZERO
29627 1 CONTINUE
29628 DENTRY(1,IHIS)= ZERO
29629 DENTRY(2,IHIS)= ZERO
29630 OVERF(IHIS) = ZERO
29631 UNDERF(IHIS) = ZERO
29632 TMPUFL(IHIS) = ZERO
29633 TMPOFL(IHIS) = ZERO
29634
29635* bin str. sensitive to lower edge, bin size, and numb. of bins
29636 IF (XLIM3.GT.ZERO) THEN
29637 DO 3 K=1,IBINS(IHIS)+1
29638 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29639 3 CONTINUE
29640 ISWI(IHIS) = 1
29641* bin str. sensitive to lower/upper edge and numb. of bins
29642 ELSEIF (XLIM3.EQ.ZERO) THEN
29643* linear binning
29644 IF (IBIN.GT.0) THEN
29645 XLOW = XLIM1
29646 XHI = XLIM2
29647 IF (XLIM2.LE.XLIM1) THEN
29648 WRITE(LOUT,1002) XLIM1,XLIM2
29649 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29650 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29651 GOTO 9999
29652 ENDIF
29653 ISWI(IHIS) = 1
29654 ELSEIF (IBIN.LT.-1) THEN
29655* logarithmic binning
29656 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29657 WRITE(LOUT,1004) XLIM1,XLIM2
29658 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29659 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29660 GOTO 9999
29661 ENDIF
29662 IF (XLIM2.LE.XLIM1) THEN
29663 WRITE(LOUT,1005) XLIM1,XLIM2
29664 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29665 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29666 GOTO 9999
29667 ENDIF
29668 XLOW = LOG10(XLIM1)
29669 XHI = LOG10(XLIM2)
29670 ISWI(IHIS) = 3
29671 ENDIF
29672 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29673 DO 4 K=1,IBINS(IHIS)+1
29674 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29675 4 CONTINUE
29676 ELSE
29677* user defined bin structure
29678 DO 5 K=1,IBINS(IHIS)+1
29679 IF (IBIN.GT.0) THEN
29680 HIST(1,IHIS,K) = XLIMB(K)
29681 ISWI(IHIS) = 2
29682 ELSEIF (IBIN.LT.-1) THEN
29683 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29684 ISWI(IHIS) = 4
29685 ENDIF
29686 5 CONTINUE
29687 ENDIF
29688
29689* histogram accepted
29690 IHISL = IHIS
29691
29692 RETURN
29693
29694 9999 CONTINUE
29695 IREFN = -1
29696 RETURN
29697 END
29698
29699*$ CREATE DT_FILHGR.FOR
29700*COPY DT_FILHGR
29701*
29702*===filhgr=============================================================*
29703*
29704 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29705
29706************************************************************************
29707* *
29708* Scoring for histogram IHIS. *
29709* *
29710* This subroutine is based on a original version by R. Engel. *
29711* This version dated 23.4.95 is written by S. Roesler. *
29712************************************************************************
29713
29714 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29715 SAVE
29716
29717 PARAMETER ( LINP = 10 ,
29718 & LOUT = 6 ,
29719 & LDAT = 9 )
29720
29721 PARAMETER (ZERO = 0.0D0,
29722 & ONE = 1.0D0,
29723 & TINY = 1.0D-10)
29724
29725* histograms
29726
29727 PARAMETER (NHIS=150, NDIM=250)
29728
29729 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29730 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29731
29732* auxiliary common for histograms
29733 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29734
29735 DATA NCEVT /1/
29736
29737 X = XI
29738 Y = YI
29739
29740* dump content of temorary arrays into histograms
29741 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29742 CALL DT_EVTHIS(IDUM)
29743 NCEVT = NEVT
29744 ENDIF
29745
29746* check histogram index
29747 IF (IHIS.EQ.-1) RETURN
29748 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29749C WRITE(LOUT,1000) IHIS,IHISL
29750 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29751 & ' out of range (1..',I3,')')
29752 RETURN
29753 ENDIF
29754
29755 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29756* bin structure not explicitly given
29757 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29758 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29759 IF (X.LT.HIST(1,IHIS,1)) THEN
29760 I1 = 0
29761 ELSE
29762 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29763 ENDIF
29764
29765 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29766* user defined bin structure
29767 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29768 IF (X.LT.HIST(1,IHIS,1)) THEN
29769 I1 = 0
29770 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29771 I1 = IBINS(IHIS)+1
29772 ELSE
29773* binary sort algorithm
29774 KMIN = 0
29775 KMAX = IBINS(IHIS)+1
29776 1 CONTINUE
29777 IF ((KMAX-KMIN).EQ.1) GOTO 2
29778 KK = (KMAX+KMIN)/2
29779 IF (X.LE.HIST(1,IHIS,KK)) THEN
29780 KMAX=KK
29781 ELSE
29782 KMIN=KK
29783 ENDIF
29784 GOTO 1
29785 2 CONTINUE
29786 I1 = KMIN
29787 ENDIF
29788
29789 ELSE
29790 WRITE(LOUT,1001)
29791 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29792 RETURN
29793 ENDIF
29794
29795* scoring
29796 IF (I1.LE.0) THEN
29797 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29798 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29799 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29800 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29801 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29802 ELSE
29803 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29804 ENDIF
29805 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29806 ELSE
29807 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29808 ENDIF
29809
29810 RETURN
29811 END
29812
29813*$ CREATE DT_EVTHIS.FOR
29814*COPY DT_EVTHIS
29815*
29816*===evthis=============================================================*
29817*
29818 SUBROUTINE DT_EVTHIS(NEVT)
29819
29820************************************************************************
29821* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29822* is called after each event and for the last event before any call *
29823* to OUTHGR. *
29824* NEVT number of events dumped, this is only needed to *
29825* get the normalization after the last event *
29826* This version dated 23.4.95 is written by S. Roesler. *
29827************************************************************************
29828
29829 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29830 SAVE
29831
29832 PARAMETER ( LINP = 10 ,
29833 & LOUT = 6 ,
29834 & LDAT = 9 )
29835
29836 LOGICAL LNOETY
29837
29838 PARAMETER (ZERO = 0.0D0,
29839 & ONE = 1.0D0,
29840 & TINY = 1.0D-10)
29841
29842* histograms
29843
29844 PARAMETER (NHIS=150, NDIM=250)
29845
29846 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29847 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29848
29849* auxiliary common for histograms
29850 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29851
29852 DATA NCEVT /0/
29853
29854 NCEVT = NCEVT+1
29855 NEVT = NCEVT
29856
29857 DO 1 I=1,IHISL
29858 LNOETY = .TRUE.
29859 DO 2 J=1,IBINS(I)
29860 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29861 LNOETY = .FALSE.
29862 HIST(2,I,J) = HIST(2,I,J)+ONE
29863 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29864 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29865 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29866 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29867 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29868 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29869 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29870 TMPHIS(1,I,J) = ZERO
29871 TMPHIS(2,I,J) = ZERO
29872 TMPHIS(3,I,J) = ZERO
29873 ENDIF
29874 2 CONTINUE
29875 IF (LNOETY) THEN
29876 IF (TMPUFL(I).GT.ZERO) THEN
29877 UNDERF(I) = UNDERF(I)+ONE
29878 TMPUFL(I) = ZERO
29879 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29880 OVERF(I) = OVERF(I)+ONE
29881 TMPOFL(I) = ZERO
29882 ENDIF
29883 ELSE
29884 DENTRY(1,I) = DENTRY(1,I)+ONE
29885 ENDIF
29886 1 CONTINUE
29887
29888 RETURN
29889 END
29890
29891*$ CREATE DT_OUTHGR.FOR
29892*COPY DT_OUTHGR
29893*
29894*===outhgr=============================================================*
29895*
29896 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29897 & ILOGY,INORM,NMODE)
29898
29899************************************************************************
29900* *
29901* Plot histogram(s) to standard output unit *
29902* *
29903* I1..6 indices of histograms to be plotted *
29904* CHEAD,IHEAD header string,integer *
29905* NEVTS number of events *
29906* FAC scaling factor *
29907* ILOGY = 1 logarithmic y-axis *
29908* INORM normalization *
29909* = 0 no further normalization (FAC is obsolete) *
29910* = 1 per event and bin width *
29911* = 2 per entry and bin width *
29912* = 3 per bin entry *
29913* = 4 per event and "bin width" x1^2...x2^2 *
29914* = 5 per event and "log. bin width" ln x1..ln x2 *
29915* = 6 per event *
29916* MODE = 0 no output but normalization applied *
29917* = 1 all valid histograms separately (small frame) *
29918* all valid histograms separately (small frame) *
29919* = -1 and tables as histograms *
29920* = 2 all valid histograms (one plot, wide frame) *
29921* all valid histograms (one plot, wide frame) *
29922* = -2 and tables as histograms *
29923* *
29924* *
29925* Note: All histograms to be plotted with one call to this *
29926* subroutine and |MODE|=2 must have the same bin structure! *
29927* There is no test included ensuring this fact. *
29928* *
29929* This version dated 23.4.95 is written by S. Roesler. *
29930************************************************************************
29931
29932 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29933 SAVE
29934
29935 PARAMETER ( LINP = 10 ,
29936 & LOUT = 6 ,
29937 & LDAT = 9 )
29938
29939 CHARACTER*72 CHEAD
29940
29941 PARAMETER (ZERO = 0.0D0,
29942 & IZERO = 0,
29943 & ONE = 1.0D0,
29944 & TWO = 2.0D0,
29945 & OHALF = 0.5D0,
29946 & EPS = 1.0D-5,
29947 & TINY = 1.0D-8,
29948 & SMALL = -1.0D8,
29949 & RLARGE = 1.0D8 )
29950
29951* histograms
29952
29953 PARAMETER (NHIS=150, NDIM=250)
29954
29955 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29956 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29957
29958 PARAMETER (NDIM2 = 2*NDIM)
29959 DIMENSION XX(NDIM2),YY(NDIM2)
29960
29961 PARAMETER (NHISTO = 6)
29962 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29963 & IDX(NHISTO)
29964
29965 CHARACTER*43 CNORM(0:8)
29966 DATA CNORM /'no further normalization ',
29967 & 'per event and bin width ',
29968 & 'per entry1 and bin width ',
29969 & 'per bin entry ',
29970 & 'per event and "bin width" x1^2...x2^2 ',
29971 & 'per event and "log. bin width" ln x1..ln x2',
29972 & 'per event ',
29973 & 'per bin entry1 ',
29974 & 'per entry2 and bin width '/
29975
29976 IDX1(1) = I1
29977 IDX1(2) = I2
29978 IDX1(3) = I3
29979 IDX1(4) = I4
29980 IDX1(5) = I5
29981 IDX1(6) = I6
29982
29983 MODE = NMODE
29984
29985* initialization if "wide frame" is requested
29986 IF (ABS(MODE).EQ.2) THEN
29987 DO 1 I=1,NHISTO
29988 DO 2 J=1,NDIM
29989 XX1(J,I) = ZERO
29990 YY1(J,I) = ZERO
29991 2 CONTINUE
29992 1 CONTINUE
29993 ENDIF
29994
29995* plot header
29996 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29997
29998* check histogram indices
29999 NHI = 0
30000 DO 3 I=1,NHISTO
30001 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30002 IF (ISWI(IDX1(I)).NE.0) THEN
30003 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30004 WRITE(LOUT,1000)
30005 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30006 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30007 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30008 & ' overflows: ',F10.0)
30009 ELSE
30010 NHI = NHI+1
30011 IDX(NHI) = IDX1(I)
30012 ENDIF
30013 ENDIF
30014 ENDIF
30015 3 CONTINUE
30016 IF (NHI.EQ.0) THEN
30017 WRITE(LOUT,1001)
30018 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30019 RETURN
30020 ENDIF
30021
30022* check normalization request
30023 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30024 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30025 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30026 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30027 WRITE(LOUT,1002) NEVTS,INORM,FAC
30028 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30029 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30030 & 'FAC = ',E11.4)
30031 RETURN
30032 ENDIF
30033
30034 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30035
30036* apply normalization
30037 DO 4 N=1,NHI
30038
30039 I = IDX(N)
30040
30041 IF (ISWI(I).EQ.1) THEN
30042 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30043 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30044 & ' to',2X,E10.4,',',2X,I3,' bins')
30045 ELSEIF (ISWI(I).EQ.2) THEN
30046 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30047 WRITE(LOUT,1007)
30048 1007 FORMAT(1X,'user defined bin structure')
30049 ELSEIF (ISWI(I).EQ.3) THEN
30050 WRITE(LOUT,1004)
30051 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30052 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30053 & ' to',2X,E10.4,',',2X,I3,' bins')
30054 ELSEIF (ISWI(I).EQ.4) THEN
30055 WRITE(LOUT,1004)
30056 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30057 WRITE(LOUT,1007)
30058 ELSE
30059 WRITE(LOUT,1008) ISWI(I)
30060 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30061 ENDIF
30062 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30063 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30064 & ' overfl.:',F8.0)
30065 WRITE(LOUT,1009) CNORM(INORM)
30066 1009 FORMAT(1X,'normalization: ',A,/)
30067
30068 DO 5 K=1,IBINS(I)
30069 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30070 YMEAN = FAC*YMEAN
30071 YERR = FAC*YERR
30072 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30073 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30074 1006 FORMAT(1X,5E11.3)
30075* small frame
30076 II = 2*K
30077 XX(II-1) = HIST(1,I,K)
30078 XX(II) = HIST(1,I,K+1)
30079 YY(II-1) = YMEAN
30080 YY(II) = YMEAN
30081* wide frame
30082 XX1(K,N) = XMEAN
30083 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30084 & XX1(K,N) = LOG10(XMEAN)
30085 YY1(K,N) = YMEAN
30086 5 CONTINUE
30087
30088* plot small frame
30089 IF (ABS(MODE).EQ.1) THEN
30090 IBIN2 = 2*IBINS(I)
30091 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30092 IF(ILOGY.EQ.1) THEN
30093 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30094 ELSE
30095 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30096 ENDIF
30097 ENDIF
30098
30099 4 CONTINUE
30100
30101* plot wide frame
30102 IF (ABS(MODE).EQ.2) THEN
30103 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30104 NSIZE = NDIM*NHISTO
30105 DXLOW = HIST(1,IDX(1),1)
30106 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30107 YLOW = RLARGE
30108 YHI = SMALL
30109 DO 6 I=1,NHISTO
30110 DO 7 J=1,NDIM
30111 IF (YY1(J,I).LT.YLOW) THEN
30112 IF (ILOGY.EQ.1) THEN
30113 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30114 ELSE
30115 YLOW = YY1(J,I)
30116 ENDIF
30117 ENDIF
30118 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30119 7 CONTINUE
30120 6 CONTINUE
30121 DY = (YHI-YLOW)/DBLE(NDIM)
30122 IF (DY.LE.ZERO) THEN
30123 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30124 & 'OUTHGR: warning! zero bin width for histograms ',
30125 & IDX,': ',YLOW,YHI
30126 RETURN
30127 ENDIF
30128 IF (ILOGY.EQ.1) THEN
30129 YLOW = LOG10(YLOW)
30130 DY = (LOG10(YHI)-YLOW)/100.0D0
30131 DO 8 I=1,NHISTO
30132 DO 9 J=1,NDIM
30133 IF (YY1(J,I).LE.ZERO) THEN
30134 YY1(J,I) = YLOW
30135 ELSE
30136 YY1(J,I) = LOG10(YY1(J,I))
30137 ENDIF
30138 9 CONTINUE
30139 8 CONTINUE
30140 ENDIF
30141 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30142 ENDIF
30143
30144 RETURN
30145 END
30146
30147*$ CREATE DT_GETBIN.FOR
30148*COPY DT_GETBIN
30149*
30150*===getbin=============================================================*
30151*
30152 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30153 & XMEAN,YMEAN,YERR)
30154
30155************************************************************************
30156* This version dated 23.4.95 is written by S. Roesler. *
30157************************************************************************
30158
30159 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30160 SAVE
30161
30162 PARAMETER ( LINP = 10 ,
30163 & LOUT = 6 ,
30164 & LDAT = 9 )
30165
30166 PARAMETER (ZERO = 0.0D0,
30167 & ONE = 1.0D0,
30168 & TINY35 = 1.0D-35)
30169
30170* histograms
30171
30172 PARAMETER (NHIS=150, NDIM=250)
30173
30174 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30175 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30176
30177 XLOW = HIST(1,IHIS,IBIN)
30178 XHI = HIST(1,IHIS,IBIN+1)
30179 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30180 XLOW = 10**XLOW
30181 XHI = 10**XHI
30182 ENDIF
30183 IF (NORM.EQ.2) THEN
30184 DX = XHI-XLOW
30185 NEVT = INT(DENTRY(1,IHIS))
30186 ELSEIF (NORM.EQ.3) THEN
30187 DX = ONE
30188 NEVT = INT(HIST(2,IHIS,IBIN))
30189 ELSEIF (NORM.EQ.4) THEN
30190 DX = XHI**2-XLOW**2
30191 NEVT = KEVT
30192 ELSEIF (NORM.EQ.5) THEN
30193 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30194 NEVT = KEVT
30195 ELSEIF (NORM.EQ.6) THEN
30196 DX = ONE
30197 NEVT = KEVT
30198 ELSEIF (NORM.EQ.7) THEN
30199 DX = ONE
30200 NEVT = INT(HIST(7,IHIS,IBIN))
30201 ELSEIF (NORM.EQ.8) THEN
30202 DX = XHI-XLOW
30203 NEVT = INT(DENTRY(2,IHIS))
30204 ELSE
30205 DX = ABS(XHI-XLOW)
30206 NEVT = KEVT
30207 ENDIF
30208 IF (ABS(DX).LT.TINY35) DX = ONE
30209 NEVT = MAX(NEVT,1)
30210 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30211 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30212 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30213 YSUM = HIST(5,IHIS,IBIN)
30214 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30215C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30216 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30217 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30218
30219 RETURN
30220 END
30221
30222*$ CREATE DT_JOIHIS.FOR
30223*COPY DT_JOIHIS
30224*
30225*===joihis=============================================================*
30226*
30227 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30228
30229************************************************************************
30230* *
30231* Operation on histograms. *
30232* *
30233* input: IH1,IH2 histogram indices to be joined *
30234* COPER character defining the requested operation, *
30235* i.e. '+', '-', '*', '/' *
30236* FAC1,FAC2 factors for joining, i.e. *
30237* FAC1*histo1 COPER FAC2*histo2 *
30238* *
30239* This version dated 23.4.95 is written by S. Roesler. *
30240************************************************************************
30241
30242 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30243 SAVE
30244
30245 PARAMETER ( LINP = 10 ,
30246 & LOUT = 6 ,
30247 & LDAT = 9 )
30248
30249 CHARACTER COPER*1
30250
30251 PARAMETER (ZERO = 0.0D0,
30252 & ONE = 1.0D0,
30253 & OHALF = 0.5D0,
30254 & TINY8 = 1.0D-8,
30255 & SMALL = -1.0D8,
30256 & RLARGE = 1.0D8 )
30257
30258* histograms
30259
30260 PARAMETER (NHIS=150, NDIM=250)
30261
30262 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30263 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30264
30265 PARAMETER (NDIM2 = 2*NDIM)
30266 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30267
30268 CHARACTER*43 CNORM(0:6)
30269 DATA CNORM /'no further normalization ',
30270 & 'per event and bin width ',
30271 & 'per entry and bin width ',
30272 & 'per bin entry ',
30273 & 'per event and "bin width" x1^2...x2^2 ',
30274 & 'per event and "log. bin width" ln x1..ln x2',
30275 & 'per event '/
30276
30277* check histogram indices
30278 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30279 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30280 WRITE(LOUT,1000) IH1,IH2,IHISL
30281 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30282 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30283 GOTO 9999
30284 ENDIF
30285
30286* check bin structure of histograms to be joined
30287 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30288 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30289 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30290 & ' and ',I3,' failed',/,21X,
30291 & 'due to different numbers of bins (',I3,',',I3,')')
30292 GOTO 9999
30293 ENDIF
30294 DO 1 K=1,IBINS(IH1)+1
30295 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30296 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30297 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30298 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30299 & 'X1,X2 = ',2E11.4)
30300 GOTO 9999
30301 ENDIF
30302 1 CONTINUE
30303
30304 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30305 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30306 & 'operation ',A,/,11X,'and factors ',2E11.4)
30307 WRITE(LOUT,1004) CNORM(NORM)
30308 1004 FORMAT(1X,'normalization: ',A,/)
30309
30310 DO 2 K=1,IBINS(IH1)
30311 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30312 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30313 XLOW = XLOW1
30314 XHI = XHI1
30315 XMEAN = OHALF*(XMEAN1+XMEAN2)
30316 IF (COPER.EQ.'+') THEN
30317 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30318 ELSEIF (COPER.EQ.'*') THEN
30319 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30320 ELSEIF (COPER.EQ.'/') THEN
30321 IF (YMEAN2.EQ.ZERO) THEN
30322 YMEAN = ZERO
30323 ELSE
30324 IF (FAC2.EQ.ZERO) FAC2 = ONE
30325 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30326 ENDIF
30327 ELSE
30328 GOTO 9998
30329 ENDIF
30330 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30331 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30332 1006 FORMAT(1X,5E11.3)
30333* small frame
30334 II = 2*K
30335 XX(II-1) = HIST(1,IH1,K)
30336 XX(II) = HIST(1,IH1,K+1)
30337 YY(II-1) = YMEAN
30338 YY(II) = YMEAN
30339* wide frame
30340 XX1(K) = XMEAN
30341 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30342 YY1(K) = YMEAN
30343 2 CONTINUE
30344
30345* plot small frame
30346 IF (ABS(MODE).EQ.1) THEN
30347 IBIN2 = 2*IBINS(IH1)
30348 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30349 IF(ILOGY.EQ.1) THEN
30350 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30351 ELSE
30352 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30353 ENDIF
30354 ENDIF
30355
30356* plot wide frame
30357 IF (ABS(MODE).EQ.2) THEN
30358 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30359 NSIZE = NDIM
30360 DXLOW = HIST(1,IH1,1)
30361 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30362 YLOW = RLARGE
30363 YHI = SMALL
30364 DO 3 I=1,NDIM
30365 IF (YY1(I).LT.YLOW) THEN
30366 IF (ILOGY.EQ.1) THEN
30367 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30368 ELSE
30369 YLOW = YY1(I)
30370 ENDIF
30371 ENDIF
30372 IF (YY1(I).GT.YHI) YHI = YY1(I)
30373 3 CONTINUE
30374 DY = (YHI-YLOW)/DBLE(NDIM)
30375 IF (DY.LE.ZERO) THEN
30376 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30377 & 'JOIHIS: warning! zero bin width for histograms ',
30378 & IH1,IH2,': ',YLOW,YHI
30379 RETURN
30380 ENDIF
30381 IF (ILOGY.EQ.1) THEN
30382 YLOW = LOG10(YLOW)
30383 DY = (LOG10(YHI)-YLOW)/100.0D0
30384 DO 4 I=1,NDIM
30385 IF (YY1(I).LE.ZERO) THEN
30386 YY1(I) = YLOW
30387 ELSE
30388 YY1(I) = LOG10(YY1(I))
30389 ENDIF
30390 4 CONTINUE
30391 ENDIF
30392 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30393 ENDIF
30394
30395 RETURN
30396
30397 9998 CONTINUE
30398 WRITE(LOUT,1005) COPER
30399 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30400
30401 9999 CONTINUE
30402 RETURN
30403 END
30404
30405*$ CREATE DT_XGRAPH.FOR
30406*COPY DT_XGRAPH
30407*
30408*===qgraph=============================================================*
30409*
30410 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30411C***********************************************************************
30412C
30413C calculate quasi graphic picture with 25 lines and 79 columns
30414C ranges will be chosen automatically
30415C
30416C input N dimension of input fields
30417C IARG number of curves (fields) to plot
30418C X field of X
30419C Y1 field of Y1
30420C Y2 field of Y2
30421C
30422C This subroutine is written by R. Engel.
30423C***********************************************************************
30424 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30425 SAVE
30426
30427 PARAMETER ( LINP = 10 ,
30428 & LOUT = 6 ,
30429 & LDAT = 9 )
30430
30431C
30432 DIMENSION X(N),Y1(N),Y2(N)
30433 PARAMETER (EPS=1.D-30)
30434 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30435 CHARACTER SYMB(5)
30436 CHARACTER COL(0:149,0:49)
30437C
30438 DATA SYMB /'0','e','z','#','x'/
30439C
30440 ISPALT=IBREIT-10
30441C
30442C*** automatic range fitting
30443C
30444 XMAX=X(1)
30445 XMIN=X(1)
30446 DO 600 I=1,N
30447 XMAX=MAX(X(I),XMAX)
30448 XMIN=MIN(X(I),XMIN)
30449 600 CONTINUE
30450 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30451C
30452 ITEST=0
30453 DO 1100 K=0,IZEIL-1
30454 ITEST=ITEST+1
30455 IF (ITEST.EQ.IYRAST) THEN
30456 DO 1010 L=1,ISPALT-1
30457 COL(L,K)='-'
304581010 CONTINUE
30459 COL(ISPALT,K)='+'
30460 ITEST=0
30461 DO 1020 L=0,ISPALT-1,IXRAST
30462 COL(L,K)='+'
304631020 CONTINUE
30464 ELSE
30465 DO 1030 L=1,ISPALT-1
30466 COL(L,K)=' '
304671030 CONTINUE
30468 DO 1040 L=0,ISPALT-1,IXRAST
30469 COL(L,K)='|'
304701040 CONTINUE
30471 COL(ISPALT,K)='|'
30472 ENDIF
304731100 CONTINUE
30474C
30475C*** plot curve Y1
30476C
30477 YMAX=Y1(1)
30478 YMIN=Y1(1)
30479 DO 500 I=1,N
30480 YMAX=MAX(Y1(I),YMAX)
30481 YMIN=MIN(Y1(I),YMIN)
30482500 CONTINUE
30483 IF(IARG.GT.1) THEN
30484 DO 550 I=1,N
30485 YMAX=MAX(Y2(I),YMAX)
30486 YMIN=MIN(Y2(I),YMIN)
30487550 CONTINUE
30488 ENDIF
30489 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30490 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30491 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30492 IF(YZOOM.LT.EPS) THEN
30493 WRITE(LOUT,'(1X,A)')
30494 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30495 RETURN
30496 ENDIF
30497C
30498C*** plot curve Y1
30499C
30500 ILAST=-1
30501 LLAST=-1
30502 DO 1200 K=1,N
30503 L=NINT((X(K)-XMIN)/XZOOM)
30504 I=NINT((YMAX-Y1(K))/YZOOM)
30505 IF(ILAST.GE.0) THEN
30506 LD = L-LLAST
30507 ID = I-ILAST
30508 DO 55 II=0,LD,SIGN(1,LD)
30509 DO 66 KK=0,ID,SIGN(1,ID)
30510 COL(II+LLAST,KK+ILAST)=SYMB(1)
30511 66 CONTINUE
30512 55 CONTINUE
30513 ELSE
30514 COL(L,I)=SYMB(1)
30515 ENDIF
30516 ILAST = I
30517 LLAST = L
305181200 CONTINUE
30519C
30520 IF(IARG.GT.1) THEN
30521C
30522C*** plot curve Y2
30523C
30524 DO 1250 K=1,N
30525 L=NINT((X(K)-XMIN)/XZOOM)
30526 I=NINT((YMAX-Y2(K))/YZOOM)
30527 COL(L,I)=SYMB(2)
305281250 CONTINUE
30529 ENDIF
30530C
30531C*** write it
30532C
30533 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30534C
30535C*** write range of X
30536C
30537 XZOOM = (XMAX-XMIN)/DBLE(7)
30538 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30539C
30540 DO 1300 K=0,IZEIL-1
30541 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30542 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30543 110 FORMAT(1X,1PE9.2,70A1)
305441300 CONTINUE
30545C
30546C*** write range of X
30547C
30548 XZOOM = (XMAX-XMIN)/DBLE(7)
30549 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30550 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30551 120 FORMAT(6X,7(1PE10.3))
30552 END
30553
30554*$ CREATE DT_XGLOGY.FOR
30555*COPY DT_XGLOGY
30556*
30557*===qglogy=============================================================*
30558*
30559 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30560C***********************************************************************
30561C
30562C calculate quasi graphic picture with 25 lines and 79 columns
30563C logarithmic y axis
30564C ranges will be chosen automatically
30565C
30566C input N dimension of input fields
30567C IARG number of curves (fields) to plot
30568C X field of X
30569C Y1 field of Y1
30570C Y2 field of Y2
30571C
30572C This subroutine is written by R. Engel.
30573C***********************************************************************
30574C
30575 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30576 SAVE
30577
30578 PARAMETER ( LINP = 10 ,
30579 & LOUT = 6 ,
30580 & LDAT = 9 )
30581
30582 DIMENSION X(N),Y1(N),Y2(N)
30583 PARAMETER (EPS=1.D-30)
30584 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30585 CHARACTER SYMB(5)
30586 CHARACTER COL(0:149,0:49)
30587 PARAMETER (DEPS = 1.D-10)
30588C
30589 DATA SYMB /'0','e','z','#','x'/
30590C
30591 ISPALT=IBREIT-10
30592C
30593C*** automatic range fitting
30594C
30595 XMAX=X(1)
30596 XMIN=X(1)
30597 DO 600 I=1,N
30598 XMAX=MAX(X(I),XMAX)
30599 XMIN=MIN(X(I),XMIN)
30600 600 CONTINUE
30601 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30602C
30603 ITEST=0
30604 DO 1100 K=0,IZEIL-1
30605 ITEST=ITEST+1
30606 IF (ITEST.EQ.IYRAST) THEN
30607 DO 1010 L=1,ISPALT-1
30608 COL(L,K)='-'
306091010 CONTINUE
30610 COL(ISPALT,K)='+'
30611 ITEST=0
30612 DO 1020 L=0,ISPALT-1,IXRAST
30613 COL(L,K)='+'
306141020 CONTINUE
30615 ELSE
30616 DO 1030 L=1,ISPALT-1
30617 COL(L,K)=' '
306181030 CONTINUE
30619 DO 1040 L=0,ISPALT-1,IXRAST
30620 COL(L,K)='|'
306211040 CONTINUE
30622 COL(ISPALT,K)='|'
30623 ENDIF
306241100 CONTINUE
30625C
30626C*** plot curve Y1
30627C
30628 YMAX=Y1(1)
30629 YMIN=MAX(Y1(1),EPS)
30630 DO 500 I=1,N
30631 YMAX =MAX(Y1(I),YMAX)
30632 IF(Y1(I).GT.EPS) THEN
30633 IF(YMIN.EQ.EPS) THEN
30634 YMIN = Y1(I)/10.D0
30635 ELSE
30636 YMIN = MIN(Y1(I),YMIN)
30637 ENDIF
30638 ENDIF
30639500 CONTINUE
30640 IF(IARG.GT.1) THEN
30641 DO 550 I=1,N
30642 YMAX=MAX(Y2(I),YMAX)
30643 IF(Y2(I).GT.EPS) THEN
30644 IF(YMIN.EQ.EPS) THEN
30645 YMIN = Y2(I)
30646 ELSE
30647 YMIN = MIN(Y2(I),YMIN)
30648 ENDIF
30649 ENDIF
30650550 CONTINUE
30651 ENDIF
30652C
30653 DO 560 I=1,N
30654 Y1(I) = MAX(Y1(I),YMIN)
30655 560 CONTINUE
30656 IF(IARG.GT.1) THEN
30657 DO 570 I=1,N
30658 Y2(I) = MAX(Y2(I),YMIN)
30659 570 CONTINUE
30660 ENDIF
30661C
30662 IF(YMAX.LE.YMIN) THEN
30663 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30664 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30665 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30666 RETURN
30667 ENDIF
30668C
30669 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30670 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30671 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30672 IF(YZOOM.LT.EPS) THEN
30673 WRITE(LOUT,'(1X,A)')
30674 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30675 RETURN
30676 ENDIF
30677C
30678C*** plot curve Y1
30679C
30680 ILAST=-1
30681 LLAST=-1
30682 DO 1200 K=1,N
30683 L=NINT((X(K)-XMIN)/XZOOM)
30684 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30685 IF(ILAST.GE.0) THEN
30686 LD = L-LLAST
30687 ID = I-ILAST
30688 DO 55 II=0,LD,SIGN(1,LD)
30689 DO 66 KK=0,ID,SIGN(1,ID)
30690 COL(II+LLAST,KK+ILAST)=SYMB(1)
30691 66 CONTINUE
30692 55 CONTINUE
30693 ELSE
30694 COL(L,I)=SYMB(1)
30695 ENDIF
30696 ILAST = I
30697 LLAST = L
306981200 CONTINUE
30699C
30700 IF(IARG.GT.1) THEN
30701C
30702C*** plot curve Y2
30703C
30704 DO 1250 K=1,N
30705 L=NINT((X(K)-XMIN)/XZOOM)
30706 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30707 COL(L,I)=SYMB(2)
307081250 CONTINUE
30709 ENDIF
30710C
30711C*** write it
30712C
30713 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30714 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30715C
30716C*** write range of X
30717C
30718 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30719 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30720C
30721 DO 1300 K=0,IZEIL-1
30722 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30723 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30724 110 FORMAT(1X,1PE9.2,70A1)
307251300 CONTINUE
30726C
30727C*** write range of X
30728C
30729 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30730 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30731 120 FORMAT(6X,7(1PE10.3))
30732C
30733 END
30734
30735*$ CREATE DT_SRPLOT.FOR
30736*COPY DT_SRPLOT
30737*
30738*===plot===============================================================*
30739*
30740 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30741
30742 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30743 SAVE
30744
30745 PARAMETER ( LINP = 10 ,
30746 & LOUT = 6 ,
30747 & LDAT = 9 )
30748
30749*
30750* initial version
30751* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30752* This is a subroutine of fluka to plot Y across the page
30753* as a function of X down the page. Up to 37 curves can be
30754* plotted in the same picture with different plotting characters.
30755* Output of first 10 overprinted characters addad by FB 88
30756* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30757*
30758* Input Variables:
30759* X = array containing the values of X
30760* Y = array containing the values of Y
30761* N = number of values in X and in Y
30762* can exceed the fixed number of lines
30763* M = number of different curves X,Y are containing
30764* MM = number of points in each curve i.e. N=M*MM
30765* XO = smallest value of X to be plotted
30766* DX = increment of X between subsequent lines
30767* YO = smallest value of Y to be plotted
30768* DY = increment of Y between subsequent character spaces
30769*
30770* other variables used inside:
30771* XX = numbers along the X-coordinate axis
30772* YY = numbers along the Y-coordinate axis
30773* LL = ten lines temporary storage for the plot
30774* L = character set used to plot different curves
30775* LOV = memorizes overprinted symbols
30776* the first 10 overprinted symbols are printed on
30777* the end of the line to avoid ambiguities
30778* (added by FB as considered quite helpful)
30779*
30780*********************************************************************
30781*
30782 DIMENSION XX(61),YY(61),LL(101,10)
30783 DIMENSION X(N),Y(N),L(40),LOV(40,10)
004932dd 30784 INTEGER*4 LL, L, LOV
7b076c76 30785 DATA L/
30786 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30787 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30788 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30789 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30790*
30791*
30792 MN=51
30793 DO 10 I=1,MN
30794 AI=I-1
30795 10 XX(I)=XO+AI*DX
30796 DO 20 I=1,11
30797 AI=I-1
30798 20 YY(I)=YO+10.0D0*AI*DY
30799 WRITE(LOUT, 500) (YY(I),I=1,11)
30800 MMN=MN-1
30801*
30802*
30803 DO 90 JJ=1,MMN,10
30804 JJJ=JJ-1
30805 DO 30 I=1,101
30806 DO 30 J=1,10
30807 30 LL(I,J)=L(40)
30808 DO 40 I=1,101
30809 40 LL(I,1)=L(39)
30810 DO 50 I=1,101,10
30811 DO 50 J=1,10
30812 50 LL(I,J)=L(38)
30813 DO 60 I=1,40
30814 DO 60 J=1,10
30815 60 LOV(I,J)=L(40)
30816*
30817*
30818 DO 70 I=1,M
30819 DO 70 J=1,MM
30820 II=J+(I-1)*MM
30821 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30822 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30823 AIX=AIX-DBLE(JJJ)
30824* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30825 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30826 + . AIY .LT. 102.D0) THEN
30827 IX=INT(AIX)
30828 IY=INT(AIY)
30829 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30830 + THEN
30831 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30832 + =LL(IY,IX)
30833 LL(IY,IX)=L(I)
30834 ENDIF
30835 ENDIF
30836 70 CONTINUE
30837*
30838*
30839 DO 80 I=1,10
30840 II=I+JJJ
30841 III=II+1
30842 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30843 & (LOV(J,I),J=1,10)
30844 80 CONTINUE
30845 90 CONTINUE
30846*
30847*
30848 WRITE(LOUT, 520)
30849 WRITE(LOUT, 500) (YY(I),I=1,11)
30850 RETURN
30851*
30852 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30853 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30854 520 FORMAT(20X,10('1---------'),'1')
30855 END
30856*$ CREATE DT_DEFSET.FOR
30857*COPY DT_DEFSET
30858*
30859*===defset=============================================================*
30860*
30861 BLOCK DATA DT_DEFSET
30862
30863 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30864 SAVE
30865
30866* flags for input different options
30867 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30868 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30869 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30870
30871 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30872
30873* emulsion treatment
30874 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30875 & NCOMPO,IEMUL
30876
30877* / DTFLG1 /
30878 DATA IFRAG / 2, 1 /
30879 DATA IRESCO / 1 /
30880 DATA IMSHL / 1 /
30881 DATA IRESRJ / 0 /
30882 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30883 DATA LEMCCK / .FALSE. /
30884 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30885 & .TRUE.,.TRUE.,.TRUE./
30886 DATA LSEADI / .TRUE. /
30887 DATA LEVAPO / .TRUE. /
30888 DATA IFRAME / 1 /
30889 DATA ITRSPT / 0 /
30890
30891* / DTCOMP /
30892 DATA EMUFRA / NCOMPX*0.0D0 /
30893 DATA IEMUMA / NCOMPX*1 /
30894 DATA IEMUCH / NCOMPX*1 /
30895 DATA NCOMPO / 0 /
30896 DATA IEMUL / 0 /
30897
30898 END
30899
30900*$ CREATE DT_HADPRP.FOR
30901*COPY DT_HADPRP
30902*
30903*===hadprp=============================================================*
30904*
30905 BLOCK DATA DT_HADPRP
30906
30907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30908 SAVE
30909
30910* auxiliary common for reggeon exchange (DTUNUC 1.x)
30911 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30912 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30913 & IQTCHR(-6:6),MQUARK(3,39)
30914
30915* hadron index conversion (BAMJET <--> PDG)
30916 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30917 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30918 & IAMCIN(210)
30919
30920* names of hadrons used in input-cards
30921 CHARACTER*8 BTYPE
30922 COMMON /DTPAIN/ BTYPE(30)
30923
30924* / DTQUAR /
30925*----------------------------------------------------------------------*
30926* *
30927* Quark content of particles: *
30928* index quark el. charge bar. charge isospin isospin3 *
30929* 1 = u 2/3 1/3 1/2 1/2 *
30930* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30931* 2 = d -1/3 1/3 1/2 -1/2 *
30932* -2 = dbar 1/3 -1/3 1/2 1/2 *
30933* 3 = s -1/3 1/3 0 0 *
30934* -3 = sbar 1/3 -1/3 0 0 *
30935* 4 = c 2/3 1/3 0 0 *
30936* -4 = cbar -2/3 -1/3 0 0 *
30937* 5 = b -1/3 1/3 0 0 *
30938* -5 = bbar 1/3 -1/3 0 0 *
30939* 6 = t 2/3 1/3 0 0 *
30940* -6 = tbar -2/3 -1/3 0 0 *
30941* *
30942* Mquark = particle quark composition (Paprop numbering) *
30943* Iqechr = electric charge ( in 1/3 unit ) *
30944* Iqbchr = baryonic charge ( in 1/3 unit ) *
30945* Iqichr = isospin ( in 1/2 unit ), z component *
30946* Iqschr = strangeness *
30947* Iqcchr = charm *
30948* Iquchr = beauty *
30949* Iqtchr = ...... *
30950* *
30951*----------------------------------------------------------------------*
30952 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30953 DATA IQBCHR / 6*-1, 0, 6*1 /
30954 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30955 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30956 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30957 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30958 DATA IQTCHR / -1, 11*0, 1 /
30959 DATA MQUARK /
30960 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30961 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30962 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30963 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30964 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30965 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30966 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30967 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30968
30969* / DTHAIC /
30970* (renamed) (HAdron InDex COnversion)
30971* translation table version filled up by r.e. 25.01.94 *
30972 DATA IAMCIN /
30973 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30974 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30975 &3222,3212,111,311,-311, 0,0,0,0,0,
30976 &221,213,113,-213,223, 323,313,-323,-313,10323,
30977 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30978 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30979 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30980 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30981 &5*99999, 5*99999,
30982 &4*99999,331, 333,3322,3312,-3222,-3212,
30983 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30984 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30985 &-431,441,423,413,-413, -423,433,-433,20443,443,
30986 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30987 &4212,4112,3*99999, 3*99999,-4122,-4232,
30988 &-4132,-4222,-4212,-4112,99999, 5*99999,
30989 &5*99999, 5*99999,
30990 &10*99999,
30991 &5*99999 , 20211,20111,-20211,99999,20321,
30992 &-20321,20311,-20311,7*99999 ,
30993 &7*99999,12212,12112,99999/
30994
30995* / DTHAIC /
30996* (HAdron InDex COnversion)
30997 DATA (IPDG2(1,K),K=1,7)
30998 & / -11, -12, -13, -15, -16, -14, 0/
30999 DATA (IBAM2(1,K),K=1,7)
31000 & / 4, 6, 10, 131, 134, 136, 0/
31001 DATA (IPDG2(2,K),K=1,7)
31002 & / 11, 12, 22, 13, 15, 16, 14/
31003 DATA (IBAM2(2,K),K=1,7)
31004 & / 3, 5, 7, 11, 132, 133, 135/
31005 DATA (IPDG3(1,K),K=1,22)
31006 & / -211, -321, -311, -213, -323, -313, -411, -421,
31007 & -431, -413, -423, -433, 0, 0, 0, 0,
31008 & 0, 0, 0, 0, 0, 0/
31009 DATA (IBAM3(1,K),K=1,22)
31010 & / 14, 16, 25, 34, 38, 39, 118, 119,
31011 & 121, 125, 126, 128, 0, 0, 0, 0,
31012 & 0, 0, 0, 0, 0, 0/
31013 DATA (IPDG3(2,K),K=1,22)
31014 & / 130, 211, 321, 310, 111, 311, 221, 213,
31015 & 113, 223, 323, 313, 331, 333, 421, 411,
31016 & 431, 441, 423, 413, 433, 443/
31017 DATA (IBAM3(2,K),K=1,22)
31018 & / 12, 13, 15, 19, 23, 24, 31, 32,
31019 & 33, 35, 36, 37, 95, 96, 116, 117,
31020 & 120, 122, 123, 124, 127, 130/
31021 DATA (IPDG4(1,K),K=1,29)
31022 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31023 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31024 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31025 & -4212, -4112, 0, 0, 0/
31026 DATA (IBAM4(1,K),K=1,29)
31027 & / 2, 9, 18, 67, 68, 69, 70, 75,
31028 & 76, 99, 100, 101, 102, 103, 110, 111,
31029 & 112, 113, 114, 115, 149, 150, 151, 152,
31030 & 153, 154, 0, 0, 0/
31031 DATA (IPDG4(2,K),K=1,29)
31032 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31033 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31034 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31035 & 4232, 4132, 4222, 4212, 4112/
31036 DATA (IBAM4(2,K),K=1,29)
31037 & / 1, 8, 17, 20, 21, 22, 48, 49,
31038 & 50, 51, 52, 53, 54, 55, 56, 97,
31039 & 98, 104, 105, 106, 107, 108, 109, 137,
31040 & 138, 139, 140, 141, 142/
31041 DATA (IPDG5(1,K),K=1,19)
31042 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31043 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31044 & 0, 0, 0/
31045 DATA (IBAM5(1,K),K=1,19)
31046 & / 42, 43, 46, 47, 71, 72, 73, 74,
31047 & 188, 191, 193, 0, 0, 0, 0, 0,
31048 & 0, 0, 0/
31049 DATA (IPDG5(2,K),K=1,19)
31050 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31051 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31052 & 20311, 12212, 12112/
31053 DATA (IBAM5(2,K),K=1,19)
31054 & / 40, 41, 44, 45, 57, 58, 59, 60,
31055 & 63, 64, 65, 66, 129, 186, 187, 190,
31056 & 192, 208, 209/
31057
31058* / DTPAIN /
31059* internal particle names
31060 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31061 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31062 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31063 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31064 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31065 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31066 &'BLANK ' /
31067
31068 END
31069
31070*$ CREATE DT_BLKD46.FOR
31071*COPY DT_BLKD46
31072*
31073*===blkd46=============================================================*
31074*
31075 BLOCK DATA DT_BLKD46
31076
31077 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31078 SAVE
31079
31080 PARAMETER ( AMELCT = 0.51099906 D-03 )
31081 PARAMETER ( AMMUON = 0.105658389 D+00 )
31082
31083* particle properties (BAMJET index convention)
31084 CHARACTER*8 ANAME
31085 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31086 & IICH(210),IIBAR(210),K1(210),K2(210)
31087
31088* / DTPART /
31089* Particle masses Engel version JETSET compatible
31090C DATA (AAM(K),K=1,85) /
31091C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31092C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31093C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31094C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31095C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31096C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31097C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31098C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31099C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31100C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31101C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31102C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31103C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31104C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31105C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31106C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31107C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31108C DATA (AAM(K),K=86,183) /
31109C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31110C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31111C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31112C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31113C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31114C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31115C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31116C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31117C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31118C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31119C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31120C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31121C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31122C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31123C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31124C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31125C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31126C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31127C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31128C & .1250D+01, .1250D+01, .1250D+01 /
31129C DATA (AAM ( I ), I = 184,210 ) /
31130C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31131C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31132C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31133C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31134C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31135C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31136C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31137C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31138C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31139* sr 25.1.06: particle masses adjusted to Pythia
31140 DATA (AAM(K),K=1,85) /
31141 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31142 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31143 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31144 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31145 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31146 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31147 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31148 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31149 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31150 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31151 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31152 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31153 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31154 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31155 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31156 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31157 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31158 DATA (AAM(K),K=86,183) /
31159 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31160 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31161 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31162 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31163 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31164 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31165 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31166 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31167 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31168 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31169 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31170 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31171 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31172 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31173 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31174 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31175 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31176 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31177 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31178 & .1250D+01, .1250D+01, .1250D+01 /
31179 DATA (AAM ( I ), I = 184,210 ) /
31180 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31181 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31182 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31183 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31184 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31185 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31186 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31187 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31188 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31189* Particle mean lives
31190 DATA (TAU(K),K=1,183) /
31191 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31192 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31193 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31194 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31195 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31196 & 70*.0000D+00,
31197 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31198 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31199 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31200 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31201 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31202 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31203 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31204 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31205 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31206 & 40*.0000D+00,
31207 & .0000D+00, .0000D+00, .0000D+00 /
31208 DATA ( TAU ( I ), I = 184,210 ) /
31209 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31210 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31211 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31212 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31213 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31214 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31215 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31216 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31217 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31218* Resonance width Gamma in GeV
31219 DATA (GA(K),K= 1,85) /
31220 & 30*.0000D+00,
31221 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31222 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31223 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31224 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31225 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31226 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31227 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31228 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31229 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31230 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31231 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31232 DATA (GA(K),K= 86,183) /
31233 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31234 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31235 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31236 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31237 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31238 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31239 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31240 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31241 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31242 & 50*.0000D+00,
31243 & .3000D+00, .3000D+00, .3000D+00 /
31244 DATA ( GA ( I ), I = 184,210 ) /
31245 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31246 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31247 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31248 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31249 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31250 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31251 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31252 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31253 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31254* Particle names
31255* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31256* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31257* designation N*@@ means N*@1(@2)
31258 DATA (ANAME(K),K=1,85) /
31259 & 'P ','AP ','E- ','E+ ','NUE ',
31260 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31261 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31262 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31263 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31264 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31265 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31266 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31267 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31268 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31269 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31270 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31271 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31272 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31273 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31274 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31275 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31276 DATA (ANAME(K),K=86,183) /
31277 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31278 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31279 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31280 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31281 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31282 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31283 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31284 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31285 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31286 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31287 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31288 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31289 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31290 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31291 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31292 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31293 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31294 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31295 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31296 & 'RO ','R+ ','R- ' /
31297 DATA ( ANAME ( I ), I = 184,210 ) /
31298 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31299 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31300 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31301 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31302 &'N*+14 ','N*014 ','BLANK '/
31303* Charge of particles and resonances
31304 DATA (IICH ( I ), I = 1,210 ) /
31305 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31306 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31307 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31308 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31309 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31310 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31311 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31312 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31313 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31314 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31315 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31316 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31317 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31318 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31319* Particle baryonic charges
31320 DATA (IIBAR ( I ), I = 1,210 ) /
31321 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31322 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31323 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31324 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31325 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31326 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31327 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31328 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31329 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31330 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31331 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31332 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31333 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31334 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31335* First number of decay channels used for resonances
31336* and decaying particles
31337 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31338 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31339 & 2*330, 46, 51, 52, 54, 55, 58,
31340* 50
31341 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31342 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31343 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31344* 85
31345 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31346 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31347 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31348 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31349 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31350 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31351 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31352 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31353 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31354 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31355 & 590, 596, 602 /
31356* Last number of decay channels used for resonances
31357* and decaying particles
31358 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31359 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31360 & 2* 330, 50, 51, 53, 54, 57,
31361* 50
31362 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31363 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31364 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31365* 85
31366 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31367 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31368 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31369 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31370 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31371 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31372 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31373 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31374 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31375 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31376 & 589, 595, 601, 602 /
31377
31378 END
31379
31380*$ CREATE DT_BLKD47.FOR
31381*COPY DT_BLKD47
31382*
31383*===blkd47=============================================================*
31384*
31385 BLOCK DATA DT_BLKD47
31386
31387 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31388 SAVE
31389
31390* HADRIN: decay channel information
31391 PARAMETER (IDMAX9=602)
31392 CHARACTER*8 ZKNAME
31393 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31394
31395* Name of decay channel
31396* Designation N*@ means N*@1(1236)
31397* @1=# means ++, @1 = = means --
31398* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31399 DATA (ZKNAME(K),K= 1, 85) /
31400 & 'P ','AP ','E- ','E+ ','NUE ',
31401 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31402 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31403 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31404 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31405 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31406 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31407 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31408 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31409 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31410 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31411 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31412 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31413 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31414 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31415 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31416 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31417 DATA (ZKNAME(K),K= 86,170) /
31418 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31419 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31420 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31421 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31422 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31423 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31424 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31425 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31426 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31427 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31428 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31429 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31430 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31431 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31432 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31433 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31434 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31435 DATA (ZKNAME(K),K=171,255) /
31436 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31437 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31438 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31439 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31440 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31441 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31442 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31443 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31444 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31445 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31446 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31447 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31448 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31449 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31450 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31451 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31452 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31453 DATA (ZKNAME(K),K=256,340) /
31454 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31455 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31456 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31457 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31458 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31459 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31460 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31461 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31462 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31463 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31464 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31465 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31466 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31467 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31468 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31469 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31470 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31471 DATA (ZKNAME(K),K=341,425) /
31472 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31473 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31474 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31475 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31476 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31477 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31478 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31479 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31480 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31481 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31482 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31483 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31484 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31485 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31486 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31487 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31488 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31489 DATA (ZKNAME(K),K=426,510) /
31490 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31491 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31492 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31493 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31494 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31495 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31496 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31497 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31498 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31499 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31500 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31501 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31502 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31503 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31504 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31505 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31506 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31507 DATA (ZKNAME(K),K=511,540) /
31508 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31509 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31510 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31511 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31512 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31513 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31514 DATA (ZKNAME(I),I=541,602)/
31515 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31516 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31517 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31518 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31519 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31520 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31521 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31522 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31523 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31524* Weight of decay channel
31525 DATA (WT(K),K= 1, 85) /
31526 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31527 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31528 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31529 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31530 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31531 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31532 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31533 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31534 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31535 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31536 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31537 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31538 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31539 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31540 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31541 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31542 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31543 DATA (WT(K),K= 86,170) /
31544 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31545 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31546 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31547 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31548 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31549 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31550 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31551 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31552 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31553 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31554 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31555 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31556 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31557 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31558 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31559 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31560 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31561 DATA (WT(K),K=171,255) /
31562 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31563 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31564 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31565 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31566 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31567 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31568 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31569 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31570 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31571 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31572 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31573 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31574 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31575 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31576 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31577 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31578 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31579 DATA (WT(K),K=256,340) /
31580 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31581 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31582 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31583 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31584 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31585 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31586 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31587 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31588 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31589 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31590 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31591 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31592 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31593 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31594 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31596 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31597 DATA (WT(K),K=341,425) /
31598 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31599 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31600 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31601 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31602 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31603 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31604 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31605 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31606 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31607 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31608 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31609 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31610 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31611 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31612 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31613 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31614 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31615 DATA (WT(K),K=426,510) /
31616 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31617 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31618 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31619 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31620 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31621 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31622 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31624 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31625 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31626 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31627 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31628 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31629 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31630 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31631 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31632 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31633 DATA (WT(K),K=511,540) /
31634 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31635 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31636 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31637 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31638 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31639 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31640C
31641 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31642 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31643 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31644 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31645 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31646 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31647 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31648* Particle numbers in decay channel
31649 DATA (NZK(K,1),K= 1,170) /
31650 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31651 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31652 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31653 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31654 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31655 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31656 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31657 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31658 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31659 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31660 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31661 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31662 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31663 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31664 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31665 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31666 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31667 DATA (NZK(K,1),K=171,340) /
31668 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31669 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31670 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31671 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31672 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31673 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31674 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31675 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31676 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31677 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31678 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31679 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31680 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31681 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31682 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31683 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31684 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31685 DATA (NZK(K,1),K=341,510) /
31686 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31687 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31688 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31689 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31690 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31691 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31692 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31693 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31694 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31695 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31696 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31697 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31698 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31699 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31700 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31701 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31702 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31703 DATA (NZK(K,1),K=511,540) /
31704 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31705 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31706 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31707 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31708 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31709 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31710 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31711 & 55, 8, 1, 8, 8, 54, 55, 210/
31712 DATA (NZK(K,2),K= 1,170) /
31713 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31714 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31715 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31716 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31717 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31718 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31719 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31720 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31721 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31722 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31723 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31724 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31725 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31726 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31727 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31728 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31729 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31730 DATA (NZK(K,2),K=171,340) /
31731 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31732 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31733 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31734 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31735 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31736 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31737 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31738 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31739 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31740 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31741 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31742 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31743 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31744 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31745 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31746 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31747 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31748 DATA (NZK(K,2),K=341,510) /
31749 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31750 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31751 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31752 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31753 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31754 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31755 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31756 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31757 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31758 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31759 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31760 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31761 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31762 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31763 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31764 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31765 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31766 DATA (NZK(K,2),K=511,540) /
31767 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31768 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31769 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31770 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31771 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31772 & 14, 14, 23, 14, 16, 25,
31773 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31774 & 23, 13, 14, 23, 0 /
31775 DATA (NZK(K,3),K= 1,170) /
31776 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31777 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31778 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31779 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31780 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31781 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31782 & 110*0 /
31783 DATA (NZK(K,3),K=171,340) /
31784 & 80*0,
31785 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31786 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31787 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31788 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31789 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31790 & 30*0,
31791 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31792 DATA (NZK(K,3),K=341,510) /
31793 & 30*0,
31794 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31795 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31796 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31797 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31798 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31799 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31800 & 80*0 /
31801 DATA (NZK(K,3),K=511,540) /
31802 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31803 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31804 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31805 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31806 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31807
31808 END
31809
31810*$ CREATE DT_XHOINI.FOR
31811*COPY DT_XHOINI
31812*
31813*====phoini============================================================*
31814*
31815 SUBROUTINE DT_XHOINI
31816C SUBROUTINE DT_PHOINI
31817
31818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31819 SAVE
31820
31821 PARAMETER ( LINP = 10 ,
31822 & LOUT = 6 ,
31823 & LDAT = 9 )
31824
31825 RETURN
31826 END
31827
31828*$ CREATE DT_XVENTB.FOR
31829*COPY DT_XVENTB
31830*
31831*====eventb============================================================*
31832*
31833 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31834C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31835
31836 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31837 SAVE
31838
31839 PARAMETER ( LINP = 10 ,
31840 & LOUT = 6 ,
31841 & LDAT = 9 )
31842
31843 WRITE(LOUT,1000)
31844 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31845 STOP
31846
31847 END
31848
31849*$ CREATE DT_XVENT.FOR
31850*COPY DT_XVENT
31851*
31852*===event==============================================================*
31853*
31854 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31855C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31856
31857 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31858 SAVE
31859
31860 DIMENSION PP(4),PT(4)
31861
31862 RETURN
31863 END
31864
31865*$ CREATE DT_XOHISX.FOR
31866*COPY DT_XOHISX
31867*
31868*===pohisx=============================================================*
31869*
31870 SUBROUTINE DT_XOHISX(I,X)
31871C SUBROUTINE POHISX(I,X)
31872
31873 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31874 SAVE
31875
31876 RETURN
31877 END
31878
31879*$ CREATE PHO_LHIST.FOR
31880*COPY PHO_LHIST
31881*
31882*===poluhi=============================================================*
31883*
31884 SUBROUTINE PHO_LHIST(I,X)
31885
31886**
31887
31888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31889 SAVE
31890
31891 RETURN
31892 END
31893
31894*$ CREATE PDFSET.FOR
31895*COPY PDFSET
31896*
31897C**********************************************************************
31898C
31899C dummy subroutines, remove to link PDFLIB
31900C
31901C**********************************************************************
31902 SUBROUTINE PDFSET(PARAM,VALUE)
31903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31904 DIMENSION PARAM(20),VALUE(20)
31905 CHARACTER*20 PARAM
31906 END
31907
31908*$ CREATE STRUCTM.FOR
31909*COPY STRUCTM
31910*
31911 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31913 END
31914
31915*$ CREATE STRUCTP.FOR
31916*COPY STRUCTP
31917*
31918 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31920 END
31921
31922*$ CREATE DT_DIQBRK.FOR
31923*COPY DT_DIQBRK
31924*
31925*===diqbrk=============================================================*
31926*
31927 SUBROUTINE DT_XIQBRK
31928C SUBROUTINE DT_DIQBRK
31929
31930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31931 SAVE
31932
31933 STOP 'diquark-breaking not implemeted !'
31934
31935 RETURN
31936 END
31937*$ CREATE DT_ELHAIN.FOR
31938*COPY DT_ELHAIN
31939*
31940*===elhain=============================================================*
31941*
31942 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31943
31944************************************************************************
31945* Elastic hadron-hadron scattering. *
31946* This is a revised version of the original. *
31947* This version dated 03.04.98 is written by S. Roesler *
31948************************************************************************
31949
31950 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31951 SAVE
31952
31953 PARAMETER ( LINP = 10 ,
31954 & LOUT = 6 ,
31955 & LDAT = 9 )
31956
31957 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31958 & TINY10=1.0D-10)
31959
31960 PARAMETER (ENNTHR = 3.5D0)
31961 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31962 & BLOWB=0.05D0,BHIB=0.2D0,
31963 & BLOWM=0.1D0, BHIM=2.0D0)
31964
31965* particle properties (BAMJET index convention)
31966 CHARACTER*8 ANAME
31967 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31968 & IICH(210),IIBAR(210),K1(210),K2(210)
31969
31970* final state from HADRIN interaction
31971 PARAMETER (MAXFIN=10)
31972 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31973 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31974
31975C DATA TSLOPE /10.0D0/
31976
31977 IREJ = 0
31978
31979 1 CONTINUE
31980
31981 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31982 EKIN = ELAB-AAM(IP)
31983* kinematical quantities in cms of the hadrons
31984 AMP2 = AAM(IP)**2
31985 AMT2 = AAM(IT)**2
31986 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31987 ECM = SQRT(S)
31988 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31989 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31990
31991* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31992 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31993 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31994* TSAMCS treats pp and np only, therefore change pn into np and
31995* nn into pp
31996 IF (IT.EQ.1) THEN
31997 KPROJ = IP
31998 ELSE
31999 KPROJ = 8
32000 IF (IP.EQ.8) KPROJ = 1
32001 ENDIF
32002 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32003 T = TWO*PCM**2*(CTCMS-ONE)
32004
32005* very crude treatment otherwise: sample t from exponential dist.
32006 ELSE
32007* momentum transfer t
32008 TMAX = TWO*TWO*PCM**2
32009 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32010 IF (IIBAR(IP).NE.0) THEN
32011 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32012 ELSE
32013 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32014 ENDIF
32015 FMAX = EXP(-TSLOPE*TMAX)-ONE
32016 R = DT_RNDM(RR)
32017 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32018 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32019 ENDIF
32020
32021* target hadron in Lab after scattering
32022 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32023 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32024 IF (PLRH(2).LE.TINY10) THEN
32025C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32026 GOTO 1
32027 ENDIF
32028* projectile hadron in Lab after scattering
32029 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32030 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32031* scattering angle of projectile in Lab
32032 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32033 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32034 CALL DT_DSFECF(SPLABP,CPLABP)
32035* direction cosines of projectile in Lab
32036 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32037 & CXRH(1),CYRH(1),CZRH(1))
32038* scattering angle of target in Lab
32039 PLLABT = PLAB-CTLABP*PLRH(1)
32040 CTLABT = PLLABT/PLRH(2)
32041 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32042* direction cosines of target in Lab
32043 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32044 & CXRH(2),CYRH(2),CZRH(2))
32045* fill /HNFSPA/
32046 IRH = 2
32047 ITRH(1) = IP
32048 ITRH(2) = IT
32049
32050 RETURN
32051 END
32052
32053*$ CREATE DT_TSAMCS.FOR
32054*COPY DT_TSAMCS
32055*
32056*===tsamcs=============================================================*
32057*
32058 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32059
32060************************************************************************
32061* Sampling of cos(theta) for nucleon-proton scattering according to *
32062* hetkfa2/bertini parametrization. *
32063* This is a revised version of the original (HJM 24/10/88) *
32064* This version dated 28.10.95 is written by S. Roesler *
32065************************************************************************
32066
32067 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32068 SAVE
32069
32070 PARAMETER ( LINP = 10 ,
32071 & LOUT = 6 ,
32072 & LDAT = 9 )
32073
32074 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32075 & TINY10=1.0D-10)
32076
32077 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32078 DIMENSION PDCI(60),PDCH(55)
32079
32080 DATA (DCLIN(I),I=1,80) /
32081 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32082 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32083 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32084 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32085 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32086 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32087 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32088 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32089 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32090 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32091 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32092 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32093 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32094 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32095 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32096 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32097 DATA (DCLIN(I),I=81,160) /
32098 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32099 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32100 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32101 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32102 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32103 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32104 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32105 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32106 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32107 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32108 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32109 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32110 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32111 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32112 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32113 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32114 DATA (DCLIN(I),I=161,195) /
32115 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32116 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32117 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32118 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32119 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32120 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32121 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32122
32123 DATA PDCI /
32124 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32125 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32126 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32127 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32128 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32129 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32130 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32131 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32132 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32133 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32134 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32135 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32136
32137 DATA PDCH /
32138 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32139 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32140 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32141 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32142 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32143 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32144 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32145 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32146 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32147 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32148 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32149
32150 DATA (DCHN(I),I=1,90) /
32151 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32152 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32153 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32154 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32155 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32156 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32157 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32158 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32159 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32160 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32161 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32162 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32163 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32164 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32165 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32166 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32167 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32168 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32169 DATA (DCHN(I),I=91,143) /
32170 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32171 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32172 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32173 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32174 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32175 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32176 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32177 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32178 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32179 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32180 & 6.488D-02, 6.485D-02, 6.480D-02/
32181
32182 DATA DCHNA /
32183 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32184 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32185 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32186 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32187 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32188 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32189 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32190 & 1.000D+00/
32191
32192 DATA DCHNB /
32193 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32194 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32195 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32196 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32197 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32198 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32199 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32200 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32201 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32202 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32203 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32204 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32205
32206 CST = ONE
32207 IF (EKIN.GT.3.5D0) RETURN
32208C
32209 IF(KPROJ.EQ.8) GOTO 101
32210 IF(KPROJ.EQ.1) GOTO 102
32211C* INVALID REACTION
32212 WRITE(LOUT,'(A,I5/A)')
32213 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32214 & ' COS(THETA) = 1D0 RETURNED'
32215 RETURN
32216C-------------------------------- NP ELASTIC SCATTERING----------
32217101 CONTINUE
32218 IF (EKIN.GT.0.740D0)GOTO 1000
32219 IF (EKIN.LT.0.300D0)THEN
32220C EKIN .LT. 300 MEV
32221 IDAT=1
32222 ELSE
32223C 300 MEV < EKIN < 740 MEV
32224 IDAT=6
32225 END IF
32226C
32227 ENER=EKIN
32228 IE=INT(ABS(ENER/0.020D0))
32229 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32230C FORWARD/BACKWARD DECISION
32231 K=IDAT+5*IE
32232 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32233 IF (DT_RNDM(CST).LT.BWFW)THEN
32234 VALUE2=-1D0
32235 K=K+1
32236 ELSE
32237 VALUE2=1D0
32238 K=K+3
32239 END IF
32240C
32241 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32242 RND=DT_RNDM(COEF)
32243C
32244 IF(RND.LT.COEF)THEN
32245 CST=DT_RNDM(RND)
32246 CST=CST*VALUE2
32247 ELSE
32248 R1=DT_RNDM(CST)
32249 R2=DT_RNDM(R1)
32250 R3=DT_RNDM(R2)
32251 R4=DT_RNDM(R3)
32252C
32253 IF(VALUE2.GT.0.0)THEN
32254 CST=MAX(R1,R2,R3,R4)
32255 GOTO 1500
32256 ELSE
32257 R5=DT_RNDM(R4)
32258C
32259 IF (IDAT.EQ.1)THEN
32260 CST=-MAX(R1,R2,R3,R4,R5)
32261 ELSE
32262 R6=DT_RNDM(R5)
32263 R7=DT_RNDM(R6)
32264 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32265 END IF
32266C
32267 END IF
32268C
32269 END IF
32270C
32271 GOTO 1500
32272C
32273C******** EKIN .GT. 0.74 GEV
32274C
322751000 ENER=EKIN - 0.66D0
32276C IE=ABS(ENER/0.02)
32277 IE=INT(ENER/0.02D0)
32278 EMEV=EKIN*1D3
32279C
32280 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32281 K=IE
32282 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32283 RND=DT_RNDM(BWFW)
32284C FORWARD NEUTRON
32285 IF (RND.GE.BWFW)THEN
32286 DO 1200 K=10,36,9
32287 IF (DCHNA(K).GT.EMEV) THEN
32288 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32289 UNIV=DT_RNDM(UNIVE)
32290 DO 1100 I=1,8
32291 II=K+I
32292 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32293C
32294 IF (P.GT.UNIV)THEN
32295 UNIV=DT_RNDM(UNIVE)
32296 FLTI=DBLE(I)-UNIV
32297 GOTO(290,290,290,290,330,340,350,360) I
32298 END IF
32299 1100 CONTINUE
32300 END IF
32301 1200 CONTINUE
32302C
32303 ELSE
32304C BACKWARD NEUTRON
32305 DO 1400 K=13,60,12
32306 IF (DCHNB(K).GT.EMEV) THEN
32307 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32308 UNIV=DT_RNDM(UNIVE)
32309 DO 1300 I=1,11
32310 II=K+I
32311 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32312C
32313 IF (P.GT.UNIV)THEN
32314 UNIV=DT_RNDM(P)
32315 FLTI=DBLE(I)-UNIV
32316 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32317 END IF
32318 1300 CONTINUE
32319 END IF
32320 1400 CONTINUE
32321 END IF
32322C
32323120 CST=1.0D-2*FLTI-1.0D0
32324 GOTO 1500
32325140 CST=2.0D-2*UNIV-0.98D0
32326 GOTO 1500
32327150 CST=4.0D-2*UNIV-0.96D0
32328 GOTO 1500
32329160 CST=6.0D-2*FLTI-1.16D0
32330 GOTO 1500
32331180 CST=8.0D-2*UNIV-0.80D0
32332 GOTO 1500
32333190 CST=1.0D-1*UNIV-0.72D0
32334 GOTO 1500
32335200 CST=1.2D-1*UNIV-0.62D0
32336 GOTO 1500
32337210 CST=2.0D-1*UNIV-0.50D0
32338 GOTO 1500
32339220 CST=3.0D-1*(UNIV-1.0D0)
32340 GOTO 1500
32341C
32342290 CST=1.0D0-2.5d-2*FLTI
32343 GOTO 1500
32344330 CST=0.85D0+0.5D-1*UNIV
32345 GOTO 1500
32346340 CST=0.70D0+1.5D-1*UNIV
32347 GOTO 1500
32348350 CST=0.50D0+2.0D-1*UNIV
32349 GOTO 1500
32350360 CST=0.50D0*UNIV
32351C
323521500 RETURN
32353C
32354C----------------------------------- PP ELASTIC SCATTERING -------
32355C
32356 102 CONTINUE
32357 EMEV=EKIN*1D3
32358C
32359 IF (EKIN.LE.0.500D0) THEN
32360 RND=DT_RNDM(EMEV)
32361 CST=2.0D0*RND-1.0D0
32362 RETURN
32363C
32364 ELSEIF (EKIN.LT.1.0D0) THEN
32365 DO 2200 K=13,60,12
32366 IF (PDCI(K).GT.EMEV) THEN
32367 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32368 UNIV=DT_RNDM(UNIVE)
32369 SUM=0
32370 DO 2100 I=1,11
32371 II=K+I
32372 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32373C
32374 IF (UNIV.LT.SUM)THEN
32375 UNIV=DT_RNDM(SUM)
32376 FLTI=DBLE(I)-UNIV
32377 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32378 END IF
32379 2100 CONTINUE
32380 END IF
32381 2200 CONTINUE
32382 ELSE
32383 DO 2400 K=12,55,11
32384 IF (PDCH(K).GT.EMEV) THEN
32385 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32386 UNIV=DT_RNDM(UNIVE)
32387 SUM=0.0D0
32388 DO 2300 I=1,10
32389 II=K+I
32390 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32391C
32392 IF (UNIV.LT.SUM)THEN
32393 UNIV=DT_RNDM(SUM)
32394 FLTI=UNIV+DBLE(I)
32395 GOTO(50,55,60,60,65,65,65,65,70,70) I
32396 END IF
32397 2300 CONTINUE
32398 END IF
32399 2400 CONTINUE
32400 END IF
32401C
3240250 CST=0.4D0*UNIV
32403 GOTO 2500
3240455 CST=0.2D0*FLTI
32405 GOTO 2500
3240660 CST=0.3D0+0.1D0*FLTI
32407 GOTO 2500
3240865 CST=0.6D0+0.04D0*FLTI
32409 GOTO 2500
3241070 CST=0.78D0+0.02D0*FLTI
32411C
324122500 CONTINUE
32413 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32414C
32415 RETURN
32416 END
32417
32418*$ CREATE DT_DHADRI.FOR
32419*COPY DT_DHADRI
32420*
32421*===dhadri=============================================================*
32422*
32423 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32424
32425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32426 SAVE
32427
32428 PARAMETER ( LINP = 10 ,
32429 & LOUT = 6 ,
32430 & LDAT = 9 )
32431
32432C
32433C-----------------------------
32434C*** INPUT VARIABLES LIST:
32435C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32436C*** GEV/C LABORATORY MOMENTUM REGION
32437C*** N - PROJECTILE HADRON INDEX
32438C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32439C*** ELAB - LABORATORY ENERGY OF N (GEV)
32440C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32441C*** ITTA - TARGET NUCLEON INDEX
32442C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32443C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32444C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32445C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32446C*** RESPECT., UNITS (GEV/C AND GEV)
32447C----------------------------
32448
32449 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32450
32451 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32452
32453 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32454 & NRK(2,268),NURE(30,2)
32455
32456* particle properties (BAMJET index convention),
32457* (dublicate of DTPART for HADRIN)
32458 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32459 & K1H(110),K2H(110)
32460
32461 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32462
32463 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32464 & ITS(149),IS
32465
32466 COMMON /HNDRUN/ RUNTES,EFTES
32467
32468* particle properties (BAMJET index convention)
32469 CHARACTER*8 ANAME
32470 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32471 & IICH(210),IIBAR(210),K1(210),K2(210)
32472
32473* final state from HADRIN interaction
32474 PARAMETER (MAXFIN=10)
32475 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32476 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32477
32478 DIMENSION ITPRF(110)
32479 DATA NNN/0/
32480 DATA UMODA/0./
32481 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32482 LOWP=0
32483 IF (N.LE.0.OR.N.GE.111)N=1
32484 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32485 GOTO 280
32486* WRITE (6,1000)
32487* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32488* STOP
32489*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32490* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32491 ENDIF
32492 IATMPT=0
32493 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32494C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32495C STOP
32496 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32497 + ALLOWED REGION, PLAB=',1E15.5)
32498
32499 20 CONTINUE
32500 UMODAT=N*1.11111D0+ITTA*2.19291D0
32501 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32502 UMODA=UMODAT
32503 30 IATMPT=0
32504 LOWP=LOWP+1
32505 40 CONTINUE
32506 IMACH=0
32507 REDU=2.0D0
32508 IF (LOWP.GT.20) THEN
32509C WRITE(LOUT,*) ' jump 1'
32510 GO TO 280
32511 ENDIF
32512 NNN=N
32513 IF (NNN.EQ.N) GO TO 50
32514 RUNTES=0.0D0
32515 EFTES=0.0D0
32516 50 CONTINUE
32517 IS=1
32518 IRH=0
32519 IST=1
32520 NSTAB=23
32521 IRE=NURE(N,1)
32522 IF(ITTA.GT.1) IRE=NURE(N,2)
32523C
32524C-----------------------------
32525C*** IE,AMT,ECM,SI DETERMINATION
32526C----------------------------
32527 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32528 IANTH=-1
32529**sr
32530C IF (AMH(1).NE.0.93828D0) IANTH=1
32531 IF (AMH(1).NE.0.9383D0) IANTH=1
32532**
32533 IF (IANTH.GE.0) SI=1.0D0
32534 ECMMH=ECM
32535C
32536C-----------------------------
32537C ENERGY INDEX
32538C IRE CHARACTERIZES THE REACTION
32539C IE IS THE ENERGY INDEX
32540C----------------------------
32541 IF (SI.LT.1.D-6) THEN
32542C WRITE(LOUT,*) ' jump 2'
32543 GO TO 280
32544 ENDIF
32545 IF (N.LE.NSTAB) GO TO 60
32546 RUNTES=RUNTES+1.0D0
32547 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32548 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32549 IF(IBARH(N).EQ.1) N=8
32550 IF(IBARH(N).EQ.-1) N=9
32551 60 CONTINUE
32552 IMACH=IMACH+1
32553**sr 19.2.97: loop for direct channel suppression
32554C IF (IMACH.GT.10) THEN
32555 IF (IMACH.GT.1000) THEN
32556**
32557C WRITE(LOUT,*) ' jump 3'
32558 GO TO 280
32559 ENDIF
32560 ECM =ECMMH
32561 AMN2=AMN**2
32562 AMT2=AMT**2
32563 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32564 IF(ECMN.LE.AMN) ECMN=AMN
32565 PCMN=SQRT(ECMN**2-AMN2)
32566 GAM=(ELAB+AMT)/ECM
32567 BGAM=PLAB/ECM
32568 IF (IANTH.GE.0) ECM=2.1D0
32569C
32570C-----------------------------
32571C*** RANDOM CHOICE OF REACTION CHANNEL
32572C----------------------------
32573 IST=0
32574 VV=DT_RNDM(AMN2)
32575 VV=VV-1.D-17
32576C
32577C-----------------------------
32578C*** PLACE REDUCED VERSION
32579C----------------------------
32580 IIEI=IEII(IRE)
32581 IDWK=IEII(IRE+1)-IIEI
32582 IIWK=IRII(IRE)
32583 IIKI=IKII(IRE)
32584C
32585C-----------------------------
32586C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32587C----------------------------
32588 HECM=ECM
32589 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32590 IF (HUMO.LT.ECM) ECM=HUMO
32591C
32592C-----------------------------
32593C*** INTERPOLATION PREPARATION
32594C----------------------------
32595 ECMO=UMO(IE)
32596 ECM1=UMO(IE-1)
32597 DECM=ECMO-ECM1
32598 DEC=ECMO-ECM
32599C
32600C-----------------------------
32601C*** RANDOM LOOP
32602C----------------------------
32603 IK=0
32604 WKK=0.0D0
32605 WICOR=0.0D0
32606 70 IK=IK+1
32607 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32608 WOK=WK(IWK)
32609 WDK=WOK-WK(IWK-1)
32610C
32611C-----------------------------
32612C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32613C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32614C CONTRIBUTE
32615C----------------------------
32616 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32617 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32618 IF (WICO.EQ.WICOR) GO TO 70
32619 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32620 WICOR=WICO
32621C
32622C-----------------------------
32623C*** INTERPOLATION IN CHANNEL WEIGHTS
32624C----------------------------
32625 EKLIM=-THRESH(IIKI+IK)
32626 IELIM=IDT_IEFUND(EKLIM,IRE)
32627 DELIM=UMO(IELIM)+EKLIM
32628 *+1.D-16
32629 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32630 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32631 80 DECC=DELIM
32632 GO TO 100
32633 90 DECC=DECM
32634 100 CONTINUE
32635 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32636C
32637C-----------------------------
32638C*** RANDOM CHOICE
32639C----------------------------
32640C
32641 IF (VV.GT.WKK) GO TO 70
32642C
32643C***IK IS THE REACTION CHANNEL
32644C----------------------------
32645 INRK=IKII(IRE)+IK
32646 ECM=HECM
32647 I1001 =0
32648C
32649 110 CONTINUE
32650 IT1=NRK(1,INRK)
32651 AM1=DT_DAMG(IT1)
32652 IT2=NRK(2,INRK)
32653 AM2=DT_DAMG(IT2)
32654 AMS=AM1+AM2
32655 I1001=I1001+1
32656 IF (I1001.GT.50) GO TO 60
32657C
32658 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32659 IT11=IT1
32660 IT22=IT2
32661 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32662 AM11=AM1
32663 AM22=AM2
32664 IF (IT2.GT.0) GO TO 120
32665**sr 19.2.97: supress direct channel for pp-collisions
32666 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32667 RR = DT_RNDM(AM11)
32668 IF (RR.LE.0.75D0) GOTO 60
32669 ENDIF
32670**
32671C
32672C-----------------------------
32673C INCLUSION OF DIRECT RESONANCES
32674C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32675C------------------------
32676 KZ1=K1H(IT1)
32677 IST=IST+1
32678 IECO=0
32679 ECO=ECM
32680 GAM=(ELAB+AMT)/ECO
32681 BGAM=PLAB/ECO
32682 CXS(1)=CX
32683 CYS(1)=CY
32684 CZS(1)=CZ
32685 GO TO 170
32686 120 CONTINUE
32687 WW=DT_RNDM(ECO)
32688 IF(WW.LT. 0.5D0) GO TO 130
32689 IT1=IT22
32690 IT2=IT11
32691 AM1=AM22
32692 AM2=AM11
32693 130 CONTINUE
32694C
32695C-----------------------------
32696C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32697 IBN=IBARH(N)
32698 IB1=IBARH(IT1)
32699 IT11=IT1
32700 IT22=IT2
32701 AM11=AM1
32702 AM22=AM2
32703 IF(IB1.EQ.IBN) GO TO 140
32704 IT1=IT22
32705 IT2=IT11
32706 AM1=AM22
32707 AM2=AM11
32708 140 CONTINUE
32709C-----------------------------
32710C***IT1,IT2 ARE THE CREATED PARTICLES
32711C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32712C------------------------
32713 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32714 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32715 IST=IST+1
32716 ITS(IST)=IT1
32717 AMM(IST)=AM1
32718C
32719C-----------------------------
32720C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32721C----------------------------
32722 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32723 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32724 IST=IST+1
32725 ITS(IST)=IT2
32726 AMM(IST)=AM2
32727 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32728 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32729 150 CONTINUE
32730C
32731C-----------------------------
32732C***TEST STABLE OR UNSTABLE
32733C----------------------------
32734 IF(ITS(IST).GT.NSTAB) GO TO 160
32735 IRH=IRH+1
32736C
32737C-----------------------------
32738C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32739C----------------------------
32740C* IF (REDU.LT.0.D0) GO TO 1009
32741 ITRH(IRH)=ITS(IST)
32742 PLRH(IRH)=PLS(IST)
32743 CXRH(IRH)=CXS(IST)
32744 CYRH(IRH)=CYS(IST)
32745 CZRH(IRH)=CZS(IST)
32746 ELRH(IRH)=ELS(IST)
32747 IST=IST-1
32748 IF(IST.GE.1) GO TO 150
32749 GO TO 260
32750 160 CONTINUE
32751C
32752C RANDOM CHOICE OF DECAY CHANNELS
32753C----------------------------
32754C
32755 IT=ITS(IST)
32756 ECO=AMM(IST)
32757 GAM=ELS(IST)/ECO
32758 BGAM=PLS(IST)/ECO
32759 IECO=0
32760 KZ1=K1H(IT)
32761 170 CONTINUE
32762 IECO=IECO+1
32763 VV=DT_RNDM(GAM)
32764 VV=VV-1.D-17
32765 IIK=KZ1-1
32766 180 IIK=IIK+1
32767 IF (VV.GT.WTI(IIK)) GO TO 180
32768C
32769C IIK IS THE DECAY CHANNEL
32770C----------------------------
32771 IT1=NZKI(IIK,1)
32772 I310=0
32773 190 CONTINUE
32774 I310=I310+1
32775 AM1=DT_DAMG(IT1)
32776 IT2=NZKI(IIK,2)
32777 AM2=DT_DAMG(IT2)
32778 IF (IT2-1.LT.0) GO TO 240
32779 IT3=NZKI(IIK,3)
32780 AM3=DT_DAMG(IT3)
32781 AMS=AM1+AM2+AM3
32782C
32783C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32784C----------------------------
32785 IF (IECO.LE.10) GO TO 200
32786 IATMPT=IATMPT+1
32787 IF(IATMPT.GT.3) THEN
32788C WRITE(LOUT,*) ' jump 4'
32789 GO TO 280
32790 ENDIF
32791 GO TO 40
32792 200 CONTINUE
32793 IF (I310.GT.50) GO TO 170
32794 IF (AMS.GT.ECO) GO TO 190
32795C
32796C FOR THE DECAY CHANNEL
32797C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32798C----------------------------
32799 IF (REDU.LT.0.D0) GO TO 30
32800 ITWTHC=0
32801 REDU=2.0D0
32802 IF(IT3.EQ.0) GO TO 220
32803 210 CONTINUE
32804 ITWTH=1
32805 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32806 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32807 GO TO 230
32808 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32809 &COD2,COF2,SIF2,AM1,AM2)
32810 ITWTH=-1
32811 IT3=0
32812 230 CONTINUE
32813 ITWTHC=ITWTHC+1
32814 IF (REDU.GT.0.D0) GO TO 240
32815 REDU=2.0D0
32816 IF (ITWTHC.GT.100) GO TO 30
32817 IF (ITWTH) 220,220,210
32818 240 CONTINUE
32819 ITS(IST )=IT1
32820 IF (IT2-1.LT.0) GO TO 250
32821 ITS(IST+1) =IT2
32822 ITS(IST+2)=IT3
32823 RX=CXS(IST)
32824 RY=CYS(IST)
32825 RZ=CZS(IST)
32826 AMM(IST)=AM1
32827 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32828 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32829 IST=IST+1
32830 AMM(IST)=AM2
32831 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32832 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32833 IF (IT3.LE.0) GO TO 250
32834 IST=IST+1
32835 AMM(IST)=AM3
32836 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32837 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32838 250 CONTINUE
32839 GO TO 150
32840 260 CONTINUE
32841 270 CONTINUE
32842 RETURN
32843 280 CONTINUE
32844C
32845C----------------------------
32846C
32847C ZERO CROSS SECTION CASE
32848C----------------------------
32849C
32850 IRH=1
32851 ITRH(1)=N
32852 CXRH(1)=CX
32853 CYRH(1)=CY
32854 CZRH(1)=CZ
32855 ELRH(1)=ELAB
32856 PLRH(1)=PLAB
32857 RETURN
32858 END
32859
32860*$ CREATE DT_RUNTT.FOR
32861*COPY DT_RUNTT
32862*
32863*===runtt==============================================================*
32864*
32865 BLOCK DATA DT_RUNTT
32866
32867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32868 SAVE
32869
32870 COMMON /HNDRUN/ RUNTES,EFTES
32871
32872 DATA RUNTES,EFTES /100.D0,100.D0/
32873
32874 END
32875
32876*$ CREATE DT_NONAME.FOR
32877*COPY DT_NONAME
32878*
32879*===noname=============================================================*
32880*
32881 BLOCK DATA DT_NONAME
32882
32883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32884 SAVE
32885
32886* slope parameters for HADRIN interactions
32887 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32888
32889 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32890
32891C DATAS DATAS DATAS DATAS DATAS
32892C****** *********
32893 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32894 & 207, 224, 241, 252, 268 /
32895 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32896 & 220, 241, 262, 279, 296 /
32897 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32898 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32899
32900C
32901C MASSES FOR THE SLOPE B(M) IN GEV
32902C SLOPE B(M) FOR AN MESONIC SYSTEM
32903C SLOPE B(M) FOR A BARYONIC SYSTEM
32904
32905*
32906 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32907 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32908 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32909 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32910 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32911 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32912 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32913 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32914 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32915 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32916 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32917 & 14.2D0, 13.4D0, 12.6D0,
32918 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32919 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32920*
32921 END
32922
32923*$ CREATE DT_DAMG.FOR
32924*COPY DT_DAMG
32925*
32926*===damg===============================================================*
32927*
32928 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32929
32930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32931 SAVE
32932
32933* particle properties (BAMJET index convention),
32934* (dublicate of DTPART for HADRIN)
32935 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32936 & K1H(110),K2H(110)
32937
32938 DIMENSION GASUNI(14)
32939 DATA GASUNI/
32940 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32941 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32942 DATA GAUNO/2.352D0/
32943 DATA GAUNON/2.4D0/
32944 DATA IO/14/
32945 DATA NSTAB/23/
32946
32947 I=1
32948 IF (IT.LE.0) GO TO 30
32949 IF (IT.LE.NSTAB) GO TO 20
32950 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32951 VV=DT_RNDM(DGAUNI)
32952 VV=VV*2.0D0-1.0D0+1.D-16
32953 10 CONTINUE
32954 VO=GASUNI(I)
32955 I=I+1
32956 V1=GASUNI(I)
32957 IF (VV.GT.V1) GO TO 10
32958 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32959 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32960 DAM=GAH(IT)*UNIGA/GAUNO
32961 AAM=AMH(IT)+DAM
32962 DT_DAMG=AAM
32963 RETURN
32964 20 CONTINUE
32965 DT_DAMG=AMH(IT)
32966 RETURN
32967 30 CONTINUE
32968 DT_DAMG=0.0D0
32969 RETURN
32970 END
32971
32972*$ CREATE DT_DCALUM.FOR
32973*COPY DT_DCALUM
32974*
32975*===dcalum=============================================================*
32976*
32977 SUBROUTINE DT_DCALUM(N,ITTA)
32978
32979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32980 SAVE
32981
32982C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32983
32984* particle properties (BAMJET index convention),
32985* (dublicate of DTPART for HADRIN)
32986 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32987 & K1H(110),K2H(110)
32988
32989 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32990
32991 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32992
32993 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32994 & NRK(2,268),NURE(30,2)
32995
32996 IRE=NURE(N,ITTA/8+1)
32997 IEO=IEII(IRE)+1
32998 IEE=IEII(IRE +1)
32999 AM1=AMH(N )
33000 AM12=AM1**2
33001 AM2=AMH(ITTA)
33002 AM22=AM2**2
33003 DO 10 IE=IEO,IEE
33004 PLAB2=PLABF(IE)**2
33005 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33006 UMO(IE)=ELAB
33007 10 CONTINUE
33008 IKO=IKII(IRE)+1
33009 IKE=IKII(IRE +1)
33010 UMOO=UMO(IEO)
33011 DO 30 IK=IKO,IKE
33012 IF(NRK(2,IK).GT.0) GO TO 30
33013 IKI=NRK(1,IK)
33014 AMSS=5.0D0
33015 K11=K1H(IKI)
33016 K22=K2H(IKI)
33017 DO 20 IK1=K11,K22
33018 IN=NZKI(IK1,1)
33019 AMS=AMH(IN)
33020 IN=NZKI(IK1,2)
33021 IF(IN.GT.0)AMS=AMS+AMH(IN)
33022 IN=NZKI(IK1,3)
33023 IF(IN.GT.0) AMS=AMS+AMH(IN)
33024 IF (AMS.LT.AMSS) AMSS=AMS
33025 20 CONTINUE
33026 IF(UMOO.LT.AMSS) UMOO=AMSS
33027 THRESH(IK)=UMOO
33028 30 CONTINUE
33029 RETURN
33030 END
33031
33032*$ CREATE DT_DCHANH.FOR
33033*COPY DT_DCHANH
33034*
33035*===dchanh=============================================================*
33036*
33037 SUBROUTINE DT_DCHANH
33038
33039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33040 SAVE
33041
33042 PARAMETER ( LINP = 10 ,
33043 & LOUT = 6 ,
33044 & LDAT = 9 )
33045
33046* particle properties (BAMJET index convention),
33047* (dublicate of DTPART for HADRIN)
33048 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33049 & K1H(110),K2H(110)
33050
33051 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33052
33053 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33054
33055 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33056 & NRK(2,268),NURE(30,2)
33057
33058 DIMENSION HWT(460),HWK(40),SI(5184)
33059 EQUIVALENCE (WK(1),SI(1))
33060C--------------------
33061C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33062C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33063C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33064C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33065C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33066C--------------------------
33067 IREG=16
33068 DO 90 IRE=1,IREG
33069 IWKO=IRII(IRE)
33070 IEE=IEII(IRE+1)-IEII(IRE)
33071 IKE=IKII(IRE+1)-IKII(IRE)
33072 IEO=IEII(IRE)+1
33073 IIKA=IKII(IRE)
33074* modifications to suppress elestic scattering 24/07/91
33075 DO 80 IE=1,IEE
33076 SIS=1.D-14
33077 SINORC=0.0D0
33078 DO 10 IK=1,IKE
33079 IWK=IWKO+IEE*(IK-1)+IE
33080 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33081 SIS=SIS+SI(IWK)*SINORC
33082 10 CONTINUE
33083 SIIN(IEO+IE-1)=SIS
33084 SIO=0.D0
33085 IF (SIS.GE.1.D-12) GO TO 20
33086 SIS=1.D0
33087 SIO=1.D0
33088 20 CONTINUE
33089 SINORC=0.0D0
33090 DO 30 IK=1,IKE
33091 IWK=IWKO+IEE*(IK-1)+IE
33092 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33093 SIO=SIO+SI(IWK)*SINORC/SIS
33094 HWK(IK)=SIO
33095 30 CONTINUE
33096 DO 40 IK=1,IKE
33097 IWK=IWKO+IEE*(IK-1)+IE
33098 40 WK(IWK)=HWK(IK)
33099 IIKI=IKII(IRE)
33100 DO 70 IK=1,IKE
33101 AM111=0.D0
33102 INRK1=NRK(1,IIKI+IK)
33103 IF (INRK1.GT.0) AM111=AMH(INRK1)
33104 AM222=0.D0
33105 INRK2=NRK(2,IIKI+IK)
33106 IF (INRK2.GT.0) AM222=AMH(INRK2)
33107 THRESH(IIKI+IK)=AM111 +AM222
33108 IF (INRK2-1.GE.0) GO TO 60
33109 INRKK=K1H(INRK1)
33110 AMSS=5.D0
33111 INRKO=K2H(INRK1)
33112 DO 50 INRK1=INRKK,INRKO
33113 INZK1=NZKI(INRK1,1)
33114 INZK2=NZKI(INRK1,2)
33115 INZK3=NZKI(INRK1,3)
33116 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33117 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33118 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33119C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33120 1000 FORMAT (4I10)
33121 AMS=AMH(INZK1)+AMH(INZK2)
33122 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33123 IF (AMSS.GT.AMS) AMSS=AMS
33124 50 CONTINUE
33125 AMS=AMSS
33126 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33127 THRESH(IIKI+IK)=AMS
33128 60 CONTINUE
33129 70 CONTINUE
33130 80 CONTINUE
33131 90 CONTINUE
33132 DO 100 J=1,460
33133 100 HWT(J)=0.D0
33134 DO 120 I=1,110
33135 IK1=K1H(I)
33136 IK2=K2H(I)
33137 HV=0.D0
33138 IF (IK2.GT.460)IK2=460
33139 IF (IK1.LE.0)IK1=1
33140 DO 110 J=IK1,IK2
33141 HV=HV+WTI(J)
33142 HWT(J)=HV
33143 JI=J
33144 110 CONTINUE
33145 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33146 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33147 120 CONTINUE
33148 DO 130 J=1,460
33149 130 WTI(J)=HWT(J)
33150 RETURN
33151 END
33152
33153*$ CREATE DT_DHADDE.FOR
33154*COPY DT_DHADDE
33155*
33156*===dhadde=============================================================*
33157*
33158 SUBROUTINE DT_DHADDE
33159
33160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33161 SAVE
33162
33163* particle properties (BAMJET index convention)
33164 CHARACTER*8 ANAME
33165 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33166 & IICH(210),IIBAR(210),K1(210),K2(210)
33167
33168* HADRIN: decay channel information
33169 PARAMETER (IDMAX9=602)
33170 CHARACTER*8 ZKNAME
33171 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33172
33173* particle properties (BAMJET index convention),
33174* (dublicate of DTPART for HADRIN)
33175 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33176 & K1H(110),K2H(110)
33177
33178 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33179
33180* decay channel information for HADRIN
33181 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33182 & K1Z(16),K2Z(16),WTZ(153),II22,
33183 & NZK1(153),NZK2(153),NZK3(153)
33184
33185 DATA IRETUR/0/
33186
33187 IRETUR=IRETUR+1
33188 AMH(31)=0.48D0
33189 IF (IRETUR.GT.1) RETURN
33190 DO 10 I=1,94
33191 AMH(I) = AAM(I)
33192 GAH(I) = GA(I)
33193 TAUH(I) = TAU(I)
33194 ICHH(I) = IICH(I)
33195 IBARH(I) = IIBAR(I)
33196 K1H(I) = K1(I)
33197 K2H(I) = K2(I)
33198 10 CONTINUE
33199**sr
33200C AMH(1)=0.93828D0
33201 AMH(1)=0.9383D0
33202**
33203 AMH(2)=AMH(1)
33204 DO 20 I=26,30
33205 K1H(I)=452
33206 K2H(I)=452
33207 20 CONTINUE
33208 DO 30 I=1,307
33209 WTI(I) = WT(I)
33210 NZKI(I,1) = NZK(I,1)
33211 NZKI(I,2) = NZK(I,2)
33212 NZKI(I,3) = NZK(I,3)
33213 30 CONTINUE
33214 DO 40 I=1,16
33215 L=I+94
33216 AMH(L)=AMZ(I)
33217 GAH( L)=GAZ(I)
33218 TAUH( L)=TAUZ(I)
33219 ICHH( L)=ICHZ(I)
33220 IBARH( L)=IBARZ(I)
33221 K1H( L)=K1Z(I)
33222 K2H( L)=K2Z(I)
33223 40 CONTINUE
33224 DO 50 I=1,153
33225 L=I+307
33226 WTI(L) = WTZ(I)
33227 NZKI(L,3) = NZK3(I)
33228 NZKI(L,2) = NZK2(I)
33229 NZKI(L,1) = NZK1(I)
33230 50 CONTINUE
33231 RETURN
33232 END
33233
33234*$ CREATE IDT_IEFUND.FOR
33235*COPY IDT_IEFUND
33236*
33237*===iefund=============================================================*
33238*
33239 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33240
33241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33242 SAVE
33243
33244C*****IEFUN CALCULATES A MOMENTUM INDEX
33245
33246 PARAMETER ( LINP = 10 ,
33247 & LOUT = 6 ,
33248 & LDAT = 9 )
33249
33250 COMMON /HNDRUN/ RUNTES,EFTES
33251
33252 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33253
33254 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33255 & NRK(2,268),NURE(30,2)
33256
33257 IPLA=IEII(IRE)+1
33258 *+1
33259 IPLE=IEII(IRE+1)
33260 IF (PL.LT.0.) GO TO 30
33261 DO 10 I=IPLA,IPLE
33262 J=I-IPLA+1
33263 IF (PL.LE.PLABF(I)) GO TO 60
33264 10 CONTINUE
33265 I=IPLE
33266 IF ( EFTES.GT.40.D0) GO TO 20
33267 EFTES=EFTES+1.0D0
33268 WRITE(LOUT,1000)PL,J
33269 20 CONTINUE
33270 GO TO 70
33271 30 CONTINUE
33272 DO 40 I=IPLA,IPLE
33273 J=I-IPLA+1
33274 IF (-PL.LE.UMO(I)) GO TO 60
33275 40 CONTINUE
33276 I=IPLE
33277 IF ( EFTES.GT.40.D0) GO TO 50
33278 EFTES=EFTES+1.0D0
33279 WRITE(LOUT,1000)PL,I
33280 50 CONTINUE
33281 60 CONTINUE
33282 70 CONTINUE
33283 IDT_IEFUND=I
33284 RETURN
33285 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33286 +7H IEFUN=,I5)
33287 END
33288
33289*$ CREATE DT_DSIGIN.FOR
33290*COPY DT_DSIGIN
33291*
33292*===dsigin=============================================================*
33293*
33294 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33295
33296 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33297 SAVE
33298
33299* particle properties (BAMJET index convention),
33300* (dublicate of DTPART for HADRIN)
33301 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33302 & K1H(110),K2H(110)
33303
33304 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33305
33306 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33307 & NRK(2,268),NURE(30,2)
33308
33309 IE=IDT_IEFUND(PLAB,IRE)
33310 IF (IE.LE.IEII(IRE)) IE=IE+1
33311 AMT=AMH(ITAR)
33312 AMN=AMH(N)
33313 AMN2=AMN*AMN
33314 AMT2=AMT*AMT
33315 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33316C*** INTERPOLATION PREPARATION
33317 ECMO=UMO(IE)
33318 ECM1=UMO(IE-1)
33319 DECM=ECMO-ECM1
33320 DEC=ECMO-ECM
33321 IIKI=IKII(IRE)+1
33322 EKLIM=-THRESH(IIKI)
33323 WOK=SIIN(IE)
33324 WDK=WOK-SIIN(IE-1)
33325 IF (ECM.GT.ECMO) WDK=0.0D0
33326C*** INTERPOLATION IN CHANNEL WEIGHTS
33327 IELIM=IDT_IEFUND(EKLIM,IRE)
33328 DELIM=UMO(IELIM)+EKLIM
33329 *+1.D-16
33330 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33331 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33332 10 DECC=DELIM
33333 GO TO 30
33334 20 DECC=DECM
33335 30 CONTINUE
33336 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33337 IF (WKK.LT.0.0D0) WKK=0.0D0
33338 SI=WKK+1.D-12
33339 IF (-EKLIM.GT.ECM) SI=1.D-14
33340 RETURN
33341 END
33342
33343*$ CREATE DT_DTCHOI.FOR
33344*COPY DT_DTCHOI
33345*
33346*===dtchoi=============================================================*
33347*
33348 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33349
33350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33351 SAVE
33352
33353C ****************************
33354C TCHOIC CALCULATES A RANDOM VALUE
33355C FOR THE FOUR-MOMENTUM-TRANSFER T
33356C ****************************
33357
33358* particle properties (BAMJET index convention),
33359* (dublicate of DTPART for HADRIN)
33360 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33361 & K1H(110),K2H(110)
33362
33363* slope parameters for HADRIN interactions
33364 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33365
33366 AMA=AM1
33367 AMB=AM2
33368 IF (I.GT.30.AND.II.GT.30) GO TO 20
33369 III=II
33370 AM3=AM2
33371 IF (I.LE.30) GO TO 10
33372 III=I
33373 AM3=AM1
33374 10 CONTINUE
33375 GO TO 30
33376 20 CONTINUE
33377 III=II
33378 AM3=AM2
33379 IF (AMA.LE.AMB) GO TO 30
33380 III=I
33381 AM3=AM1
33382 30 CONTINUE
33383 IB=IBARH(III)
33384 AMA=AM3
33385 K=INT((AMA-0.75D0)/0.05D0)
33386 IF (K-2.LT.0) K=1
33387 IF (K-26.GE.0) K=25
33388 IF (IB)50,40,50
33389 40 BM=BBM(K)
33390 GO TO 60
33391 50 BM=BBB(K)
33392 60 CONTINUE
33393C NORMALIZATION
33394 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33395 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33396 VB=DT_RNDM(TMIN)
33397**sr test
33398C IF (VB.LT.0.2D0) BM=BM*0.1
33399C **0.5
33400 BM = BM*5.05D0
33401**
33402 TMI=BM*TMIN
33403 TMA=BM*TMAX
33404 ETMA=0.D0
33405 IF (ABS(TMA).GT.120.D0) GO TO 70
33406 ETMA=EXP(TMA)
33407 70 CONTINUE
33408 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33409C*** RANDOM CHOICE OF THE T - VALUE
33410 R=DT_RNDM(TMI)
33411 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33412 RETURN
33413 END
33414
33415*$ CREATE DT_DTWOPA.FOR
33416*COPY DT_DTWOPA
33417*
33418*===dtwopa=============================================================*
33419*
33420 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33421 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33422
33423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33424 SAVE
33425
33426C ******************************************************
33427C QUASI TWO PARTICLE PRODUCTION
33428C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33429C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33430C IN THE CM - SYSTEM
33431C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33432C SPHERICAL COORDINATES
33433C ******************************************************
33434
33435* particle properties (BAMJET index convention),
33436* (dublicate of DTPART for HADRIN)
33437 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33438 & K1H(110),K2H(110)
33439
33440 AMA=AM1
33441 AMB=AM2
33442 AMA2=AMA*AMA
33443 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33444 E2=UMOO - E1
33445 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33446 AMTE=(E1-AMA)*(E1+AMA)
33447 AMTE=AMTE+1.D-18
33448 P1=SQRT(AMTE)
33449 P2=P1
33450C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33451C DETERMINATION OF THE ANGLES
33452C COS(THETA1)=COD1 COS(THETA2)=COD2
33453C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33454C COS(PHI1)=COF1 COS(PHI2)=COF2
33455C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33456 CALL DT_DSFECF(COF1,SIF1)
33457 COF2=-COF1
33458 SIF2=-SIF1
33459C CALCULATION OF THETA1
33460 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33461 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33462 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33463 COD2=-COD1
33464 RETURN
33465 END
33466
33467*$ CREATE DT_ZK.FOR
33468*COPY DT_ZK
33469*
33470*===zk=================================================================*
33471*
33472 BLOCK DATA DT_ZK
33473
33474 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33475 SAVE
33476
33477* decay channel information for HADRIN
33478 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33479 & K1Z(16),K2Z(16),WTZ(153),II22,
33480 & NZK1(153),NZK2(153),NZK3(153)
33481
33482* decay channel information for HADRIN
33483 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33484 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33485
33486* Particle masses in GeV *
33487 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33488 & 2*1.7D0, 3*0.D0/
33489* Resonance width Gamma in GeV *
33490 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33491* Mean life time in seconds *
33492 DATA TAUZ / 16*0.D0 /
33493* Charge of particles and resonances *
33494 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33495* Baryonic charge *
33496 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33497* First number of decay channels used for resonances *
33498* and decaying particles *
33499 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33500 & 3*460/
33501* Last number of decay channels used for resonances *
33502* and decaying particles *
33503 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33504 & 3*460/
33505* Weight of decay channel *
33506 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33507 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33508 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33509 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33510 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33511 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33512 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33513 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33514 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33515 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33516 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33517 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33518 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33519 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33520 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33521 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33522 & .05D0, .65D0, 9*1.D0 /
33523* Particle numbers in decay channel *
33524 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33525 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33526 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33527 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33528 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33529 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33530 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33531 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33532 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33533 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33534 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33535 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33536 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33537 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33538 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33539 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33540 & 1, 8, 1, 8, 1, 9*0 /
33541 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33542 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33543 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33544 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33545 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33546 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33547* Particle names *
33548 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33549 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33550 & 3*'BLANK' /
33551* Name of decay channel *
33552 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33553 & 'ANNPI0','APPPI0','ANPPI-'/
33554 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33555 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33556 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33557 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33558 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33559 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33560 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33561 & 'OMOMOM',
33562 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33563 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33564 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33565 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33566 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33567 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33568 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33569 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33570 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33571 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33572 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33573 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33574 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33575 & 9*'BLANK'/
33576*= end*block.zk *
33577 END
33578
33579*$ CREATE DT_BLKD43.FOR
33580*COPY DT_BLKD43
33581*
33582*===blkd43=============================================================*
33583*
33584 BLOCK DATA DT_BLKD43
33585
33586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33587 SAVE
33588
33589*
33590*=== reac =============================================================*
33591*
33592*----------------------------------------------------------------------*
33593* *
33594* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33595* Infn - Milan *
33596* *
33597* Last change on 10-dec-91 by Alfredo Ferrari *
33598* *
33599* This is the original common reac of Hadrin *
33600* *
33601*----------------------------------------------------------------------*
33602*
33603
33604 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33605 & NRK(2,268),NURE(30,2)
33606
33607 DIMENSION
33608 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33609 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33610 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33611 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33612 & SPIKP5(187), SPIKP6(289),
33613 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33614 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33615 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33616 & SANPEL(84) , SPIKPF(273),
33617 & SPKP15(187), SPKP16(272),
33618 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33619 & NURELN(60)
33620*
33621 DIMENSION NRKLIN(532)
33622 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33623 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33624 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33625 EQUIVALENCE ( UMO(263), UMOK0(1))
33626 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33627 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33628 EQUIVALENCE ( PLABF(263), PLAK0(1))
33629 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33630 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33631 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33632 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33633 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33634 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33635 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33636 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33637 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33638 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33639 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33640 EQUIVALENCE ( WK(4913), SPKP16(1))
33641 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33642 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33643 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33644 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33645 EQUIVALENCE (NURE(1,1), NURELN(1))
33646*
33647**** pi- p data *
33648**** pi+ n data *
33649 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33650 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33651 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33652 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33653 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33654 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33655 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33656 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33657 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33658 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33659 DATA PLAKC /
33660 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33661 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33662 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33663 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33664 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33665 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33666 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33667 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33668 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
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 DATA PLAK0 /
33673 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33674 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33675 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33676 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33677 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33678 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33679* pp pn np nn *
33680 DATA PLAP /
33681 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33682 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33683 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33684 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33685 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33687* app apn anp ann *
33688 DATA PLAN /
33689 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33690 & .74D0, 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.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33693 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33694 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33695 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33696 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33697 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33698 DATA SIIN / 296*0.D0 /
33699 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33700 & 1.557D0,1.615D0,1.6435D0,
33701 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33702 & 2.286D0,2.366D0,2.482D0,2.56D0,
33703 & 2.735D0,2.90D0,
33704 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33705 & 1.496D0,1.527D0,1.557D0,
33706 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33707 & 2.071D0,2.159D0,2.286D0,2.366D0,
33708 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33709 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33710 & 1.496D0,1.527D0,1.557D0,
33711 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33712 & 2.071D0,2.159D0,2.286D0,2.366D0,
33713 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33714 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33715 & 1.557D0,1.615D0,1.6435D0,
33716 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33717 & 2.286D0,2.366D0,2.482D0,2.56D0,
33718 & 2.735D0, 2.90D0/
33719 DATA UMOKC/ 1.44D0,
33720 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33721 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33722 & 3.1D0,1.44D0,
33723 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33724 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33725 & 3.1D0,1.44D0,
33726 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33727 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33728 & 3.1D0,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/
33732 DATA UMOK0/ 1.44D0,
33733 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33734 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33735 & 3.1D0,1.44D0,
33736 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33737 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33738 & 3.1D0/
33739* pp pn np nn *
33740 DATA UMOP/
33741 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33742 & 3.D0,3.1D0,3.2D0,
33743 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33744 & 3.D0,3.1D0,3.2D0,
33745 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746 & 3.D0,3.1D0,3.2D0/
33747* app apn anp ann *
33748 DATA UMON /
33749 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33750 & 2.D0,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.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33753 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33754 & 3.D0,3.1D0,3.2D0,
33755 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33756 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33757 & 3.D0,3.1D0,3.2D0/
33758**** reaction channel state particles *
33759 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33760 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33761 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33762 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33763 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33764 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33765 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33766 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33767 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33768 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33769 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33770 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33771 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33772 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33773 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33774 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33775 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33776 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33777* *
33778* k0 p k0 n ak0 p ak/ n *
33779* *
33780 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33781 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33782 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33783 & 53, 47, 1, 103, 0, 93, 0/
33784* pp pn np nn *
33785 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33786 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33787 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33788 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33789* app apn anp ann *
33790 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33791 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33792 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33793 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33794 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33795 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33796 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33797**** channel cross section *
33798 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33799 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33800 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33801 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33802 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33803 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33804 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33805 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33806 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33807 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33808 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33809 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33810 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33811 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33812 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33813 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33814 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33815 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33816 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33817 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33818**** pi+ n data *
33819 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33820 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33821 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33822 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33823 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33824 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33825 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33826 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33827 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33828 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33829 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33830 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33831 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33832 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33833 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33834 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33835 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33836 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33837 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33838 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33839*
33840 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33841 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33842 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33843 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33844 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33845 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33846 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33847 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33848 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33849 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33850 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33851 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33852 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33853 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33854 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33855 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33856 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33857 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33858 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33859 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33860**** pi- p data *
33861 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33862 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33863 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33864 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33865 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33866 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33867 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33868 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33869 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33870 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33871 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33872 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33873 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33874 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33875 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33876 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33877 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33878 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33879 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33880*
33881 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33882 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33883 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33884 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33885 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33886 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33887 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33888 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33889 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33890 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33891 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33892 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33893 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33894 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33895 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33896 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33897 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33898 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33899 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33900 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33901**** pi- n data *
33902 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33903 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33904 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33905 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33906 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33907 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33908 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33909 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33910 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33911 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33912 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33913 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33914 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33915 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33916 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33917 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33918 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33919 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33920 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33921 & 3.3D0, 5.4D0, 7.D0 /
33922**** k+ p data *
33923 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33924 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33925 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33926 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33927 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33928 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33929 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33930 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33931 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33932 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33933 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33934 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33935 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33936**** k+ n data *
33937 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33938 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33939 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33940 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33941 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33942 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33943 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33944 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33945 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33946 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33947 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33948 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33949 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33950 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33951 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33952 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33953 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33954 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33955 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33956**** k- p data *
33957 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33958 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33959 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33960 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33961 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33962 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33963 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33964 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33965 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33966 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33967 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33968 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33969 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33970 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33971 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33972 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33973 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33974 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33975 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33976 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33977 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33978 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33979 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33980 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33981 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33982 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33983 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33984 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33985 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33986 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33987 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33988 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33989 & 10*0.D0/
33990***** k- n data *
33991 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33992 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33993 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33994 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33995 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33996 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33997 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33998 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33999 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34000 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34001 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34002 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34003 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34004 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34005 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34006 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34007 & .39D0, .22D0, .07D0, 0.D0,
34008 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34009 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34010 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34011 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34012 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34013 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34014 & 5.10D0, 5.44D0, 5.3D0,
34015 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34016***** p p data *
34017 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34018 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34019 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34020 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34021 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34022 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34023 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34024 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34025 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34026 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34027 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34028 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34029 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34030 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34031 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34032***** p n data *
34033 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34034 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34035 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34036 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34037 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34038 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34039 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34040 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34041 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34042 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34043 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34044 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34045 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34046 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34047 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34048 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34049 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34050 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34051* nn - data *
34052* *
34053 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34054 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34055 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34056 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34057 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34058 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34059 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34060 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34061 & 11.D0, 5.5D0, 3.5D0,
34062 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34063 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34064 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34065 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34066 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34067 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34068**************** ap - p - data *
34069 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34070 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34071 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34072 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34073 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34074 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34075 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34076 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34077 & 1.55D0, 1.3D0, .95D0, .75D0,
34078 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34079 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34080 & .01D0, .008D0, .006D0, .005D0/
34081 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34082 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34083 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34084 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34085 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34086 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34087 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34088 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34089 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34090 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34091 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34092 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34093 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34094 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34095 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34096 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34097 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34098 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34099 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34100 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34101**************** ap - n - data *
34102 DATA SAPNEL/
34103 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34104 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34105 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34106 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34107 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34108 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34109 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34110 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34111 & .01D0, .008D0, .006D0, .005D0 /
34112 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34113 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34114 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34115 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34116 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34117 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34118 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34119 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34121 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34122 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34123 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34124 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34125 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34126* *
34127* *
34128**************** an - p - data *
34129* *
34130 DATA SANPEL/
34131 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34132 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34133 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34134 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34135 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34136 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34137 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34138 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34139 & .01D0, .008D0, .006D0, .005D0 /
34140 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34141 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34142 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34143 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34144 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34145 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34146 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34147 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34148 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34149 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34150 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34151 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34152 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34153 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34154**** ko - n - data *
34155 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34156 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34157 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34158 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34159 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34160 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34161 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34162 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34163 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34164 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34165 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34166 & 4.85D0, 4.9D0,
34167 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34168 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34169 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34170 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34171 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34172**** ako - p - data *
34173 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34174 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34175 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34176 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34177 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34178 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34179 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34180 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34181 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34182 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34183 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34184 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34185 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34186 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34187 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34188 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34189 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34190 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34191 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34192 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34193 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34194 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34195 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34196*= end*block.blkdt3 *
34197 END
34198*$ CREATE DT_QEL_POL.FOR
34199*COPY DT_QEL_POL
34200*
34201*===qel_pol============================================================*
34202*
34203 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34204
34205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34206 SAVE
34207
34208 CALL DT_MASS_INI
34209 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34210
34211 RETURN
34212 END
34213
34214*$ CREATE DT_GEN_QEL.FOR
34215*COPY DT_GEN_QEL
34216C==================================================================
34217C Generation of a Quasi-Elastic neutrino scattering
34218C==================================================================
34219*
34220*===gen_qel============================================================*
34221*
34222 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34223
34224C...Generate a quasi-elastic neutrino/antineutrino
34225C. Interaction on a nuclear target
34226C. INPUT : LTYP = neutrino type (1,...,6)
34227C. ENU (GeV) = neutrino energy
34228C----------------------------------------------------
34229
34230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34231 SAVE
34232
34233 PARAMETER ( LINP = 10 ,
34234 & LOUT = 6 ,
34235 & LDAT = 9 )
34236 PARAMETER (MAXLND=4000)
34237 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34238
34239* nuclear potential
34240 LOGICAL LFERMI
34241 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34242 & EBINDP(2),EBINDN(2),EPOT(2,210),
34243 & ETACOU(2),ICOUL,LFERMI
34244
34245* steering flags for qel neutrino scattering modules
34246 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34247**sr - removed (not needed)
34248C COMMON /CBAD/ LBAD, NBAD
34249C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34250**
34251
34252 DIMENSION PI(3),PO(3)
34253CJR+
34254 DATA ININU/0/
34255CJR-
34256C REAL*8 DBETA(3)
34257C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34258 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34259 DATA AMN /0.93827231D0, 0.93956563D0/
34260 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34261 DATA INIPRI/0/
34262
34263C DATA PFERMI/0.22D0/
34264CGB+...Binding Energy
34265 DATA EBIND/0.008D0/
34266CGB-...
34267
34268 ININU=ININU+1
34269 IF(ININU.EQ.1)NDSIG=0
34270 LBAD = 0
34271 enu0=enu
34272c write(*,*) enu0
34273C...Lepton mass
34274 AML = AML0(LTYP) ! massa leptoni
34275 AML2 = AML**2 ! massa leptoni **2
34276C...Particle labels (LUND)
34277 N = 5
34278 K(1,1) = 21
34279 K(2,1) = 21
34280 K(3,1) = 21
34281 K(3,3) = 1
34282 K(4,1) = 1
34283 K(4,3) = 1
34284 K(5,1) = 1
34285 K(5,3) = 2
34286 K0 = (LTYP-1)/2 ! 2
34287 K1 = LTYP/2 ! 2
34288 KA = 12 + 2*K0 ! 16
34289 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34290 K(1,2) = IS*KA
34291 K(4,2) = IS*(KA-1)
34292 K(3,2) = IS*24
34293 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34294 IF (LNU .EQ. 2) THEN
34295 K(2,2) = 2212
34296 K(5,2) = 2112
34297 AMI = AMN(1)
34298 AMF = AMN(2)
34299CJR+
34300 PFERMI=PFERMN(2)
34301CJR-
34302 ELSE
34303 K(2,2) = 2112
34304 K(5,2) = 2212
34305 AMI = AMN(2)
34306 AMF = AMN(1)
34307CJR+
34308 PFERMI=PFERMP(2)
34309CJR-
34310 ENDIF
34311 AMI2 = AMI**2
34312 AMF2 = AMF**2
34313
34314 DO IGB=1,5
34315 P(3,IGB) = 0.
34316 P(4,IGB) = 0.
34317 P(5,IGB) = 0.
34318 END DO
34319
34320 NTRY = 0
34321CGB+...
34322 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34323 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34324CGB-...
34325
34326 100 CONTINUE
34327
34328C...4-momentum initial lepton
34329 P(1,5) = 0. ! massa
34330 P(1,4) = ENU0 ! energia
34331 P(1,1) = 0. ! px
34332 P(1,2) = 0. ! py
34333 P(1,3) = ENU0 ! pz
34334
34335C PF = PFERMI*PYR(0)**(1./3.)
34336c write(23,*) PYR(0)
34337c write(*,*) 'Pfermi=',PF
34338c PF = 0.
34339 NTRY=NTRY+1
34340C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34341 IF (NTRY .GT. 500) THEN
34342 LBAD = 1
34343 WRITE (LOUT,1001) NBAD, ENU
34344 RETURN
34345 ENDIF
34346C CT = -1. + 2.*PYR(0)
34347c CT = -1.
34348C ST = SQRT(1.-CT*CT)
34349C F = 2.*3.1415926*PYR(0)
34350c F = 0.
34351
34352C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34353C P(2,1) = PF*ST*COS(F) ! px
34354C P(2,2) = PF*ST*SIN(F) ! py
34355C P(2,3) = PF*CT ! pz
34356C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34357 P(2,1) = P21
34358 P(2,2) = P22
34359 P(2,3) = P23
34360 P(2,4) = P24
34361 P(2,5) = P25
34362 beta1=-p(2,1)/p(2,4)
34363 beta2=-p(2,2)/p(2,4)
34364 beta3=-p(2,3)/p(2,4)
34365 N=2
34366C WRITE(6,*)' before transforming into target rest frame'
34367
34368 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34369
34370C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34371 N=5
34372
34373 phi11=atan(p(1,2)/p(1,3))
34374 pi(1)=p(1,1)
34375 pi(2)=p(1,2)
34376 pi(3)=p(1,3)
34377
34378 CALL DT_TESTROT(PI,Po,PHI11,1)
34379 DO ll=1,3
34380 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34381 END DO
34382c WRITE(*,*) po
34383 p(1,1)=po(1)
34384 p(1,2)=po(2)
34385 p(1,3)=po(3)
34386 phi12=atan(p(1,1)/p(1,3))
34387
34388 pi(1)=p(1,1)
34389 pi(2)=p(1,2)
34390 pi(3)=p(1,3)
34391 CALL DT_TESTROT(Pi,Po,PHI12,2)
34392 DO ll=1,3
34393 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34394 END DO
34395c WRITE(*,*) po
34396 p(1,1)=po(1)
34397 p(1,2)=po(2)
34398 p(1,3)=po(3)
34399
34400 enu=p(1,4)
34401
34402C...Kinematical limits in Q**2
34403c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34404 S = P(2,5)**2 + 2.*ENU*P(2,5)
34405 SQS = SQRT(S) ! E centro massa
34406 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34407 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34408 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34409 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34410 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34411 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34412 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34413
34414C...Generate Q**2
34415 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34416 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34417 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34418 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34419 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34420 NDSIG=NDSIG+1
34421C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34422C &Q2,Q2min,Q2MAX,DSIGEV
34423
34424C...c.m. frame. Neutrino along z axis
34425 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34426 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34427 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34428 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34429c WRITE(*,*)
34430c WRITE(*,*)
34431C WRITE(*,*) 'Input values laboratory frame'
34432 N=2
34433
34434 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34435
34436 N=5
34437c STHETA = ULANGL(P(1,3),P(1,1))
34438c write(*,*) 'stheta' ,stheta
34439c stheta=0.
34440c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34441c WRITE(*,*)
34442c WRITE(*,*)
34443C WRITE(*,*) 'Output values cm frame'
34444C...Kinematic in c.m. frame
34445 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34446 STSTAR = SQRT(1.-CTSTAR**2)
34447 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34448 P(4,5) = AML ! massa leptone
34449 P(4,4) = ELF ! e leptone
34450 P(4,3) = PLF*CTSTAR ! px
34451 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34452 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34453
34454 P(5,5) = AMF ! barione
34455 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34456 P(5,3) = -P(4,3) ! px
34457 P(5,1) = -P(4,1) ! py
34458 P(5,2) = -P(4,2) ! pz
34459
34460 P(3,5) = -Q2
34461 P(3,1) = P(1,1)-P(4,1)
34462 P(3,2) = P(1,2)-P(4,2)
34463 P(3,3) = P(1,3)-P(4,3)
34464 P(3,4) = P(1,4)-P(4,4)
34465
34466C...Transform back to laboratory frame
34467C WRITE(*,*) 'before going back to nucl rest frame'
34468c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34469 N=5
34470
34471 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34472
34473C WRITE(*,*) 'Now back in nucl rest frame'
34474 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34475
34476c********************************************
34477
34478 DO kw=1,5
34479 pi(1)=p(kw,1)
34480 pi(2)=p(kw,2)
34481 pi(3)=p(kw,3)
34482 CALL DT_TESTROT(Pi,Po,PHI12,3)
34483 DO ll=1,3
34484 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34485 END DO
34486 p(kw,1)=po(1)
34487 p(kw,2)=po(2)
34488 p(kw,3)=po(3)
34489 END DO
34490c********************************************
34491
34492 DO kw=1,5
34493 pi(1)=p(kw,1)
34494 pi(2)=p(kw,2)
34495 pi(3)=p(kw,3)
34496 CALL DT_TESTROT(Pi,Po,PHI11,4)
34497 DO ll=1,3
34498 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34499 END DO
34500 p(kw,1)=po(1)
34501 p(kw,2)=po(2)
34502 p(kw,3)=po(3)
34503 END DO
34504
34505c********************************************
34506
34507C WRITE(*,*) 'Now back in lab frame'
34508
34509 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34510
34511CGB+...
34512C...test (on final momentum of nucleon) if Fermi-blocking
34513C...is operating
34514 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34515 & - P(5,5)
34516 IF (ENUCL.LT. EFMAX) THEN
34517 IF(INIPRI.LT.10)THEN
34518 INIPRI=INIPRI+1
34519C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34520C...the interaction is not possible due to Pauli-Blocking and
34521C...it must be resampled
34522 ENDIF
34523 GOTO 100
34524 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34525 IF(INIPRI.LT.10)THEN
34526 INIPRI=INIPRI+1
34527C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34528 ENDIF
34529C Reject (J:R) here all these events
34530C are otherwise rejected in dpmjet
34531 GOTO 100
34532C...the interaction is possible, but the nucleon remains inside
34533C...the nucleus. The nucleus is therefore left excited.
34534C...We treat this case as a nucleon with 0 kinetic energy.
34535C P(5,5) = AMF
34536C P(5,4) = AMF
34537C P(5,1) = 0.
34538C P(5,2) = 0.
34539C P(5,3) = 0.
34540 ELSE IF (ENUCL.GE.ENWELL) THEN
34541C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34542C...the interaction is possible, the nucleon can exit the nucleus
34543C...but the nuclear well depth must be subtracted. The nucleus could be
34544C...left in an excited state.
34545 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34546C P(5,4) = ENUCL-ENWELL + AMF
34547 Pnucl = SQRT(P(5,4)**2-AMF**2)
34548C...The 3-momentum is scaled assuming that the direction remains
34549C...unaffected
34550 P(5,1) = P(5,1) * Pnucl/Pstart
34551 P(5,2) = P(5,2) * Pnucl/Pstart
34552 P(5,3) = P(5,3) * Pnucl/Pstart
34553C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34554 ENDIF
34555CGB-...
34556 DSIGSU=DSIGSU+DSIGEV
34557
34558 GA=P(4,4)/P(4,5)
34559 BGX=P(4,1)/P(4,5)
34560 BGY=P(4,2)/P(4,5)
34561 BGZ=P(4,3)/P(4,5)
34562*
34563 DBETB(1)=BGX/GA
34564 DBETB(2)=BGY/GA
34565 DBETB(3)=BGZ/GA
34566 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34567
34568 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34569
34570 ENDIF
34571c
34572C PRINT*,' FINE EVENTO '
34573 enu=enu0
34574 RETURN
34575
34576 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34577 END
34578
34579*$ CREATE DT_MASS_INI.FOR
34580*COPY DT_MASS_INI
34581C====================================================================
34582C. Masses
34583C====================================================================
34584*
34585*===mass_ini===========================================================*
34586*
34587 SUBROUTINE DT_MASS_INI
34588C...Initialize the kinematics for the quasi-elastic cross section
34589
34590 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34591 SAVE
34592
34593* particle masses used in qel neutrino scattering modules
34594 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34595 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34596 & EMPROTSQ,EMNEUTSQ,EMNSQ
34597
34598 EML(1) = 0.51100D-03 ! e-
34599 EML(2) = EML(1) ! e+
34600 EML(3) = 0.105659D0 ! mu-
34601 EML(4) = EML(3) ! mu+
34602 EML(5) = 1.7777D0 ! tau-
34603 EML(6) = EML(5) ! tau+
34604 EMPROT = 0.93827231D0 ! p
34605 EMNEUT = 0.93956563D0 ! n
34606 EMPROTSQ = EMPROT**2
34607 EMNEUTSQ = EMNEUT**2
34608 EMN = (EMPROT + EMNEUT)/2.
34609 EMNSQ = EMN**2
34610 DO J=1,3
34611 J0 = 2*(J-1)
34612 EMN1(J0+1) = EMNEUT
34613 EMN1(J0+2) = EMPROT
34614 EMN2(J0+1) = EMPROT
34615 EMN2(J0+2) = EMNEUT
34616 ENDDO
34617 DO J=1,6
34618 EMLSQ(J) = EML(J)**2
34619 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34620 ENDDO
34621 RETURN
34622 END
34623
34624*$ CREATE DT_DSQEL_Q2.FOR
34625*COPY DT_DSQEL_Q2
34626*
34627*===dsqel_q2===========================================================*
34628*
34629 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34630
34631C...differential cross section for Quasi-Elastic scattering
34632C. nu + N -> l + N'
34633C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34634C.
34635C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34636C. ENU (GeV) = Neutrino energy
34637C. Q2 (GeV**2) = (Transfer momentum)**2
34638C.
34639C. OUTPUT : DSQEL_Q2 = differential cross section :
34640C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34641C------------------------------------------------------------------
34642
34643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34644 SAVE
34645
34646* particle masses used in qel neutrino scattering modules
34647 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34648 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34649 & EMPROTSQ,EMNEUTSQ,EMNSQ
34650**sr - removed (not needed)
34651C COMMON /CAXIAL/ FA0, AXIAL2
34652**
34653
34654 DIMENSION SS(6)
34655 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34656 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34657 DATA AXIAL2 /1.03D0/ ! to be checked
34658
34659 FA0=-1.253D0
34660 CSI = 3.71D0 ! ???
34661 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34662 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34663 X = Q2/(EMN*EMN) ! emn=massa barione
34664 XA = X/4.D0
34665 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34666 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34667 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34668 FFA = FA*FA
34669 FFV1 = FV1*FV1
34670 FFV2 = FV2*FV2
34671 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34672 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34673 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34674 AA = (XA+0.25D0*RM)*(A1 + A2)
34675 BB = -X*FA*(FV1 + FV2)
34676 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34677 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34678 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34679 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34680
34681 RETURN
34682 END
34683
34684*$ CREATE DT_PREPOLA.FOR
34685*COPY DT_PREPOLA
34686*
34687*===prepola============================================================*
34688*
34689 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34690
34691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34692 SAVE
34693c
34694c By G. Battistoni and E. Scapparone (sept. 1997)
34695c According to:
34696c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34697c
34698c
34699 PARAMETER (MAXLND=4000)
34700 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34701
34702 COMMON /QNPOL/ POLARX(4),PMODUL
34703
34704* particle masses used in qel neutrino scattering modules
34705 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34706 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34707 & EMPROTSQ,EMNEUTSQ,EMNSQ
34708
34709* steering flags for qel neutrino scattering modules
34710 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34711**sr - removed (not needed)
34712C COMMON /CAXIAL/ FA0, AXIAL2
34713C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34714C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34715**
34716 REAL*8 POL(4,4),BB2(3)
34717 DIMENSION SS(6)
34718C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34719 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34720**sr uncommented since common block CAXIAL is now commented
34721 DATA AXIAL2 /1.03D0/ ! to be checked
34722**
34723
34724 RML=P(4,5)
34725 RMM=0.93960D+00
34726 FM2 = RMM**2
34727 MPI = 0.135D+00
34728 OLDQ2=Q2
34729 FA0=-1.253D+00
34730 CSI = 3.71D+00 !
34731 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34732 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34733 X = Q2/(EMN*EMN) ! emn=massa barione
34734 XA = X/4.D0
34735 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34736 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34737 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34738 FFA = FA*FA
34739 FFV1 = FV1*FV1
34740 FFV2 = FV2*FV2
34741 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34742 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34743 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34744 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34745 AA = (XA+0.25D+00*RM)*(A1 + A2)
34746 BB = -X*FA*(FV1 + FV2)
34747 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34748 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34749
34750 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34751 OMEGA2=4.D+00*CC
34752 OMEGA3=2.D+00*FA*(FV1+FV2)
34753 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34754 1 (Q2/FM2))*FP**2)
34755 OMEGA5=OMEGA2
34756 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34757 WW1=2.D+00*OMEGA1*EMN**2
34758 WW2=2.D+00*OMEGA2*EMN**2
34759 WW3=2.D+00*OMEGA3*EMN**2
34760 WW4=2.D+00*OMEGA4*EMN**2
34761 WW5=2.D+00*OMEGA5*EMN**2
34762
34763 DO I=1,3
34764 BB2(I)=-P(4,I)/P(4,4)
34765 END DO
34766c WRITE(*,*)
34767c WRITE(*,*)
34768c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34769 N=5
34770
34771 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34772
34773* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34774c WRITE(*,*)
34775c WRITE(*,*)
34776c WRITE(*,*) 'Prepola: now in lepton rest frame'
34777 EE=ENU
34778 QM2=Q2+RML**2
34779 U=Q2/(2.*RMM)
34780 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34781 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34782 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34783
34784 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34785 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34786
34787 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34788
34789 DO I=1,3
34790 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34791 POLARX(I)=POL(4,I)
34792 END DO
34793
34794 PMODUL=0.D0
34795 DO I=1,3
34796 PMODUL=PMODUL+POL(4,I)**2
34797 END DO
34798
34799 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34800 IF(NEUDEC.EQ.1) THEN
34801 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34802 + ETL,PXL,PYL,PZL,
34803 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34804c
34805c Tau has decayed in muon
34806c
34807 ENDIF
34808 IF(NEUDEC.EQ.2) THEN
34809 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34810 + ETL,PXL,PYL,PZL,
34811 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34812c
34813c Tau has decayed in electron
34814c
34815 ENDIF
34816 K(4,1)=15
34817 K(4,4) = 6
34818 K(4,5) = 8
34819 N=N+3
34820c
34821c fill common for muon(electron)
34822c
34823 P(6,1)=PXL
34824 P(6,2)=PYL
34825 P(6,3)=PZL
34826 P(6,4)=ETL
34827 K(6,1)=1
34828 IF(JTYP.EQ.5) THEN
34829 IF(NEUDEC.EQ.1) THEN
34830 P(6,5)=EML(JTYP-2)
34831 K(6,2)=13
34832 ELSEIF(NEUDEC.EQ.2) THEN
34833 P(6,5)=EML(JTYP-4)
34834 K(6,2)=11
34835 ENDIF
34836 ELSEIF(JTYP.EQ.6) THEN
34837 IF(NEUDEC.EQ.1) THEN
34838 K(6,2)=-13
34839 ELSEIF(NEUDEC.EQ.2) THEN
34840 K(6,2)=-11
34841 ENDIF
34842 END IF
34843 K(6,3)=4
34844 K(6,4)=0
34845 K(6,5)=0
34846c
34847c fill common for tau_(anti)neutrino
34848c
34849 P(7,1)=PXB
34850 P(7,2)=PYB
34851 P(7,3)=PZB
34852 P(7,4)=ETB
34853 P(7,5)=0.
34854 K(7,1)=1
34855 IF(JTYP.EQ.5) THEN
34856 K(7,2)=16
34857 ELSEIF(JTYP.EQ.6) THEN
34858 K(7,2)=-16
34859 END IF
34860 K(7,3)=4
34861 K(7,4)=0
34862 K(7,5)=0
34863c
34864c Fill common for muon(electron)_(anti)neutrino
34865c
34866 P(8,1)=PXN
34867 P(8,2)=PYN
34868 P(8,3)=PZN
34869 P(8,4)=ETN
34870 P(8,5)=0.
34871 K(8,1)=1
34872 IF(JTYP.EQ.5) THEN
34873 IF(NEUDEC.EQ.1) THEN
34874 K(8,2)=-14
34875 ELSEIF(NEUDEC.EQ.2) THEN
34876 K(8,2)=-12
34877 ENDIF
34878 ELSEIF(JTYP.EQ.6) THEN
34879 IF(NEUDEC.EQ.1) THEN
34880 K(8,2)=14
34881 ELSEIF(NEUDEC.EQ.2) THEN
34882 K(8,2)=12
34883 ENDIF
34884 END IF
34885 K(8,3)=4
34886 K(8,4)=0
34887 K(8,5)=0
34888 ENDIF
34889c WRITE(*,*)
34890c WRITE(*,*)
34891
34892c IF(PMODUL.GE.1.D+00) THEN
34893c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34894c write(*,*) pmodul
34895c DO I=1,3
34896c POL(4,I)=POL(4,I)/PMODUL
34897c POLARX(I)=POL(4,I)
34898c END DO
34899c PMODUL=0.
34900c DO I=1,3
34901c PMODUL=PMODUL+POL(4,I)**2
34902c END DO
34903c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34904c
34905c ENDIF
34906
34907c WRITE(*,*) 'PMODUL = ',PMODUL
34908
34909c WRITE(*,*)
34910c WRITE(*,*)
34911c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34912
34913 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34914
34915 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34916 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34917 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34918 DO NDC =6,8
34919 V(NDC,1) = XDC
34920 V(NDC,2) = YDC
34921 V(NDC,3) = ZDC
34922 END DO
34923
34924 RETURN
34925 END
34926
34927*$ CREATE DT_TESTROT.FOR
34928*COPY DT_TESTROT
34929*
34930*===testrot============================================================*
34931*
34932 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34933
34934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34935 SAVE
34936
34937 DIMENSION ROT(3,3),PI(3),PO(3)
34938
34939 IF (MODE.EQ.1) THEN
34940 ROT(1,1) = 1.D0
34941 ROT(1,2) = 0.D0
34942 ROT(1,3) = 0.D0
34943 ROT(2,1) = 0.D0
34944 ROT(2,2) = COS(PHI)
34945 ROT(2,3) = -SIN(PHI)
34946 ROT(3,1) = 0.D0
34947 ROT(3,2) = SIN(PHI)
34948 ROT(3,3) = COS(PHI)
34949 ELSEIF (MODE.EQ.2) THEN
34950 ROT(1,1) = 0.D0
34951 ROT(1,2) = 1.D0
34952 ROT(1,3) = 0.D0
34953 ROT(2,1) = COS(PHI)
34954 ROT(2,2) = 0.D0
34955 ROT(2,3) = -SIN(PHI)
34956 ROT(3,1) = SIN(PHI)
34957 ROT(3,2) = 0.D0
34958 ROT(3,3) = COS(PHI)
34959 ELSEIF (MODE.EQ.3) THEN
34960 ROT(1,1) = 0.D0
34961 ROT(2,1) = 1.D0
34962 ROT(3,1) = 0.D0
34963 ROT(1,2) = COS(PHI)
34964 ROT(2,2) = 0.D0
34965 ROT(3,2) = -SIN(PHI)
34966 ROT(1,3) = SIN(PHI)
34967 ROT(2,3) = 0.D0
34968 ROT(3,3) = COS(PHI)
34969 ELSEIF (MODE.EQ.4) THEN
34970 ROT(1,1) = 1.D0
34971 ROT(2,1) = 0.D0
34972 ROT(3,1) = 0.D0
34973 ROT(1,2) = 0.D0
34974 ROT(2,2) = COS(PHI)
34975 ROT(3,2) = -SIN(PHI)
34976 ROT(1,3) = 0.D0
34977 ROT(2,3) = SIN(PHI)
34978 ROT(3,3) = COS(PHI)
34979 ELSE
34980 STOP ' TESTROT: mode not supported!'
34981 ENDIF
34982 DO 1 J=1,3
34983 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34984 1 CONTINUE
34985
34986 RETURN
34987 END
34988
34989*$ CREATE DT_LEPDCYP.FOR
34990*COPY DT_LEPDCYP
34991*
34992*===lepdcyp============================================================*
34993*
34994 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34995 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34996C
34997C-----------------------------------------------------------------
34998C
34999C Author :- G. Battistoni 10-NOV-1995
35000C
35001C=================================================================
35002C
35003C Purpose : performs decay of polarized lepton in
35004C its rest frame: a => b + l + anti-nu
35005C (Example: mu- => nu-mu + e- + anti-nu-e)
35006C Polarization is assumed along Z-axis
35007C WARNING:
35008C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35009C OF NEGLIGIBLE MASS
35010C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35011C IN THIS VERSION
35012C
35013C Method : modifies phase space distribution obtained
35014C by routine EXPLOD using a rejection against the
35015C matrix element for unpolarized lepton decay
35016C
35017C Inputs : Mass of a : AMA
35018C Mass of l : AML
35019C Polar. of a: POL
35020C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35021C POL = -1)
35022C
35023C Outputs : kinematic variables in the rest frame of decaying lepton
35024C ETL,PXL,PYL,PZL 4-moment of l
35025C ETB,PXB,PYB,PZB 4-moment of b
35026C ETN,PXN,PYN,PZN 4-moment of anti-nu
35027C
35028C============================================================
35029C +
35030C Declarations.
35031C -
35032 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35033 SAVE
35034
35035 PARAMETER ( LINP = 10 ,
35036 & LOUT = 6 ,
35037 & LDAT = 9 )
35038
35039 PARAMETER ( KALGNM = 2 )
35040 PARAMETER ( ANGLGB = 5.0D-16 )
35041 PARAMETER ( ANGLSQ = 2.5D-31 )
35042 PARAMETER ( AXCSSV = 0.2D+16 )
35043 PARAMETER ( ANDRFL = 1.0D-38 )
35044 PARAMETER ( AVRFLW = 1.0D+38 )
35045 PARAMETER ( AINFNT = 1.0D+30 )
35046 PARAMETER ( AZRZRZ = 1.0D-30 )
35047 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35048 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35049 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35050 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35051 PARAMETER ( CSNNRM = 2.0D-15 )
35052 PARAMETER ( DMXTRN = 1.0D+08 )
35053 PARAMETER ( ZERZER = 0.D+00 )
35054 PARAMETER ( ONEONE = 1.D+00 )
35055 PARAMETER ( TWOTWO = 2.D+00 )
35056 PARAMETER ( THRTHR = 3.D+00 )
35057 PARAMETER ( FOUFOU = 4.D+00 )
35058 PARAMETER ( FIVFIV = 5.D+00 )
35059 PARAMETER ( SIXSIX = 6.D+00 )
35060 PARAMETER ( SEVSEV = 7.D+00 )
35061 PARAMETER ( EIGEIG = 8.D+00 )
35062 PARAMETER ( ANINEN = 9.D+00 )
35063 PARAMETER ( TENTEN = 10.D+00 )
35064 PARAMETER ( HLFHLF = 0.5D+00 )
35065 PARAMETER ( ONETHI = ONEONE / THRTHR )
35066 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35067 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35068 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35069 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35070 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35071 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35072 PARAMETER ( AMELGR = 9.1093897 D-28 )
35073 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35074 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35075 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35076 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35077 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35078 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35079 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35080 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35081 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35082 PARAMETER ( PLABRC = 0.197327053 D+00 )
35083 PARAMETER ( AMELCT = 0.51099906 D-03 )
35084 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35085 PARAMETER ( AMMUON = 0.105658389 D+00 )
35086 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35087 PARAMETER ( GEVMEV = 1.0 D+03 )
35088 PARAMETER ( EMVGEV = 1.0 D-03 )
35089 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35090 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35091 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35092C +
35093C variables for EXPLOD
35094C -
35095 PARAMETER ( KPMX = 10 )
35096 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35097 & PZEXPL (KPMX), ETEXPL (KPMX)
35098C +
35099C test variables
35100C -
35101**sr - removed (not needed)
35102C COMMON /GBATNU/ ELERAT,NTRY
35103**
35104C +
35105C Initializes test variables
35106C -
35107 NTRY = 0
35108 ELERAT = 0.D+00
35109C +
35110C Maximum value for matrix element
35111C -
35112 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35113 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35114C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35115C Inputs for EXPLOD
35116C part. no. 1 is l (e- in mu- decay)
35117C part. no. 2 is b (nu-mu in mu- decay)
35118C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35119C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35120 NPEXPL = 3
35121 ETOTEX = AMA
35122 AMEXPL(1) = AML
35123 AMEXPL(2) = 0.D+00
35124 AMEXPL(3) = 0.D+00
35125C +
35126C phase space distribution
35127C -
35128 100 CONTINUE
35129 NTRY = NTRY + 1
35130
35131 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35132 & PYEXPL, PZEXPL )
35133
35134C +
35135C Calculates matrix element:
35136C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35137C Here CTH is the cosine of the angle between anti-nu and Z axis
35138C -
35139 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35140 & PZEXPL(3)**2 )
35141 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35142 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35143 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35144 ELEMAT = 16.D+00 * PROD1 * PROD2
35145 IF(ELEMAT.GT.ELEMAX) THEN
35146 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35147 STOP
35148 ENDIF
35149C +
35150C Here performs the rejection
35151C -
35152 TEST = DT_RNDM(ETOTEX) * ELEMAX
35153 IF ( TEST .GT. ELEMAT ) GO TO 100
35154C +
35155C final assignment of variables
35156C -
35157 ELERAT = ELEMAT/ELEMAX
35158 ETL = ETEXPL(1)
35159 PXL = PXEXPL(1)
35160 PYL = PYEXPL(1)
35161 PZL = PZEXPL(1)
35162 ETB = ETEXPL(2)
35163 PXB = PXEXPL(2)
35164 PYB = PYEXPL(2)
35165 PZB = PZEXPL(2)
35166 ETN = ETEXPL(3)
35167 PXN = PXEXPL(3)
35168 PYN = PYEXPL(3)
35169 PZN = PZEXPL(3)
35170 999 RETURN
35171 END
35172
35173*$ CREATE DT_GEN_DELTA.FOR
35174*COPY DT_GEN_DELTA
35175C==================================================================
35176C. Generation of Delta resonance events
35177C==================================================================
35178*
35179*===gen_delta==========================================================*
35180*
35181 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35182
35183 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35184 SAVE
35185
35186 PARAMETER ( LINP = 10 ,
35187 & LOUT = 6 ,
35188 & LDAT = 9 )
35189
35190C...Generate a Delta-production neutrino/antineutrino
35191C. CC-interaction on a nucleon
35192C
35193C. INPUT ENU (GeV) = Neutrino Energy
35194C. LLEP = neutrino type
35195C. LTARG = nucleon target type 1=p, 2=n.
35196C. JINT = 1:CC, 2::NC
35197C.
35198C. OUTPUT PPL(4) 4-monentum of final lepton
35199C----------------------------------------------------
35200 PARAMETER (MAXLND=4000)
35201 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35202
35203**sr - removed (not needed)
35204C COMMON /CBAD/ LBAD, NBAD
35205**
35206
35207 DIMENSION PI(3),PO(3)
35208C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35209 DIMENSION AML0(6),AMN(2)
35210 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35211 DATA AMN /0.93827231, 0.93956563/
35212 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35213
35214c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35215 LBAD = 0
35216C...Final lepton mass
35217 IF (JINT.EQ.1) THEN
35218 AML = AML0(LLEP)
35219 ELSE
35220 AML = 0.
35221 ENDIF
35222 AML2 = AML**2
35223
35224C...Particle labels (LUND)
35225 N = 5
35226 K(1,1) = 21
35227 K(2,1) = 21
35228 K(3,1) = 21
35229 K(4,1) = 1
35230 K(3,3) = 1
35231 K(4,3) = 1
35232 IF (LTARG .EQ. 1) THEN
35233 K(2,2) = 2212
35234 ELSE
35235 K(2,2) = 2112
35236 ENDIF
35237 K0 = (LLEP-1)/2
35238 K1 = LLEP/2
35239 KA = 12 + 2*K0
35240 IS = -1 + 2*LLEP - 4*K1
35241 LNU = 2 - LLEP + 2*K1
35242 K(1,2) = IS*KA
35243 K(5,1) = 1
35244 K(5,3) = 2
35245 IF (JINT .EQ. 1) THEN ! CC interactions
35246 K(3,2) = IS*24
35247 K(4,2) = IS*(KA-1)
35248 IF(LNU.EQ.1) THEN
35249 IF (LTARG .EQ. 1) THEN
35250 K(5,2) = 2224
35251 ELSE
35252 K(5,2) = 2214
35253 ENDIF
35254 ELSE
35255 IF (LTARG .EQ. 1) THEN
35256 K(5,2) = 2114
35257 ELSE
35258 K(5,2) = 1114
35259 ENDIF
35260 ENDIF
35261 ELSE
35262 K(3,2) = 23 ! NC (Z0) interactions
35263 K(4,2) = K(1,2)
35264**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35265* Delta0 for neutron (LTARG=2)
35266C IF (LTARG .EQ. 1) THEN
35267C K(5,2) = 2114
35268C ELSE
35269C K(5,2) = 2214
35270C ENDIF
35271 IF (LTARG .EQ. 1) THEN
35272 K(5,2) = 2214
35273 ELSE
35274 K(5,2) = 2114
35275 ENDIF
35276**
35277 ENDIF
35278
35279C...4-momentum initial lepton
35280 P(1,5) = 0.
35281 P(1,4) = ENU
35282 P(1,1) = 0.
35283 P(1,2) = 0.
35284 P(1,3) = ENU
35285C...4-momentum initial nucleon
35286 P(2,5) = AMN(LTARG)
35287C P(2,4) = P(2,5)
35288C P(2,1) = 0.
35289C P(2,2) = 0.
35290C P(2,3) = 0.
35291 P(2,1) = P21
35292 P(2,2) = P22
35293 P(2,3) = P23
35294 P(2,4) = P24
35295 P(2,5) = P25
35296 N=2
35297 beta1=-p(2,1)/p(2,4)
35298 beta2=-p(2,2)/p(2,4)
35299 beta3=-p(2,3)/p(2,4)
35300 N=2
35301
35302 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35303
35304C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35305
35306 phi11=atan(p(1,2)/p(1,3))
35307 pi(1)=p(1,1)
35308 pi(2)=p(1,2)
35309 pi(3)=p(1,3)
35310
35311 CALL DT_TESTROT(PI,Po,PHI11,1)
35312 DO ll=1,3
35313 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35314 END DO
35315 p(1,1)=po(1)
35316 p(1,2)=po(2)
35317 p(1,3)=po(3)
35318 phi12=atan(p(1,1)/p(1,3))
35319
35320 pi(1)=p(1,1)
35321 pi(2)=p(1,2)
35322 pi(3)=p(1,3)
35323 CALL DT_TESTROT(Pi,Po,PHI12,2)
35324 DO ll=1,3
35325 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35326 END DO
35327 p(1,1)=po(1)
35328 p(1,2)=po(2)
35329 p(1,3)=po(3)
35330
35331 ENUU=P(1,4)
35332
35333C...Generate the Mass of the Delta
35334 NTRY = 0
35335100 R = PYR(0)
35336 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35337 NTRY = NTRY + 1
35338 IF (NTRY .GT. 1000) THEN
35339 LBAD = 1
35340 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35341 RETURN
35342 ENDIF
35343 IF (AMD .LT. AMDMIN) GOTO 100
35344 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35345 IF (ENUU .LT. ET) GOTO 100
35346
35347C...Kinematical limits in Q**2
35348 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35349 SQS = SQRT(S)
35350 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35351 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35352 PLF = SQRT(ELF**2 - AML2)
35353 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35354 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35355 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35356
35357 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35358200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35359 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35360 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35361
35362C...Generate the kinematics of the final particles
35363 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35364 GAM = EISTAR/AMN(LTARG)
35365 BET = PSTAR/EISTAR
35366 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35367 EL = GAM*(ELF + BET*PLF*CTSTAR)
35368 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35369 PL = SQRT(EL**2 - AML2)
35370 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35371 PHI = 6.28319*PYR(0)
35372 P(4,1) = PLT*COS(PHI)
35373 P(4,2) = PLT*SIN(PHI)
35374 P(4,3) = PLZ
35375 P(4,4) = EL
35376 P(4,5) = AML
35377
35378C...4-momentum of Delta
35379 P(5,1) = -P(4,1)
35380 P(5,2) = -P(4,2)
35381 P(5,3) = ENUU-P(4,3)
35382 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35383 P(5,5) = AMD
35384
35385C...4-momentum of intermediate boson
35386 P(3,5) = -Q2
35387 P(3,4) = P(1,4)-P(4,4)
35388 P(3,1) = P(1,1)-P(4,1)
35389 P(3,2) = P(1,2)-P(4,2)
35390 P(3,3) = P(1,3)-P(4,3)
35391 N=5
35392
35393 DO kw=1,5
35394 pi(1)=p(kw,1)
35395 pi(2)=p(kw,2)
35396 pi(3)=p(kw,3)
35397 CALL DT_TESTROT(Pi,Po,PHI12,3)
35398 DO ll=1,3
35399 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35400 END DO
35401 p(kw,1)=po(1)
35402 p(kw,2)=po(2)
35403 p(kw,3)=po(3)
35404 END DO
35405
35406c********************************************
35407
35408 DO kw=1,5
35409 pi(1)=p(kw,1)
35410 pi(2)=p(kw,2)
35411 pi(3)=p(kw,3)
35412 CALL DT_TESTROT(Pi,Po,PHI11,4)
35413 DO ll=1,3
35414 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35415 END DO
35416 p(kw,1)=po(1)
35417 p(kw,2)=po(2)
35418 p(kw,3)=po(3)
35419 END DO
35420c********************************************
35421C transform back into Lab.
35422
35423 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35424
35425C WRITE(6,*)' Lab fram ( fermi incl.) '
35426 N=5
35427 CALL PYEXEC
35428
35429 RETURN
354301001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35431 END
35432
35433*$ CREATE DT_DSIGMA_DELTA.FOR
35434*COPY DT_DSIGMA_DELTA
35435*
35436*===dsigma_delta=======================================================*
35437*
35438 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35439
35440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35441 SAVE
35442
35443C...Reaction nu + N -> lepton + Delta
35444C. returns the cross section
35445C. dsigma/dt
35446C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35447C. QQ = t (always negative) GeV**2
35448C. S = (c.m energy)**2 GeV**2
35449C. OUTPUT = 10**-38 cm+2/GeV**2
35450C-----------------------------------------------------
35451 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35452 DATA MN /0.938/
35453 DATA PI /3.1415926/
35454
35455 GF = (1.1664 * 1.97)
35456 GF2 = GF*GF
35457 MN2 = MN*MN
35458 MN4 = MN2*MN2
35459 MD2 = MD*MD
35460 MD4 = MD2*MD2
35461 AML2 = AML*AML
35462 AML4 = AML2*AML2
35463 VQ = (MN2 - MD2 - QQ)/2.
35464 VPI = (MN2 + MD2 - QQ)/2.
35465 VK = (S + QQ - MN2 - AML2)/2.
35466 PIK = (S - MN2)/2.
35467 QK = (AML2 - QQ)/2.
35468 PIQ = (QQ + MN2 - MD2)/2.
35469 Q = SQRT(-QQ)
35470 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35471 C3 = SQRT(3.)*C3V/MN
35472 C4 = -C3/MD ! attenzione al segno
35473 C5A = 1.18/(1.-QQ/0.4225)**2
35474 C32 = C3**2
35475 C42 = C4**2
35476 C5A2 = C5A**2
35477
35478 IF (LNU .EQ. 1) THEN
35479 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35480 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35481 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35482 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35483 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35484 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35485 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35486 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35487 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35488 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35489 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35490 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35491 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35492 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35493 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35494 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35495 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35496 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35497 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35498 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35499 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35500 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35501 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35502 ELSE
35503 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35504 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35505 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35506 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35507 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35508 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35509 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35510 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35511 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35512 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35513 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35514 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35515 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35516 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35517 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35518 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35519 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35520 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35521 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35522 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35523 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35524 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35525 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35526 ENDIF
35527 ANS1=32.*ANS2
35528 ANS=ANS1/(3.*MD2)
35529 P1CM = (S-MN2)/(2.*SQRT(S))
35530 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35531
35532 RETURN
35533 END
35534
35535*$ CREATE DT_QGAUS.FOR
35536*COPY DT_QGAUS
35537*
35538*===qgaus==============================================================*
35539*
35540 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35541
35542 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35543 SAVE
35544
35545 DIMENSION X(5),W(5)
35546 DATA X/.1488743389D0,.4333953941D0,
35547 & .6794095682D0,.8650633666D0,.9739065285D0
35548 */
35549 DATA W/.2955242247D0,.2692667193D0,
35550 & .2190863625D0,.1494513491D0,.0666713443D0
35551 */
35552 XM=0.5D0*(B+A)
35553 XR=0.5D0*(B-A)
35554 SS=0
35555 DO 11 J=1,5
35556 DX=XR*X(J)
35557 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35558 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3555911 CONTINUE
35560 SS=XR*SS
35561
35562 RETURN
35563 END
35564*$ CREATE DT_DIQBRK.FOR
35565*COPY DT_DIQBRK
35566*
35567*===diqbrk=============================================================*
35568*
35569 SUBROUTINE DT_DIQBRK
35570
35571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35572 SAVE
35573
35574* event history
35575
35576 PARAMETER (NMXHKK=200000)
35577
35578 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35579 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35580 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35581
35582* extended event history
35583 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35584 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35585 & IHIST(2,NMXHKK)
35586
35587* event flag
35588 COMMON /DTEVNO/ NEVENT,ICASCA
35589
35590C IF(DT_RNDM(VV).LE.0.5D0)THEN
35591C CALL GSQBS1(NHKK)
35592C CALL GSQBS2(NHKK)
35593C CALL USQBS1(NHKK)
35594C CALL USQBS2(NHKK)
35595C CALL GSABS1(NHKK)
35596C CALL GSABS2(NHKK)
35597C CALL USABS1(NHKK)
35598C CALL USABS2(NHKK)
35599C ELSE
35600C CALL GSQBS2(NHKK)
35601C CALL GSQBS1(NHKK)
35602C CALL USQBS2(NHKK)
35603C CALL USQBS1(NHKK)
35604C CALL GSABS2(NHKK)
35605C CALL GSABS1(NHKK)
35606C CALL USABS2(NHKK)
35607C CALL USABS1(NHKK)
35608C ENDIF
35609
35610 IF(DT_RNDM(VV).LE.0.5D0) THEN
35611 CALL DT_DBREAK(1)
35612 CALL DT_DBREAK(2)
35613 CALL DT_DBREAK(3)
35614 CALL DT_DBREAK(4)
35615 CALL DT_DBREAK(5)
35616 CALL DT_DBREAK(6)
35617 CALL DT_DBREAK(7)
35618 CALL DT_DBREAK(8)
35619 ELSE
35620 CALL DT_DBREAK(2)
35621 CALL DT_DBREAK(1)
35622 CALL DT_DBREAK(4)
35623 CALL DT_DBREAK(3)
35624 CALL DT_DBREAK(6)
35625 CALL DT_DBREAK(5)
35626 CALL DT_DBREAK(8)
35627 CALL DT_DBREAK(7)
35628 ENDIF
35629
35630 RETURN
35631 END
35632
35633*$ CREATE MUSQBS2.FOR
35634*COPY MUSQBS2
35635C
35636C
35637C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35638 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35639 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35640C
35641C USQBS-2 diagram (split target diquark)
35642C
35643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35644 SAVE
35645
35646 PARAMETER ( LINP = 10 ,
35647 & LOUT = 6 ,
35648 & LDAT = 9 )
35649
35650* event history
35651
35652 PARAMETER (NMXHKK=200000)
35653
35654 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35655 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35656 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35657
35658* extended event history
35659 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35660 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35661 & IHIST(2,NMXHKK)
35662
35663* Lorentz-parameters of the current interaction
35664 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35665 & UMO,PPCM,EPROJ,PPROJ
35666
35667* diquark-breaking mechanism
35668 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35669
35670C
35671 PARAMETER (NTMHKK= 300)
35672 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35673 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35674 +(4,NTMHKK)
35675*KEEP,XSEADI.
35676 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35677 +SSMIMQ,VVMTHR
35678*KEEP,DPRIN.
35679 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35680 COMMON /EVFLAG/ NUMEV
35681C
35682C USQBS-2 diagram (split target diquark)
35683C
35684C
35685C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35686C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35687C
35688C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35689C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35690C
35691C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35692C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35693C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35694C
35695C
35696C Put new chains into COMMON /HKKTMP/
35697C
35698 IIGLU1=NC1T-NC1P-1
35699 IIGLU2=NC2T-NC2P-1
35700 IGCOUN=0
35701C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35702 CVQ=1.D0
35703 IREJ=0
35704 IF(IPIP.EQ.2)THEN
35705C IF(NUMEV.EQ.-324)THEN
35706C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35707C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35708C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35709C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35710 ENDIF
35711C
35712C
35713C
35714C determine x-values of NC1T diquark
35715 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35716 XVQP=PHKK(4,NC1P)*2.D0/UMO
35717C
35718C determine x-values of sea quark pair
35719C
35720 IPCO=1
35721 ICOU=0
35722 2234 CONTINUE
35723 ICOU=ICOU+1
35724 IF(ICOU.GE.500)THEN
35725 IREJ=1
35726 IF(ISQ.EQ.3)IREJ=3
35727 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35728 IPCO=0
35729 RETURN
35730 ENDIF
35731 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35732 * UMO, XDIQT,XVQP
35733 XSQ=0.D0
35734 XSAQ=0.D0
35735**NEW
35736C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35737 IF (IPIP.EQ.1) THEN
35738 XQMAX = XDIQT/2.0D0
35739 XAQMAX = 2.D0*XVQP/3.0D0
35740 ELSE
35741 XQMAX = 2.D0*XVQP/3.0D0
35742 XAQMAX = XDIQT/2.0D0
35743 ENDIF
35744 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35745 ISAQ = 6+ISQ
35746C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35747**
35748 IF(IPCO.GE.3)
35749 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35750 IF(IREJ.GE.1)THEN
35751 IF(IPCO.GE.3)
35752 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35753 IPCO=0
35754 RETURN
35755 ENDIF
35756 IF(IPIP.EQ.1)THEN
35757 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35758 ELSEIF(IPIP.EQ.2)THEN
35759 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35760 ENDIF
35761 IF(IPCO.GE.3)THEN
35762 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35763 & XDIQT,XVQP,XSQ,XSAQ
35764 ENDIF
35765C
35766C subtract xsq,xsaq from NC1T diquark and NC1P quark
35767C
35768C XSQ=0.D0
35769 IF(IPIP.EQ.1)THEN
35770 XDIQT=XDIQT-XSQ
35771 XVQP =XVQP -XSAQ
35772 ELSEIF(IPIP.EQ.2)THEN
35773 XDIQT=XDIQT-XSAQ
35774 XVQP =XVQP -XSQ
35775 ENDIF
35776 IF(IPCO.GE.3)
35777 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35778C
35779C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35780C
35781 XVTHRO=CVQ/UMO
35782 IVTHR=0
35783 3466 CONTINUE
35784 IF(IVTHR.EQ.10)THEN
35785 IREJ=1
35786 IF(ISQ.EQ.3)IREJ=3
35787 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35788 IPCO=0
35789 RETURN
35790 ENDIF
35791 IVTHR=IVTHR+1
35792 XVTHR=XVTHRO/(201-IVTHR)
35793 UNOPRV=UNON
35794 380 CONTINUE
35795 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35796 IREJ=1
35797 IF(ISQ.EQ.3)IREJ=3
35798 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35799 * XVTHR
35800 IPCO=0
35801 RETURN
35802 ENDIF
35803 IF(DT_RNDM(V).LT.0.5D0)THEN
35804 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35805 XVTQII=XDIQT-XVTQI
35806 ELSE
35807 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35808 XVTQI=XDIQT-XVTQII
35809 ENDIF
35810 IF(IPCO.GE.3)THEN
35811 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35812 ENDIF
35813C
35814C Prepare 4 momenta of new chains and chain ends
35815C
35816C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35817C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35818C +(4,NTMHKK)
35819C
35820C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35821C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35822C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35823C
35824C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35825C * IP1,IP21,IP22,IPP1,IPP2)
35826C
35827 IF(IPIP.EQ.1)THEN
35828 XSQ1=XSQ
35829 XSAQ1=XSAQ
35830 ISQ1=ISQ
35831 ISAQ1=ISAQ
35832 ELSEIF(IPIP.EQ.2)THEN
35833 XSQ1=XSAQ
35834 XSAQ1=XSQ
35835 ISQ1=ISAQ
35836 ISAQ1=ISQ
35837 ENDIF
35838 IDHKT(1) =IPP1
35839 ISTHKT(1) =951
35840 JMOHKT(1,1)=NC2P
35841 JMOHKT(2,1)=0
35842 JDAHKT(1,1)=3+IIGLU1
35843 JDAHKT(2,1)=0
35844C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35845 PHKT(1,1) =PHKK(1,NC2P)
35846 PHKT(2,1) =PHKK(2,NC2P)
35847 PHKT(3,1) =PHKK(3,NC2P)
35848 PHKT(4,1) =PHKK(4,NC2P)
35849C PHKT(5,1) =PHKK(5,NC2P)
35850 XMIST =(PHKT(4,1)**2-
35851 * PHKT(3,1)**2-PHKT(2,1)**2-
35852 *PHKT(1,1)**2)
35853 IF(XMIST.GT.0.D0)THEN
35854 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35855 *PHKT(1,1)**2)
35856 ELSE
35857C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35858 PHKT(5,1)=0.D0
35859 ENDIF
35860 VHKT(1,1) =VHKK(1,NC2P)
35861 VHKT(2,1) =VHKK(2,NC2P)
35862 VHKT(3,1) =VHKK(3,NC2P)
35863 VHKT(4,1) =VHKK(4,NC2P)
35864 WHKT(1,1) =WHKK(1,NC2P)
35865 WHKT(2,1) =WHKK(2,NC2P)
35866 WHKT(3,1) =WHKK(3,NC2P)
35867 WHKT(4,1) =WHKK(4,NC2P)
35868C Add here IIGLU1 gluons to this chaina
35869 PG1=0.D0
35870 PG2=0.D0
35871 PG3=0.D0
35872 PG4=0.D0
35873 IF(IIGLU1.GE.1)THEN
35874 JJG=NC1P
35875 DO 61 IIG=2,2+IIGLU1-1
35876 KKG=JJG+IIG-1
35877 IDHKT(IIG) =IDHKK(KKG)
35878 ISTHKT(IIG) =921
35879 JMOHKT(1,IIG)=KKG
35880 JMOHKT(2,IIG)=0
35881 JDAHKT(1,IIG)=3+IIGLU1
35882 JDAHKT(2,IIG)=0
35883 PHKT(1,IIG)=PHKK(1,KKG)
35884 PG1=PG1+ PHKT(1,IIG)
35885 PHKT(2,IIG)=PHKK(2,KKG)
35886 PG2=PG2+ PHKT(2,IIG)
35887 PHKT(3,IIG)=PHKK(3,KKG)
35888 PG3=PG3+ PHKT(3,IIG)
35889 PHKT(4,IIG)=PHKK(4,KKG)
35890 PG4=PG4+ PHKT(4,IIG)
35891 PHKT(5,IIG)=PHKK(5,KKG)
35892 VHKT(1,IIG) =VHKK(1,KKG)
35893 VHKT(2,IIG) =VHKK(2,KKG)
35894 VHKT(3,IIG) =VHKK(3,KKG)
35895 VHKT(4,IIG) =VHKK(4,KKG)
35896 WHKT(1,IIG) =WHKK(1,KKG)
35897 WHKT(2,IIG) =WHKK(2,KKG)
35898 WHKT(3,IIG) =WHKK(3,KKG)
35899 WHKT(4,IIG) =WHKK(4,KKG)
35900 61 CONTINUE
35901 ENDIF
35902 IDHKT(2+IIGLU1) =IP21
35903 ISTHKT(2+IIGLU1) =952
35904 JMOHKT(1,2+IIGLU1)=NC1T
35905 JMOHKT(2,2+IIGLU1)=0
35906 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35907 JDAHKT(2,2+IIGLU1)=0
35908 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35909 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35910 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35911 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35912C PHKT(5,2) =PHKK(5,NC1T)
35913 XMIST =(PHKT(4,2+IIGLU1)**2-
35914 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35915 *PHKT(1,2+IIGLU1)**2)
35916 IF(XMIST.GT.0.D0)THEN
35917 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35918 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35919 *PHKT(1,2+IIGLU1)**2)
35920 ELSE
35921C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35922 PHKT(5,5+IIGLU1)=0.D0
35923 ENDIF
35924 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35925 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35926 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35927 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35928 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35929 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35930 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35931 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35932 IDHKT(3+IIGLU1) =88888
35933 ISTHKT(3+IIGLU1) =95
35934 JMOHKT(1,3+IIGLU1)=1
35935 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35936 JDAHKT(1,3+IIGLU1)=0
35937 JDAHKT(2,3+IIGLU1)=0
35938 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35939 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35940 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35941 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35942 XMIST
35943 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35944 * -PHKT(3,3+IIGLU1)**2)
35945 IF(XMIST.GT.0.D0)THEN
35946 PHKT(5,3+IIGLU1)
35947 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35948 * -PHKT(3,3+IIGLU1)**2)
35949 ELSE
35950C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35951 PHKT(5,5+IIGLU1)=0.D0
35952 ENDIF
35953 IF(IPIP.GE.2)THEN
35954C IF(NUMEV.EQ.-324)THEN
35955C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35956C * JDAHKT(1,1),
35957C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35958 DO 71 IIG=2,2+IIGLU1-1
35959C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35960C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35961C * JDAHKT(1,IIG),
35962C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35963 71 CONTINUE
35964C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35965C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35966C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35967C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35968C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35969C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35970 ENDIF
35971 CHAMAL=CHAM1
35972 IF(IPIP.EQ.1)THEN
35973 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35974 ELSEIF(IPIP.EQ.2)THEN
35975 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35976 ENDIF
35977 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35978C IREJ=1
35979 IPCO=0
35980C RETURN
35981C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35982 GO TO 3466
35983 ENDIF
35984 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35985 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35986 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35987 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35988 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35989 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35990 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35991 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35992 IF(IPIP.EQ.1)THEN
35993 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35994 ELSEIF(IPIP.EQ.2)THEN
35995 IDHKT(4+IIGLU1) =ISAQ1
35996 ENDIF
35997 ISTHKT(4+IIGLU1) =951
35998 JMOHKT(1,4+IIGLU1)=NC1P
35999 JMOHKT(2,4+IIGLU1)=0
36000 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36001 JDAHKT(2,4+IIGLU1)=0
36002C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36003 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36004 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36005 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36006 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36007C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36008 XMIST =(PHKT(4,4+IIGLU1)**2-
36009 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36010 *PHKT(1,4+IIGLU1)**2)
36011 IF(XMIST.GT.0.D0)THEN
36012 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36013 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36014 *PHKT(1,4+IIGLU1)**2)
36015 ELSE
36016C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36017 PHKT(5,4+IIGLU1)=0.D0
36018 ENDIF
36019 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36020 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36021 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36022 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36023 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36024 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36025 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36026 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36027 IDHKT(5+IIGLU1) =IP22
36028 ISTHKT(5+IIGLU1) =952
36029 JMOHKT(1,5+IIGLU1)=NC1T
36030 JMOHKT(2,5+IIGLU1)=0
36031 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36032 JDAHKT(2,5+IIGLU1)=0
36033 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36034 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36035 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36036 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36037C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36038 XMIST =(PHKT(4,5+IIGLU1)**2-
36039 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36040 *PHKT(1,5+IIGLU1)**2)
36041 IF(XMIST.GT.0.D0)THEN
36042 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36043 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36044 *PHKT(1,5+IIGLU1)**2)
36045 ELSE
36046C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36047 PHKT(5,5+IIGLU1)=0.D0
36048 ENDIF
36049 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36050 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36051 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36052 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36053 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36054 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36055 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36056 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36057 IDHKT(6+IIGLU1) =88888
36058 ISTHKT(6+IIGLU1) =95
36059 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36060 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36061 JDAHKT(1,6+IIGLU1)=0
36062 JDAHKT(2,6+IIGLU1)=0
36063 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36064 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36065 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36066 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36067 XMIST
36068 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36069 * -PHKT(3,6+IIGLU1)**2)
36070 IF(XMIST.GT.0.D0)THEN
36071 PHKT(5,6+IIGLU1)
36072 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36073 * -PHKT(3,6+IIGLU1)**2)
36074 ELSE
36075C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36076 PHKT(5,5+IIGLU1)=0.D0
36077 ENDIF
36078C IF(IPIP.GE.2)THEN
36079C IF(NUMEV.EQ.-324)THEN
36080C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36081C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36082C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36083C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36084C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36085C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36086C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36087C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36088C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36089C ENDIF
36090 CHAMAL=CHAM1
36091 IF(IPIP.EQ.1)THEN
36092 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36093 ELSEIF(IPIP.EQ.2)THEN
36094 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36095 ENDIF
36096 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36097C IREJ=1
36098 IPCO=0
36099C RETURN
36100C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36101C * CHAMAL,PHKT(5,6+IIGLU1)
36102 GO TO 3466
36103 ENDIF
36104 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36105 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36106 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36107 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36108 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36109 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36110 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36111 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36112C IDHKT(7) =1000*IPP1+100*ISQ+1
36113 IDHKT(7+IIGLU1) =IP1
36114 ISTHKT(7+IIGLU1) =951
36115 JMOHKT(1,7+IIGLU1)=NC1P
36116 JMOHKT(2,7+IIGLU1)=0
36117**NEW
36118C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36119 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36120**
36121 JDAHKT(2,7+IIGLU1)=0
36122 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36123 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36124 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36125 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36126C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36127 XMIST =(PHKT(4,7+IIGLU1)**2-
36128 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36129 *PHKT(1,7+IIGLU1)**2)
36130 IF(XMIST.GT.0.D0)THEN
36131 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36132 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36133 *PHKT(1,7+IIGLU1)**2)
36134 ELSE
36135C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36136 PHKT(5,7+IIGLU1)=0.D0
36137 ENDIF
36138 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36139 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36140 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36141 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36142 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36143 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36144 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36145 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36146C Insert here the IIGLU2 gluons
36147 PG1=0.D0
36148 PG2=0.D0
36149 PG3=0.D0
36150 PG4=0.D0
36151 IF(IIGLU2.GE.1)THEN
36152 JJG=NC2P
36153 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36154 KKG=JJG+IIG-7-IIGLU1
36155 IDHKT(IIG) =IDHKK(KKG)
36156 ISTHKT(IIG) =921
36157 JMOHKT(1,IIG)=KKG
36158 JMOHKT(2,IIG)=0
36159 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36160 JDAHKT(2,IIG)=0
36161 PHKT(1,IIG)=PHKK(1,KKG)
36162 PG1=PG1+ PHKT(1,IIG)
36163 PHKT(2,IIG)=PHKK(2,KKG)
36164 PG2=PG2+ PHKT(2,IIG)
36165 PHKT(3,IIG)=PHKK(3,KKG)
36166 PG3=PG3+ PHKT(3,IIG)
36167 PHKT(4,IIG)=PHKK(4,KKG)
36168 PG4=PG4+ PHKT(4,IIG)
36169 PHKT(5,IIG)=PHKK(5,KKG)
36170 VHKT(1,IIG) =VHKK(1,KKG)
36171 VHKT(2,IIG) =VHKK(2,KKG)
36172 VHKT(3,IIG) =VHKK(3,KKG)
36173 VHKT(4,IIG) =VHKK(4,KKG)
36174 WHKT(1,IIG) =WHKK(1,KKG)
36175 WHKT(2,IIG) =WHKK(2,KKG)
36176 WHKT(3,IIG) =WHKK(3,KKG)
36177 WHKT(4,IIG) =WHKK(4,KKG)
36178 81 CONTINUE
36179 ENDIF
36180 IF(IPIP.EQ.1)THEN
36181 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36182 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36183 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36184 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36185 ELSEIF(IPIP.EQ.2)THEN
36186 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36187 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36188 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36189 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36190 ENDIF
36191 ISTHKT(8+IIGLU1+IIGLU2) =952
36192 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36193 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36194 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36195 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36196 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36197 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36198 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36199 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36200 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36201 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36202 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36203 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36204C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36205C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36206 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36207C IREJ=1
36208C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36209C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36210 IPCO=0
36211C RETURN
36212 GO TO 3466
36213 ENDIF
36214C PHKT(5,8) =PHKK(5,NC2T)
36215 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36216 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36217 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36218 IF(XMIST.GT.0.D0)THEN
36219 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36220 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36221 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36222 ELSE
36223C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36224 PHKT(5,5+IIGLU1)=0.D0
36225 ENDIF
36226 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36227 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36228 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36229 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36230 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36231 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36232 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36233 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36234 IDHKT(9+IIGLU1+IIGLU2) =88888
36235 ISTHKT(9+IIGLU1+IIGLU2) =95
36236 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36237 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36238 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36239 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36240**NEW
36241C PHKT(1,9+IIGLU1+IIGLU2)
36242C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36243C PHKT(2,9+IIGLU1+IIGLU2)
36244C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36245C PHKT(3,9+IIGLU1+IIGLU2)
36246C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36247C PHKT(4,9+IIGLU1+IIGLU2)
36248C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36249 PHKT(1,9+IIGLU1+IIGLU2)
36250 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36251 PHKT(2,9+IIGLU1+IIGLU2)
36252 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36253 PHKT(3,9+IIGLU1+IIGLU2)
36254 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36255 PHKT(4,9+IIGLU1+IIGLU2)
36256 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36257**
36258 XMIST
36259 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36260 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36261 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36262 IF(XMIST.GT.0.D0)THEN
36263 PHKT(5,9+IIGLU1+IIGLU2)
36264 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36265 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36266 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36267 ELSE
36268C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36269 PHKT(5,5+IIGLU1)=0.D0
36270 ENDIF
36271 IF(IPIP.GE.2)THEN
36272C IF(NUMEV.EQ.-324)THEN
36273C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36274C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36275C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36276C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36277C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36278C * JDAHKT(1,IIG),
36279C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36280C 91 CONTINUE
36281C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36282C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36283C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36284C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36285C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36286C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36287C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36288C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36289 ENDIF
36290 CHAMAL=CHAB1
36291 IF(IPIP.EQ.1)THEN
36292 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36293 ELSEIF(IPIP.EQ.2)THEN
36294 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36295 ENDIF
36296 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36297C IREJ=1
36298 IPCO=0
36299C RETURN
36300C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36301C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36302 GO TO 3466
36303 ENDIF
36304 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36305 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36306 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36307 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36308 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36309 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36310 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36311 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36312C
36313 IPCO=0
36314 IGCOUN=9+IIGLU1+IIGLU2
36315 RETURN
36316 END
36317
36318*$ CREATE MGSQBS2.FOR
36319*COPY MGSQBS2
36320C
36321C
36322C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36323 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36324 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36325C
36326C GSQBS-2 diagram (split target diquark)
36327C
36328 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36329 SAVE
36330
36331 PARAMETER ( LINP = 10 ,
36332 & LOUT = 6 ,
36333 & LDAT = 9 )
36334
36335* event history
36336
36337 PARAMETER (NMXHKK=200000)
36338
36339 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36340 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36341 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36342
36343* extended event history
36344 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36345 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36346 & IHIST(2,NMXHKK)
36347
36348* Lorentz-parameters of the current interaction
36349 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36350 & UMO,PPCM,EPROJ,PPROJ
36351
36352* diquark-breaking mechanism
36353 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36354
36355C
36356 PARAMETER (NTMHKK= 300)
36357 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36358 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36359 +(4,NTMHKK)
36360
36361*KEEP,XSEADI.
36362 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36363 +SSMIMQ,VVMTHR
36364*KEEP,DPRIN.
36365 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36366C
36367C GSQBS-2 diagram (split target diquark)
36368C
36369C
36370C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36371C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36372C
36373C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36374C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36375C
36376C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36377C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36378C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36379C
36380C
36381C
36382C Put new chains into COMMON /HKKTMP/
36383C
36384 IIGLU1=NC1T-NC1P-1
36385 IIGLU2=NC2T-NC2P-1
36386 IGCOUN=0
36387C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36388 CVQ=1.D0
36389 IREJ=0
36390C IF(IPIP.EQ.2)THEN
36391C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36392C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36393C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36394C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36395C ENDIF
36396C
36397C
36398C
36399C determine x-values of NC1T diquark
36400 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36401 XVQP=PHKK(4,NC1P)*2.D0/UMO
36402C
36403C determine x-values of sea quark pair
36404C
36405 IPCO=1
36406 ICOU=0
36407 2234 CONTINUE
36408 ICOU=ICOU+1
36409 IF(ICOU.GE.500)THEN
36410 IREJ=1
36411 IF(ISQ.EQ.3)IREJ=3
36412 IF(IPCO.GE.3)
36413 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36414 IPCO=0
36415 RETURN
36416 ENDIF
36417 IF(IPCO.GE.3)
36418 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36419 * UMO, XDIQT,XVQP
36420 XSQ=0.D0
36421 XSAQ=0.D0
36422**NEW
36423C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36424 IF (IPIP.EQ.1) THEN
36425 XQMAX = XDIQT/2.0D0
36426 XAQMAX = 2.D0*XVQP/3.0D0
36427 ELSE
36428 XQMAX = 2.D0*XVQP/3.0D0
36429 XAQMAX = XDIQT/2.0D0
36430 ENDIF
36431 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36432 ISAQ = 6+ISQ
36433C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36434**
36435 IF(IPCO.GE.3)
36436 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36437 IF(IREJ.GE.1)THEN
36438 IF(IPCO.GE.3)
36439 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36440 IPCO=0
36441 RETURN
36442 ENDIF
36443 IF(IPIP.EQ.1)THEN
36444 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36445 ELSEIF(IPIP.EQ.2)THEN
36446 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36447 ENDIF
36448 IF(IPCO.GE.3)THEN
36449 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36450 & XDIQT,XVQP,XSQ,XSAQ
36451 ENDIF
36452C
36453C subtract xsq,xsaq from NC1T diquark and NC1P quark
36454C
36455C XSQ=0.D0
36456 IF(IPIP.EQ.1)THEN
36457 XDIQT=XDIQT-XSQ
36458 XVQP =XVQP -XSAQ
36459 ELSEIF(IPIP.EQ.2)THEN
36460 XDIQT=XDIQT-XSAQ
36461 XVQP =XVQP -XSQ
36462 ENDIF
36463 IF(IPCO.GE.3)
36464 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36465C
36466C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36467C
36468 XVTHRO=CVQ/UMO
36469 IVTHR=0
36470 3466 CONTINUE
36471 IF(IVTHR.EQ.10)THEN
36472 IREJ=1
36473 IF(ISQ.EQ.3)IREJ=3
36474 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36475 IPCO=0
36476 RETURN
36477 ENDIF
36478 IVTHR=IVTHR+1
36479 XVTHR=XVTHRO/(201-IVTHR)
36480 UNOPRV=UNON
36481 380 CONTINUE
36482 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36483 IREJ=1
36484 IF(ISQ.EQ.3)IREJ=3
36485 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36486 * XVTHR
36487 IPCO=0
36488 RETURN
36489 ENDIF
36490 IF(DT_RNDM(V).LT.0.5D0)THEN
36491 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36492 XVTQII=XDIQT-XVTQI
36493 ELSE
36494 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36495 XVTQI=XDIQT-XVTQII
36496 ENDIF
36497 IF(IPCO.GE.3)THEN
36498 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36499 ENDIF
36500C
36501C Prepare 4 momenta of new chains and chain ends
36502C
36503C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36504C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36505C +(4,NTMHKK)
36506C
36507C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36508C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36509C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36510C
36511C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36512C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36513C
36514 IF(IPIP.EQ.1)THEN
36515 XSQ1=XSQ
36516 XSAQ1=XSAQ
36517 ISQ1=ISQ
36518 ISAQ1=ISAQ
36519 ELSEIF(IPIP.EQ.2)THEN
36520 XSQ1=XSAQ
36521 XSAQ1=XSQ
36522 ISQ1=ISAQ
36523 ISAQ1=ISQ
36524 ENDIF
36525 KK11=IP21
36526C IDHKT(1) =1000*IPP11+100*IPP12+1
36527 KK21=IPP11
36528 KK22=IPP12
36529 XGIVE=0.D0
36530 IF(IPIP.EQ.1)THEN
36531 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36532 ELSEIF(IPIP.EQ.2)THEN
36533 IDHKT(4+IIGLU1) =ISAQ1
36534 ENDIF
36535 ISTHKT(4+IIGLU1) =961
36536 JMOHKT(1,4+IIGLU1)=NC1P
36537 JMOHKT(2,4+IIGLU1)=0
36538 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36539 JDAHKT(2,4+IIGLU1)=0
36540C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36541 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36542 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36543 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36544 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36545C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36546 XXMIST=(PHKT(4,4+IIGLU1)**2-
36547 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36548 *PHKT(1,4+IIGLU1)**2)
36549 IF(XXMIST.GT.0.D0)THEN
36550 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36551 ELSE
36552 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36553 XXMIST=ABS(XXMIST)
36554 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36555 ENDIF
36556 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36557 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36558 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36559 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36560 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36561 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36562 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36563 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36564 IDHKT(5+IIGLU1) =IP22
36565 ISTHKT(5+IIGLU1) =962
36566 JMOHKT(1,5+IIGLU1)=NC1T
36567 JMOHKT(2,5+IIGLU1)=0
36568 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36569 JDAHKT(2,5+IIGLU1)=0
36570 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36571 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36572 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36573 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36574C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36575 XXMIST=(PHKT(4,5+IIGLU1)**2-
36576 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36577 *PHKT(1,5+IIGLU1)**2)
36578 IF(XXMIST.GT.0.D0)THEN
36579 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36580 ELSE
36581 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36582 XXMIST=ABS(XXMIST)
36583 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36584 ENDIF
36585 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36586 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36587 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36588 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36589 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36590 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36591 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36592 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36593 IDHKT(6+IIGLU1) =88888
36594 ISTHKT(6+IIGLU1) =96
36595 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36596 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36597 JDAHKT(1,6+IIGLU1)=0
36598 JDAHKT(2,6+IIGLU1)=0
36599 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36600 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36601 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36602 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36603 PHKT(5,6+IIGLU1)
36604 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36605 * -PHKT(3,6+IIGLU1)**2)
36606 CHAMAL=CHAM1
36607 IF(IPIP.EQ.1)THEN
36608 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36609 ELSEIF(IPIP.EQ.2)THEN
36610 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36611 ENDIF
36612C---------------------------------------------------
36613 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36614 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36615C we drop chain 6 and give the energy to chain 3
36616 IDHKT(6+IIGLU1)=22888
36617 XGIVE=1.D0
36618C WRITE(6,*)' drop chain 6 xgive=1'
36619 GO TO 7788
36620 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36621C we drop chain 6 and give the energy to chain 3
36622C and change KK11 to IDHKT(5)
36623 IDHKT(6+IIGLU1)=22888
36624 XGIVE=1.D0
36625C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36626 KK11=IDHKT(5+IIGLU1)
36627 GO TO 7788
36628 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36629C we drop chain 6 and give the energy to chain 3
36630C and change KK21 to IDHKT(5+IIGLU1)
36631C IDHKT(1) =1000*IPP11+100*IPP12+1
36632 IDHKT(6+IIGLU1)=22888
36633 XGIVE=1.D0
36634C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36635 KK21=IDHKT(5+IIGLU1)
36636 GO TO 7788
36637 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36638C we drop chain 6 and give the energy to chain 3
36639C and change KK22 to IDHKT(5)
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 KK22=IDHKT(5+IIGLU1)'
36644 KK22=IDHKT(5+IIGLU1)
36645 GO TO 7788
36646 ENDIF
36647C IREJ=1
36648 IPCO=0
36649C RETURN
36650 GO TO 3466
36651 ENDIF
36652 7788 CONTINUE
36653C---------------------------------------------------
36654 IF(IPIP.GE.3)THEN
36655 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36656 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36657 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36658 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36659 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36660 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36661 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36662 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36663 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36664 ENDIF
36665 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36666 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36667 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36668 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36669 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36670 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36671 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36672 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36673C IDHKT(1) =1000*IPP11+100*IPP12+1
36674 IF(IPIP.EQ.1)THEN
36675 IDHKT(1) =1000*KK21+100*KK22+3
36676 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36677 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36678 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36679 ELSEIF(IPIP.EQ.2)THEN
36680 IDHKT(1) =1000*KK21+100*KK22-3
36681 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36682 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36683 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36684 ENDIF
36685 ISTHKT(1) =961
36686 JMOHKT(1,1)=NC2P
36687 JMOHKT(2,1)=0
36688 JDAHKT(1,1)=3+IIGLU1
36689 JDAHKT(2,1)=0
36690C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36691 PHKT(1,1) =PHKK(1,NC2P)
36692 *+XGIVE*PHKT(1,4+IIGLU1)
36693 PHKT(2,1) =PHKK(2,NC2P)
36694 *+XGIVE*PHKT(2,4+IIGLU1)
36695 PHKT(3,1) =PHKK(3,NC2P)
36696 *+XGIVE*PHKT(3,4+IIGLU1)
36697 PHKT(4,1) =PHKK(4,NC2P)
36698 *+XGIVE*PHKT(4,4+IIGLU1)
36699C PHKT(5,1) =PHKK(5,NC2P)
36700 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36701 *PHKT(1,1)**2
36702 IF(XXMIST.GT.0.D0)THEN
36703 PHKT(5,1) =SQRT(XXMIST)
36704 ELSE
36705 WRITE(LOUT,*)'MGSQBS2',XXMIST
36706 XXMIST=ABS(XXMIST)
36707 PHKT(5,1) =SQRT(XXMIST)
36708 ENDIF
36709 VHKT(1,1) =VHKK(1,NC2P)
36710 VHKT(2,1) =VHKK(2,NC2P)
36711 VHKT(3,1) =VHKK(3,NC2P)
36712 VHKT(4,1) =VHKK(4,NC2P)
36713 WHKT(1,1) =WHKK(1,NC2P)
36714 WHKT(2,1) =WHKK(2,NC2P)
36715 WHKT(3,1) =WHKK(3,NC2P)
36716 WHKT(4,1) =WHKK(4,NC2P)
36717C Add here IIGLU1 gluons to this chaina
36718 PG1=0.D0
36719 PG2=0.D0
36720 PG3=0.D0
36721 PG4=0.D0
36722 IF(IIGLU1.GE.1)THEN
36723 JJG=NC1P
36724 DO 61 IIG=2,2+IIGLU1-1
36725 KKG=JJG+IIG-1
36726 IDHKT(IIG) =IDHKK(KKG)
36727 ISTHKT(IIG) =921
36728 JMOHKT(1,IIG)=KKG
36729 JMOHKT(2,IIG)=0
36730 JDAHKT(1,IIG)=3+IIGLU1
36731 JDAHKT(2,IIG)=0
36732 PHKT(1,IIG)=PHKK(1,KKG)
36733 PG1=PG1+ PHKT(1,IIG)
36734 PHKT(2,IIG)=PHKK(2,KKG)
36735 PG2=PG2+ PHKT(2,IIG)
36736 PHKT(3,IIG)=PHKK(3,KKG)
36737 PG3=PG3+ PHKT(3,IIG)
36738 PHKT(4,IIG)=PHKK(4,KKG)
36739 PG4=PG4+ PHKT(4,IIG)
36740 PHKT(5,IIG)=PHKK(5,KKG)
36741 VHKT(1,IIG) =VHKK(1,KKG)
36742 VHKT(2,IIG) =VHKK(2,KKG)
36743 VHKT(3,IIG) =VHKK(3,KKG)
36744 VHKT(4,IIG) =VHKK(4,KKG)
36745 WHKT(1,IIG) =WHKK(1,KKG)
36746 WHKT(2,IIG) =WHKK(2,KKG)
36747 WHKT(3,IIG) =WHKK(3,KKG)
36748 WHKT(4,IIG) =WHKK(4,KKG)
36749 61 CONTINUE
36750 ENDIF
36751C IDHKT(2) =IP21
36752 IDHKT(2+IIGLU1) =KK11
36753 ISTHKT(2+IIGLU1) =962
36754 JMOHKT(1,2+IIGLU1)=NC1T
36755 JMOHKT(2,2+IIGLU1)=0
36756 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36757 JDAHKT(2,2+IIGLU1)=0
36758 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36759C * +0.5D0*PHKK(1,NC2T)
36760 *+XGIVE*PHKT(1,5+IIGLU1)
36761 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36762C *+0.5D0*PHKK(2,NC2T)
36763 *+XGIVE*PHKT(2,5+IIGLU1)
36764 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36765C *+0.5D0*PHKK(3,NC2T)
36766 *+XGIVE*PHKT(3,5+IIGLU1)
36767 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36768C *+0.5D0*PHKK(4,NC2T)
36769 *+XGIVE*PHKT(4,5+IIGLU1)
36770C PHKT(5,2) =PHKK(5,NC1T)
36771 XXMIST=(PHKT(4,2+IIGLU1)**2-
36772 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36773 *PHKT(1,2+IIGLU1)**2)
36774 IF(XXMIST.GT.0.D0)THEN
36775 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36776 ELSE
36777 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36778 XXMIST=ABS(XXMIST)
36779 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36780 ENDIF
36781 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36782 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36783 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36784 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36785 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36786 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36787 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36788 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36789 IDHKT(3+IIGLU1) =88888
36790 ISTHKT(3+IIGLU1) =96
36791 JMOHKT(1,3+IIGLU1)=1
36792 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36793 JDAHKT(1,3+IIGLU1)=0
36794 JDAHKT(2,3+IIGLU1)=0
36795 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36796 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36797 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36798 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36799 PHKT(5,3+IIGLU1)
36800 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36801 * -PHKT(3,3+IIGLU1)**2)
36802 IF(IPIP.EQ.3)THEN
36803 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36804 * JDAHKT(1,1),
36805 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36806 DO 71 IIG=2,2+IIGLU1-1
36807 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36808 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36809 * JDAHKT(1,IIG),
36810 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36811 71 CONTINUE
36812 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36813 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36814 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36815 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36816 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36817 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36818 ENDIF
36819 CHAMAL=CHAB1
36820 IF(IPIP.EQ.1)THEN
36821 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36822 ELSEIF(IPIP.EQ.2)THEN
36823 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36824 ENDIF
36825 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36826C IREJ=1
36827 IPCO=0
36828C RETURN
36829 GO TO 3466
36830 ENDIF
36831 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36832 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36833 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36834 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36835 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36836 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36837 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36838 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36839C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36840 IDHKT(7+IIGLU1) =IP1
36841 ISTHKT(7+IIGLU1) =961
36842 JMOHKT(1,7+IIGLU1)=NC1P
36843 JMOHKT(2,7+IIGLU1)=0
36844 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36845 JDAHKT(2,7+IIGLU1)=0
36846 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36847 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36848 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36849 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36850C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36851 XXMIST=(PHKT(4,7+IIGLU1)**2-
36852 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36853 *PHKT(1,7+IIGLU1)**2)
36854 IF(XXMIST.GT.0.D0)THEN
36855 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36856 ELSE
36857 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36858 XXMIST=ABS(XXMIST)
36859 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36860 ENDIF
36861 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36862 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36863 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36864 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36865 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36866 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36867 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36868 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36869C IDHKT(7) =1000*IPP1+100*ISQ+1
36870C Insert here the IIGLU2 gluons
36871 PG1=0.D0
36872 PG2=0.D0
36873 PG3=0.D0
36874 PG4=0.D0
36875 IF(IIGLU2.GE.1)THEN
36876 JJG=NC2P
36877 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36878 KKG=JJG+IIG-7-IIGLU1
36879 IDHKT(IIG) =IDHKK(KKG)
36880 ISTHKT(IIG) =921
36881 JMOHKT(1,IIG)=KKG
36882 JMOHKT(2,IIG)=0
36883 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36884 JDAHKT(2,IIG)=0
36885 PHKT(1,IIG)=PHKK(1,KKG)
36886 PG1=PG1+ PHKT(1,IIG)
36887 PHKT(2,IIG)=PHKK(2,KKG)
36888 PG2=PG2+ PHKT(2,IIG)
36889 PHKT(3,IIG)=PHKK(3,KKG)
36890 PG3=PG3+ PHKT(3,IIG)
36891 PHKT(4,IIG)=PHKK(4,KKG)
36892 PG4=PG4+ PHKT(4,IIG)
36893 PHKT(5,IIG)=PHKK(5,KKG)
36894 VHKT(1,IIG) =VHKK(1,KKG)
36895 VHKT(2,IIG) =VHKK(2,KKG)
36896 VHKT(3,IIG) =VHKK(3,KKG)
36897 VHKT(4,IIG) =VHKK(4,KKG)
36898 WHKT(1,IIG) =WHKK(1,KKG)
36899 WHKT(2,IIG) =WHKK(2,KKG)
36900 WHKT(3,IIG) =WHKK(3,KKG)
36901 WHKT(4,IIG) =WHKK(4,KKG)
36902 81 CONTINUE
36903 ENDIF
36904 IF(IPIP.EQ.1)THEN
36905 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36906 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36907 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36908 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36909 ELSEIF(IPIP.EQ.2)THEN
36910**NEW
36911C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36912 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36913**
36914 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36915 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36916 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36917 ENDIF
36918 ISTHKT(8+IIGLU1+IIGLU2) =962
36919 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36920 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36921 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36922 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36923C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36924C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36925C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36926C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36927 PHKT(1,8+IIGLU1+IIGLU2) =
36928 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36929 PHKT(2,8+IIGLU1+IIGLU2) =
36930 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36931 PHKT(3,8+IIGLU1+IIGLU2) =
36932 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36933 PHKT(4,8+IIGLU1+IIGLU2) =
36934 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36935C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36936C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36937 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36938C IREJ=1
36939C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36940 IPCO=0
36941C RETURN
36942 GO TO 3466
36943 ENDIF
36944C PHKT(5,8) =PHKK(5,NC2T)
36945 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36946 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36947 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36948 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36949 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36950 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36951 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36952 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36953 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36954 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36955 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36956 IDHKT(9+IIGLU1+IIGLU2) =88888
36957 ISTHKT(9+IIGLU1+IIGLU2) =96
36958 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36959 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36960 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36961 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36962 PHKT(1,9+IIGLU1+IIGLU2)
36963 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36964 PHKT(2,9+IIGLU1+IIGLU2)
36965 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36966 PHKT(3,9+IIGLU1+IIGLU2)
36967 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36968 PHKT(4,9+IIGLU1+IIGLU2)
36969 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36970 PHKT(5,9+IIGLU1+IIGLU2)
36971 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36972 * PHKT(2,9+IIGLU1+IIGLU2)**2
36973 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36974 IF(IPIP.GE.3)THEN
36975 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36976 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36977 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36978 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36979 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36980 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36981 * JDAHKT(1,IIG),
36982 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36983 91 CONTINUE
36984 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36985 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36986 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36987 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36988 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36989 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36990 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36991 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36992 ENDIF
36993 CHAMAL=CHAB1
36994 IF(IPIP.EQ.1)THEN
36995 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36996 ELSEIF(IPIP.EQ.2)THEN
36997 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36998 ENDIF
36999 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37000C IREJ=1
37001 IPCO=0
37002C RETURN
37003 GO TO 3466
37004 ENDIF
37005 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37006 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37007 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37008 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37009 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37010 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37011 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37012 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37013C
37014 IPCO=0
37015 IGCOUN=9+IIGLU1+IIGLU2
37016 RETURN
37017 END
37018
37019*$ CREATE MUSQBS1.FOR
37020*COPY MUSQBS1
37021C
37022C
37023C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37024 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37025 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37026C
37027C USQBS-1 diagram (split projectile diquark)
37028C
37029 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37030 SAVE
37031
37032 PARAMETER ( LINP = 10 ,
37033 & LOUT = 6 ,
37034 & LDAT = 9 )
37035
37036* event history
37037
37038 PARAMETER (NMXHKK=200000)
37039
37040 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37041 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37042 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37043
37044* extended event history
37045 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37046 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37047 & IHIST(2,NMXHKK)
37048
37049* Lorentz-parameters of the current interaction
37050 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37051 & UMO,PPCM,EPROJ,PPROJ
37052
37053* diquark-breaking mechanism
37054 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37055
37056C
37057 PARAMETER (NTMHKK= 300)
37058 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37059 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37060 +(4,NTMHKK)
37061*KEEP,XSEADI.
37062 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37063 +SSMIMQ,VVMTHR
37064*KEEP,DPRIN.
37065 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37066 COMMON /EVFLAG/ NUMEV
37067C
37068C USQBS-1 diagram (split projectile diquark)
37069C
37070C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37071C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37072C
37073C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37074C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37075C
37076C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37077C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37078C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37079C
37080C Put new chains into COMMON /HKKTMP/
37081C
37082 IIGLU1=NC1T-NC1P-1
37083 IIGLU2=NC2T-NC2P-1
37084 IGCOUN=0
37085C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37086 CVQ=1.D0
37087 IREJ=0
37088 IF(IPIP.EQ.3)THEN
37089C IF(NUMEV.EQ.-324)THEN
37090 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37091 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37092 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37093 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37094 ENDIF
37095C
37096C
37097C
37098C determine x-values of NC1P diquark
37099 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37100 XVQT=PHKK(4,NC1T)*2.D0/UMO
37101C
37102C determine x-values of sea quark pair
37103C
37104 IPCO=1
37105 ICOU=0
37106 2234 CONTINUE
37107 ICOU=ICOU+1
37108 IF(ICOU.GE.500)THEN
37109 IREJ=1
37110 IF(ISQ.EQ.3)IREJ=3
37111 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37112 IPCO=0
37113 RETURN
37114 ENDIF
37115 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37116 * UMO, XDIQP,XVQT
37117 XSQ=0.D0
37118 XSAQ=0.D0
37119**NEW
37120C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37121 IF (IPIP.EQ.1) THEN
37122 XQMAX = XDIQP/2.0D0
37123 XAQMAX = 2.D0*XVQT/3.0D0
37124 ELSE
37125 XQMAX = 2.D0*XVQT/3.0D0
37126 XAQMAX = XDIQP/2.0D0
37127 ENDIF
37128 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37129 ISAQ = 6+ISQ
37130C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37131**
37132 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37133 IF(IREJ.GE.1)THEN
37134 IF(IPCO.GE.3)
37135 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37136 IPCO=0
37137 RETURN
37138 ENDIF
37139 IF(IPIP.EQ.1)THEN
37140 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37141 ELSEIF(IPIP.EQ.2)THEN
37142 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37143 ENDIF
37144 IF(IPCO.GE.3)THEN
37145 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37146 & XDIQP,XVQT,XSQ,XSAQ
37147 ENDIF
37148C
37149C subtract xsq,xsaq from NC1P diquark and NC1T quark
37150C
37151C XSQ=0.D0
37152 IF(IPIP.EQ.1)THEN
37153 XDIQP=XDIQP-XSQ
37154 XVQT =XVQT -XSAQ
37155 ELSEIF(IPIP.EQ.2)THEN
37156 XDIQP=XDIQP-XSAQ
37157 XVQT =XVQT -XSQ
37158 ENDIF
37159 IF(IPCO.GE.3)
37160 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37161C
37162C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37163C
37164 XVTHRO=CVQ/UMO
37165 IVTHR=0
37166 3466 CONTINUE
37167 IF(IVTHR.EQ.10)THEN
37168 IREJ=1
37169 IF(ISQ.EQ.3)IREJ=3
37170 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37171 IPCO=0
37172 RETURN
37173 ENDIF
37174 IVTHR=IVTHR+1
37175 XVTHR=XVTHRO/(201-IVTHR)
37176 UNOPRV=UNON
37177 380 CONTINUE
37178 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37179 IREJ=1
37180 IF(ISQ.EQ.3)IREJ=3
37181 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37182 * XVTHR
37183 IPCO=0
37184 RETURN
37185 ENDIF
37186 IF(DT_RNDM(V).LT.0.5D0)THEN
37187 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37188 XVPQII=XDIQP-XVPQI
37189 ELSE
37190 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37191 XVPQI=XDIQP-XVPQII
37192 ENDIF
37193 IF(IPCO.GE.3)THEN
37194 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37195 ENDIF
37196C
37197C Prepare 4 momenta of new chains and chain ends
37198C
37199C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37200C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37201C +(4,NTMHKK)
37202C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37203C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37204C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37205 IF(IPIP.EQ.1)THEN
37206 XSQ1=XSQ
37207 XSAQ1=XSAQ
37208 ISQ1=ISQ
37209 ISAQ1=ISAQ
37210 ELSEIF(IPIP.EQ.2)THEN
37211 XSQ1=XSAQ
37212 XSAQ1=XSQ
37213 ISQ1=ISAQ
37214 ISAQ1=ISQ
37215 ENDIF
37216 IDHKT(1) =IP11
37217 ISTHKT(1) =931
37218 JMOHKT(1,1)=NC1P
37219 JMOHKT(2,1)=0
37220 JDAHKT(1,1)=3+IIGLU1
37221 JDAHKT(2,1)=0
37222C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37223 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37224 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37225 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37226 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37227C PHKT(5,1) =PHKK(5,NC1P)
37228 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37229 *PHKT(1,1)**2)
37230 IF(XMIST.GE.0.D0)THEN
37231 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37232 *PHKT(1,1)**2)
37233 ELSE
37234C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37235 PHKT(5,1)=0.D0
37236 ENDIF
37237 VHKT(1,1) =VHKK(1,NC1P)
37238 VHKT(2,1) =VHKK(2,NC1P)
37239 VHKT(3,1) =VHKK(3,NC1P)
37240 VHKT(4,1) =VHKK(4,NC1P)
37241 WHKT(1,1) =WHKK(1,NC1P)
37242 WHKT(2,1) =WHKK(2,NC1P)
37243 WHKT(3,1) =WHKK(3,NC1P)
37244 WHKT(4,1) =WHKK(4,NC1P)
37245C Add here IIGLU1 gluons to this chaina
37246 PG1=0.D0
37247 PG2=0.D0
37248 PG3=0.D0
37249 PG4=0.D0
37250 IF(IIGLU1.GE.1)THEN
37251 JJG=NC1P
37252 DO 61 IIG=2,2+IIGLU1-1
37253 KKG=JJG+IIG-1
37254 IDHKT(IIG) =IDHKK(KKG)
37255 ISTHKT(IIG) =921
37256 JMOHKT(1,IIG)=KKG
37257 JMOHKT(2,IIG)=0
37258 JDAHKT(1,IIG)=3+IIGLU1
37259 JDAHKT(2,IIG)=0
37260 PHKT(1,IIG)=PHKK(1,KKG)
37261 PG1=PG1+ PHKT(1,IIG)
37262 PHKT(2,IIG)=PHKK(2,KKG)
37263 PG2=PG2+ PHKT(2,IIG)
37264 PHKT(3,IIG)=PHKK(3,KKG)
37265 PG3=PG3+ PHKT(3,IIG)
37266 PHKT(4,IIG)=PHKK(4,KKG)
37267 PG4=PG4+ PHKT(4,IIG)
37268 PHKT(5,IIG)=PHKK(5,KKG)
37269 VHKT(1,IIG) =VHKK(1,KKG)
37270 VHKT(2,IIG) =VHKK(2,KKG)
37271 VHKT(3,IIG) =VHKK(3,KKG)
37272 VHKT(4,IIG) =VHKK(4,KKG)
37273 WHKT(1,IIG) =WHKK(1,KKG)
37274 WHKT(2,IIG) =WHKK(2,KKG)
37275 WHKT(3,IIG) =WHKK(3,KKG)
37276 WHKT(4,IIG) =WHKK(4,KKG)
37277 61 CONTINUE
37278 ENDIF
37279 IDHKT(2+IIGLU1) =IPP2
37280 ISTHKT(2+IIGLU1) =932
37281 JMOHKT(1,2+IIGLU1)=NC2T
37282 JMOHKT(2,2+IIGLU1)=0
37283 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37284 JDAHKT(2,2+IIGLU1)=0
37285 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37286 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37287 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37288 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37289C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37290 XMIST=(PHKT(4,2+IIGLU1)**2-
37291 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37292 *PHKT(1,2+IIGLU1)**2)
37293 IF(XMIST.GT.0.D0)THEN
37294 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37295 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37296 *PHKT(1,2+IIGLU1)**2)
37297 ELSE
37298C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37299 PHKT(5,2+IIGLU1)=0.D0
37300 ENDIF
37301 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37302 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37303 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37304 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37305 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37306 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37307 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37308 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37309 IDHKT(3+IIGLU1) =88888
37310 ISTHKT(3+IIGLU1) =94
37311 JMOHKT(1,3+IIGLU1)=1
37312 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37313 JDAHKT(1,3+IIGLU1)=0
37314 JDAHKT(2,3+IIGLU1)=0
37315 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37316 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37317 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37318 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37319 XMIST
37320 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37321 * -PHKT(3,3+IIGLU1)**2)
37322 IF(XMIST.GE.0.D0)THEN
37323 PHKT(5,3+IIGLU1)
37324 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37325 * -PHKT(3,3+IIGLU1)**2)
37326 ELSE
37327C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37328 PHKT(5,1)=0.D0
37329 ENDIF
37330 IF(IPIP.GE.3)THEN
37331C IF(NUMEV.EQ.-324)THEN
37332 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37333 * JMOHKT(2,1),JDAHKT(1,1),
37334 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37335 DO 71 IIG=2,2+IIGLU1-1
37336 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37337 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37338 * JDAHKT(1,IIG),
37339 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37340 71 CONTINUE
37341 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37342 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37343 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37344 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37345 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37346 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37347 ENDIF
37348 CHAMAL=CHAM1
37349 IF(IPIP.EQ.1)THEN
37350 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37351 ELSEIF(IPIP.EQ.2)THEN
37352 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37353 ENDIF
37354 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37355C IREJ=1
37356 IPCO=0
37357C RETURN
37358C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37359 GO TO 3466
37360 ENDIF
37361 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37362 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37363 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37364 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37365 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37366 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37367 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37368 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37369 IDHKT(4+IIGLU1) =IP12
37370 ISTHKT(4+IIGLU1) =931
37371 JMOHKT(1,4+IIGLU1)=NC1P
37372 JMOHKT(2,4+IIGLU1)=0
37373 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37374 JDAHKT(2,4+IIGLU1)=0
37375C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37376 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37377 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37378 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37379 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37380C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37381 XMIST =(PHKT(4,4+IIGLU1)**2-
37382 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37383 *PHKT(1,4+IIGLU1)**2)
37384 IF(XMIST.GT.0.D0)THEN
37385 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37386 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37387 *PHKT(1,4+IIGLU1)**2)
37388 ELSE
37389C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37390 PHKT(5,4+IIGLU1)=0.D0
37391 ENDIF
37392 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37393 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37394 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37395 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37396 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37397 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37398 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37399 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37400 IF(IPIP.EQ.1)THEN
37401 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37402 ELSEIF(IPIP.EQ.2)THEN
37403 IDHKT(5+IIGLU1) =ISAQ1
37404 ENDIF
37405 ISTHKT(5+IIGLU1) =932
37406 JMOHKT(1,5+IIGLU1)=NC1T
37407 JMOHKT(2,5+IIGLU1)=0
37408 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37409 JDAHKT(2,5+IIGLU1)=0
37410 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37411 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37412 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37413 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37414C IF( PHKT(4,5).EQ.0.D0)THEN
37415C IREJ=1
37416CIPCO=0
37417CRETURN
37418C ENDIF
37419C PHKT(5,5) =PHKK(5,NC1T)
37420 XMIST=(PHKT(4,5+IIGLU1)**2-
37421 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37422 *PHKT(1,5+IIGLU1)**2)
37423 IF(XMIST.GT.0.D0)THEN
37424 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37425 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37426 *PHKT(1,5+IIGLU1)**2)
37427 ELSE
37428C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37429 PHKT(5,5+IIGLU1)=0.D0
37430 ENDIF
37431 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37432 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37433 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37434 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37435 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37436 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37437 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37438 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37439 IDHKT(6+IIGLU1) =88888
37440 ISTHKT(6+IIGLU1) =94
37441 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37442 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37443 JDAHKT(1,6+IIGLU1)=0
37444 JDAHKT(2,6+IIGLU1)=0
37445 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37446 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37447 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37448 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37449 XMIST
37450 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37451 * -PHKT(3,6+IIGLU1)**2)
37452 IF(XMIST.GE.0.D0)THEN
37453 PHKT(5,6+IIGLU1)
37454 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37455 * -PHKT(3,6+IIGLU1)**2)
37456 ELSE
37457C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37458 PHKT(5,1)=0.D0
37459 ENDIF
37460C IF(IPIP.EQ.3)THEN
37461 CHAMAL=CHAM1
37462 IF(IPIP.EQ.1)THEN
37463 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37464 ELSEIF(IPIP.EQ.2)THEN
37465 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37466 ENDIF
37467 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37468C IREJ=1
37469 IPCO=0
37470C RETURN
37471C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37472C & CHAMAL,PHKT(5,6+IIGLU1)
37473 GO TO 3466
37474 ENDIF
37475 IF(IPIP.GE.3)THEN
37476C IF(NUMEV.EQ.-324)THEN
37477 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37478 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37479 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37480 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37481 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37482 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37483 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37484 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37485 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37486 ENDIF
37487 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37488 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37489 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37490 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37491 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37492 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37493 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37494 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37495 IF(IPIP.EQ.1)THEN
37496 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37497 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37498 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37499 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37500 ELSEIF(IPIP.EQ.2)THEN
37501 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37502 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37503 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37504 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37505C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37506 ENDIF
37507 ISTHKT(7+IIGLU1) =931
37508 JMOHKT(1,7+IIGLU1)=NC2P
37509 JMOHKT(2,7+IIGLU1)=0
37510 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37511 JDAHKT(2,7+IIGLU1)=0
37512C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37513 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37514 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37515 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37516 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37517C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37518C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37519 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37520C IREJ=1
37521C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37522 IPCO=0
37523C RETURN
37524 GO TO 3466
37525 ENDIF
37526C PHKT(5,7) =PHKK(5,NC2P)
37527 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37528 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37529 *PHKT(1,7+IIGLU1)**2)
37530 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37531 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37532 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37533 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37534 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37535 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37536 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37537 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37538C Insert here the IIGLU2 gluons
37539 PG1=0.D0
37540 PG2=0.D0
37541 PG3=0.D0
37542 PG4=0.D0
37543 IF(IIGLU2.GE.1)THEN
37544 JJG=NC2P
37545 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37546 KKG=JJG+IIG-7-IIGLU1
37547 IDHKT(IIG) =IDHKK(KKG)
37548 ISTHKT(IIG) =921
37549 JMOHKT(1,IIG)=KKG
37550 JMOHKT(2,IIG)=0
37551 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37552 JDAHKT(2,IIG)=0
37553 PHKT(1,IIG)=PHKK(1,KKG)
37554 PG1=PG1+ PHKT(1,IIG)
37555 PHKT(2,IIG)=PHKK(2,KKG)
37556 PG2=PG2+ PHKT(2,IIG)
37557 PHKT(3,IIG)=PHKK(3,KKG)
37558 PG3=PG3+ PHKT(3,IIG)
37559 PHKT(4,IIG)=PHKK(4,KKG)
37560 PG4=PG4+ PHKT(4,IIG)
37561 PHKT(5,IIG)=PHKK(5,KKG)
37562 VHKT(1,IIG) =VHKK(1,KKG)
37563 VHKT(2,IIG) =VHKK(2,KKG)
37564 VHKT(3,IIG) =VHKK(3,KKG)
37565 VHKT(4,IIG) =VHKK(4,KKG)
37566 WHKT(1,IIG) =WHKK(1,KKG)
37567 WHKT(2,IIG) =WHKK(2,KKG)
37568 WHKT(3,IIG) =WHKK(3,KKG)
37569 WHKT(4,IIG) =WHKK(4,KKG)
37570 81 CONTINUE
37571 ENDIF
37572 IDHKT(8+IIGLU1+IIGLU2) =IP2
37573 ISTHKT(8+IIGLU1+IIGLU2) =932
37574 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37575 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37576 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37577 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37578 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37579 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37580 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37581 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37582C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37583 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37584 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37585 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37586 IF(XMIST.GT.0.D0)THEN
37587 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37588 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37589 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37590 ELSE
37591C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37592 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37593 ENDIF
37594 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37595 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37596 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37597 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37598 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37599 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37600 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37601 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37602 IDHKT(9+IIGLU1+IIGLU2) =88888
37603 ISTHKT(9+IIGLU1+IIGLU2) =94
37604 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37605 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37606 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37607 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37608 PHKT(1,9+IIGLU1+IIGLU2)
37609 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37610 PHKT(2,9+IIGLU1+IIGLU2)
37611 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37612 PHKT(3,9+IIGLU1+IIGLU2)
37613 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37614 PHKT(4,9+IIGLU1+IIGLU2)
37615 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37616 XMIST
37617 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37618 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37619 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37620 IF(XMIST.GE.0.D0)THEN
37621 PHKT(5,9+IIGLU1+IIGLU2)
37622 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37623 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37624 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37625 ELSE
37626C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37627 PHKT(5,1)=0.D0
37628 ENDIF
37629 IF(IPIP.GE.3)THEN
37630C IF(NUMEV.EQ.-324)THEN
37631 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37632 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37633 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37634 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37635 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37636 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37637 * JDAHKT(1,IIG),
37638 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37639 91 CONTINUE
37640 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37641 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37642 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37643 *JDAHKT(1,8+IIGLU1+IIGLU2),
37644 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37645 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37646 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37647 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37648 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37649 ENDIF
37650 CHAMAL=CHAB1
37651 IF(IPIP.EQ.1)THEN
37652 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37653 ELSEIF(IPIP.EQ.2)THEN
37654 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37655 ENDIF
37656 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37657C IREJ=1
37658 IPCO=0
37659C RETURN
37660C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37661C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37662 GO TO 3466
37663 ENDIF
37664 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37665 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37666 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37667 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37668 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37669 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37670 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37671 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37672C
37673 IPCO=0
37674 IGCOUN=9+IIGLU1+IIGLU2
37675 RETURN
37676 END
37677
37678*$ CREATE MGSQBS1.FOR
37679*COPY MGSQBS1
37680C
37681C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37682 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37683 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37684C
37685C GSQBS-1 diagram (split projectile diquark)
37686C
37687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37688 SAVE
37689
37690 PARAMETER ( LINP = 10 ,
37691 & LOUT = 6 ,
37692 & LDAT = 9 )
37693
37694* event history
37695
37696 PARAMETER (NMXHKK=200000)
37697
37698 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37699 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37700 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37701
37702* extended event history
37703 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37704 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37705 & IHIST(2,NMXHKK)
37706
37707* Lorentz-parameters of the current interaction
37708 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37709 & UMO,PPCM,EPROJ,PPROJ
37710
37711* diquark-breaking mechanism
37712 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37713
37714C
37715 PARAMETER (NTMHKK= 300)
37716 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37717 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37718 +(4,NTMHKK)
37719*KEEP,XSEADI.
37720 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37721 +SSMIMQ,VVMTHR
37722*KEEP,DPRIN.
37723 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37724C
37725C GSQBS-1 diagram (split projectile diquark)
37726C
37727C
37728C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37729C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37730C
37731C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37732C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37733C
37734C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37735C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37736C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37737C
37738C Put new chains into COMMON /HKKTMP/
37739C
37740 IIGLU1=NC1T-NC1P-1
37741 IIGLU2=NC2T-NC2P-1
37742 IGCOUN=0
37743C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37744 CVQ=1.D0
37745 NNNC1=IDHKK(NC1)/1000
37746 MMMC1=IDHKK(NC1)-NNNC1*1000
37747 KKKC1=ISTHKK(NC1)
37748 NNNC2=IDHKK(NC2)/1000
37749 MMMC2=IDHKK(NC2)-NNNC2*1000
37750 KKKC2=ISTHKK(NC2)
37751 IREJ=0
37752 IF(IPIP.EQ.3)THEN
37753 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37754 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37755 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37756 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37757 ENDIF
37758C
37759C
37760C
37761C determine x-values of NC1P diquark
37762 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37763 XVQT=PHKK(4,NC1T)*2.D0/UMO
37764C
37765C determine x-values of sea quark pair
37766C
37767 IPCO=1
37768 ICOU=0
37769 2234 CONTINUE
37770 ICOU=ICOU+1
37771 IF(ICOU.GE.500)THEN
37772 IREJ=1
37773 IF(ISQ.EQ.3)IREJ=3
37774 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37775 IPCO=0
37776 RETURN
37777 ENDIF
37778 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37779 * UMO, XDIQP,XVQT
37780 XSQ=0.D0
37781 XSAQ=0.D0
37782**NEW
37783C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37784 IF (IPIP.EQ.1) THEN
37785 XQMAX = XDIQP/2.0D0
37786 XAQMAX = 2.D0*XVQT/3.0D0
37787 ELSE
37788 XQMAX = 2.D0*XVQT/3.0D0
37789 XAQMAX = XDIQP/2.0D0
37790 ENDIF
37791 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37792 ISAQ = 6+ISQ
37793C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37794**
37795 IF(IPCO.GE.3)
37796 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37797 IF(IREJ.GE.1)THEN
37798 IF(IPCO.GE.3)
37799 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37800 IPCO=0
37801 RETURN
37802 ENDIF
37803 IF(IPIP.EQ.1)THEN
37804 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37805 ELSEIF(IPIP.EQ.2)THEN
37806 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37807 ENDIF
37808 IF(IPCO.GE.3)THEN
37809 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37810 & XDIQP,XVQT,XSQ,XSAQ
37811 ENDIF
37812C
37813C subtract xsq,xsaq from NC1P diquark and NC1T quark
37814C
37815C XSQ=0.D0
37816 IF(IPIP.EQ.1)THEN
37817 XDIQP=XDIQP-XSQ
37818**NEW
37819C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37820**
37821 XVQT =XVQT -XSAQ
37822 ELSEIF(IPIP.EQ.2)THEN
37823 XDIQP=XDIQP-XSAQ
37824 XVQT =XVQT -XSQ
37825 ENDIF
37826 IF(IPCO.GE.3)
37827 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37828C
37829C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37830C
37831 XVTHRO=CVQ/UMO
37832 IVTHR=0
37833 3466 CONTINUE
37834 IF(IVTHR.EQ.10)THEN
37835 IREJ=1
37836 IF(ISQ.EQ.3)IREJ=3
37837 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37838 IPCO=0
37839 RETURN
37840 ENDIF
37841 IVTHR=IVTHR+1
37842 XVTHR=XVTHRO/(201-IVTHR)
37843 UNOPRV=UNON
37844 380 CONTINUE
37845 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37846 IREJ=1
37847 IF(ISQ.EQ.3)IREJ=3
37848 IF(IPCO.GE.3)
37849 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37850 * XVTHR
37851 IPCO=0
37852 RETURN
37853 ENDIF
37854 IF(DT_RNDM(V).LT.0.5D0)THEN
37855 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37856 XVPQII=XDIQP-XVPQI
37857 ELSE
37858 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37859 XVPQI=XDIQP-XVPQII
37860 ENDIF
37861 IF(IPCO.GE.3)THEN
37862 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37863 & XVTHR,XDIQP,XVPQI,XVPQII
37864 ENDIF
37865C
37866C Prepare 4 momenta of new chains and chain ends
37867C
37868C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37869C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37870C +(4,NTMHKK)
37871C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37872C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37873C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37874 IF(IPIP.EQ.1)THEN
37875 XSQ1=XSQ
37876 XSAQ1=XSAQ
37877 ISQ1=ISQ
37878 ISAQ1=ISAQ
37879 ELSEIF(IPIP.EQ.2)THEN
37880 XSQ1=XSAQ
37881 XSAQ1=XSQ
37882 ISQ1=ISAQ
37883 ISAQ1=ISQ
37884 ENDIF
37885 KK11=IP11
37886C IDHKT(2) =1000*IPP21+100*IPP22+1
37887 KK21= IPP21
37888 KK22= IPP22
37889 XGIVE=0.D0
37890 IDHKT(4+IIGLU1) =IP12
37891 ISTHKT(4+IIGLU1) =921
37892 JMOHKT(1,4+IIGLU1)=NC1P
37893 JMOHKT(2,4+IIGLU1)=0
37894 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37895 JDAHKT(2,4+IIGLU1)=0
37896**NEW
37897 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37898 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37899**
37900 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37901 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37902 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37903 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37904C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37905 XXMIST=(PHKT(4,4+IIGLU1)**2-
37906 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37907 * PHKT(1,4+IIGLU1)**2)
37908 IF(XXMIST.GT.0.D0)THEN
37909 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37910 ELSE
37911 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37912 XXMIST=ABS(XXMIST)
37913 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37914 ENDIF
37915 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37916 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37917 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37918 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37919 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37920 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37921 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37922 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37923 IF(IPIP.EQ.1)THEN
37924 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37925 ELSEIF(IPIP.EQ.2)THEN
37926 IDHKT(5+IIGLU1) =ISAQ1
37927 ENDIF
37928 ISTHKT(5+IIGLU1) =922
37929 JMOHKT(1,5+IIGLU1)=NC1T
37930 JMOHKT(2,5+IIGLU1)=0
37931 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37932 JDAHKT(2,5+IIGLU1)=0
37933**NEW
37934 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37935 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37936**
37937 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37938 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37939 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37940 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37941C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37942 XMIST=(PHKT(4,5+IIGLU1)**2-
37943 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37944 *PHKT(1,5+IIGLU1)**2)
37945 IF(XMIST.GT.0.D0)THEN
37946 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37947 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37948 *PHKT(1,5+IIGLU1)**2)
37949 ELSE
37950C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37951 PHKT(5,5+IIGLU1)=0.D0
37952 ENDIF
37953 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37954 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37955 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37956 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37957 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37958 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37959 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37960 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37961 IDHKT(6+IIGLU1) =88888
37962C IDHKT(6) =1000*NNNC1+MMMC1
37963 ISTHKT(6+IIGLU1) =93
37964C ISTHKT(6) =KKKC1
37965 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37966 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37967 JDAHKT(1,6+IIGLU1)=0
37968 JDAHKT(2,6+IIGLU1)=0
37969 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37970 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37971 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37972 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37973 PHKT(5,6+IIGLU1)
37974 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37975 * -PHKT(3,6+IIGLU1)**2)
37976 CHAMAL=CHAM1
37977 IF(IPIP.EQ.1)THEN
37978 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37979 ELSEIF(IPIP.EQ.2)THEN
37980 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37981 ENDIF
37982 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37983 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37984C we drop chain 6 and give the energy to chain 3
37985 IDHKT(6+IIGLU1)=33888
37986 XGIVE=1.D0
37987C WRITE(6,*)' drop chain 6 xgive=1'
37988 GO TO 7788
37989 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37990C we drop chain 6 and give the energy to chain 3
37991C and change KK11 to IDHKT(4)
37992 IDHKT(6+IIGLU1)=33888
37993 XGIVE=1.D0
37994C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37995 KK11=IDHKT(4+IIGLU1)
37996 GO TO 7788
37997 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37998C we drop chain 6 and give the energy to chain 3
37999C and change KK21 to IDHKT(4)
38000C IDHKT(2) =1000*IPP21+100*IPP22+1
38001 IDHKT(6+IIGLU1)=33888
38002 XGIVE=1.D0
38003C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38004 KK21=IDHKT(4+IIGLU1)
38005 GO TO 7788
38006 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38007C we drop chain 6 and give the energy to chain 3
38008C and change KK22 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 KK22=IDHKT(4+IIGLU1)'
38013 KK22=IDHKT(4+IIGLU1)
38014 GO TO 7788
38015 ENDIF
38016C IREJ=1
38017 IPCO=0
38018C RETURN
38019C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38020 GO TO 3466
38021 ENDIF
38022 7788 CONTINUE
38023 IF(IPIP.GE.3)THEN
38024 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38025 * JMOHKT(1,4+IIGLU1),
38026 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38027 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38028 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38029 * JMOHKT(1,5+IIGLU1),
38030 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38031 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38032 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38033 * JMOHKT(1,6+IIGLU1),
38034 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38035 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38036 ENDIF
38037 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38038 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38039 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38040 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38041 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38042 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38043 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38044 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38045C IDHKT(1) =IP11
38046 IDHKT(1) =KK11
38047 ISTHKT(1) =921
38048 JMOHKT(1,1)=NC1P
38049 JMOHKT(2,1)=0
38050 JDAHKT(1,1)=3+IIGLU1
38051 JDAHKT(2,1)=0
38052 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38053C * +0.5D0*PHKK(1,NC2P)
38054 *+XGIVE*PHKT(1,4+IIGLU1)
38055 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38056C * +0.5D0*PHKK(2,NC2P)
38057 *+XGIVE*PHKT(2,4+IIGLU1)
38058 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38059C * +0.5D0*PHKK(3,NC2P)
38060 *+XGIVE*PHKT(3,4+IIGLU1)
38061 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38062C * +0.5D0*PHKK(4,NC2P)
38063 *+XGIVE*PHKT(4,4+IIGLU1)
38064C PHKT(5,1) =PHKK(5,NC1P)
38065 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38066 *PHKT(1,1)**2)
38067 IF(XMIST.GE.0.D0)THEN
38068 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38069 *PHKT(1,1)**2)
38070 ELSE
38071C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38072 PHKT(5,1)=0.D0
38073 ENDIF
38074 VHKT(1,1) =VHKK(1,NC1P)
38075 VHKT(2,1) =VHKK(2,NC1P)
38076 VHKT(3,1) =VHKK(3,NC1P)
38077 VHKT(4,1) =VHKK(4,NC1P)
38078 WHKT(1,1) =WHKK(1,NC1P)
38079 WHKT(2,1) =WHKK(2,NC1P)
38080 WHKT(3,1) =WHKK(3,NC1P)
38081 WHKT(4,1) =WHKK(4,NC1P)
38082C Add here IIGLU1 gluons to this chaina
38083 PG1=0.D0
38084 PG2=0.D0
38085 PG3=0.D0
38086 PG4=0.D0
38087 IF(IIGLU1.GE.1)THEN
38088 JJG=NC1P
38089 DO 61 IIG=2,2+IIGLU1-1
38090 KKG=JJG+IIG-1
38091 IDHKT(IIG) =IDHKK(KKG)
38092 ISTHKT(IIG) =921
38093 JMOHKT(1,IIG)=KKG
38094 JMOHKT(2,IIG)=0
38095 JDAHKT(1,IIG)=3+IIGLU1
38096 JDAHKT(2,IIG)=0
38097 PHKT(1,IIG)=PHKK(1,KKG)
38098 PG1=PG1+ PHKT(1,IIG)
38099 PHKT(2,IIG)=PHKK(2,KKG)
38100 PG2=PG2+ PHKT(2,IIG)
38101 PHKT(3,IIG)=PHKK(3,KKG)
38102 PG3=PG3+ PHKT(3,IIG)
38103 PHKT(4,IIG)=PHKK(4,KKG)
38104 PG4=PG4+ PHKT(4,IIG)
38105 PHKT(5,IIG)=PHKK(5,KKG)
38106 VHKT(1,IIG) =VHKK(1,KKG)
38107 VHKT(2,IIG) =VHKK(2,KKG)
38108 VHKT(3,IIG) =VHKK(3,KKG)
38109 VHKT(4,IIG) =VHKK(4,KKG)
38110 WHKT(1,IIG) =WHKK(1,KKG)
38111 WHKT(2,IIG) =WHKK(2,KKG)
38112 WHKT(3,IIG) =WHKK(3,KKG)
38113 WHKT(4,IIG) =WHKK(4,KKG)
38114 61 CONTINUE
38115 ENDIF
38116C IDHKT(2) =1000*IPP21+100*IPP22+1
38117 IF(IPIP.EQ.1)THEN
38118 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38119 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38120 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38121 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38122 ELSEIF(IPIP.EQ.2)THEN
38123 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38124 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38125 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38126 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38127 ENDIF
38128 ISTHKT(2+IIGLU1) =922
38129 JMOHKT(1,2+IIGLU1)=NC2T
38130 JMOHKT(2,2+IIGLU1)=0
38131 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38132 JDAHKT(2,2+IIGLU1)=0
38133 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38134 *+XGIVE*PHKT(1,5+IIGLU1)
38135 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38136 *+XGIVE*PHKT(2,5+IIGLU1)
38137 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38138 *+XGIVE*PHKT(3,5+IIGLU1)
38139 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38140 *+XGIVE*PHKT(4,5+IIGLU1)
38141C PHKT(5,2) =PHKK(5,NC2T)
38142 XMIST=(PHKT(4,2+IIGLU1)**2-
38143 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38144 *PHKT(1,2+IIGLU1)**2)
38145 IF(XMIST.GT.0.D0)THEN
38146 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38147 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38148 *PHKT(1,2+IIGLU1)**2)
38149 ELSE
38150C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38151 PHKT(5,2+IIGLU1)=0.D0
38152 ENDIF
38153 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38154 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38155 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38156 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38157 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38158 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38159 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38160 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38161 IDHKT(3+IIGLU1) =88888
38162C IDHKT(3) =1000*NNNC1+MMMC1+10
38163 ISTHKT(3+IIGLU1) =93
38164C ISTHKT(3) =KKKC1
38165 JMOHKT(1,3+IIGLU1)=1
38166 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38167 JDAHKT(1,3+IIGLU1)=0
38168 JDAHKT(2,3+IIGLU1)=0
38169 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38170 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38171 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38172 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38173 PHKT(5,3+IIGLU1)
38174 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38175 * -PHKT(3,3+IIGLU1)**2)
38176 IF(IPIP.GE.3)THEN
38177 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38178 * JDAHKT(1,1),
38179 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38180 DO 71 IIG=2,2+IIGLU1-1
38181 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38182 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38183 * JDAHKT(1,IIG),
38184 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38185 71 CONTINUE
38186 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38187 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38188 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38189 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38190 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38191 * JMOHKT(1,3+IIGLU1),
38192 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38193 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38194 ENDIF
38195 CHAMAL=CHAB1
38196**NEW
38197C IF(IPIP.EQ.1)THEN
38198C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38199C ELSEIF(IPIP.EQ.2)THEN
38200C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38201C ENDIF
38202 IF(IPIP.EQ.1)THEN
38203 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38204 ELSEIF(IPIP.EQ.2)THEN
38205 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38206 ENDIF
38207**
38208 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38209C IREJ=1
38210 IPCO=0
38211C RETURN
38212C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38213 GO TO 3466
38214 ENDIF
38215 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38216 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38217 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38218 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38219 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38220 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38221 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38222 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38223 IF(IPIP.EQ.1)THEN
38224 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38225 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38226 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38227 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38228 ELSEIF(IPIP.EQ.2)THEN
38229 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38230 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38231 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38232 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38233C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38234 ENDIF
38235 ISTHKT(7+IIGLU1) =921
38236 JMOHKT(1,7+IIGLU1)=NC2P
38237 JMOHKT(2,7+IIGLU1)=0
38238 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38239 JDAHKT(2,7+IIGLU1)=0
38240C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38241C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38242C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38243C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38244**NEW
38245 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38246 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38247**
38248 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38249 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38250 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38251 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38252C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38253C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38254 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38255C IREJ=1
38256C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38257 IPCO=0
38258C RETURN
38259 GO TO 3466
38260 ENDIF
38261C PHKT(5,7) =PHKK(5,NC2P)
38262 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38263 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38264 *PHKT(1,7+IIGLU1)**2)
38265 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38266 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38267 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38268 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38269 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38270 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38271 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38272 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38273C Insert here the IIGLU2 gluons
38274 PG1=0.D0
38275 PG2=0.D0
38276 PG3=0.D0
38277 PG4=0.D0
38278 IF(IIGLU2.GE.1)THEN
38279 JJG=NC2P
38280 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38281 KKG=JJG+IIG-7-IIGLU1
38282 IDHKT(IIG) =IDHKK(KKG)
38283 ISTHKT(IIG) =921
38284 JMOHKT(1,IIG)=KKG
38285 JMOHKT(2,IIG)=0
38286 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38287 JDAHKT(2,IIG)=0
38288 PHKT(1,IIG)=PHKK(1,KKG)
38289 PG1=PG1+ PHKT(1,IIG)
38290 PHKT(2,IIG)=PHKK(2,KKG)
38291 PG2=PG2+ PHKT(2,IIG)
38292 PHKT(3,IIG)=PHKK(3,KKG)
38293 PG3=PG3+ PHKT(3,IIG)
38294 PHKT(4,IIG)=PHKK(4,KKG)
38295 PG4=PG4+ PHKT(4,IIG)
38296 PHKT(5,IIG)=PHKK(5,KKG)
38297 VHKT(1,IIG) =VHKK(1,KKG)
38298 VHKT(2,IIG) =VHKK(2,KKG)
38299 VHKT(3,IIG) =VHKK(3,KKG)
38300 VHKT(4,IIG) =VHKK(4,KKG)
38301 WHKT(1,IIG) =WHKK(1,KKG)
38302 WHKT(2,IIG) =WHKK(2,KKG)
38303 WHKT(3,IIG) =WHKK(3,KKG)
38304 WHKT(4,IIG) =WHKK(4,KKG)
38305 81 CONTINUE
38306 ENDIF
38307 IDHKT(8+IIGLU1+IIGLU2) =IP2
38308 ISTHKT(8+IIGLU1+IIGLU2) =922
38309 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38310 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38311 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38312 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38313**NEW
38314 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38315 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38316**
38317 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38318 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38319 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38320 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38321C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38322 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38323 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38324 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38325 IF(XMIST.GT.0.D0)THEN
38326 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38327 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38328 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38329 ELSE
38330C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38331 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38332 ENDIF
38333 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38334 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38335 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38336 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38337 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38338 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38339 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38340 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38341 IDHKT(9+IIGLU1+IIGLU2) =88888
38342C IDHKT(9) =1000*NNNC2+MMMC2+10
38343 ISTHKT(9+IIGLU1+IIGLU2) =93
38344C ISTHKT(9) =KKKC2
38345 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38346 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38347 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38348 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38349 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38350 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38351 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38352 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38353 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38354 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38355 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38356 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38357 PHKT(5,9+IIGLU1+IIGLU2)
38358 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38359 * PHKT(2,9+IIGLU1+IIGLU2)**2
38360 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38361 IF(IPIP.GE.3)THEN
38362 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38363 * JMOHKT(1,7+IIGLU1),
38364 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38365 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38366 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38367 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38368 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38369 * JDAHKT(1,IIG),
38370 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38371 91 CONTINUE
38372 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38373 * IDHKT(8+IIGLU1+IIGLU2),
38374 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38375 * JDAHKT(1,8+IIGLU1+IIGLU2),
38376 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38377 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38378 * IDHKT(9+IIGLU1+IIGLU2),
38379 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38380 * JDAHKT(1,9+IIGLU1+IIGLU2),
38381 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38382 ENDIF
38383 CHAMAL=CHAB1
38384 IF(IPIP.EQ.1)THEN
38385 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38386 ELSEIF(IPIP.EQ.2)THEN
38387 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38388 ENDIF
38389 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38390C IREJ=1
38391 IPCO=0
38392C RETURN
38393C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38394C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38395 GO TO 3466
38396 ENDIF
38397 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38398 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38399 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38400 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38401 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38402 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38403 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38404 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38405C
38406 IGCOUN=9+IIGLU1+IIGLU2
38407 IPCO=0
38408 RETURN
38409 END
38410
38411*$ CREATE HKKHKT.FOR
38412*COPY HKKHKT
38413C
38414C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38415C
38416 SUBROUTINE HKKHKT(I,J)
38417 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38418 SAVE
38419
38420* event history
38421
38422 PARAMETER (NMXHKK=200000)
38423
38424 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38425 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38426 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38427
38428* extended event history
38429 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38430 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38431 & IHIST(2,NMXHKK)
38432
38433 PARAMETER (NTMHKK= 300)
38434 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38435 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38436 +(4,NTMHKK)
38437C
38438 ISTHKK(I) =ISTHKT(J)
38439 IDHKK(I) =IDHKT(J)
38440C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38441 IF(IDHKK(I).EQ.88888)THEN
38442C JMOHKK(1,I)=I-2
38443C JMOHKK(2,I)=I-1
38444 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38445 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38446 ELSE
38447 JMOHKK(1,I)=JMOHKT(1,J)
38448 JMOHKK(2,I)=JMOHKT(2,J)
38449 ENDIF
38450 JDAHKK(1,I)=JDAHKT(1,J)
38451 JDAHKK(2,I)=JDAHKT(2,J)
38452C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38453C JDAHKK(1,I)=I+2
38454C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38455C JDAHKK(1,I)=I+1
38456C ENDIF
38457 IF(JDAHKT(1,J).GT.0)THEN
38458 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38459 ENDIF
38460 PHKK(1,I) =PHKT(1,J)
38461 PHKK(2,I) =PHKT(2,J)
38462 PHKK(3,I) =PHKT(3,J)
38463 PHKK(4,I) =PHKT(4,J)
38464 PHKK(5,I) =PHKT(5,J)
38465 VHKK(1,I) =VHKT(1,J)
38466 VHKK(2,I) =VHKT(2,J)
38467 VHKK(3,I) =VHKT(3,J)
38468 VHKK(4,I) =VHKT(4,J)
38469 WHKK(1,I) =WHKT(1,J)
38470 WHKK(2,I) =WHKT(2,J)
38471 WHKK(3,I) =WHKT(3,J)
38472 WHKK(4,I) =WHKT(4,J)
38473 RETURN
38474 END
38475
38476*$ CREATE DT_DBREAK.FOR
38477*COPY DT_DBREAK
38478*
38479*===dbreak=============================================================*
38480*
38481 SUBROUTINE DT_DBREAK(MODE)
38482
38483************************************************************************
38484* This is the steering subroutine for the different diquark breaking *
38485* mechanisms. *
38486* *
38487* MODE = 1 breaking of projectile diquark in qq-q chain using *
38488* a sea quark (q-qq chain) of the same projectile *
38489* = 2 breaking of target diquark in q-qq chain using *
38490* a sea quark (qq-q chain) of the same target *
38491* = 3 breaking of projectile diquark in qq-q chain using *
38492* a sea quark (q-aq chain) of the same projectile *
38493* = 4 breaking of target diquark in q-qq chain using *
38494* a sea quark (aq-q chain) of the same target *
38495* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38496* a sea anti-quark (aq-aqaq chain) of the same projectile *
38497* = 6 breaking of target anti-diquark in aq-aqaq chain using *
38498* a sea anti-quark (aqaq-aq chain) of the same target *
38499* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38500* a sea anti-quark (aq-q chain) of the same projectile *
38501* = 8 breaking of target anti-diquark in aq-aqaq chain using *
38502* a sea anti-quark (q-aq chain) of the same target *
38503* *
38504* Original version by J. Ranft. *
38505* This version dated 17.5.00 is written by S. Roesler. *
38506************************************************************************
38507
38508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38509 SAVE
38510
38511 PARAMETER ( LINP = 10 ,
38512 & LOUT = 6 ,
38513 & LDAT = 9 )
38514
38515* event history
38516
38517 PARAMETER (NMXHKK=200000)
38518
38519 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38520 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38521 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38522
38523* extended event history
38524 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38525 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38526 & IHIST(2,NMXHKK)
38527
38528* flags for input different options
38529 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38530 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38531 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38532
38533* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38534 PARAMETER (MAXCHN=10000)
38535 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38536
38537* diquark-breaking mechanism
38538 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38539
38540* flags for particle decays
38541 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38542 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38543 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38544
38545*
38546* chain identifiers
38547* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38548* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38549 DIMENSION IDCHN1(8),IDCHN2(8)
38550 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38551 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38552*
38553* parton identifiers
38554* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38555* +-51/52 = unitarity-sea, +-61/62 = gluons )
38556 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38557 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38558 & 31, 31, 31, 31, 31, 31, 31, 31,
38559 & 41, 41, 41, 41, 51, 51, 51, 51/
38560 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38561 & 32, 32, 32, 32, 32, 32, 32, 32,
38562 & 42, 42, 42, 42, 52, 52, 52, 52/
38563 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38564 & 51, 31, 41, 41, 31, 31, 31, 31,
38565 & 0, 41, 51, 51, 51, 51, 51, 51/
38566 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38567 & 32, 52, 42, 42, 32, 32, 32, 32,
38568 & 42, 0, 52, 52, 52, 52, 52, 52/
38569
38570 IF (NCHAIN.LE.0) RETURN
38571 DO 1 I=1,NCHAIN
38572 IDX1 = IDXCHN(1,I)
38573 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38574 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38575 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38576 & .AND.
38577 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38578 & (IS1P.EQ.ISP1P(MODE,3)))
38579 & .AND.
38580 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38581 & (IS1T.EQ.ISP1T(MODE,3)))
38582 & ) THEN
38583 DO 2 J=1,NCHAIN
38584 IDX2 = IDXCHN(1,J)
38585 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38586 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38587 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38588 & .AND.
38589 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38590 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38591 & .AND.
38592 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38593 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38594 & ) THEN
38595* find mother nucleons of the diquark to be splitted and of the
38596* sea-quark and reject this combination if it is not the same
38597 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38598 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38599 IANCES = 1
38600 ELSE
38601 IANCES = 2
38602 ENDIF
38603 IDXMO1 = JMOHKK(IANCES,IDX1)
38604 4 CONTINUE
38605 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38606 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38607 IANC = IANCES
38608 ELSE
38609 IANC = 1
38610 ENDIF
38611 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38612 IDXMO1 = JMOHKK(IANC,IDXMO1)
38613 GOTO 4
38614 ENDIF
38615 IDXMO2 = JMOHKK(IANCES,IDX2)
38616 5 CONTINUE
38617 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38618 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38619 IANC = IANCES
38620 ELSE
38621 IANC = 1
38622 ENDIF
38623 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38624 IDXMO2 = JMOHKK(IANC,IDXMO2)
38625 GOTO 5
38626 ENDIF
38627 IF (IDXMO1.NE.IDXMO2) GOTO 2
38628* quark content of projectile parton
38629 IP1 = IDHKK(JMOHKK(1,IDX1))
38630 IP11 = IP1/1000
38631 IP12 = (IP1-1000*IP11)/100
38632 IP2 = IDHKK(JMOHKK(2,IDX1))
38633 IP21 = IP2/1000
38634 IP22 = (IP2-1000*IP21)/100
38635* quark content of target parton
38636 IT1 = IDHKK(JMOHKK(1,IDX2))
38637 IT11 = IT1/1000
38638 IT12 = (IT1-1000*IT11)/100
38639 IT2 = IDHKK(JMOHKK(2,IDX2))
38640 IT21 = IT2/1000
38641 IT22 = (IT2-1000*IT21)/100
38642* split diquark and form new chains
38643 IF (MODE.EQ.1) THEN
38644 IF (IT1.EQ.4) GOTO 2
38645 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38646 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38647 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38648 ELSEIF (MODE.EQ.2) THEN
38649 IF (IT2.EQ.4) GOTO 2
38650 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38651 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38652 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38653 ELSEIF (MODE.EQ.3) THEN
38654 IF (IT1.EQ.4) GOTO 2
38655 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38656 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38657 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38658 ELSEIF (MODE.EQ.4) THEN
38659 IF (IT2.EQ.4) GOTO 2
38660 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38661 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38662 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38663 ELSEIF (MODE.EQ.5) THEN
38664 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38667 ELSEIF (MODE.EQ.6) THEN
38668 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38671 ELSEIF (MODE.EQ.7) THEN
38672 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38675 ELSEIF (MODE.EQ.8) THEN
38676 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38679 ENDIF
38680 IF (IREJ.GE.1) THEN
38681 if ((ipq.lt.0).or.(ipq.ge.4))
38682 & write(LOUT,*) 'ipq !!!',ipq,mode
38683 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38684* accept or reject new chains corresponding to PDBSEA
38685 ELSE
38686 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38687 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38688 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38689 ELSEIF (IPQ.EQ.3) THEN
38690 ACC = DBRKA(3,MODE)
38691 REJ = DBRKR(3,MODE)
38692 ELSE
38693 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38694 STOP
38695 ENDIF
38696 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38697 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38698 IACC = 1
38699 ELSE
38700 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38701 IACC = 0
38702 ENDIF
38703* new chains have been accepted and are now copied into HKKEVT
38704 IF (IACC.EQ.1) THEN
38705 IF (LEMCCK) THEN
38706 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38707 & PHKK(3,IDX1),PHKK(4,IDX1),
38708 & 1,IDUM1,IDUM2)
38709 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38710 & PHKK(3,IDX2),PHKK(4,IDX2),
38711 & 2,IDUM1,IDUM2)
38712 ENDIF
38713 IDHKK(IDX1) = 99888
38714 IDHKK(IDX2) = 99888
38715 IDXCHN(2,I) = -1
38716 IDXCHN(2,J) = -1
38717 DO 3 K=1,IGCOUN
38718 NHKK = NHKK+1
38719 CALL HKKHKT(NHKK,K)
38720 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38721 PX = -PHKK(1,NHKK)
38722 PY = -PHKK(2,NHKK)
38723 PZ = -PHKK(3,NHKK)
38724 PE = -PHKK(4,NHKK)
38725 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38726 ENDIF
38727 3 CONTINUE
38728 IF (LEMCCK) THEN
38729 CHKLEV = 0.1D0
38730 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38731 & IREJ)
38732 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38733 ENDIF
38734 GOTO 1
38735 ENDIF
38736 ENDIF
38737 ENDIF
38738 2 CONTINUE
38739 ENDIF
38740 1 CONTINUE
38741 RETURN
38742 END
38743
38744*$ CREATE DT_CQPAIR.FOR
38745*COPY DT_CQPAIR
38746*
38747*===cqpair=============================================================*
38748*
38749 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38750
38751************************************************************************
38752* This subroutine Creates a Quark-antiquark PAIR from the sea. *
38753* *
38754* XQMAX maxium energy fraction of quark (input) *
38755* XAQMAX maxium energy fraction of antiquark (input) *
38756* XQ energy fraction of quark (output) *
38757* XAQ energy fraction of antiquark (output) *
38758* IFLV quark flavour (- antiquark flavor) (output) *
38759* *
38760* This version dated 14.5.00 is written by S. Roesler. *
38761************************************************************************
38762
38763 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38764 SAVE
38765
38766 PARAMETER ( LINP = 10 ,
38767 & LOUT = 6 ,
38768 & LDAT = 9 )
38769
38770* Lorentz-parameters of the current interaction
38771 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38772 & UMO,PPCM,EPROJ,PPROJ
38773
38774*
38775 IREJ = 0
38776 XQ = 0.0D0
38777 XAQ = 0.0D0
38778*
38779* sample quark flavour
38780*
38781* set seasq here (the one from DTCHAI should be used in the future)
38782 SEASQ = 0.5D0
38783 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38784*
38785* sample energy fractions of sea pair
38786* we first sample the energy fraction of a gluon and then split the gluon
38787*
38788* maximum energy fraction of the gluon forced via input
38789 XGMAXI = XQMAX+XAQMAX
38790* minimum energy fraction of the gluon
38791 XTHR1 = 4.0D0 /UMO**2
38792 XTHR2 = 0.54D0/UMO**1.5D0
38793 XGMIN = MAX(XTHR1,XTHR2)
38794* maximum energy fraction of the gluon
38795 XGMAX = 0.3D0
38796 XGMAX = MIN(XGMAXI,XGMAX)
38797 IF (XGMIN.GE.XGMAX) THEN
38798 IREJ = 1
38799 RETURN
38800 ENDIF
38801*
38802* sample energy fraction of the gluon
38803 NLOOP = 0
38804 1 CONTINUE
38805 NLOOP = NLOOP+1
38806 IF (NLOOP.GE.50) THEN
38807 IREJ = 1
38808 RETURN
38809 ENDIF
38810 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38811 EGLUON = XGLUON*UMO/2.0D0
38812*
38813* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38814 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38815 ZMAX = 1.0D0-ZMIN
38816 RZ = DT_RNDM(ZMAX)
38817 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38818 RQ = DT_RNDM(ZMAX)
38819 IF (RQ.LT.0.5D0) THEN
38820 XQ = XGLUON*XHLP
38821 XAQ = XGLUON-XQ
38822 ELSE
38823 XAQ = XGLUON*XHLP
38824 XQ = XGLUON-XAQ
38825 ENDIF
38826 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38827
38828 RETURN
38829 END