]> 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
Starting a collection of QA/Comparison macros
[u/mrichter/AliRoot.git] / DPMJET / dpmjet3.0-5F.f
CommitLineData
7b076c76 1*$ CREATE DT_INIT.FOR
2*COPY DT_INIT
3*
4* +-------------------------------------------------------------+
5* | |
6* | |
7* | DPMJET 3.0 |
8* | |
9* | |
10* | S. Roesler+), R. Engel#), J. Ranft*) |
11* | |
12* | +) CERN, SC-RP |
13* | CH-1211 Geneva 23, Switzerland |
14* | Email: Stefan.Roesler@cern.ch |
15* | |
16* | #) Institut fuer Kernphysik |
17* | Forschungszentrum Karlsruhe |
18* | D-76021 Karlsruhe, Germany |
19* | |
20* | *) University of Siegen, Dept. of Physics |
21* | D-57068 Siegen, Germany |
22* | |
23* | |
24* | http://home.cern.ch/sroesler/dpmjet3.html |
25* | |
26* | |
27* | Monte Carlo models used for event generation: |
28* | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
29* | |
30* +-------------------------------------------------------------+
31*
32*
33*===init===============================================================*
34*
35 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
36 & IDP,IGLAU)
37
38************************************************************************
39* Initialization of event generation *
40* This version dated 7.4.98 is written by S. Roesler. *
41* *
42* Last change 27.12.2006 by S. Roesler. *
43************************************************************************
44
45 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
46 SAVE
47
48 PARAMETER ( LINP = 10 ,
49 & LOUT = 6 ,
50 & LDAT = 9 )
51 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
52
53* particle properties (BAMJET index convention)
54 CHARACTER*8 ANAME
55 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
56 & IICH(210),IIBAR(210),K1(210),K2(210)
57
58* names of hadrons used in input-cards
59 CHARACTER*8 BTYPE
60 COMMON /DTPAIN/ BTYPE(30)
61
62* INCLUDE '(DIMPAR)'
63* DIMPAR taken from FLUKA
64 PARAMETER ( MXXRGN =20000 )
65 PARAMETER ( MXXMDF = 710 )
66 PARAMETER ( MXXMDE = 702 )
67 PARAMETER ( MFSTCK =40000 )
68 PARAMETER ( MESTCK = 100 )
69 PARAMETER ( MOSTCK = 2000 )
70 PARAMETER ( MXPRSN = 100 )
71 PARAMETER ( MXPDPM = 800 )
72 PARAMETER ( MXPSCS =30000 )
73 PARAMETER ( MXGLWN = 300 )
74 PARAMETER ( MXOUTU = 50 )
75 PARAMETER ( NALLWP = 64 )
76 PARAMETER ( NELEMX = 80 )
77 PARAMETER ( MPDPDX = 18 )
78 PARAMETER ( MXHTTR = 260 )
79 PARAMETER ( MXSEAX = 20 )
80 PARAMETER ( MXHTNC = MXSEAX + 1 )
81 PARAMETER ( ICOMAX = 2400 )
82 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
83 PARAMETER ( NSTBIS = 304 )
84 PARAMETER ( NQSTIS = 46 )
85 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
86 PARAMETER ( MXPABL = 120 )
87 PARAMETER ( IDMAXP = 450 )
88 PARAMETER ( IDMXDC = 2000 )
89 PARAMETER ( MXMCIN = 410 )
90 PARAMETER ( IHYPMX = 4 )
91 PARAMETER ( MKBMX1 = 11 )
92 PARAMETER ( MKBMX2 = 11 )
93 PARAMETER ( MXIRRD = 2500 )
94 PARAMETER ( MXTRDC = 1500 )
95 PARAMETER ( NKTL = 17 )
96 PARAMETER ( NBLNMX = 40000000 )
97
98* INCLUDE '(PAREVT)'
99* PAREVT taken from FLUKA
100 PARAMETER ( FRDIFF = 0.2D+00 )
101 PARAMETER ( ETHSEA = 1.0D+00 )
102*
103 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
104 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
105 & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
106 & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
107 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
108 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
109 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
110 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
111 & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
112 & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
113
114* INCLUDE '(EVAFLG)'
115* EVAFLG taken from FLUKA
116 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
117 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
118 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
119 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
120 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
121 & FDSCST,
122 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
123 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
124 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
125 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
126 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
127 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
128 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
129
130* INCLUDE '(FRBKCM)'
131* FRBKCM taken from FLUKA
132* Maximum number of fragments to be emitted:
133 PARAMETER ( MXFFBK = 6 )
134 PARAMETER ( MXZFBK = 10 )
135 PARAMETER ( MXNFBK = 12 )
136 PARAMETER ( MXAFBK = 16 )
137 PARAMETER ( MXASST = 25 )
138 PARAMETER ( NXAFBK = MXAFBK + 1 )
139 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
140 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
141 PARAMETER ( MXPSST = 700 )
142* Maximum number of pre-computed break-up combinations
143 PARAMETER ( MXPPFB = 42500 )
144* Maximum number of break-up combinations, including special
145* run-time ones:
146 PARAMETER ( MXPSFB = 43000 )
147* Base for J multiplicity encoding:
148 PARAMETER ( IBFRBK = 73 )
149* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
150* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
151* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
152* --> Ibfrbk^(Jpwfbx+1) < 2100000000
153 PARAMETER ( JPWFBX = 4 )
154 LOGICAL LFRMBK, LNCMSS
155 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
156 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
157 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
158 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
159 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
160 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
161 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
162 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
163 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
164 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
165 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
166
167* emulsion treatment
168 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
169 & NCOMPO,IEMUL
170
171* Glauber formalism: parameters
172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
173 & BMAX(NCOMPX),BSTEP(NCOMPX),
174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
175 & NSITEB,NSTATB
176
177* Glauber formalism: cross sections
178 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
179 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
180 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
181 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
182 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
183 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
184 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
185 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
186 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
187 & BSLOPE,NEBINI,NQBINI
188
189* interface HADRIN-DPM
190 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
191
192* central particle production, impact parameter biasing
193 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
194
195* parameter for intranuclear cascade
196 LOGICAL LPAULI
197 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
198
199* various options for treatment of partons (DTUNUC 1.x)
200* (chain recombination, Cronin,..)
201 LOGICAL LCO2CR,LINTPT
202 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
203 & LCO2CR,LINTPT
204
205* threshold values for x-sampling (DTUNUC 1.x)
206 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
207 & SSMIMQ,VVMTHR
208
209* flags for input different options
210 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
211 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
212 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
213
214* nuclear potential
215 LOGICAL LFERMI
216 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
217 & EBINDP(2),EBINDN(2),EPOT(2,210),
218 & ETACOU(2),ICOUL,LFERMI
219
220* n-n cross section fluctuations
221 PARAMETER (NBINS = 1000)
222 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
223
224* flags for particle decays
225 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
226 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
227 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
228
229* diquark-breaking mechanism
230 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
231
232* nucleon-nucleon event-generator
233 CHARACTER*8 CMODEL
234 LOGICAL LPHOIN
235 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
236
237* properties of interacting particles
238 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
239
240* properties of photon/lepton projectiles
241 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
242
243* flags for diffractive interactions (DTUNUC 1.x)
244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
245
246* parameters for hA-diffraction
247 COMMON /DTDIHA/ DIBETA,DIALPH
248
249* Lorentz-parameters of the current interaction
250 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
251 & UMO,PPCM,EPROJ,PPROJ
252
253* kinematical cuts for lepton-nucleus interactions
254 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
255 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
256
257* VDM parameter for photon-nucleus interactions
258 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
259
260* Glauber formalism: flags and parameters for statistics
261 LOGICAL LPROD
262 CHARACTER*8 CGLB
263 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
264
265* cuts for variable energy runs
266 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
267
268* flags for activated histograms
269 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
270
271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
004932dd 272 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 273
274* LEPTO
275**LUND single / double precision
276 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
277 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
278 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
279
280* LEPTO
281 REAL RPPN
282 COMMON /LEPTOI/ RPPN,LEPIN,INTER
283
284* steering flags for qel neutrino scattering modules
285 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
286
287* event flag
288 COMMON /DTEVNO/ NEVENT,ICASCA
289
290 INTEGER PYCOMP
291
292C DIMENSION XPARA(5)
293 DIMENSION XDUMB(40),IPRANG(5)
294
295 PARAMETER (MXCARD=58)
296 CHARACTER*78 CLINE,CTITLE
297 CHARACTER*60 CWHAT
298 CHARACTER*8 BLANK,SDUM
299 CHARACTER*10 CODE,CODEWD
300 CHARACTER*72 HEADER
301 LOGICAL LSTART,LEINP,LXSTAB
302 DIMENSION WHAT(6),CODE(MXCARD)
303 DATA CODE/
304 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
305 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
306 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
307 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
308 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
309 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
310 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
311 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
312 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
313 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
314 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
315 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
316 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
317 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
318 & 'START ','STOP '/
319 DATA BLANK /' '/
320
321 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
322 DATA CMEOLD /0.0D0/
323
324*---------------------------------------------------------------------
325* at the first call of INIT: initialize event generation
326 EPNSAV = EPN
327 IF (LSTART) THEN
328 CALL DT_TITLE
329* initialization and test of the random number generator
330 IF (ITRSPT.NE.1) THEN
331
332 IJKLIN = -1
333 INSEED = 1
334 ISEED1 = 0
335 ISEED2 = 0
336 CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
337
338 ENDIF
339* initialization of BAMJET, DECAY and HADRIN
340 CALL DT_DDATAR
341 CALL DT_DHADDE
342 CALL DT_DCHANT
343 CALL DT_DCHANH
344* set default values for input variables
345 CALL DT_DEFAUL(EPN,PPN)
346 IGLAU = 0
347 IXSQEL = 0
348* flag for collision energy input
349 LEINP = .FALSE.
350 LSTART = .FALSE.
351 ENDIF
352
353*---------------------------------------------------------------------
354 10 CONTINUE
355
356* bypass reading input cards (e.g. for use with Fluka)
357* in this case Epn is expected to carry the beam momentum
358 IF (NCASES.EQ.-1) THEN
359 IP = NPMASS
360 IPZ = NPCHAR
361 PPN = EPNSAV
362 EPN = ZERO
363 CMENER = ZERO
364 LEINP = .TRUE.
365 MKCRON = 0
366 WHAT(1) = 1
367 WHAT(2) = 0
368 CODEWD = 'START '
369 GOTO 900
370 ENDIF
371
372* read control card from input-unit LINP
373 READ(LINP,'(A78)',END=9999) CLINE
374 IF (CLINE(1:1).EQ.'*') THEN
375* comment-line
376 WRITE(LOUT,'(A78)') CLINE
377 GOTO 10
378 ENDIF
379C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
380C1000 FORMAT(A10,6E10.0,A8)
381 DO 1008 I=1,6
382 WHAT(I) = ZERO
383 1008 CONTINUE
384 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
385 1006 FORMAT(A10,A60,A8)
386 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
387 1007 CONTINUE
388 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
389 1001 FORMAT(A10,6G10.3,A8)
390
391 900 CONTINUE
392
393* check for valid control card and get card index
394 ICW = 0
395 DO 11 I=1,MXCARD
396 IF (CODEWD.EQ.CODE(I)) ICW = I
397 11 CONTINUE
398 IF (ICW.EQ.0) THEN
399 WRITE(LOUT,1002) CODEWD
400 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
401 GOTO 10
402 ENDIF
403
404 GOTO(
405*------------------------------------------------------------
406* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
407 & 100 , 110 , 120 , 130 , 140 ,
408*
409*------------------------------------------------------------
410* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
411 & 150 , 160 , 170 , 180 , 190 ,
412*
413*------------------------------------------------------------
414* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
415 & 200 , 210 , 220 , 230 , 240 ,
416*
417*------------------------------------------------------------
418* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
419 & 250 , 260 , 270 , 280 , 290 ,
420*
421*------------------------------------------------------------
422* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
423 & 300 , 310 , 320 , 330 , 340 ,
424*
425*------------------------------------------------------------
426* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
427 & 350 , 360 , 370 , 380 , 390 ,
428*
429*------------------------------------------------------------
430* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
431 & 400 , 410 , 420 , 430 , 440 ,
432*
433*------------------------------------------------------------
434* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
435 & 450 , 451 , 452 , 460 , 470 ,
436*
437*------------------------------------------------------------
438* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
439 & 480 , 490 , 500 , 510 , 520 ,
440*
441*------------------------------------------------------------
442* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
443 & 530 , 540 , 550 , 560 , 565 ,
444*
445*------------------------------------------------------------
446* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
447 & 570 , 580 , 590 ,
448*
449*------------------------------------------------------------
450* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
451 & 600 , 610 , 620 , 630 , 640 ) , ICW
452*
453*------------------------------------------------------------
454
455 GOTO 10
456
457*********************************************************************
458* *
459* control card: codewd = TITLE *
460* *
461* what (1..6), sdum no meaning *
462* *
463* Note: The control-card following this must consist of *
464* a string of characters usually giving the title of *
465* the run. *
466* *
467*********************************************************************
468
469 100 CONTINUE
470 READ(LINP,'(A78)') CTITLE
471 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
472 GOTO 10
473
474*********************************************************************
475* *
476* control card: codewd = PROJPAR *
477* *
478* what (1) = mass number of projectile nucleus default: 1 *
479* what (2) = charge of projectile nucleus default: 1 *
480* what (3..6) no meaning *
481* sdum projectile particle code word *
482* *
483* Note: If sdum is defined what (1..2) have no meaning. *
484* *
485*********************************************************************
486
487 110 CONTINUE
488 IF (SDUM.EQ.BLANK) THEN
489 IP = INT(WHAT(1))
490 IPZ = INT(WHAT(2))
491 IJPROJ = 1
492 IBPROJ = 1
493 ELSE
494 IJPROJ = 0
495 DO 111 II=1,30
496 IF (SDUM.EQ.BTYPE(II)) THEN
497 IP = 1
498 IPZ = 1
499 IF (II.EQ.26) THEN
500 IJPROJ = 135
501 ELSEIF (II.EQ.27) THEN
502 IJPROJ = 136
503 ELSEIF (II.EQ.28) THEN
504 IJPROJ = 133
505 ELSEIF (II.EQ.29) THEN
506 IJPROJ = 134
507 ELSE
508 IJPROJ = II
509 ENDIF
510 IBPROJ = IIBAR(IJPROJ)
511* photon
512 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
513* lepton
514 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
515 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
516 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
517 ENDIF
518 111 CONTINUE
519 IF (IJPROJ.EQ.0) THEN
520 WRITE(LOUT,1110)
521 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
522 GOTO 9999
523 ENDIF
524 ENDIF
525 GOTO 10
526
527*********************************************************************
528* *
529* control card: codewd = TARPAR *
530* *
531* what (1) = mass number of target nucleus default: 1 *
532* what (2) = charge of target nucleus default: 1 *
533* what (3..6) no meaning *
534* sdum target particle code word *
535* *
536* Note: If sdum is defined what (1..2) have no meaning. *
537* *
538*********************************************************************
539
540 120 CONTINUE
541 IF (SDUM.EQ.BLANK) THEN
542 IT = INT(WHAT(1))
543 ITZ = INT(WHAT(2))
544 IJTARG = 1
545 IBTARG = 1
546 ELSE
547 IJTARG = 0
548 DO 121 II=1,30
549 IF (SDUM.EQ.BTYPE(II)) THEN
550 IT = 1
551 ITZ = 1
552 IJTARG = II
553 IBTARG = IIBAR(IJTARG)
554 ENDIF
555 121 CONTINUE
556 IF (IJTARG.EQ.0) THEN
557 WRITE(LOUT,1120)
558 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
559 GOTO 9999
560 ENDIF
561 ENDIF
562 GOTO 10
563
564*********************************************************************
565* *
566* control card: codewd = ENERGY *
567* *
568* what (1) = energy (GeV) of projectile in Lab. *
569* if what(1) < 0: |what(1)| = kinetic energy *
570* default: 200 GeV *
571* if |what(2)| > 0: min. energy for variable *
572* energy runs *
573* what (2) = max. energy for variable energy runs *
574* if what(2) < 0: |what(2)| = kinetic energy *
575* *
576*********************************************************************
577
578 130 CONTINUE
579 EPN = WHAT(1)
580 PPN = ZERO
581 CMENER = ZERO
582 IF ((ABS(WHAT(2)).GT.ZERO).AND.
583 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
584 VARELO = WHAT(1)
585 VAREHI = WHAT(2)
586 EPN = VAREHI
587 ENDIF
588 LEINP = .TRUE.
589 GOTO 10
590
591*********************************************************************
592* *
593* control card: codewd = MOMENTUM *
594* *
595* what (1) = momentum (GeV/c) of projectile in Lab. *
596* default: 200 GeV/c *
597* what (2..6), sdum no meaning *
598* *
599*********************************************************************
600
601 140 CONTINUE
602 EPN = ZERO
603 PPN = WHAT(1)
604 CMENER = ZERO
605 LEINP = .TRUE.
606 GOTO 10
607
608*********************************************************************
609* *
610* control card: codewd = CMENERGY *
611* *
612* what (1) = energy in nucleon-nucleon cms. *
613* default: none *
614* what (2..6), sdum no meaning *
615* *
616*********************************************************************
617
618 150 CONTINUE
619 EPN = ZERO
620 PPN = ZERO
621 CMENER = WHAT(1)
622 LEINP = .TRUE.
623 GOTO 10
624
625*********************************************************************
626* *
627* control card: codewd = EMULSION *
628* *
629* definition of nuclear emulsions *
630* *
631* what(1) mass number of emulsion component *
632* what(2) charge of emulsion component *
633* what(3) fraction of events in which a scattering on a *
634* nucleus of this properties is performed *
635* what(4,5,6) as what(1,2,3) but for another component *
636* default: no emulsion *
637* sdum no meaning *
638* *
639* Note: If this input-card is once used with valid parameters *
640* TARPAR is obsolete. *
641* Not the absolute values of the fractions are important *
642* but only the ratios of fractions of different comp. *
643* This control card can be repeatedly used to define *
644* emulsions consisting of up to 10 elements. *
645* *
646*********************************************************************
647
648 160 CONTINUE
649 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
650 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
651 NCOMPO = NCOMPO+1
652 IF (NCOMPO.GT.NCOMPX) THEN
653 WRITE(LOUT,1600)
654 STOP
655 ENDIF
656 IEMUMA(NCOMPO) = INT(WHAT(1))
657 IEMUCH(NCOMPO) = INT(WHAT(2))
658 EMUFRA(NCOMPO) = WHAT(3)
659 IEMUL = 1
660C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
661 ENDIF
662 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
663 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
664 NCOMPO = NCOMPO+1
665 IF (NCOMPO.GT.NCOMPX) THEN
666 WRITE(LOUT,1001)
667 STOP
668 ENDIF
669 IEMUMA(NCOMPO) = INT(WHAT(4))
670 IEMUCH(NCOMPO) = INT(WHAT(5))
671 EMUFRA(NCOMPO) = WHAT(6)
672C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
673 ENDIF
674 1600 FORMAT(1X,'too many emulsion components - program stopped')
675 GOTO 10
676
677*********************************************************************
678* *
679* control card: codewd = FERMI *
680* *
681* what (1) = -1 Fermi-motion of nucleons not treated *
682* default: 1 *
683* what (2) = scale factor for Fermi-momentum *
684* default: 0.75 *
685* what (3..6), sdum no meaning *
686* *
687*********************************************************************
688
689 170 CONTINUE
690 IF (WHAT(1).EQ.-1.0D0) THEN
691 LFERMI = .FALSE.
692 ELSE
693 LFERMI = .TRUE.
694 ENDIF
695 XMOD = WHAT(2)
696 IF (XMOD.GE.ZERO) FERMOD = XMOD
697 GOTO 10
698
699*********************************************************************
700* *
701* control card: codewd = TAUFOR *
702* *
703* formation time supressed intranuclear cascade *
704* *
705* what (1) formation time (in fm/c) *
706* note: what(1)=10. corresponds roughly to an *
707* average formation time of 1 fm/c *
708* default: 5. fm/c *
709* what (2) number of generations followed *
710* default: 25 *
711* what (3) = 1. p_t-dependent formation zone *
712* = 2. constant formation zone *
713* default: 1 *
714* what (4) modus of selection of nucleus where the *
715* cascade if followed first *
716* = 1. proj./target-nucleus with probab. 1/2 *
717* = 2. nucleus with highest mass *
718* = 3. proj. nucleus if particle is moving in pos. z *
719* targ. nucleus if particle is moving in neg. z *
720* default: 1 *
721* what (5..6), sdum no meaning *
722* *
723*********************************************************************
724
725 180 CONTINUE
726 TAUFOR = WHAT(1)
727 KTAUGE = INT(WHAT(2))
728 INCMOD = 1
729 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
730 & ITAUVE = INT(WHAT(3))
731 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
732 & INCMOD = INT(WHAT(4))
733 GOTO 10
734
735*********************************************************************
736* *
737* control card: codewd = PAULI *
738* *
739* what (1) = -1 Pauli's principle for secondary *
740* interactions not treated *
741* default: 1 *
742* what (2..6), sdum no meaning *
743* *
744*********************************************************************
745
746 190 CONTINUE
747 IF (WHAT(1).EQ.-1.0D0) THEN
748 LPAULI = .FALSE.
749 ELSE
750 LPAULI = .TRUE.
751 ENDIF
752 GOTO 10
753
754*********************************************************************
755* *
756* control card: codewd = COULOMB *
757* *
758* what (1) = -1. Coulomb-energy treatment switched off *
759* default: 1 *
760* what (2..6), sdum no meaning *
761* *
762*********************************************************************
763
764 200 CONTINUE
765 ICOUL = 1
766 IF (WHAT(1).EQ.-1.0D0) THEN
767 ICOUL = 0
768 ELSE
769 ICOUL = 1
770 ENDIF
771 GOTO 10
772
773*********************************************************************
774* *
775* control card: codewd = HADRIN *
776* *
777* HADRIN module *
778* *
779* what (1) = 0. elastic/inelastic interactions with probab. *
780* as defined by cross-sections *
781* = 1. inelastic interactions forced *
782* = 2. elastic interactions forced *
783* default: 1 *
784* what (2) upper threshold in total energy (GeV) below *
785* which interactions are sampled by HADRIN *
786* default: 5. GeV *
787* what (3..6), sdum no meaning *
788* *
789*********************************************************************
790
791 210 CONTINUE
792 IWHAT = INT(WHAT(1))
793 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
794 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
795 GOTO 10
796
797*********************************************************************
798* *
799* control card: codewd = EVAP *
800* *
801* evaporation module *
802* *
803* what (1) =< -1 ==> evaporation is switched off *
804* >= 1 ==> evaporation is performed *
805* *
806* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
807* (i1, i2, i3, i4 >= 0 ) *
808* *
809* i1 is the flag for selecting the T=0 level density option used *
810* = 1: standard EVAP level densities with Cook pairing *
811* energies *
812* = 2: Z,N-dependent Gilbert & Cameron level densities *
813* (default) *
814* = 3: Julich A-dependent level densities *
815* = 4: Z,N-dependent Brancazio & Cameron level densities *
816* *
817* i2 >= 1: high energy fission activated *
818* (default high energy fission activated) *
819* *
820* i3 = 0: No energy dependence for level densities *
821* = 1: Standard Ignyatuk (1975, 1st) energy dependence *
822* for level densities (default) *
823* = 2: Standard Ignyatuk (1975, 1st) energy dependence *
824* for level densities with NOT used set of parameters *
825* = 3: Standard Ignyatuk (1975, 1st) energy dependence *
826* for level densities with NOT used set of parameters *
827* = 4: Second Ignyatuk (1975, 2nd) energy dependence *
828* for level densities *
829* = 5: Second Ignyatuk (1975, 2nd) energy dependence *
830* for level densities with fit 1 Iljinov & Mebel set of *
831* parameters *
832* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
833* for level densities with fit 2 Iljinov & Mebel set of *
834* parameters *
835* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
836* for level densities with fit 3 Iljinov & Mebel set of *
837* parameters *
838* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
839* for level densities with fit 4 Iljinov & Mebel set of *
840* parameters *
841* *
842* i4 >= 1: Original Gilbert and Cameron pairing energies used *
843* (default Cook's modified pairing energies) *
844* *
845* what (2) = ig + 10 * if (ig and if must have the same sign) *
846* *
847* ig =< -1 ==> deexcitation gammas are not produced *
848* (if the evaporation step is not performed *
849* they are never produced) *
850* if =< -1 ==> Fermi Break Up is not invoked *
851* (if the evaporation step is not performed *
852* it is never invoked) *
853* The default is: deexcitation gamma produced and Fermi break up *
854* activated for the new preequilibrium, not *
855* activated otherwise. *
856* what (3..6), sdum no meaning *
857* *
858*********************************************************************
859
860 220 CONTINUE
861 IF (WHAT(1).LE.-1.0D0) THEN
862 LEVPRT = .FALSE.
863 LDEEXG = .FALSE.
864 LHEAVY = .FALSE.
865 GOTO 10
866 ENDIF
867 WHTSAV = WHAT (1)
868 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
869 LLVMOD = .FALSE.
870 JLVHLP = NINT (WHAT (1)) / 10000
871 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
872 END IF
873 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
874 JLVMOD = NINT (WHAT (1)) / 100
875 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
876 END IF
877 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
878
879 IEVFSS = 1
880
881 JLVHLP = NINT (WHAT (1)) / 10
882 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
883 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
884
885 IEVFSS = 0
886
887 END IF
888 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
889 LEVPRT = .TRUE.
890 ILVMOD = NINT (WHAT(1))
891 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
892 LFRMBK = .TRUE.
893 JLVHLP = NINT (WHAT (2)) / 10
894 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
895 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
896 LFRMBK = .FALSE.
897 END IF
898 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
899 LDEEXG = .TRUE.
900 ELSE
901 LDEEXG = .FALSE.
902 END IF
903**sr heavies are always put to /FKFHVY/
904C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
905C LHEAVY = .TRUE.
906C ELSE
907C LHEAVY = .FALSE.
908C END IF
909 LHEAVY = .TRUE.
910 ELSE
911 LEVPRT = .FALSE.
912 LDEEXG = .FALSE.
913 LHEAVY = .FALSE.
914 END IF
915
916 LOLDEV = .FALSE.
917
918 GOTO 10
919
920*********************************************************************
921* *
922* control card: codewd = EMCCHECK *
923* *
924* extended energy-momentum / quantum-number conservation check *
925* *
926* what (1) = -1 extended check not performed *
927* default: 1. *
928* what (2..6), sdum no meaning *
929* *
930*********************************************************************
931
932 230 CONTINUE
933 IF (WHAT(1).EQ.-1) THEN
934 LEMCCK = .FALSE.
935 ELSE
936 LEMCCK = .TRUE.
937 ENDIF
938 GOTO 10
939
940*********************************************************************
941* *
942* control card: codewd = MODEL *
943* *
944* Model to be used to treat nucleon-nucleon interactions *
945* *
946* sdum = DTUNUC two-chain model *
947* = PHOJET multiple chains including minijets *
948* = LEPTO DIS *
949* = QNEUTRIN quasi-elastic neutrino scattering *
950* default: PHOJET *
951* *
952* if sdum = LEPTO: *
953* what (1) (variable INTER) *
954* = 1 gamma exchange *
955* = 2 W+- exchange *
956* = 3 Z0 exchange *
957* = 4 gamma/Z0 exchange *
958* *
959* if sdum = QNEUTRIN: *
960* what (1) = 0 elastic scattering on nucleon and *
961* tau does not decay (default) *
962* = 1 decay of tau into mu.. *
963* = 2 decay of tau into e.. *
964* = 10 CC events on p and n *
965* = 11 NC events on p and n *
966* *
967* what (2..6) no meaning *
968* *
969*********************************************************************
970
971 240 CONTINUE
972 IF (SDUM.EQ.CMODEL(1)) THEN
973 MCGENE = 1
974 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
975 MCGENE = 2
976 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
977 MCGENE = 3
978 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
979 & INTER = INT(WHAT(1))
980 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
981 MCGENE = 4
982 IWHAT = INT(WHAT(1))
983 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
984 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
985 & NEUDEC = IWHAT
986 ELSE
987 STOP ' Unknown model !'
988 ENDIF
989 GOTO 10
990
991*********************************************************************
992* *
993* control card: codewd = PHOINPUT *
994* *
995* Start of input-section for PHOJET-specific input-cards *
996* Note: This section will not be finished before giving *
997* ENDINPUT-card *
998* what (1..6), sdum no meaning *
999* *
1000*********************************************************************
1001
1002 250 CONTINUE
1003 IF (LPHOIN) THEN
1004
1005 CALL PHO_INIT(LINP,LOUT,IREJ1)
1006
1007 IF (IREJ1.NE.0) THEN
1008 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
1009 STOP
1010 ENDIF
1011 LPHOIN = .FALSE.
1012 ENDIF
1013 GOTO 10
1014
1015*********************************************************************
1016* *
1017* control card: codewd = GLAUBERI *
1018* *
1019* Pre-initialization of impact parameter selection *
1020* *
1021* what (1..6), sdum no meaning *
1022* *
1023*********************************************************************
1024
1025 260 CONTINUE
1026 IF (IFIRST.NE.99) THEN
1027 CALL DT_RNDMST(12,34,56,78)
1028 CALL DT_RNDMTE(1)
1029 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1031 IFIRST = 99
1032 ENDIF
1033
1034 IPPN = 8
1035 PLOW = 10.0D0
1036C IPPN = 1
1037C PLOW = 100.0D0
1038 PHI = 1.0D5
1039 APLOW = LOG10(PLOW)
1040 APHI = LOG10(PHI)
1041 ADP = (APHI-APLOW)/DBLE(IPPN)
1042
1043 IPLOW = 1
1044 IDIP = 1
1045 IIP = 5
1046C IPLOW = 1
1047C IDIP = 1
1048C IIP = 1
1049 IPRANG(1) = 1
1050 IPRANG(2) = 2
1051 IPRANG(3) = 5
1052 IPRANG(4) = 10
1053 IPRANG(5) = 20
1054
1055 ITLOW = 30
1056 IDIT = 3
1057 IIT = 60
1058C IDIT = 10
1059C IIT = 21
1060
1061 DO 473 NCIT=1,IIT
1062 IT = ITLOW+(NCIT-1)*IDIT
1063C IPHI = IT
1064C IDIP = 10
1065C IIP = (IPHI-IPLOW)/IDIP
1066C IF (IIP.EQ.0) IIP = 1
1067C IF (IT.EQ.IPLOW) IIP = 0
1068
1069 DO 472 NCIP=1,IIP
1070 IP = IPRANG(NCIP)
1071CC IF (NCIP.LE.IIP) THEN
1072C IP = IPLOW+(NCIP-1)*IDIP
1073CC ELSE
1074CC IP = IT
1075CC ENDIF
1076 IF (IP.GT.IT) GOTO 472
1077
1078 DO 471 NCP=1,IPPN+1
1079 APPN = APLOW+DBLE(NCP-1)*ADP
1080 PPN = 10**APPN
1081
1082 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1084 CLOSE(12)
1085
1086 XLIM1 = 0.0D0
1087 XLIM2 = 50.0D0
1088 XLIM3 = ZERO
1089 IBIN = 50
1090 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1092
1093 NEVFIT = 5
1094C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1095C NEVFIT = 5
1096C ELSE
1097C NEVFIT = 10
1098C ENDIF
1099 SIGAV = 0.0D0
1100
1101 DO 478 I=1,NEVFIT
1102 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103 SIGAV = SIGAV+XSPRO(1,1,1)
1104 DO 479 J=1,50
1105 XC = DBLE(J)
1106 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1107 479 CONTINUE
1108 478 CONTINUE
1109
1110 CALL DT_EVTHIS(IDUM)
1111 HEADER = ' BSITE'
1112C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1113
1114C CALL GENFIT(XPARA)
1115C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1117
1118 471 CONTINUE
1119
1120 472 CONTINUE
1121
1122 473 CONTINUE
1123
1124 STOP
1125
1126*********************************************************************
1127* *
1128* control card: codewd = FLUCTUAT *
1129* *
1130* Treatment of cross section fluctuations *
1131* *
1132* what (1) = 1 treat cross section fluctuations *
1133* default: 0. *
1134* what (1..6), sdum no meaning *
1135* *
1136*********************************************************************
1137
1138 270 CONTINUE
1139 IFLUCT = 0
1140 IF (WHAT(1).EQ.ONE) THEN
1141 IFLUCT = 1
1142 CALL DT_FLUINI
1143 ENDIF
1144 GOTO 10
1145
1146*********************************************************************
1147* *
1148* control card: codewd = CENTRAL *
1149* *
1150* what (1) = 1. central production forced default: 0 *
1151* if what (1) < 0 and > -100 *
1152* what (2) = min. impact parameter default: 0 *
1153* what (3) = max. impact parameter default: b_max *
1154* if what (1) < -99 *
1155* what (2) = fraction of cross section default: 1 *
1156* if what (1) = -1 : evaporation/fzc suppressed *
1157* if what (1) < -1 : evaporation/fzc allowed *
1158* *
1159* what (4..6), sdum no meaning *
1160* *
1161*********************************************************************
1162
1163 280 CONTINUE
1164 ICENTR = INT(WHAT(1))
1165 IF (ICENTR.LT.0) THEN
1166 IF (ICENTR.GT.-100) THEN
1167 BIMIN = WHAT(2)
1168 BIMAX = WHAT(3)
1169 ELSE
1170 XSFRAC = WHAT(2)
1171 ENDIF
1172 ENDIF
1173 GOTO 10
1174
1175*********************************************************************
1176* *
1177* control card: codewd = RECOMBIN *
1178* *
1179* Chain recombination *
1180* (recombine S-S and V-V chains to V-S chains) *
1181* *
1182* what (1) = -1. recombination switched off default: 1 *
1183* what (2..6), sdum no meaning *
1184* *
1185*********************************************************************
1186
1187 290 CONTINUE
1188 IRECOM = 1
1189 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1190 GOTO 10
1191
1192*********************************************************************
1193* *
1194* control card: codewd = COMBIJET *
1195* *
1196* chain fusion (2 q-aq --> qq-aqaq) *
1197* *
1198* what (1) = 1 fusion treated *
1199* default: 0. *
1200* what (2) minimum number of uncombined chains from *
1201* single projectile or target nucleons *
1202* default: 0. *
1203* what (3..6), sdum no meaning *
1204* *
1205*********************************************************************
1206
1207 300 CONTINUE
1208 LCO2CR = .FALSE.
1209 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1211 GOTO 10
1212
1213*********************************************************************
1214* *
1215* control card: codewd = XCUTS *
1216* *
1217* thresholds for x-sampling *
1218* *
1219* what (1) defines lower threshold for val.-q x-value (CVQ) *
1220* default: 1. *
1221* what (2) defines lower threshold for val.-qq x-value (CDQ) *
1222* default: 2. *
1223* what (3) defines lower threshold for sea-q x-value (CSEA) *
1224* default: 0.2 *
1225* what (4) sea-q x-values in S-S chains (SSMIMA) *
1226* default: 0.14 *
1227* what (5) not used *
1228* default: 2. *
1229* what (6), sdum no meaning *
1230* *
1231* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1232* *
1233*********************************************************************
1234
1235 310 CONTINUE
1236 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1237 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1238 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1239 IF (WHAT(4).GE.ZERO) THEN
1240 SSMIMA = WHAT(4)
1241 SSMIMQ = SSMIMA**2
1242 ENDIF
1243 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1244 GOTO 10
1245
1246*********************************************************************
1247* *
1248* control card: codewd = INTPT *
1249* *
1250* what (1) = -1 intrinsic transverse momenta of partons *
1251* not treated default: 1 *
1252* what (2..6), sdum no meaning *
1253* *
1254*********************************************************************
1255
1256 320 CONTINUE
1257 IF (WHAT(1).EQ.-1.0D0) THEN
1258 LINTPT = .FALSE.
1259 ELSE
1260 LINTPT = .TRUE.
1261 ENDIF
1262 GOTO 10
1263
1264*********************************************************************
1265* *
1266* control card: codewd = CRONINPT *
1267* *
1268* Cronin effect (multiple scattering of partons at chain ends) *
1269* *
1270* what (1) = -1 Cronin effect not treated default: 1 *
1271* what (2) = 0 scattering parameter default: 0.64 *
1272* what (3..6), sdum no meaning *
1273* *
1274*********************************************************************
1275
1276 330 CONTINUE
1277 IF (WHAT(1).EQ.-1.0D0) THEN
1278 MKCRON = 0
1279 ELSE
1280 MKCRON = 1
1281 ENDIF
1282 CRONCO = WHAT(2)
1283 GOTO 10
1284
1285*********************************************************************
1286* *
1287* control card: codewd = SEADISTR *
1288* *
1289* what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1290* what (2) (UNON) default: 2. *
1291* what (3) (UNOM) default: 1.5 *
1292* what (4) (UNOSEA) default: 5. *
1293* qdis(x) prop. (1-x)**what (1) etc. *
1294* what (5..6), sdum no meaning *
1295* *
1296*********************************************************************
1297
1298 340 CONTINUE
1299 XSEACO = WHAT(1)
1300 XSEACU = 1.05D0-XSEACO
1301 UNON = WHAT(2)
1302 IF (UNON.LT.0.1D0) UNON = 2.0D0
1303 UNOM = WHAT(3)
1304 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1305 UNOSEA = WHAT(4)
1306 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1307 GOTO 10
1308
1309*********************************************************************
1310* *
1311* control card: codewd = SEASU3 *
1312* *
1313* Treatment of strange-quarks at chain ends *
1314* *
1315* what (1) (SEASQ) strange-quark supression factor *
1316* iflav = 1.+rndm*(2.+SEASQ) *
1317* default: 1. *
1318* what (2..6), sdum no meaning *
1319* *
1320*********************************************************************
1321
1322 350 CONTINUE
1323 SEASQ = WHAT(1)
1324 GOTO 10
1325
1326*********************************************************************
1327* *
1328* control card: codewd = DIQUARKS *
1329* *
1330* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1331* default: 1. *
1332* what (2..6), sdum no meaning *
1333* *
1334*********************************************************************
1335
1336 360 CONTINUE
1337 IF (WHAT(1).EQ.-1.0D0) THEN
1338 LSEADI = .FALSE.
1339 ELSE
1340 LSEADI = .TRUE.
1341 ENDIF
1342 GOTO 10
1343
1344*********************************************************************
1345* *
1346* control card: codewd = RESONANC *
1347* *
1348* treatment of low mass chains *
1349* *
1350* what (1) = -1 low chain masses are not corrected for resonance *
1351* masses (obsolete for BAMJET-fragmentation) *
1352* default: 1. *
1353* what (2) = -1 massless partons default: 1. (massive) *
1354* default: 1. (massive) *
1355* what (3) = -1 chain-system containing chain of too small *
1356* mass is rejected (note: this does not fully *
1357* apply to S-S chains) default: 0. *
1358* what (4..6), sdum no meaning *
1359* *
1360*********************************************************************
1361
1362 370 CONTINUE
1363 IRESCO = 1
1364 IMSHL = 1
1365 IRESRJ = 0
1366 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1368 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1369 GOTO 10
1370
1371*********************************************************************
1372* *
1373* control card: codewd = DIFFRACT *
1374* *
1375* Treatment of diffractive events *
1376* *
1377* what (1) = (ISINGD) 0 no single diffraction *
1378* 1 single diffraction included *
1379* +-2 single diffractive events only *
1380* +-3 projectile single diffraction only *
1381* +-4 target single diffraction only *
1382* -5 double pomeron exchange only *
1383* (neg. sign applies to PHOJET events) *
1384* default: 0. *
1385* *
1386* what (2) = (IDOUBD) 0 no double diffraction *
1387* 1 double diffraction included *
1388* 2 double diffractive events only *
1389* default: 0. *
1390* what (3) = 1 projectile diffraction treated (2-channel form.) *
1391* default: 0. *
1392* what (4) = alpha-parameter in projectile diffraction *
1393* default: 0. *
1394* what (5..6), sdum no meaning *
1395* *
1396*********************************************************************
1397
1398 380 CONTINUE
1399 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1402 WRITE(LOUT,1380)
1403 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1404 & 11X,'IDOUBD is reset to zero')
1405 IDOUBD = 0
1406 ENDIF
1407 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1409 GOTO 10
1410
1411*********************************************************************
1412* *
1413* control card: codewd = SINGLECH *
1414* *
1415* what (1) = 1. Regge contribution (one chain) included *
1416* default: 0. *
1417* what (2..6), sdum no meaning *
1418* *
1419*********************************************************************
1420
1421 390 CONTINUE
1422 ISICHA = 0
1423 IF (WHAT(1).EQ.ONE) ISICHA = 1
1424 GOTO 10
1425
1426*********************************************************************
1427* *
1428* control card: codewd = NOFRAGME *
1429* *
1430* biased chain hadronization *
1431* *
1432* what (1..6) = -1 no of hadronizsation of S-S chains *
1433* = -2 no of hadronizsation of D-S chains *
1434* = -3 no of hadronizsation of S-D chains *
1435* = -4 no of hadronizsation of S-V chains *
1436* = -5 no of hadronizsation of D-V chains *
1437* = -6 no of hadronizsation of V-S chains *
1438* = -7 no of hadronizsation of V-D chains *
1439* = -8 no of hadronizsation of V-V chains *
1440* = -9 no of hadronizsation of comb. chains *
1441* default: complete hadronization *
1442* sdum no meaning *
1443* *
1444*********************************************************************
1445
1446 400 CONTINUE
1447 DO 401 I=1,6
1448 ICHAIN = INT(WHAT(I))
1449 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450 & LHADRO(ABS(ICHAIN)) = .FALSE.
1451 401 CONTINUE
1452 GOTO 10
1453
1454*********************************************************************
1455* *
1456* control card: codewd = HADRONIZE *
1457* *
1458* hadronization model and parameter switch *
1459* *
1460* what (1) = 1 hadronization via BAMJET *
1461* = 2 hadronization via JETSET *
1462* default: 2 *
1463* what (2) = 1..3 parameter set to be used *
1464* JETSET: 3 sets available *
1465* ( = 3 default JETSET-parameters) *
1466* BAMJET: 1 set available *
1467* default: 1 *
1468* what (3..6), sdum no meaning *
1469* *
1470*********************************************************************
1471
1472 410 CONTINUE
1473 IWHAT1 = INT(WHAT(1))
1474 IWHAT2 = INT(WHAT(2))
1475 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1477 & IFRAG(2) = IWHAT2
1478 GOTO 10
1479
1480*********************************************************************
1481* *
1482* control card: codewd = POPCORN *
1483* *
1484* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1485* *
1486* what (1) = (PDB) frac. of diquark fragmenting directly into *
1487* baryons (PYTHIA/JETSET fragmentation) *
1488* (JETSET: = 0. Popcorn mechanism switched off) *
1489* default: 0.5 *
1490* what (2) = probability for accepting a diquark breaking *
1491* diagram involving the generation of a u/d quark- *
1492* antiquark pair default: 0.0 *
1493* what (3) = same a what (2), here for s quark-antiquark pair *
1494* default: 0.0 *
1495* what (4..6), sdum no meaning *
1496* *
1497*********************************************************************
1498
1499 420 CONTINUE
1500 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501 IF (WHAT(2).GE.0.0D0) THEN
1502 PDBSEA(1) = WHAT(2)
1503 PDBSEA(2) = WHAT(2)
1504 ENDIF
1505 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1506 DO 421 I=1,8
1507 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1510 421 CONTINUE
1511 GOTO 10
1512
1513*********************************************************************
1514* *
1515* control card: codewd = PARDECAY *
1516* *
1517* what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1518* = 2. pion^0 decay after intranucl. cascade *
1519* default: no decay *
1520* what (2..6), sdum no meaning *
1521* *
1522*********************************************************************
1523
1524 430 CONTINUE
1525 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1526 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1527 GOTO 10
1528
1529*********************************************************************
1530* *
1531* control card: codewd = BEAM *
1532* *
1533* definition of beam parameters *
1534* *
1535* what (1/2) > 0 : energy of beam 1/2 (GeV) *
1536* < 0 : abs(what(1/2)) energy per charge of *
1537* beam 1/2 (GeV) *
1538* (beam 1 is directed into positive z-direction) *
1539* what (3) beam crossing angle, defined as 2x angle between *
1540* one beam and the z-axis (micro rad) *
1541* what (4) angle with x-axis defining the collision plane *
1542* what (5..6), sdum no meaning *
1543* *
1544* Note: this card requires previously defined projectile and *
1545* target identities (PROJPAR, TARPAR) *
1546* *
1547*********************************************************************
1548
1549 440 CONTINUE
1550 CALL DT_BEAMPR(WHAT,PPN,1)
1551 EPN = ZERO
1552 CMENER = ZERO
1553 LEINP = .TRUE.
1554 GOTO 10
1555
1556*********************************************************************
1557* *
1558* control card: codewd = LUND-MSTU *
1559* *
1560* set parameter MSTU in JETSET-common /LUDAT1/ *
1561* *
1562* what (1) = index according to LUND-common block *
1563* what (2) = new value of MSTU( int(what(1)) ) *
1564* what (3), what(4) and what (5), what(6) further *
1565* parameter in the same way as what (1) and *
1566* what (2) *
1567* default: default-Lund or corresponding to *
1568* the set given in HADRONIZE *
1569* *
1570*********************************************************************
1571
1572 450 CONTINUE
1573 IF (WHAT(1).GT.ZERO) THEN
1574 NMSTU = NMSTU+1
1575 IMSTU(NMSTU) = INT(WHAT(1))
1576 MSTUX(NMSTU) = INT(WHAT(2))
1577 ENDIF
1578 IF (WHAT(3).GT.ZERO) THEN
1579 NMSTU = NMSTU+1
1580 IMSTU(NMSTU) = INT(WHAT(3))
1581 MSTUX(NMSTU) = INT(WHAT(4))
1582 ENDIF
1583 IF (WHAT(5).GT.ZERO) THEN
1584 NMSTU = NMSTU+1
1585 IMSTU(NMSTU) = INT(WHAT(5))
1586 MSTUX(NMSTU) = INT(WHAT(6))
1587 ENDIF
1588 GOTO 10
1589
1590*********************************************************************
1591* *
1592* control card: codewd = LUND-MSTJ *
1593* *
1594* set parameter MSTJ in JETSET-common /LUDAT1/ *
1595* *
1596* what (1) = index according to LUND-common block *
1597* what (2) = new value of MSTJ( int(what(1)) ) *
1598* what (3), what(4) and what (5), what(6) further *
1599* parameter in the same way as what (1) and *
1600* what (2) *
1601* default: default-Lund or corresponding to *
1602* the set given in HADRONIZE *
1603* *
1604*********************************************************************
1605
1606 451 CONTINUE
1607 IF (WHAT(1).GT.ZERO) THEN
1608 NMSTJ = NMSTJ+1
1609 IMSTJ(NMSTJ) = INT(WHAT(1))
1610 MSTJX(NMSTJ) = INT(WHAT(2))
1611 ENDIF
1612 IF (WHAT(3).GT.ZERO) THEN
1613 NMSTJ = NMSTJ+1
1614 IMSTJ(NMSTJ) = INT(WHAT(3))
1615 MSTJX(NMSTJ) = INT(WHAT(4))
1616 ENDIF
1617 IF (WHAT(5).GT.ZERO) THEN
1618 NMSTJ = NMSTJ+1
1619 IMSTJ(NMSTJ) = INT(WHAT(5))
1620 MSTJX(NMSTJ) = INT(WHAT(6))
1621 ENDIF
1622 GOTO 10
1623
1624*********************************************************************
1625* *
1626* control card: codewd = LUND-MDCY *
1627* *
1628* set parameter MDCY(I,1) for particle decays in JETSET-common *
1629* /LUDAT3/ *
1630* *
1631* what (1-6) = PDG particle index of particle which should *
1632* not decay *
1633* default: default-Lund or forced in *
1634* DT_INITJS *
1635* *
1636*********************************************************************
1637
1638 452 CONTINUE
1639 DO 4521 I=1,6
1640 IF (WHAT(I).NE.ZERO) THEN
1641
1642 KC = PYCOMP(INT(WHAT(I)))
1643
1644 MDCY(KC,1) = 0
1645 ENDIF
1646 4521 CONTINUE
1647 GOTO 10
1648
1649*********************************************************************
1650* *
1651* control card: codewd = LUND-PARJ *
1652* *
1653* set parameter PARJ in JETSET-common /LUDAT1/ *
1654* *
1655* what (1) = index according to LUND-common block *
1656* what (2) = new value of PARJ( int(what(1)) ) *
1657* what (3), what(4) and what (5), what(6) further *
1658* parameter in the same way as what (1) and *
1659* what (2) *
1660* default: default-Lund or corresponding to *
1661* the set given in HADRONIZE *
1662* *
1663*********************************************************************
1664
1665 460 CONTINUE
1666 IF (WHAT(1).NE.ZERO) THEN
1667 NPARJ = NPARJ+1
1668 IPARJ(NPARJ) = INT(WHAT(1))
1669 PARJX(NPARJ) = WHAT(2)
1670 ENDIF
1671 IF (WHAT(3).NE.ZERO) THEN
1672 NPARJ = NPARJ+1
1673 IPARJ(NPARJ) = INT(WHAT(3))
1674 PARJX(NPARJ) = WHAT(4)
1675 ENDIF
1676 IF (WHAT(5).NE.ZERO) THEN
1677 NPARJ = NPARJ+1
1678 IPARJ(NPARJ) = INT(WHAT(5))
1679 PARJX(NPARJ) = WHAT(6)
1680 ENDIF
1681 GOTO 10
1682
1683*********************************************************************
1684* *
1685* control card: codewd = LUND-PARU *
1686* *
1687* set parameter PARJ in JETSET-common /LUDAT1/ *
1688* *
1689* what (1) = index according to LUND-common block *
1690* what (2) = new value of PARU( int(what(1)) ) *
1691* what (3), what(4) and what (5), what(6) further *
1692* parameter in the same way as what (1) and *
1693* what (2) *
1694* default: default-Lund or corresponding to *
1695* the set given in HADRONIZE *
1696* *
1697*********************************************************************
1698
1699 470 CONTINUE
1700 IF (WHAT(1).GT.ZERO) THEN
1701 NPARU = NPARU+1
1702 IPARU(NPARU) = INT(WHAT(1))
1703 PARUX(NPARU) = WHAT(2)
1704 ENDIF
1705 IF (WHAT(3).GT.ZERO) THEN
1706 NPARU = NPARU+1
1707 IPARU(NPARU) = INT(WHAT(3))
1708 PARUX(NPARU) = WHAT(4)
1709 ENDIF
1710 IF (WHAT(5).GT.ZERO) THEN
1711 NPARU = NPARU+1
1712 IPARU(NPARU) = INT(WHAT(5))
1713 PARUX(NPARU) = WHAT(6)
1714 ENDIF
1715 GOTO 10
1716
1717*********************************************************************
1718* *
1719* control card: codewd = OUTLEVEL *
1720* *
1721* output control switches *
1722* *
1723* what (1) = internal rejection informations default: 0 *
1724* what (2) = energy-momentum conservation check output *
1725* default: 0 *
1726* what (3) = internal warning messages default: 0 *
1727* what (4..6), sdum not yet used *
1728* *
1729*********************************************************************
1730
1731 480 CONTINUE
1732 DO 481 K=1,6
1733 IOULEV(K) = INT(WHAT(K))
1734 481 CONTINUE
1735 GOTO 10
1736
1737*********************************************************************
1738* *
1739* control card: codewd = FRAME *
1740* *
1741* frame in which final state is given in DTEVT1 *
1742* *
1743* what (1) = 1 target rest frame (laboratory) *
1744* = 2 nucleon-nucleon cms *
1745* default: 1 *
1746* *
1747*********************************************************************
1748
1749 490 CONTINUE
1750 KFRAME = INT(WHAT(1))
1751 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1752 GOTO 10
1753
1754*********************************************************************
1755* *
1756* control card: codewd = L-TAG *
1757* *
1758* lepton tagger: *
1759* definition of kinematical cuts for radiated photon and *
1760* outgoing lepton detection in lepton-nucleus interactions *
1761* *
1762* what (1) = y_min *
1763* what (2) = y_max *
1764* what (3) = Q^2_min *
1765* what (4) = Q^2_max *
1766* what (5) = theta_min (Lab) *
1767* what (6) = theta_max (Lab) *
1768* default: no cuts *
1769* sdum no meaning *
1770* *
1771*********************************************************************
1772
1773 500 CONTINUE
1774 YMIN = WHAT(1)
1775 YMAX = WHAT(2)
1776 Q2MIN = WHAT(3)
1777 Q2MAX = WHAT(4)
1778 THMIN = WHAT(5)
1779 THMAX = WHAT(6)
1780 GOTO 10
1781
1782*********************************************************************
1783* *
1784* control card: codewd = L-ETAG *
1785* *
1786* lepton tagger: *
1787* what (1) = min. outgoing lepton energy (in Lab) *
1788* what (2) = min. photon energy (in Lab) *
1789* what (3) = max. photon energy (in Lab) *
1790* default: no cuts *
1791* what (2..6), sdum no meaning *
1792* *
1793*********************************************************************
1794
1795 510 CONTINUE
1796 ELMIN = MAX(WHAT(1),ZERO)
1797 EGMIN = MAX(WHAT(2),ZERO)
1798 EGMAX = MAX(WHAT(3),ZERO)
1799 GOTO 10
1800
1801*********************************************************************
1802* *
1803* control card: codewd = ECMS-CUT *
1804* *
1805* what (1) = min. c.m. energy to be sampled *
1806* what (2) = max. c.m. energy to be sampled *
1807* what (3) = min x_Bj to be sampled *
1808* default: no cuts *
1809* what (3..6), sdum no meaning *
1810* *
1811*********************************************************************
1812
1813 520 CONTINUE
1814 ECMIN = WHAT(1)
1815 ECMAX = WHAT(2)
1816 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817 XBJMIN = MAX(WHAT(3),ZERO)
1818 GOTO 10
1819
1820*********************************************************************
1821* *
1822* control card: codewd = VDM-PAR1 *
1823* *
1824* parameters in gamma-nucleus cross section calculation *
1825* *
1826* what (1) = Lambda^2 default: 2. *
1827* what (2) lower limit in M^2 integration *
1828* = 1 (3m_pi)^2 *
1829* = 2 (m_rho0)^2 *
1830* = 3 (m_phi)^2 default: 1 *
1831* what (3) upper limit in M^2 integration *
1832* = 1 s/2 *
1833* = 2 s/4 *
1834* = 3 s default: 3 *
1835* what (4) CKMT F_2 structure function *
1836* = 2212 proton *
1837* = 100 deuteron default: 2212 *
1838* what (5) calculation of gamma-nucleon xsections *
1839* = 1 according to CKMT-parametrization of F_2 *
1840* = 2 integrating SIGVP over M^2 *
1841* = 3 using SIGGA *
1842* = 4 PHOJET cross sections default: 4 *
1843* *
1844* what (6), sdum no meaning *
1845* *
1846*********************************************************************
1847
1848 530 CONTINUE
1849 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1854 GOTO 10
1855
1856*********************************************************************
1857* *
1858* control card: codewd = HISTOGRAM *
1859* *
1860* activate different classes of histograms *
1861* *
1862* default: no histograms *
1863* *
1864*********************************************************************
1865
1866 540 CONTINUE
1867 DO 541 J=1,6
1868 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869 IHISPP(INT(WHAT(J))-100) = 1
1870 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1873 ENDIF
1874 541 CONTINUE
1875 GOTO 10
1876
1877*********************************************************************
1878* *
1879* control card: codewd = XS-TABLE *
1880* *
1881* output of cross section table for requested interaction *
1882* - particle production deactivated ! - *
1883* *
1884* what (1) lower energy limit for tabulation *
1885* > 0 Lab. frame *
1886* < 0 nucleon-nucleon cms *
1887* what (2) upper energy limit for tabulation *
1888* > 0 Lab. frame *
1889* < 0 nucleon-nucleon cms *
1890* what (3) > 0 # of equidistant lin. bins in E *
1891* < 0 # of equidistant log. bins in E *
1892* what (4) lower limit of particle virtuality (photons) *
1893* what (5) upper limit of particle virtuality (photons) *
1894* what (6) > 0 # of equidistant lin. bins in Q^2 *
1895* < 0 # of equidistant log. bins in Q^2 *
1896* *
1897*********************************************************************
1898
1899 550 CONTINUE
1900 IF (WHAT(1).EQ.99999.0D0) THEN
1901 IRATIO = INT(WHAT(2))
1902 GOTO 10
1903 ENDIF
1904 CMENER = ABS(WHAT(2))
1905 IF (.NOT.LXSTAB) THEN
1906
1907 CALL NCDTRD
1908 CALL INCINI
1909
1910 ENDIF
1911 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1912 CMEOLD = CMENER
1913 IF (WHAT(2).GT.ZERO)
1914 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1915 EPN = ZERO
1916 PPN = ZERO
1917C WRITE(LOUT,*) 'CMENER = ',CMENER
1918 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1919 CALL DT_PHOINI
1920 ENDIF
1921 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1922 IXSQEL = 0
1923 LXSTAB = .TRUE.
1924 GOTO 10
1925
1926*********************************************************************
1927* *
1928* control card: codewd = GLAUB-PAR *
1929* *
1930* parameters in Glauber-formalism *
1931* *
1932* what (1) # of nucleon configurations sampled in integration *
1933* over nuclear desity default: 1000 *
1934* what (2) # of bins for integration over impact-parameter and *
1935* for profile-function calculation default: 49 *
1936* what (3) = 1 calculation of tot., el. and qel. cross sections *
1937* default: 0 *
1938* what (4) = 1 read pre-calculated impact-parameter distrib. *
1939* from "sdum".glb *
1940* =-1 dump pre-calculated impact-parameter distrib. *
1941* into "sdum".glb *
1942* = 100 read pre-calculated impact-parameter distrib. *
1943* for variable projectile/target/energy runs *
1944* from "sdum".glb *
1945* default: 0 *
1946* what (5..6) no meaning *
1947* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1948* *
1949*********************************************************************
1950
1951 560 CONTINUE
1952 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956 IOGLB = INT(WHAT(4))
1957 CGLB = SDUM
1958 ENDIF
1959 GOTO 10
1960
1961*********************************************************************
1962* *
1963* control card: codewd = GLAUB-INI *
1964* *
1965* pre-initialization of profile function *
1966* *
1967* what (1) lower energy limit for initialization *
1968* > 0 Lab. frame *
1969* < 0 nucleon-nucleon cms *
1970* what (2) upper energy limit for initialization *
1971* > 0 Lab. frame *
1972* < 0 nucleon-nucleon cms *
1973* what (3) > 0 # of equidistant lin. bins in E *
1974* < 0 # of equidistant log. bins in E *
1975* what (4) maximum projectile mass number for which the *
1976* Glauber data are initialized for each *
1977* projectile mass number *
1978* (if <= mass given with the PROJPAR-card) *
1979* default: 18 *
1980* what (5) steps in mass number starting from what (4) *
1981* up to mass number defined with PROJPAR-card *
1982* for which Glauber data are initialized *
1983* default: 5 *
1984* what (6) no meaning *
1985* sdum no meaning *
1986* *
1987*********************************************************************
1988
1989 565 CONTINUE
1990 IOGLB = -100
1991 CALL DT_GLBINI(WHAT)
1992 GOTO 10
1993
1994*********************************************************************
1995* *
1996* control card: codewd = VDM-PAR2 *
1997* *
1998* parameters in gamma-nucleus cross section calculation *
1999* *
2000* what (1) = 0 no suppression of shadowing by direct photon *
2001* processes *
2002* = 1 suppression .. default: 1 *
2003* what (2) = 0 no suppression of shadowing by anomalous *
2004* component if photon-F_2 *
2005* = 1 suppression .. default: 1 *
2006* what (3) = 0 no suppression of shadowing by coherence *
2007* length of the photon *
2008* = 1 suppression .. default: 1 *
2009* what (4) = 1 longitudinal polarized photons are taken into *
2010* account *
2011* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
2012* what (5..6), sdum no meaning *
2013* *
2014*********************************************************************
2015
2016 570 CONTINUE
2017 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2020 EPSPOL = WHAT(4)
2021 GOTO 10
2022
2023*********************************************************************
2024* *
2025* control card: XS-QELPRO *
2026* *
2027* what (1..6), sdum no meaning *
2028* *
2029*********************************************************************
2030
2031 580 CONTINUE
2032 IXSQEL = ABS(WHAT(1))
2033 GOTO 10
2034
2035*********************************************************************
2036* *
2037* control card: RNDMINIT *
2038* *
2039* initialization of random number generator *
2040* *
2041* what (1..4) values for initialization (= 1..168) *
2042* what (5..6), sdum no meaning *
2043* *
2044*********************************************************************
2045
2046 590 CONTINUE
2047 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2048 NA1 = 22
2049 ELSE
2050 NA1 = WHAT(1)
2051 ENDIF
2052 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2053 NA2 = 54
2054 ELSE
2055 NA2 = WHAT(2)
2056 ENDIF
2057 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2058 NA3 = 76
2059 ELSE
2060 NA3 = WHAT(3)
2061 ENDIF
2062 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2063 NA4 = 92
2064 ELSE
2065 NA4 = WHAT(4)
2066 ENDIF
2067 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2068 GOTO 10
2069
2070*********************************************************************
2071* *
2072* control card: codewd = LEPTO-CUT *
2073* *
2074* set parameter CUT in LEPTO-common /LEPTOU/ *
2075* *
2076* what (1) = index in CUT-array *
2077* what (2) = new value of CUT( int(what(1)) ) *
2078* what (3), what(4) and what (5), what(6) further *
2079* parameter in the same way as what (1) and *
2080* what (2) *
2081* default: default-LEPTO parameters *
2082* *
2083*********************************************************************
2084
2085 600 CONTINUE
2086 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2089 GOTO 10
2090
2091*********************************************************************
2092* *
2093* control card: codewd = LEPTO-LST *
2094* *
2095* set parameter LST in LEPTO-common /LEPTOU/ *
2096* *
2097* what (1) = index in LST-array *
2098* what (2) = new value of LST( int(what(1)) ) *
2099* what (3), what(4) and what (5), what(6) further *
2100* parameter in the same way as what (1) and *
2101* what (2) *
2102* default: default-LEPTO parameters *
2103* *
2104*********************************************************************
2105
2106 610 CONTINUE
2107 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2110 GOTO 10
2111
2112*********************************************************************
2113* *
2114* control card: codewd = LEPTO-PARL *
2115* *
2116* set parameter PARL in LEPTO-common /LEPTOU/ *
2117* *
2118* what (1) = index in PARL-array *
2119* what (2) = new value of PARL( int(what(1)) ) *
2120* what (3), what(4) and what (5), what(6) further *
2121* parameter in the same way as what (1) and *
2122* what (2) *
2123* default: default-LEPTO parameters *
2124* *
2125*********************************************************************
2126
2127 620 CONTINUE
2128 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2131 GOTO 10
2132
2133*********************************************************************
2134* *
2135* control card: codewd = START *
2136* *
2137* what (1) = number of events default: 100. *
2138* what (2) = 0 Glauber initialization follows *
2139* = 1 Glauber initialization supressed, fitted *
2140* results are used instead *
2141* (this does not apply if emulsion-treatment *
2142* is requested) *
2143* = 2 Glauber initialization is written to *
2144* output-file shmakov.out *
2145* = 3 Glauber initialization is read from input-file *
2146* shmakov.out default: 0 *
2147* what (3..6) no meaning *
2148* what (3..6) no meaning *
2149* *
2150*********************************************************************
2151
2152 630 CONTINUE
2153
2154* check for cross-section table output only
2155 IF (LXSTAB) STOP
2156
2157 NCASES = INT(WHAT(1))
2158 IF (NCASES.LE.0) NCASES = 100
2159 IGLAU = INT(WHAT(2))
2160 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2161 & IGLAU = 0
2162
2163 NPMASS = IP
2164 NPCHAR = IPZ
2165 NTMASS = IT
2166 NTCHAR = ITZ
2167 IDP = IJPROJ
2168 IDT = IJTARG
2169 IF (IDP.LE.0) IDP = 1
2170* muon neutrinos: temporary (missing index)
2171* (new patch in projpar: therefore the following this is probably not
2172* necessary anymore..)
2173C IF (IDP.EQ.26) IDP = 5
2174C IF (IDP.EQ.27) IDP = 6
2175
2176* redefine collision energy
2177 IF (LEINP) THEN
2178 IF (ABS(VAREHI).GT.ZERO) THEN
2179 PDUM = ZERO
2180 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2182 PDUM = ZERO
2183 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2184 ENDIF
2185 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2186 ELSE
2187 WRITE(LOUT,1003)
2188 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2189 & 1X,' -program stopped- ')
2190 STOP
2191 ENDIF
2192
2193* switch off evaporation (even if requested) if central coll. requ.
2194 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2195 IF (LEVPRT) THEN
2196 WRITE(LOUT,1004)
2197 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2198 & ' central collisions forced.')
2199 LEVPRT = .FALSE.
2200 LDEEXG = .FALSE.
2201 LHEAVY = .FALSE.
2202 ENDIF
2203 ENDIF
2204
2205* initialization of evaporation-module
2206
2207* initialize evaporation if the code is not used as Fluka event generator
2208 WRITE(LOUT,*) ' ITRSPT = ', ITRSPT
2209 IF (ITRSPT.NE.1) THEN
2210 CALL NCDTRD
2211 CALL INCINI
2212 ENDIF
2213 WRITE(LOUT,*) ' LEVPRT = ',LEVPRT
2214 IF (LEVPRT) LHEAVY = .TRUE.
2215* save the default JETSET-parameter
2216 CALL DT_JSPARA(0)
2217
2218 WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE
2219* force use of phojet for g-A
2220 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221* initialization of nucleon-nucleon event generator
2222 IF (MCGENE.EQ.2) CALL DT_PHOINI
2223* initialization of LEPTO event generator
2224 IF (MCGENE.EQ.3) THEN
2225
2226 STOP ' This version does not contain LEPTO !'
2227
2228 ENDIF
2229
2230* initialization of quasi-elastic neutrino scattering
2231 IF (MCGENE.EQ.4) THEN
2232 IF (IJPROJ.EQ.5) THEN
2233 NEUTYP = 1
2234 ELSEIF (IJPROJ.EQ.6) THEN
2235 NEUTYP = 2
2236 ELSEIF (IJPROJ.EQ.135) THEN
2237 NEUTYP = 3
2238 ELSEIF (IJPROJ.EQ.136) THEN
2239 NEUTYP = 4
2240 ELSEIF (IJPROJ.EQ.133) THEN
2241 NEUTYP = 5
2242 ELSEIF (IJPROJ.EQ.134) THEN
2243 NEUTYP = 6
2244 ENDIF
2245 ENDIF
2246
2247* normalize fractions of emulsion components
2248 IF (NCOMPO.GT.0) THEN
2249 SUMFRA = ZERO
2250 DO 491 I=1,NCOMPO
2251 SUMFRA = SUMFRA+EMUFRA(I)
2252 491 CONTINUE
2253 IF (SUMFRA.GT.ZERO) THEN
2254 DO 492 I=1,NCOMPO
2255 EMUFRA(I) = EMUFRA(I)/SUMFRA
2256 492 CONTINUE
2257 ENDIF
2258 ENDIF
2259
2260* disallow Cronin's multiple scattering for nucleus-nucleus interactions
6cf1df4c 2261 IF ((IP.GT.1) .AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
7b076c76 2262 WRITE(LOUT,1005)
2263 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2264 MKCRON = 0
2265 ENDIF
2266
2267* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2268C IF (NCOMPO.LE.0) THEN
2269C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2270C ELSE
2271C DO 493 I=1,NCOMPO
2272C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2273C 493 CONTINUE
2274C ENDIF
2275
2276* pre-tabulation of elastic cross-sections
2277 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2278
2279 CALL DT_XTIME
2280
2281 RETURN
2282
2283*********************************************************************
2284* *
2285* control card: codewd = STOP *
2286* *
2287* stop of the event generation *
2288* *
2289* what (1..6) no meaning *
2290* *
2291*********************************************************************
2292
2293 9999 CONTINUE
2294 WRITE(LOUT,9000)
2295 9000 FORMAT(1X,'---> unexpected end of input !')
2296
2297 640 CONTINUE
2298 STOP
2299
2300 END
2301
2302*$ CREATE DT_KKINC.FOR
2303*COPY DT_KKINC
2304*
2305*===kkinc==============================================================*
2306*
2307 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2308 & IREJ)
2309
2310************************************************************************
2311* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2312* This subroutine is an update of the previous version written *
2313* by J. Ranft/ H.-J. Moehring. *
2314* This version dated 19.11.95 is written by S. Roesler *
2315************************************************************************
2316
2317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2318 SAVE
2319
2320 PARAMETER ( LINP = 10 ,
2321 & LOUT = 6 ,
2322 & LDAT = 9 )
2323
2324 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2325 & TINY2=1.0D-2,TINY3=1.0D-3)
2326
2327 LOGICAL LFZC
2328
2329* event history
2330
2331 PARAMETER (NMXHKK=200000)
2332
2333 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2334 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2335 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2336
2337* extended event history
2338 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2339 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2340 & IHIST(2,NMXHKK)
2341
2342* particle properties (BAMJET index convention)
2343 CHARACTER*8 ANAME
2344 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2345 & IICH(210),IIBAR(210),K1(210),K2(210)
2346
2347* properties of interacting particles
2348 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2349
2350* Lorentz-parameters of the current interaction
2351 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2352 & UMO,PPCM,EPROJ,PPROJ
2353
2354* flags for input different options
2355 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2356 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2357 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2358
2359* flags for particle decays
2360 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2361 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2362 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2363
2364* cuts for variable energy runs
2365 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2366
2367* Glauber formalism: flags and parameters for statistics
2368 LOGICAL LPROD
2369 CHARACTER*8 CGLB
2370 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2371
2372 DIMENSION WHAT(6)
2373
2374 IREJ = 0
2375 ILOOP = 0
2376 100 CONTINUE
2377 IF (ILOOP.EQ.4) THEN
2378 WRITE(LOUT,1000) NEVHKK
2379 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2380 GOTO 9999
2381 ENDIF
2382 ILOOP = ILOOP+1
2383
2384* variable energy-runs, recalculate parameters for LT's
2385 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2386 PDUM = ZERO
2387 CDUM = ZERO
2388 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2389 ENDIF
2390 IF (EPN.GT.EPROJ) THEN
2391 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2392 & ' Requested energy (',EPN,'GeV) exceeds',
2393 & ' initialization energy (',EPROJ,'GeV) !'
2394 STOP
2395 ENDIF
2396
2397* re-initialize /DTPRTA/
2398 IP = NPMASS
2399 IPZ = NPCHAR
2400 IT = NTMASS
2401 ITZ = NTCHAR
2402 IJPROJ = IDP
2403 IBPROJ = IIBAR(IJPROJ)
2404
2405* calculate nuclear potentials (common /DTNPOT/)
2406 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2407
2408* initialize treatment for residual nuclei
2409 CALL DT_RESNCL(EPN,NLOOP,1)
2410
2411* sample hadron/nucleus-nucleus interaction
2412 CALL DT_KKEVNT(KKMAT,IREJ1)
2413 IF (IREJ1.GT.0) THEN
2414 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2415 GOTO 9999
2416 ENDIF
2417
2418 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2419
2420* intranuclear cascade of final state particles for KTAUGE generations
2421* of secondaries
2422 CALL DT_FOZOCA(LFZC,IREJ1)
2423 IF (IREJ1.GT.0) THEN
2424 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2425 GOTO 9999
2426 ENDIF
2427
2428* baryons unable to escape the nuclear potential are treated as
2429* excited nucleons (ISTHKK=15,16)
2430 CALL DT_SCN4BA
2431
2432* decay of resonances produced in intranuclear cascade processes
2433**sr 15-11-95 should be obsolete
2434C IF (LFZC) CALL DT_DECAY1
2435
2436 101 CONTINUE
2437* treatment of residual nuclei
2438 CALL DT_RESNCL(EPN,NLOOP,2)
2439
2440* evaporation / fission / fragmentation
2441* (if intranuclear cascade was sampled only)
2442 IF (LFZC) THEN
2443 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2444 IF (IREJ1.GT.1) GOTO 101
2445 IF (IREJ1.EQ.1) GOTO 100
2446 ENDIF
2447
2448 ENDIF
2449
2450* rejection of unphysical configurations
2451C CALL DT_REJUCO(1,IREJ1)
2452C IF (IREJ1.GT.0) THEN
2453C IF (IOULEV(1).GT.0)
2454C & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2455C GOTO 100
2456C ENDIF
2457
2458* transform finale state into Lab.
2459 IFLAG = 2
2460 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2461 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2462
2463 IF (IPI0.EQ.1) CALL DT_DECPI0
2464
2465C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2466
2467 RETURN
2468 9999 CONTINUE
2469 IREJ = 1
2470 RETURN
2471 END
2472
2473*$ CREATE DT_DEFAUL.FOR
2474*COPY DT_DEFAUL
2475*
2476*===defaul=============================================================*
2477*
2478 SUBROUTINE DT_DEFAUL(EPN,PPN)
2479
2480************************************************************************
2481* Variables are set to default values. *
2482* This version dated 8.5.95 is written by S. Roesler. *
2483************************************************************************
2484
2485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2486 SAVE
2487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2488 PARAMETER (TWOPI = 6.283185307179586454D+00)
2489
2490* particle properties (BAMJET index convention)
2491 CHARACTER*8 ANAME
2492 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2493 & IICH(210),IIBAR(210),K1(210),K2(210)
2494
2495* nuclear potential
2496 LOGICAL LFERMI
2497 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2498 & EBINDP(2),EBINDN(2),EPOT(2,210),
2499 & ETACOU(2),ICOUL,LFERMI
2500
2501* interface HADRIN-DPM
2502 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2503
2504* central particle production, impact parameter biasing
2505 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2506
2507* properties of interacting particles
2508 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2509
2510* properties of photon/lepton projectiles
2511 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2512
2513 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2514
2515* emulsion treatment
2516 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2517 & NCOMPO,IEMUL
2518
2519* parameter for intranuclear cascade
2520 LOGICAL LPAULI
2521 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2522
2523* various options for treatment of partons (DTUNUC 1.x)
2524* (chain recombination, Cronin,..)
2525 LOGICAL LCO2CR,LINTPT
2526 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2527 & LCO2CR,LINTPT
2528
2529* threshold values for x-sampling (DTUNUC 1.x)
2530 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2531 & SSMIMQ,VVMTHR
2532
2533* flags for input different options
2534 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2535 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2536 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2537
2538* n-n cross section fluctuations
2539 PARAMETER (NBINS = 1000)
2540 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2541
2542* flags for particle decays
2543 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2544 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2545 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2546
2547* diquark-breaking mechanism
2548 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2549
2550* nucleon-nucleon event-generator
2551 CHARACTER*8 CMODEL
2552 LOGICAL LPHOIN
2553 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2554
2555* flags for diffractive interactions (DTUNUC 1.x)
2556 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2557
2558* VDM parameter for photon-nucleus interactions
2559 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2560
2561* Glauber formalism: flags and parameters for statistics
2562 LOGICAL LPROD
2563 CHARACTER*8 CGLB
2564 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2565
2566* kinematical cuts for lepton-nucleus interactions
2567 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2568 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2569
2570* flags for activated histograms
2571 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2572
2573* cuts for variable energy runs
2574 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2575
2576* parameters for hA-diffraction
2577 COMMON /DTDIHA/ DIBETA,DIALPH
2578
2579* LEPTO
2580 REAL RPPN
2581 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2582
2583* steering flags for qel neutrino scattering modules
2584 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2585
2586* event flag
2587 COMMON /DTEVNO/ NEVENT,ICASCA
2588
2589 DATA POTMES /0.002D0/
2590
2591* common /DTNPOT/
2592 DO 10 I=1,2
2593 PFERMP(I) = ZERO
2594 PFERMN(I) = ZERO
2595 EBINDP(I) = ZERO
2596 EBINDN(I) = ZERO
2597 DO 11 J=1,210
2598 EPOT(I,J) = ZERO
2599 11 CONTINUE
2600* nucleus independent meson potential
2601 EPOT(I,13) = POTMES
2602 EPOT(I,14) = POTMES
2603 EPOT(I,15) = POTMES
2604 EPOT(I,16) = POTMES
2605 EPOT(I,23) = POTMES
2606 EPOT(I,24) = POTMES
2607 EPOT(I,25) = POTMES
2608 10 CONTINUE
2609 FERMOD = 0.55D0
2610 ETACOU(1) = ZERO
2611 ETACOU(2) = ZERO
2612 ICOUL = 1
2613 LFERMI = .TRUE.
2614
2615* common /HNTHRE/
2616 EHADTH = -99.0D0
2617 EHADLO = 4.06D0
2618 EHADHI = 6.0D0
2619 INTHAD = 1
2620 IDXTA = 2
2621
2622* common /DTIMPA/
2623 ICENTR = 0
2624 BIMIN = ZERO
2625 BIMAX = 1.0D10
2626 XSFRAC = 1.0D0
2627
2628* common /DTPRTA/
2629 IP = 1
2630 IPZ = 1
2631 IT = 1
2632 ITZ = 1
2633 IJPROJ = 1
2634 IBPROJ = 1
2635 IJTARG = 1
2636 IBTARG = 1
2637* common /DTGPRO/
2638 VIRT = ZERO
2639 DO 14 I=1,4
2640 PGAMM(I) = ZERO
2641 PLEPT0(I) = ZERO
2642 PLEPT1(I) = ZERO
2643 PNUCL(I) = ZERO
2644 14 CONTINUE
2645 IDIREC = 0
2646
2647* common /DTFOTI/
2648**sr 7.4.98: changed after corrected B-sampling
2649C TAUFOR = 4.4D0
2650 TAUFOR = 3.5D0
2651 KTAUGE = 25
2652 ITAUVE = 1
2653 INCMOD = 1
2654 LPAULI = .TRUE.
2655
2656* common /DTCHAI/
2657 SEASQ = ONE
2658 MKCRON = 1
2659 CRONCO = 0.64D0
2660 ISICHA = 0
2661 CUTOF = 100.0D0
2662 LCO2CR = .FALSE.
2663 IRECOM = 1
2664 LINTPT = .TRUE.
2665
2666* common /DTXCUT/
2667* definition of soft quark distributions
2668 XSEACU = 0.05D0
2669 UNON = 2.0D0
2670 UNOM = 1.5D0
2671 UNOSEA = 5.0D0
2672* cutoff parameters for x-sampling
2673 CVQ = 1.0D0
2674 CDQ = 2.0D0
2675C CSEA = 0.3D0
2676 CSEA = 0.1D0
2677 SSMIMA = 1.2D0
2678 SSMIMQ = SSMIMA**2
2679 VVMTHR = 2.0D0
2680
2681* common /DTXSFL/
2682 IFLUCT = 0
2683
2684* common /DTFRPA/
2685 PDB = 0.15D0
2686 PDBSEA(1) = 0.0D0
2687 PDBSEA(2) = 0.0D0
2688 PDBSEA(3) = 0.0D0
2689 ISIG0 = 0
2690 IPI0 = 0
2691 NMSTU = 0
2692 NPARU = 0
2693 NMSTJ = 0
2694 NPARJ = 0
2695
2696* common /DTDIQB/
2697 DO 15 I=1,8
2698 DBRKR(1,I) = 5.0D0
2699 DBRKR(2,I) = 5.0D0
2700 DBRKR(3,I) = 10.0D0
2701 DBRKA(1,I) = ZERO
2702 DBRKA(2,I) = ZERO
2703 DBRKA(3,I) = ZERO
2704 15 CONTINUE
2705 CHAM1 = 0.2D0
2706 CHAM3 = 0.5D0
2707 CHAB1 = 0.7D0
2708 CHAB3 = 1.0D0
2709
2710* common /DTFLG3/
2711 ISINGD = 0
2712 IDOUBD = 0
2713 IFLAGD = 0
2714 IDIFF = 0
2715
2716* common /DTMODL/
2717 MCGENE = 2
2718 CMODEL(1) = 'DTUNUC '
2719 CMODEL(2) = 'PHOJET '
2720 CMODEL(3) = 'LEPTO '
2721 CMODEL(4) = 'QNEUTRIN'
2722 LPHOIN = .TRUE.
2723 ELOJET = 5.0D0
2724
2725* common /DTLCUT/
2726 ECMIN = 3.5D0
2727 ECMAX = 1.0D10
2728 XBJMIN = ZERO
2729 ELMIN = ZERO
2730 EGMIN = ZERO
2731 EGMAX = 1.0D10
2732 YMIN = TINY10
2733 YMAX = 0.999D0
2734 Q2MIN = TINY10
2735 Q2MAX = 10.0D0
2736 THMIN = ZERO
2737 THMAX = TWOPI
2738 Q2LI = ZERO
2739 Q2HI = 1.0D10
2740 ECMLI = ZERO
2741 ECMHI = 1.0D10
2742
2743* common /DTVDMP/
2744 RL2 = 2.0D0
2745 INTRGE(1) = 1
2746 INTRGE(2) = 3
2747 IDPDF = 2212
2748 MODEGA = 4
2749 ISHAD(1) = 1
2750 ISHAD(2) = 1
2751 ISHAD(3) = 1
2752 EPSPOL = ZERO
2753
2754* common /DTGLGP/
2755 JSTATB = 1000
2756 JBINSB = 49
2757 CGLB = ' '
2758 IF (ITRSPT.EQ.1) THEN
2759 IOGLB = 100
2760 ELSE
2761 IOGLB = 0
2762 ENDIF
2763 LPROD = .TRUE.
2764
2765* common /DTHIS3/
2766 DO 16 I=1,50
2767 IHISPP(I) = 0
2768 IHISXS(I) = 0
2769 16 CONTINUE
2770 IXSTBL = 0
2771
2772* common /DTVARE/
2773 VARELO = ZERO
2774 VAREHI = ZERO
2775 VARCLO = ZERO
2776 VARCHI = ZERO
2777
2778* common /DTDIHA/
2779 DIBETA = -1.0D0
2780 DIALPH = ZERO
2781
2782* common /LEPTOI/
2783 RPPN = 0.0
2784 LEPIN = 0
2785 INTER = 0
2786
2787* common /QNEUTO/
2788 NEUTYP = 1
2789 NEUDEC = 0
2790
2791* common /DTEVNO/
2792 NEVENT = 1
2793 IF (ITRSPT.EQ.1) THEN
2794 ICASCA = 1
2795 ELSE
2796 ICASCA = 0
2797 ENDIF
2798
2799* default Lab.-energy
2800 EPN = 200.0D0
2801 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2802
2803 RETURN
2804 END
2805
2806*$ CREATE DT_AAEVT.FOR
2807*COPY DT_AAEVT
2808*
2809*===aaevt==============================================================*
2810*
2811 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2812 & IDP,IGLAU)
2813
2814************************************************************************
2815* This version dated 22.03.96 is written by S. Roesler. *
2816************************************************************************
2817
2818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2819 SAVE
2820
2821 PARAMETER ( LINP = 10 ,
2822 & LOUT = 6 ,
2823 & LDAT = 9 )
2824
2825 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2826
2827* emulsion treatment
2828 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2829 & NCOMPO,IEMUL
2830
2831* event flag
2832 COMMON /DTEVNO/ NEVENT,ICASCA
2833
2834 CHARACTER*8 DATE,HHMMSS
2835 CHARACTER*9 CHDATE,CHTIME,CHZONE
2836 DIMENSION JDMNYR(8),IDMNYR(3)
2837
2838 KKMAT = 1
2839 NMSG = MAX(NEVTS/100,1)
2840
2841* initialization of run-statistics and histograms
2842 CALL DT_STATIS(1)
2843
2844 CALL PHO_PHIST(1000,DUM)
2845
2846* initialization of Glauber-formalism
2847 IF (NCOMPO.LE.0) THEN
2848 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2849 ELSE
2850 DO 1 I=1,NCOMPO
2851 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2852 1 CONTINUE
2853 ENDIF
2854 CALL DT_SIGEMU
2855
2856C CALL IDATE(IDMNYR)
2857C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2858C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2859 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2860 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2861 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2862 CALL ITIME(IDMNYR)
2863 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2864 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2865 WRITE(LOUT,1001) DATE,HHMMSS
2866 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2867 & ' Time: ',A8,' )')
2868
2869* generate NEVTS events
2870 DO 2 IEVT=1,NEVTS
2871
2872* print run-status message
2873 IF (MOD(IEVT,NMSG).EQ.0) THEN
2874C CALL IDATE(IDMNYR)
2875C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2876C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2877 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2878 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2879 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2880 CALL ITIME(IDMNYR)
2881 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2882 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2883 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2884 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2885 & ' Time: ',A,' )',/)
2886C WRITE(LOUT,1000) IEVT-1
2887C1000 FORMAT(1X,I8,' events sampled')
2888 ENDIF
2889 NEVENT = IEVT
2890* treat nuclear emulsions
2891 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2892* composite targets only
2893 KKMAT = -KKMAT
2894* sample this event
2895 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2896
2897 CALL PHO_PHIST(2000,DUM)
2898
2899 2 CONTINUE
2900
2901* print run-statistics and histograms to output-unit 6
2902
2903 CALL PHO_PHIST(3000,DUM)
2904
2905 CALL DT_STATIS(2)
2906
2907 RETURN
2908 END
2909
2910*$ CREATE DT_LAEVT.FOR
2911*COPY DT_LAEVT
2912*
2913*===laevt==============================================================*
2914*
2915 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2916 & IDP,IGLAU)
2917
2918************************************************************************
2919* Interface to run DPMJET for lepton-nucleus interactions. *
2920* Kinematics is sampled using the equivalent photon approximation *
2921* Based on GPHERA-routine by R. Engel. *
2922* This version dated 23.03.96 is written by S. Roesler. *
2923************************************************************************
2924
2925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2926 SAVE
2927
2928 PARAMETER ( LINP = 10 ,
2929 & LOUT = 6 ,
2930 & LDAT = 9 )
2931
2932 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2933 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2934 PARAMETER (TWOPI = 6.283185307179586454D+00,
2935 & PI = TWOPI/TWO,
2936 & ALPHEM = ONE/137.0D0)
2937
2938C CHARACTER*72 HEADER
2939
2940* particle properties (BAMJET index convention)
2941 CHARACTER*8 ANAME
2942 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2943 & IICH(210),IIBAR(210),K1(210),K2(210)
2944
2945* event history
2946
2947 PARAMETER (NMXHKK=200000)
2948
2949 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2950 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2951 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2952
2953* extended event history
2954 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2955 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2956 & IHIST(2,NMXHKK)
2957
2958* kinematical cuts for lepton-nucleus interactions
2959 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2960 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2961
2962* properties of interacting particles
2963 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2964
2965* properties of photon/lepton projectiles
2966 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2967
2968* kinematics at lepton-gamma vertex
2969 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2970
2971* flags for activated histograms
2972 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2973
2974 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2975
2976* emulsion treatment
2977 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2978 & NCOMPO,IEMUL
2979
2980* Glauber formalism: cross sections
2981 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2982 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2983 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2984 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2985 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2986 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2987 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2988 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2989 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2990 & BSLOPE,NEBINI,NQBINI
2991
2992* nucleon-nucleon event-generator
2993 CHARACTER*8 CMODEL
2994 LOGICAL LPHOIN
2995 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2996
2997* flags for input different options
2998 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2999 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3000 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3001
3002* event flag
3003 COMMON /DTEVNO/ NEVENT,ICASCA
3004
3005 DIMENSION XDUMB(40),BGTA(4)
3006
3007* LEPTO
3008 IF (MCGENE.EQ.3) THEN
3009
3010 STOP ' This version does not contain LEPTO !'
3011
3012 ENDIF
3013
3014 KKMAT = 1
3015 NMSG = MAX(NEVTS/10,1)
3016
3017* mass of incident lepton
3018 AMLPT = AAM(IDP)
3019 AMLPT2 = AMLPT**2
3020 IDPPDG = IDT_IPDGHA(IDP)
3021
3022* consistency of kinematical limits
3023 Q2MIN = MAX(Q2MIN,TINY10)
3024 Q2MAX = MAX(Q2MAX,TINY10)
3025 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
3026 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
3027
3028* total energy of the lepton-nucleon system
3029 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
3030 & +(PLEPT0(3)+PNUCL(3))**2 )
3031 ETOTLN = PLEPT0(4)+PNUCL(4)
3032 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
3033 ECMAX = MIN(ECMAX,ECMLN)
3034 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
3035 & THMIN,THMAX,ELMIN
3036 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
3037 & '------------------',/,9X,'W (min) =',
3038 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
3039 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
3040 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
3041 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
3042 & F7.4,' for E_lpt >',F7.1,' GeV',/)
3043
3044* Lorentz-parameter for transf. into Lab
3045 BGTA(1) = PNUCL(1)/AAM(1)
3046 BGTA(2) = PNUCL(2)/AAM(1)
3047 BGTA(3) = PNUCL(3)/AAM(1)
3048 BGTA(4) = PNUCL(4)/AAM(1)
3049* LT of incident lepton into Lab and dump it in DTEVT1
3050 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3051 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
3052 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
3053 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3054 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
3055 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
3056* maximum energy of photon nucleon system
3057 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
3058 & +(YMAX*PPL0(3)+PPA(3))**2)
3059 ETOTGN = YMAX*PPL0(4)+PPA(4)
3060 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3061 EGNMAX = MIN(EGNMAX,ECMAX)
3062* minimum energy of photon nucleon system
3063 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
3064 & +(YMIN*PPL0(3)+PPA(3))**2)
3065 ETOTGN = YMIN*PPL0(4)+PPA(4)
3066 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3067 EGNMIN = MAX(EGNMIN,ECMIN)
3068
3069* limits for Glauber-initialization
3070 Q2LI = Q2MIN
3071 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
3072 ECMLI = MAX(EGNMIN,THREE)
3073 ECMHI = EGNMAX
3074 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
3075 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
3076 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
3077 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
3078 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
3079 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
3080* initialization of Glauber-formalism
3081 IF (NCOMPO.LE.0) THEN
3082 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3083 ELSE
3084 DO 9 I=1,NCOMPO
3085 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3086 9 CONTINUE
3087 ENDIF
3088 CALL DT_SIGEMU
3089
3090* initialization of run-statistics and histograms
3091 CALL DT_STATIS(1)
3092
3093 CALL PHO_PHIST(1000,DUM)
3094
3095* maximum photon-nucleus cross section
3096 I1 = 1
3097 I2 = 1
3098 RAT = ONE
3099 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
3100 I1 = NEBINI
3101 I2 = NEBINI
3102 RAT = ONE
3103 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
3104 DO 5 I=2,NEBINI
3105 IF (EGNMAX.LT.ECMNN(I)) THEN
3106 I1 = I-1
3107 I2 = I
3108 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3109 GOTO 6
3110 ENDIF
3111 5 CONTINUE
3112 6 CONTINUE
3113 ENDIF
3114 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3115 EGNXX = EGNMAX
3116 I1 = 1
3117 I2 = 1
3118 RAT = ONE
3119 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
3120 I1 = NEBINI
3121 I2 = NEBINI
3122 RAT = ONE
3123 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
3124 DO 7 I=2,NEBINI
3125 IF (EGNMIN.LT.ECMNN(I)) THEN
3126 I1 = I-1
3127 I2 = I
3128 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3129 GOTO 8
3130 ENDIF
3131 7 CONTINUE
3132 8 CONTINUE
3133 ENDIF
3134 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3135 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
3136 SIGMAX = MAX(SIGMAX,SIGXX)
3137 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
3138
3139* plot photon flux table
3140 AYMIN = LOG(YMIN)
3141 AYMAX = LOG(YMAX)
3142 AYRGE = AYMAX-AYMIN
3143 MAXTAB = 50
3144 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
3145C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
3146 DO 1 I=1,MAXTAB
3147 Y = EXP(AYMIN+ADY*DBLE(I-1))
3148 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
3149 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3150 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
3151 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3152 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
3153C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
3154 1 CONTINUE
3155
3156* maximum residual weight for flux sampling (dy/y)
3157 YY = YMIN
3158 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3159 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
3160 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3161
3162 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
3163 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
3164 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
3165 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
3166 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
3167 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3168 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3169 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3170 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3171 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3172 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3173 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3174 XBLOW = 0.001D0
3175 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3176 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3177 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3178
3179 ITRY = 0
3180 ITRW = 0
3181 NC0 = 0
3182 NC1 = 0
3183
3184* generate events
3185 DO 2 IEVT=1,NEVTS
3186 IF (MOD(IEVT,NMSG).EQ.0) THEN
3187C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3188C & STATUS='UNKNOWN')
3189 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3190C CLOSE(LDAT)
3191 ENDIF
3192 NEVENT = IEVT
3193
3194 100 CONTINUE
3195 ITRY = ITRY+1
3196
3197* sample y
3198 101 CONTINUE
3199 ITRW = ITRW+1
3200 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3201 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3202 Q2LOG = LOG(Q2MAX/Q2LOW)
3203 WGH = (ONE+(ONE-YY)**2)*Q2LOG
3204 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3205 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3206 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
3207 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3208
3209* sample Q2
3210 YEFF = ONE+(ONE-YY)**2
3211 102 CONTINUE
3212 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3213 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3214 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3215
3216c NC0 = NC0+1
3217c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3218c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3219
3220* kinematics at lepton-photon vertex
3221* scattered electron
3222 YQ2 = SQRT((ONE-YY)*Q2)
3223 Q2E = Q2/(4.0D0*PLEPT0(4))
3224 E1Y = (ONE-YY)*PLEPT0(4)
3225 CALL DT_DSFECF(SIF,COF)
3226 PLEPT1(1) = YQ2*COF
3227 PLEPT1(2) = YQ2*SIF
3228 PLEPT1(3) = E1Y-Q2E
3229 PLEPT1(4) = E1Y+Q2E
3230C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3231* radiated photon
3232 PGAMM(1) = -PLEPT1(1)
3233 PGAMM(2) = -PLEPT1(2)
3234 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3235 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3236* E_cm cut
3237 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3238 & +(PGAMM(3)+PNUCL(3))**2 )
3239 ETOTGN = PGAMM(4)+PNUCL(4)
3240 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3241 IF (ECMGN.LT.0.1D0) GOTO 101
3242 ECMGN = SQRT(ECMGN)
3243 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3244
3245* Lorentz-transformation into nucleon-rest system
3246 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3247 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3248 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3249 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3250 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3251 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3252* temporary checks..
3253 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3254 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3255 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3256 & 2F10.4)
3257 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3258 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3259 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3260 & 2F10.2)
3261 YYTMP = PPG(4)/PPL0(4)
3262 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3263 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3264 & 2F10.4)
3265
3266* lepton tagger (Lab)
3267 THETA = ACOS( PPL1(3)/PLTOT )
3268 IF (PPL1(4).GT.ELMIN) THEN
3269 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3270 ENDIF
3271* photon energy-cut (Lab)
3272 IF (PPG(4).LT.EGMIN) GOTO 101
3273 IF (PPG(4).GT.EGMAX) GOTO 101
3274* x_Bj cut
3275 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3276 IF (XBJ.LT.XBJMIN) GOTO 101
3277
3278 NC0 = NC0+1
3279 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3280 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3281 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3282 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3283 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3284
3285* rotation angles against z-axis
3286 COD = PPG(3)/PGTOT
3287C SID = SQRT((ONE-COD)*(ONE+COD))
3288 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3289 SID = PPT/PGTOT
3290 COF = ONE
3291 SIF = ZERO
3292 IF (PGTOT*SID.GT.TINY10) THEN
3293 COF = PPG(1)/(SID*PGTOT)
3294 SIF = PPG(2)/(SID*PGTOT)
3295 ANORF = SQRT(COF*COF+SIF*SIF)
3296 COF = COF/ANORF
3297 SIF = SIF/ANORF
3298 ENDIF
3299
3300 IF (IXSTBL.EQ.0) THEN
3301* change to photon projectile
3302 IJPROJ = 7
3303* set virtuality
3304 VIRT = Q2
3305* re-initialize LTs with new kinematics
3306* !!PGAMM ist set in cms (ECMGN) along z
3307 EPN = ZERO
3308 PPN = ZERO
3309 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3310* force Lab-system
3311 IFRAME = 1
3312* get emulsion component if requested
3313 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3314* convolute with cross section
3315 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3316 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3317 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3318 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3319 & Q2,ECMGN,STOT
3320 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3321 NC1 = NC1+1
3322 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3323 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3324 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3325 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3326 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3327* composite targets only
3328 KKMAT = -KKMAT
3329* sample this event
3330 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3331 & IREJ)
3332* rotate momenta of final state particles back in photon-nucleon syst.
3333 DO 4 I=NPOINT(4),NHKK
3334 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3335 & (ISTHKK(I).EQ.1001)) THEN
3336 PX = PHKK(1,I)
3337 PY = PHKK(2,I)
3338 PZ = PHKK(3,I)
3339 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3340 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3341 ENDIF
3342 4 CONTINUE
3343 ENDIF
3344
3345 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3346 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3347 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3348 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3349 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3350
3351* dump this event to histograms
3352
3353 CALL PHO_PHIST(2000,DUM)
3354
3355 2 CONTINUE
3356
3357 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3358 WGY = WGY*LOG(YMAX/YMIN)
3359 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3360
3361C HEADER = ' LAEVT: Q^2 distribution 0'
3362C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3363C HEADER = ' LAEVT: Q^2 distribution 1'
3364C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3365C HEADER = ' LAEVT: Q^2 distribution 2'
3366C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3367C HEADER = ' LAEVT: y distribution 0'
3368C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3369C HEADER = ' LAEVT: y distribution 1'
3370C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3371C HEADER = ' LAEVT: y distribution 2'
3372C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3373C HEADER = ' LAEVT: x distribution 0'
3374C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3375C HEADER = ' LAEVT: x distribution 1'
3376C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3377C HEADER = ' LAEVT: x distribution 2'
3378C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3379C HEADER = ' LAEVT: E_g distribution 0'
3380C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3381C HEADER = ' LAEVT: E_g distribution 1'
3382C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3383C HEADER = ' LAEVT: E_g distribution 2'
3384C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3385C HEADER = ' LAEVT: E_c distribution 0'
3386C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3387C HEADER = ' LAEVT: E_c distribution 1'
3388C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3389C HEADER = ' LAEVT: E_c distribution 2'
3390C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3391
3392* print run-statistics and histograms to output-unit 6
3393
3394 CALL PHO_PHIST(3000,DUM)
3395
3396 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3397
3398 RETURN
3399 END
3400
3401*$ CREATE DT_DTUINI.FOR
3402*COPY DT_DTUINI
3403*
3404*===dtuini=============================================================*
3405*
3406 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3407 & IDP,IEMU)
3408
3409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3410 SAVE
3411
3412 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3413
3414* emulsion treatment
3415 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3416 & NCOMPO,IEMUL
3417
3418* Glauber formalism: flags and parameters for statistics
3419 LOGICAL LPROD
3420 CHARACTER*8 CGLB
3421 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3422
3423 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3424 CALL DT_STATIS(1)
3425
3426 CALL PHO_PHIST(1000,DUM)
3427
3428 IF (NCOMPO.LE.0) THEN
3429 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3430 ELSE
3431 DO 1 I=1,NCOMPO
3432 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3433 1 CONTINUE
3434 ENDIF
3435 IF (IOGLB.NE.100) CALL DT_SIGEMU
3436 IEMU = IEMUL
3437
3438 RETURN
3439 END
3440
3441*$ CREATE DT_DTUOUT.FOR
3442*COPY DT_DTUOUT
3443*
3444*===dtuout=============================================================*
3445*
3446 SUBROUTINE DT_DTUOUT
3447
3448 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3449 SAVE
3450
3451 CALL PHO_PHIST(3000,DUM)
3452
3453 CALL DT_STATIS(2)
3454
3455 RETURN
3456 END
3457
3458*$ CREATE DT_BEAMPR.FOR
3459*COPY DT_BEAMPR
3460*
3461*===beampr=============================================================*
3462*
3463 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3464
3465************************************************************************
3466* Initialization of event generation *
3467* This version dated 7.4.98 is written by S. Roesler. *
3468************************************************************************
3469
3470 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3471 SAVE
3472
3473 PARAMETER ( LINP = 10 ,
3474 & LOUT = 6 ,
3475 & LDAT = 9 )
3476
3477 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3478 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3479
3480 LOGICAL LBEAM
3481
3482* event history
3483
3484 PARAMETER (NMXHKK=200000)
3485
3486 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3487 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3488 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3489
3490* extended event history
3491 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3492 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3493 & IHIST(2,NMXHKK)
3494
3495* properties of interacting particles
3496 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3497
3498* particle properties (BAMJET index convention)
3499 CHARACTER*8 ANAME
3500 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3501 & IICH(210),IIBAR(210),K1(210),K2(210)
3502
3503* beam momenta
3504 COMMON /DTBEAM/ P1(4),P2(4)
3505
3506C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3507 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3508
3509 DATA LBEAM /.FALSE./
3510
3511 GOTO (1,2) MODE
3512
3513 1 CONTINUE
3514
3515 E1 = WHAT(1)
3516 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3517 E2 = WHAT(2)
3518 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3519 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3520 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3521 TH = 1.D-6*WHAT(3)/2.D0
3522 PH = WHAT(4)*BOG
3523 P1(1) = PP1*SIN(TH)*COS(PH)
3524 P1(2) = PP1*SIN(TH)*SIN(PH)
3525 P1(3) = PP1*COS(TH)
3526 P1(4) = E1
3527 P2(1) = PP2*SIN(TH)*COS(PH)
3528 P2(2) = PP2*SIN(TH)*SIN(PH)
3529 P2(3) = -PP2*COS(TH)
3530 P2(4) = E2
3531 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3532 & -(P1(3)+P2(3))**2 )
3533 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3534 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3535 BGX = (P1(1)+P2(1))/ECM
3536 BGY = (P1(2)+P2(2))/ECM
3537 BGZ = (P1(3)+P2(3))/ECM
3538 BGE = (P1(4)+P2(4))/ECM
3539 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3540 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3541 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3542 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3543 COD = P1CMS(3)/P1TOT
3544C SID = SQRT((ONE-COD)*(ONE+COD))
3545 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3546 SID = PPT/P1TOT
3547 COF = ONE
3548 SIF = ZERO
3549 IF (P1TOT*SID.GT.TINY10) THEN
3550 COF = P1CMS(1)/(SID*P1TOT)
3551 SIF = P1CMS(2)/(SID*P1TOT)
3552 ANORF = SQRT(COF*COF+SIF*SIF)
3553 COF = COF/ANORF
3554 SIF = SIF/ANORF
3555 ENDIF
3556**check
3557C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3558C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3559C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3560C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3561C PAX = ZERO
3562C PAY = ZERO
3563C PAZ = P1TOT
3564C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3565C PBX = ZERO
3566C PBY = ZERO
3567C PBZ = -P2TOT
3568C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3569C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3570C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3571C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3572C & P1CMS(1),P1CMS(2),P1CMS(3))
3573C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3574C & P2CMS(1),P2CMS(2),P2CMS(3))
3575C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3576C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3577C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3578C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3579C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3580C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3581C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3582C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3583C STOP
3584**
3585
3586 LBEAM = .TRUE.
3587
3588 RETURN
3589
3590 2 CONTINUE
3591
3592 IF (LBEAM) THEN
3593 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3594 DO 20 I=NPOINT(4),NHKK
430525dd 3595
3596 IF ((ABS(ISTHKK(I)).EQ.1) .OR.
3597 & (ABS(ISTHKK(I)).EQ.2) .OR.
3598 & (ISTHKK(I).EQ.1000) .OR.
3599 & (ISTHKK(I).EQ.1001)) THEN
3600
7b076c76 3601 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3602 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3603 PECMS = PHKK(4,I)
3604 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3605 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3606 ENDIF
3607 20 CONTINUE
3608 ELSE
3609 MODE = -1
3610 ENDIF
3611
3612 RETURN
3613 END
3614
3615*$ CREATE DT_REJUCO.FOR
3616*COPY DT_REJUCO
3617*
3618*===rejuco=============================================================*
3619*
3620 SUBROUTINE DT_REJUCO(MODE,IREJ)
3621
3622************************************************************************
3623* REJection of Unphysical COnfigurations *
3624* MODE = 1 rejection of particles with unphysically large energy *
3625* *
3626* This version dated 27.12.2006 is written by S. Roesler. *
3627************************************************************************
3628
3629 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3630 SAVE
3631
3632 PARAMETER ( LINP = 10 ,
3633 & LOUT = 6 ,
3634 & LDAT = 9 )
3635
3636 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3637 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3638
3639* maximum x_cms of final state particle
3640 PARAMETER (XCMSMX = 1.4D0)
3641
3642* event history
3643
3644 PARAMETER (NMXHKK=200000)
3645
3646 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3647 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3648 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3649
3650* extended event history
3651 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3652 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3653 & IHIST(2,NMXHKK)
3654
3655* Lorentz-parameters of the current interaction
3656 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3657 & UMO,PPCM,EPROJ,PPROJ
3658
3659 IREJ = 0
3660
3661 IF (MODE.EQ.1) THEN
3662 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3663 ECMHLF = UMO/2.0D0
3664 DO 10 I=NPOINT(4),NHKK
3665 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3666 XCMS = ABS(PHKK(4,I))/ECMHLF
3667 IF (XCMS.GT.XCMSMX) GOTO 9999
3668 ENDIF
3669 10 CONTINUE
3670 ENDIF
3671
3672 RETURN
3673 9999 CONTINUE
3674 IREJ = 1
3675 RETURN
3676 END
3677*$ CREATE DT_EVENTB.FOR
3678*COPY DT_EVENTB
3679*
3680*===eventb=============================================================*
3681*
3682 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3683
3684************************************************************************
3685* Treatment of nucleon-nucleon interactions with full two-component *
3686* Dual Parton Model. *
3687* NCSY number of nucleon-nucleon interactions *
3688* IREJ rejection flag *
3689* This version dated 14.01.2000 is written by S. Roesler *
3690************************************************************************
3691
3692 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3693 SAVE
3694
3695 PARAMETER ( LINP = 10 ,
3696 & LOUT = 6 ,
3697 & LDAT = 9 )
3698
3699 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3700
3701* event history
3702
3703 PARAMETER (NMXHKK=200000)
3704
3705 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3706 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3707 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3708
3709* extended event history
3710 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3711 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3712 & IHIST(2,NMXHKK)
3713*! uncomment this line for internal phojet-fragmentation
3714C #include "dtu_dtevtp.inc"
3715
3716* particle properties (BAMJET index convention)
3717 CHARACTER*8 ANAME
3718 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3719 & IICH(210),IIBAR(210),K1(210),K2(210)
3720
3721* flags for input different options
3722 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3723 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3724 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3725
3726* rejection counter
3727 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3728 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3729 & IREXCI(3),IRDIFF(2),IRINC
3730
3731* properties of interacting particles
3732 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3733
3734* properties of photon/lepton projectiles
3735 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3736
3737* various options for treatment of partons (DTUNUC 1.x)
3738* (chain recombination, Cronin,..)
3739 LOGICAL LCO2CR,LINTPT
3740 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3741 & LCO2CR,LINTPT
3742
3743* statistics
3744 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3745 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3746 & ICEVTG(8,0:30)
3747
3748* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3749 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3750
3751* Glauber formalism: collision properties
3752 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 3753 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3754 & NCP,NCT
7b076c76 3755* flags for diffractive interactions (DTUNUC 1.x)
3756 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3757
3758* statistics: double-Pomeron exchange
3759 COMMON /DTFLG2/ INTFLG,IPOPO
3760
3761* flags for particle decays
3762 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3763 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3764 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3765
3766* nucleon-nucleon event-generator
3767 CHARACTER*8 CMODEL
3768 LOGICAL LPHOIN
3769 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3770
3771C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3772 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3773 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3774 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3775 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3776
3777C model switches and parameters
3778 CHARACTER*8 MDLNA
3779 INTEGER ISWMDL,IPAMDL
3780 DOUBLE PRECISION PARMDL
3781 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3782
3783C initial state parton radiation (internal part)
3784 INTEGER MXISR3,MXISR4
3785 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3786 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3787 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3788 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3789 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3790 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3791 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3792
3793C event debugging information
3794 INTEGER NMAXD
3795 PARAMETER (NMAXD=100)
3796 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3797 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3798 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3799 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3800
3801C general process information
3802 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3803 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3804
3805 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3806 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3807 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3808 & KPRON(15),ISINGL(2000)
3809
3810* initial values for max. number of phojet scatterings and dtunuc chains
3811* to be fragmented with one pyexec call
3812 DATA MXPHFR,MXDTFR /10,100/
3813
3814 IREJ = 0
3815* pointer to first parton of the first chain in dtevt common
3816 NPOINT(3) = NHKK+1
3817* special flag for double-Pomeron statistics
3818 IPOPO = 1
3819* counter for low-mass (DTUNUC) interactions
3820 NDTUSC = 0
3821* counter for interactions treated by PHOJET
3822 NPHOSC = 0
3823
3824* scan interactions for single nucleon-nucleon interactions
3825* (this has to be checked here because Cronin modifies parton momenta)
3826 NC = NPOINT(2)
3827 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3828 DO 8 I=1,NCSY
3829 ISINGL(I) = 0
3830 MOP = JMOHKK(1,NC)
3831 MOT = JMOHKK(1,NC+1)
3832 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3833 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3834 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3835 NC = NC+4
3836 8 CONTINUE
3837
3838* multiple scattering of chain ends
3839 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3840 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3841
3842* switch to PHOJET-settings for JETSET parameter
3843 CALL DT_INITJS(1)
3844
3845* loop over nucleon-nucleon interaction
3846 NC = NPOINT(2)
3847 DO 2 I=1,NCSY
3848*
3849* pick up one nucleon-nucleon interaction from DTEVT1
3850* ppnn / ptnn - momenta of the interacting nucleons (cms)
3851* ptotnn - total momentum of the interacting nucleons (cms)
3852* pp1,2 / pt1,2 - momenta of the four partons
3853* pp / pt - total momenta of the proj / targ partons
3854* ptot - total momentum of the four partons
3855 MOP = JMOHKK(1,NC)
3856 MOT = JMOHKK(1,NC+1)
3857 DO 3 K=1,4
3858 PPNN(K) = PHKK(K,MOP)
3859 PTNN(K) = PHKK(K,MOT)
3860 PTOTNN(K) = PPNN(K)+PTNN(K)
3861 PP1(K) = PHKK(K,NC)
3862 PT1(K) = PHKK(K,NC+1)
3863 PP2(K) = PHKK(K,NC+2)
3864 PT2(K) = PHKK(K,NC+3)
3865 PP(K) = PP1(K)+PP2(K)
3866 PT(K) = PT1(K)+PT2(K)
3867 PTOT(K) = PP(K)+PT(K)
3868 3 CONTINUE
3869*
3870*-----------------------------------------------------------------------
3871* this is a complete nucleon-nucleon interaction
3872*
3873 IF (ISINGL(I).EQ.1) THEN
3874*
3875* initialize PHOJET-variables for remnant/valence-partons
3876 IHFLD(1,1) = 0
3877 IHFLD(1,2) = 0
3878 IHFLD(2,1) = 0
3879 IHFLD(2,2) = 0
3880 IHFLS(1) = 1
3881 IHFLS(2) = 1
3882* save current settings of PHOJET process and min. bias flags
3883 DO 9 K=1,11
3884 KPRON(K) = IPRON(K,1)
3885 9 CONTINUE
3886 ISWSAV = ISWMDL(2)
3887*
3888* check if forced sampling of diffractive interaction requested
3889 IF (ISINGD.LT.-1) THEN
3890 DO 90 K=1,11
3891 IPRON(K,1) = 0
3892 90 CONTINUE
3893 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3894 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3895 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3896 ENDIF
3897*
3898* for photons: a direct/anomalous interaction is not sampled
3899* in PHOJET but already in Glauber-formalism. Here we check if such
3900* an interaction is requested
3901 IF (IJPROJ.EQ.7) THEN
3902* first switch off direct interactions
3903 IPRON(8,1) = 0
3904* this is a direct interactions
3905 IF (IDIREC.EQ.1) THEN
3906 DO 12 K=1,11
3907 IPRON(K,1) = 0
3908 12 CONTINUE
3909 IPRON(8,1) = 1
3910* this is an anomalous interactions
3911* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3912 ELSEIF (IDIREC.EQ.2) THEN
3913 ISWMDL(2) = 0
3914 ENDIF
3915 ELSE
3916 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3917 ENDIF
3918*
3919* make sure that total momenta of partons, pp and pt, are on mass
3920* shell (Cronin may have srewed this up..)
3921 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3922 IF (IR1.NE.0) THEN
3923 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3924 & 'EVENTB: mass shell correction rejected'
3925 GOTO 9999
3926 ENDIF
3927*
3928* initialize the incoming particles in PHOJET
3929 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3930
3931 CALL PHO_SETPAR(1,22,0,VIRT)
3932
3933 ELSE
3934
3935 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3936
3937 ENDIF
3938
3939 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3940
3941*
3942* initialize rejection loop counter for anomalous processes
3943 IRJANO = 0
3944 800 CONTINUE
3945 IRJANO = IRJANO+1
3946*
3947* temporary fix for ifano problem
3948 IFANO(1) = 0
3949 IFANO(2) = 0
3950*
3951* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3952
3953 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3954
3955*
3956* for photons: special consistency check for anomalous interactions
3957 IF (IJPROJ.EQ.7) THEN
3958 IF (IRJANO.LT.30) THEN
3959 IF (IFANO(1).NE.0) THEN
3960* here, an anomalous interaction was generated. Check if it
3961* was also requested. Otherwise reject this event.
3962 IF (IDIREC.EQ.0) GOTO 800
3963 ELSE
3964* here, an anomalous interaction was not generated. Check if it
3965* was requested in which case we need to reject this event.
3966 IF (IDIREC.EQ.2) GOTO 800
3967 ENDIF
3968 ELSE
3969 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3970 & IRJANO,IDIREC,NEVHKK
3971 ENDIF
3972 ENDIF
3973*
3974* copy back original settings of PHOJET process and min. bias flags
3975 DO 10 K=1,11
3976 IPRON(K,1) = KPRON(K)
3977 10 CONTINUE
3978 ISWMDL(2) = ISWSAV
3979*
3980* check if PHOJET has rejected this event
3981 IF (IREJ1.NE.0) THEN
3982C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3983 WRITE(LOUT,'(1X,A,I4)')
3984 & 'EVENTB: chain system rejected',IDIREC
3985
3986 CALL PHO_PREVNT(0)
3987
3988 GOTO 9999
3989 ENDIF
3990*
3991* copy partons and strings from PHOJET common back into DTEVT for
3992* external fragmentation
3993 MO1 = NC
3994 MO2 = NC+3
3995*! uncomment this line for internal phojet-fragmentation
3996C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3997 NPHOSC = NPHOSC+1
3998 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3999 IF (IREJ1.NE.0) THEN
4000 IF (IOULEV(1).GT.0)
4001 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
4002 GOTO 9999
4003 ENDIF
4004*
4005* update statistics counter
4006 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4007*
4008*-----------------------------------------------------------------------
4009* this interaction involves "remnants"
4010*
4011 ELSE
4012*
4013* total mass of this system
4014 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4015 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4016 IF (AMTOT2.LT.ZERO) THEN
4017 AMTOT = ZERO
4018 ELSE
4019 AMTOT = SQRT(AMTOT2)
4020 ENDIF
4021*
4022* systems with masses larger than elojet are treated with PHOJET
4023 IF (AMTOT.GT.ELOJET) THEN
4024*
4025* initialize PHOJET-variables for remnant/valence-partons
4026* projectile parton flavors and valence flag
4027 IHFLD(1,1) = IDHKK(NC)
4028 IHFLD(1,2) = IDHKK(NC+2)
4029 IHFLS(1) = 0
4030 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4031 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4032* target parton flavors and valence flag
4033 IHFLD(2,1) = IDHKK(NC+1)
4034 IHFLD(2,2) = IDHKK(NC+3)
4035 IHFLS(2) = 0
4036 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4037 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4038* flag signalizing PHOJET how to treat the remnant:
4039* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4040* iremn > -1 valence remnant: PHOJET assumes flavors according
4041* to mother particle
4042 IREMN1 = IHFLS(1)-1
4043 IREMN2 = IHFLS(2)-1
4044*
4045* initialize the incoming particles in PHOJET
4046 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4047
4048 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4049
4050 ELSE
4051
4052 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4053
4054 ENDIF
4055
4056 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4057
4058*
4059* calculate Lorentz parameter of the nucleon-nucleon cm-system
4060 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4061 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4062 BGX = PTOTNN(1)/AMNN
4063 BGY = PTOTNN(2)/AMNN
4064 BGZ = PTOTNN(3)/AMNN
4065 GAM = PTOTNN(4)/AMNN
4066* transform interacting nucleons into nucleon-nucleon cm-system
4067 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4068 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4069 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4070 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4071 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4072 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4073* transform (total) momenta of the proj and targ partons into
4074* nucleon-nucleon cm-system
4075 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4076 & PP(1),PP(2),PP(3),PP(4),
4077 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4078 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4079 & PT(1),PT(2),PT(3),PT(4),
4080 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4081* energy fractions of the proj and targ partons
4082 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4083 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4084***
4085* testprint
4086c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4087c & (PPTCMS(2)+PTTCMS(2))**2 +
4088c & (PPTCMS(3)+PTTCMS(3))**2 )
4089c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4090c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4091c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4092c & (PPSUB(2)+PTSUB(2))**2 +
4093c & (PPSUB(3)+PTSUB(3))**2 )
4094c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4095c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4096***
4097*
4098* save current settings of PHOJET process and min. bias flags
4099 DO 7 K=1,11
4100 KPRON(K) = IPRON(K,1)
4101 7 CONTINUE
4102* disallow direct photon int. (does not make sense here anyway)
4103 IPRON(8,1) = 0
4104* disallow double pomeron processes (due to technical problems
4105* in PHOJET, needs to be solved sometime)
4106 IPRON(4,1) = 0
4107* disallow diffraction for sea-diquarks
4108 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4109 & (IABS(IHFLD(1,2)).GT.1100)) THEN
4110 IPRON(3,1) = 0
4111 IPRON(6,1) = 0
4112 ENDIF
4113 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4114 & (IABS(IHFLD(2,2)).GT.1100)) THEN
4115 IPRON(3,1) = 0
4116 IPRON(5,1) = 0
4117 ENDIF
4118*
4119* we need massless partons: transform them on mass shell
4120 XMP = ZERO
4121 XMT = ZERO
4122 DO 6 K=1,4
4123 PPTMP(K) = PPSUB(K)
4124 PTTMP(K) = PTSUB(K)
4125 6 CONTINUE
4126 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4127 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4128 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4129 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4130 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4131* total energy of the subsysten after mass transformation
4132* (should be the same as before..)
4133 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4134 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
4135*
4136* after mass shell transformation the x_sub - relation has to be
4137* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4138*
4139* The old version was to scale based on the original x_sub and the
4140* 4-momenta of the subsystem. At very high energy this could lead to
4141* "pseudo-cm energies" of the parent system considerably exceeding
4142* the true cm energy. Now we keep the true cm energy and calculate
4143* new x_sub instead.
4144C old version PPTCMS(4) = PPSUB(4)/XPSUB
4145 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4146 XPSUB = PPSUB(4)/PPTCMS(4)
4147 IF (IJPROJ.EQ.7) THEN
4148 AMP2 = PHKK(5,MOT)**2
4149 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4150 ELSE
4151*???????
4152 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4153 & *(PPTCMS(4)+PHKK(5,MOP)))
4154C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4155C & *(PPTCMS(4)+PHKK(5,MOT)))
4156 ENDIF
4157C old version PTTCMS(4) = PTSUB(4)/XTSUB
4158 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4159 XTSUB = PTSUB(4)/PTTCMS(4)
4160 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4161 & *(PTTCMS(4)+PHKK(5,MOT)))
4162 DO 4 K=1,3
4163 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4164 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4165 4 CONTINUE
4166***
4167* testprint
4168*
4169* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
4170* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
4171* pptcms/ pttcms - momenta of the interacting nucleons (cms)
4172* pp1,2 / pt1,2 - momenta of the four partons
4173*
4174* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
4175* ptot - total momentum of the four partons (cms, negl. Fermi)
4176* ppsub / ptsub - total momenta of the proj / targ partons (cms)
4177*
4178c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4179c & (PPTCMS(2)+PTTCMS(2))**2 +
4180c & (PPTCMS(3)+PTTCMS(3))**2 )
4181c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4182c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4183c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4184c & (PPSUB(2)+PTSUB(2))**2 +
4185c & (PPSUB(3)+PTSUB(3))**2 )
4186c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4187c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4188c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4189c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4190c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4191c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
4192c ENDIF
4193c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4194c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4195c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4196c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4197* transform interacting nucleons into nucleon-nucleon cm-system
4198c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4199c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4200c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4201c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4202c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4203c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4204c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4205c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4206c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4207c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4208c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4209c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4210c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4211c & (PPNEW2+PTNEW2)**2 +
4212c & (PPNEW3+PTNEW3)**2 )
4213c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4214c & (PPNEW4+PTNEW4+PTSTCM) )
4215c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4216c & (PPSUB2+PTSUB2)**2 +
4217c & (PPSUB3+PTSUB3)**2 )
4218c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4219c & (PPSUB4+PTSUB4+PTSTSU) )
4220C WRITE(*,*) ' mother cmE :'
4221C WRITE(*,*) ETSTCM,ENEWCM
4222C WRITE(*,*) ' subsystem cmE :'
4223C WRITE(*,*) ETSTSU,ENEWSU
4224C WRITE(*,*) ' projectile mother :'
4225C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4226C WRITE(*,*) ' target mother :'
4227C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4228C WRITE(*,*) ' projectile subsystem:'
4229C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4230C WRITE(*,*) ' target subsystem:'
4231C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4232C WRITE(*,*) ' projectile subsystem should be:'
4233C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4234C & XPSUB*ETSTCM/2.0D0
4235C WRITE(*,*) ' target subsystem should be:'
4236C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4237C & XTSUB*ETSTCM/2.0D0
4238C WRITE(*,*) ' subsystem cmE should be: '
4239C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4240***
4241*
4242* generate complete remnant - nucleon/remnant event with PHOJET
4243
4244 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4245
4246*
4247* copy back original settings of PHOJET process flags
4248 DO 11 K=1,11
4249 IPRON(K,1) = KPRON(K)
4250 11 CONTINUE
4251*
4252* check if PHOJET has rejected this event
4253 IF (IREJ1.NE.0) THEN
4254 IF (IOULEV(1).GT.0)
4255 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
4256 WRITE(LOUT,*)
4257 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4258
4259 CALL PHO_PREVNT(0)
4260
4261 GOTO 9999
4262 ENDIF
4263*
4264* copy partons and strings from PHOJET common back into DTEVT for
4265* external fragmentation
4266 MO1 = NC
4267 MO2 = NC+3
4268*! uncomment this line for internal phojet-fragmentation
4269C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4270 NPHOSC = NPHOSC+1
4271 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4272 IF (IREJ1.NE.0) THEN
4273 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4274 & 'EVENTB: chain system rejected 2'
4275 GOTO 9999
4276 ENDIF
4277*
4278* update statistics counter
4279 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4280*
4281*-----------------------------------------------------------------------
4282* two-chain approx. for smaller systems
4283*
4284 ELSE
4285*
4286 NDTUSC = NDTUSC+1
4287* special flag for double-Pomeron statistics
4288 IPOPO = 0
4289*
4290* pick up flavors at the ends of the two chains
4291 IFP1 = IDHKK(NC)
4292 IFT1 = IDHKK(NC+1)
4293 IFP2 = IDHKK(NC+2)
4294 IFT2 = IDHKK(NC+3)
4295* ..and the indices of the mothers
4296 MOP1 = NC
4297 MOT1 = NC+1
4298 MOP2 = NC+2
4299 MOT2 = NC+3
4300 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4301 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4302*
4303* check if this chain system was rejected
4304 IF (IREJ1.GT.0) THEN
4305 IF (IOULEV(1).GT.0) THEN
4306 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4307 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4308 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4309 ENDIF
4310 IRHHA = IRHHA+1
4311 GOTO 9999
4312 ENDIF
4313* the following lines are for sea-sea chains rejected in GETCSY
4314 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4315 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4316 ENDIF
4317*
4318 ENDIF
4319*
4320* update statistics counter
4321 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4322*
4323 NC = NC+4
4324*
4325 2 CONTINUE
4326*
4327*-----------------------------------------------------------------------
4328* treatment of low-mass chains (if there are any)
4329*
4330 IF (NDTUSC.GT.0) THEN
4331*
4332* correct chains of very low masses for possible resonances
4333 IF (IRESCO.EQ.1) THEN
4334 CALL DT_EVTRES(IREJ1)
4335 IF (IREJ1.GT.0) THEN
4336 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4337 IRRES(1) = IRRES(1)+1
4338 GOTO 9999
4339 ENDIF
4340 ENDIF
4341* fragmentation of low-mass chains
4342*! uncomment this line for internal phojet-fragmentation
4343* (of course it will still be fragmented by DPMJET-routines but it
4344* has to be done here instead of further below)
4345C CALL DT_EVTFRA(IREJ1)
4346C IF (IREJ1.GT.0) THEN
4347C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4348C IRFRAG = IRFRAG+1
4349C GOTO 9999
4350C ENDIF
4351 ELSE
4352*! uncomment this line for internal phojet-fragmentation
4353C NPOINT(4) = NHKK+1
4354 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4355 ENDIF
4356*
4357*-----------------------------------------------------------------------
4358* new di-quark breaking mechanisms
4359*
4360 MXLEFT = 2
4361 CALL DT_CHASTA(0)
4362 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4363 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4364 CALL DT_DIQBRK
4365 MXLEFT = 4
4366 ENDIF
4367*
4368*-----------------------------------------------------------------------
4369* hadronize this event
4370*
4371* hadronize PHOJET chain systems
4372 NPYMAX = 0
4373 NPJE = NPHOSC/MXPHFR
4374 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4375 IF (NPJE.GT.1) THEN
4376 NLEFT = NPHOSC-NPJE*MXPHFR
4377 DO 20 JFRG=1,NPJE
4378 NFRG = JFRG*MXPHFR
4379 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4380 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4381 IF (IREJ1.GT.0) GOTO 22
4382 NLEFT = 0
4383 ELSE
4384 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4385 IF (IREJ1.GT.0) GOTO 22
4386 ENDIF
4387 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4388 20 CONTINUE
4389 IF (NLEFT.GT.0) THEN
4390 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4391 IF (IREJ1.GT.0) GOTO 22
4392 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4393 ENDIF
4394 ELSE
4395 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4396 IF (IREJ1.GT.0) GOTO 22
4397 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4398 ENDIF
4399*
4400* check max. filling level of jetset common and
4401* reduce mxphfr if necessary
4402 IF (NPYMAX.GT.3000) THEN
4403 IF (NPYMAX.GT.3500) THEN
4404 MXPHFR = MAX(1,MXPHFR-2)
4405 ELSE
4406 MXPHFR = MAX(1,MXPHFR-1)
4407 ENDIF
4408C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4409 ENDIF
4410*
4411* hadronize DTUNUC chain systems
4412 23 CONTINUE
4413 IBACK = MXDTFR
4414 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4415 IF (IREJ2.GT.0) GOTO 22
4416*
4417* check max. filling level of jetset common and
4418* reduce mxdtfr if necessary
4419 IF (NPYMEM.GT.3000) THEN
4420 IF (NPYMEM.GT.3500) THEN
4421 MXDTFR = MAX(1,MXDTFR-20)
4422 ELSE
4423 MXDTFR = MAX(1,MXDTFR-10)
4424 ENDIF
4425C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4426 ENDIF
4427*
4428 IF (IBACK.EQ.-1) GOTO 23
4429*
4430 22 CONTINUE
4431C CALL DT_EVTFRG(1,IREJ1)
4432C CALL DT_EVTFRG(2,IREJ2)
4433 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4434 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4435 IRFRAG = IRFRAG+1
4436 GOTO 9999
4437 ENDIF
4438*
4439* get final state particles from /DTEVTP/
4440*! uncomment this line for internal phojet-fragmentation
4441C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4442
4443 IF (IJPROJ.NE.7)
4444 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4445C IF (IREJ3.NE.0) GOTO 9999
4446
4447 RETURN
4448
4449 9999 CONTINUE
4450 IREVT = IREVT+1
4451 IREJ = 1
4452 RETURN
4453 END
4454
4455*$ CREATE DT_GETPJE.FOR
4456*COPY DT_GETPJE
4457*
4458*===getpje=============================================================*
4459*
4460 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4461
4462************************************************************************
4463* This subroutine copies PHOJET partons and strings from POEVT1 into *
4464* DTEVT1. *
4465* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4466* PP,PT 4-momenta of projectile/target being handled by *
4467* PHOJET *
4468* This version dated 11.12.99 is written by S. Roesler *
4469************************************************************************
4470
4471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4472 SAVE
4473
4474 PARAMETER ( LINP = 10 ,
4475 & LOUT = 6 ,
4476 & LDAT = 9 )
4477
4478 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4479 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4480
4481 LOGICAL LFLIP
4482
4483* event history
4484
4485 PARAMETER (NMXHKK=200000)
4486
4487 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4488 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4489 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4490
4491* extended event history
4492 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4493 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4494 & IHIST(2,NMXHKK)
4495
4496* Lorentz-parameters of the current interaction
4497 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4498 & UMO,PPCM,EPROJ,PPROJ
4499
4500* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4501 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4502
4503* flags for input different options
4504 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4505 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4506 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4507
4508* statistics: double-Pomeron exchange
4509 COMMON /DTFLG2/ INTFLG,IPOPO
4510
4511* statistics
4512 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4513 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4514 & ICEVTG(8,0:30)
4515
4516* rejection counter
4517 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4518 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4519 & IREXCI(3),IRDIFF(2),IRINC
4520C standard particle data interface
4521 INTEGER NMXHEP
4522
4523 PARAMETER (NMXHEP=4000)
4524
4525 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4526 DOUBLE PRECISION PHEP,VHEP
4527 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4528 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4529 & VHEP(4,NMXHEP)
4530C extension to standard particle data interface (PHOJET specific)
4531 INTEGER IMPART,IPHIST,ICOLOR
4532 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4533
4534C color string configurations including collapsed strings and hadrons
4535 INTEGER MSTR
4536 PARAMETER (MSTR=500)
4537 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4538 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4539 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4540 & NNCH(MSTR),IBHAD(MSTR),ISTR
4541
4542C general process information
4543 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4544 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4545
4546C model switches and parameters
4547 CHARACTER*8 MDLNA
4548 INTEGER ISWMDL,IPAMDL
4549 DOUBLE PRECISION PARMDL
4550 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4551
4552C event debugging information
4553 INTEGER NMAXD
4554 PARAMETER (NMAXD=100)
4555 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4556 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4557 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4558 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4559
4560 DIMENSION PP(4),PT(4)
4561 DATA MAXLOP /10000/
4562
4563 INHKK = NHKK
4564 LFLIP = .TRUE.
4565 1 CONTINUE
4566 NPVAL = 0
4567 NTVAL = 0
4568 IREJ = 0
4569
4570* store initial momenta for energy-momentum conservation check
4571 IF (LEMCCK) THEN
4572 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4573 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4574 ENDIF
4575* copy partons and strings from POEVT1 into DTEVT1
4576 DO 11 I=1,ISTR
4577C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4578 IF (NCODE(I).EQ.-99) THEN
4579 IDXSTG = NPOS(1,I)
4580 IDSTG = IDHEP(IDXSTG)
4581 PX = PHEP(1,IDXSTG)
4582 PY = PHEP(2,IDXSTG)
4583 PZ = PHEP(3,IDXSTG)
4584 PE = PHEP(4,IDXSTG)
4585 IF (MODE.LT.0) THEN
4586 ISTAT = 70000+IPJE
4587 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4588 & 11,IDSTG,0)
4589 IF (LEMCCK) THEN
4590 PX = -PX
4591 PY = -PY
4592 PZ = -PZ
4593 PE = -PE
4594 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4595 ENDIF
4596 ELSE
4597 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4598 & PPX,PPY,PPZ,PPE)
4599 ISTAT = 70000+IPJE
4600 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4601 & 11,IDSTG,0)
4602 IF (LEMCCK) THEN
4603 PX = -PPX
4604 PY = -PPY
4605 PZ = -PPZ
4606 PE = -PPE
4607 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4608 ENDIF
4609 ENDIF
4610 NOBAM(NHKK) = 0
4611 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4612 IHIST(2,NHKK) = 0
4613 ELSEIF (NCODE(I).GE.0) THEN
4614* indices of partons and string in POEVT1
4615 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4616 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4617 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4618 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4619 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4620 STOP ' GETPJE 1'
4621 ENDIF
4622 IDXSTG = NPOS(1,I)
4623* find "mother" string of the string
4624 IDXMS1 = ABS(JMOHEP(1,IDX1))
4625 IDXMS2 = ABS(JMOHEP(1,IDX2))
4626 IF (IDXMS1.NE.IDXMS2) THEN
4627 IDXMS1 = IDXSTG
4628 IDXMS2 = IDXSTG
4629C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4630 ENDIF
4631* search POEVT1 for the original hadron of the parton
4632 ILOOP = 0
4633 IPOM1 = 0
4634 14 CONTINUE
4635 ILOOP = ILOOP+1
4636
4637 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4638
4639 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4640 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4641 & (ILOOP.LT.MAXLOP)) GOTO 14
4642 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4643 IPOM2 = 0
4644 ILOOP = 0
4645 15 CONTINUE
4646 ILOOP = ILOOP+1
4647
4648 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4649
4650 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4651 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4652 ELSE
4653 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4654 ENDIF
4655 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4656 & (ILOOP.LT.MAXLOP)) GOTO 15
4657 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4658* parton 1
4659 IF (IDXMS1.EQ.1) THEN
4660 ISPTN1 = ISTHKK(MO1)
4661 M1PTN1 = MO1
4662 M2PTN1 = MO1+2
4663 ELSE
4664 ISPTN1 = ISTHKK(MO2)
4665 M1PTN1 = MO2-2
4666 M2PTN1 = MO2
4667 ENDIF
4668* parton 2
4669 IF (IDXMS2.EQ.1) THEN
4670 ISPTN2 = ISTHKK(MO1)
4671 M1PTN2 = MO1
4672 M2PTN2 = MO1+2
4673 ELSE
4674 ISPTN2 = ISTHKK(MO2)
4675 M1PTN2 = MO2-2
4676 M2PTN2 = MO2
4677 ENDIF
4678* check for mis-identified mothers and switch mother indices if necessary
4679 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4680 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4681 & (LFLIP)) THEN
4682 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4683 ISPTN1 = ISTHKK(MO1)
4684 M1PTN1 = MO1
4685 M2PTN1 = MO1+2
4686 ISPTN2 = ISTHKK(MO2)
4687 M1PTN2 = MO2-2
4688 M2PTN2 = MO2
4689 ELSE
4690 ISPTN1 = ISTHKK(MO2)
4691 M1PTN1 = MO2-2
4692 M2PTN1 = MO2
4693 ISPTN2 = ISTHKK(MO1)
4694 M1PTN2 = MO1
4695 M2PTN2 = MO1+2
4696 ENDIF
4697 ENDIF
4698* register partons in temporary common
4699* parton at chain end
4700 PX = PHEP(1,IDX1)
4701 PY = PHEP(2,IDX1)
4702 PZ = PHEP(3,IDX1)
4703 PE = PHEP(4,IDX1)
4704* flag only partons coming from Pomeron with 41/42
4705C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4706 IF (IPOM1.NE.0) THEN
4707 ISTX = ABS(ISPTN1)/10
4708 IMO = ABS(ISPTN1)-10*ISTX
4709 ISPTN1 = -(40+IMO)
4710 ELSE
4711 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4712 ISTX = ABS(ISPTN1)/10
4713 IMO = ABS(ISPTN1)-10*ISTX
4714 IF ((IDHEP(IDX1).EQ.21).OR.
4715 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4716 ISPTN1 = -(60+IMO)
4717 ELSE
4718 ISPTN1 = -(50+IMO)
4719 ENDIF
4720 ENDIF
4721 ENDIF
4722 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4723 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4724 IF (MODE.LT.0) THEN
4725 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4726 & PZ,PE,0,0,0)
4727 ELSE
4728 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4729 & PPX,PPY,PPZ,PPE)
4730 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4731 & PPZ,PPE,0,0,0)
4732 ENDIF
4733 IHIST(1,NHKK) = IPHIST(1,IDX1)
4734 IHIST(2,NHKK) = 0
4735 DO 19 KK=1,4
4736 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4737 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4738 19 CONTINUE
4739 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4740 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4741 M1STRG = NHKK
4742* gluon kinks
4743 NGLUON = IDX2-IDX1-1
4744 IF (NGLUON.GT.0) THEN
4745 DO 17 IGLUON=1,NGLUON
4746 IDX = IDX1+IGLUON
4747 IDXMS = ABS(JMOHEP(1,IDX))
4748 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4749 ILOOP = 0
4750 16 CONTINUE
4751 ILOOP = ILOOP+1
4752 IDXMS = ABS(JMOHEP(1,IDXMS))
4753 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4754 & (ILOOP.LT.MAXLOP)) GOTO 16
4755 IF (ILOOP.EQ.MAXLOP)
4756 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4757 ENDIF
4758 IF (IDXMS.EQ.1) THEN
4759 ISPTN = ISTHKK(MO1)
4760 M1PTN = MO1
4761 M2PTN = MO1+2
4762 ELSE
4763 ISPTN = ISTHKK(MO2)
4764 M1PTN = MO2-2
4765 M2PTN = MO2
4766 ENDIF
4767 PX = PHEP(1,IDX)
4768 PY = PHEP(2,IDX)
4769 PZ = PHEP(3,IDX)
4770 PE = PHEP(4,IDX)
4771 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4772 ISTX = ABS(ISPTN)/10
4773 IMO = ABS(ISPTN)-10*ISTX
4774 IF ((IDHEP(IDX).EQ.21).OR.
4775 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4776 ISPTN = -(60+IMO)
4777 ELSE
4778 ISPTN = -(50+IMO)
4779 ENDIF
4780 ENDIF
4781 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4782 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4783 IF (MODE.LT.0) THEN
4784 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4785 & PX,PY,PZ,PE,0,0,0)
4786 ELSE
4787 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4788 & PPX,PPY,PPZ,PPE)
4789 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4790 & PPX,PPY,PPZ,PPE,0,0,0)
4791 ENDIF
4792 IHIST(1,NHKK) = IPHIST(1,IDX)
4793 IHIST(2,NHKK) = 0
4794 DO 20 KK=1,4
4795 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4796 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4797 20 CONTINUE
4798 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4799 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4800 17 CONTINUE
4801 ENDIF
4802* parton at chain end
4803 PX = PHEP(1,IDX2)
4804 PY = PHEP(2,IDX2)
4805 PZ = PHEP(3,IDX2)
4806 PE = PHEP(4,IDX2)
4807* flag only partons coming from Pomeron with 41/42
4808C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4809 IF (IPOM2.NE.0) THEN
4810 ISTX = ABS(ISPTN2)/10
4811 IMO = ABS(ISPTN2)-10*ISTX
4812 ISPTN2 = -(40+IMO)
4813 ELSE
4814 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4815 ISTX = ABS(ISPTN2)/10
4816 IMO = ABS(ISPTN2)-10*ISTX
4817 IF ((IDHEP(IDX2).EQ.21).OR.
4818 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4819 ISPTN2 = -(60+IMO)
4820 ELSE
4821 ISPTN2 = -(50+IMO)
4822 ENDIF
4823 ENDIF
4824 ENDIF
4825 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4826 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4827 IF (MODE.LT.0) THEN
4828 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4829 & PX,PY,PZ,PE,0,0,0)
4830 ELSE
4831 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4832 & PPX,PPY,PPZ,PPE)
4833 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4834 & PPX,PPY,PPZ,PPE,0,0,0)
4835 ENDIF
4836 IHIST(1,NHKK) = IPHIST(1,IDX2)
4837 IHIST(2,NHKK) = 0
4838 DO 21 KK=1,4
4839 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4840 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4841 21 CONTINUE
4842 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4843 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4844 M2STRG = NHKK
4845* register string
4846 JSTRG = 100*IPROCE+NCODE(I)
4847 PX = PHEP(1,IDXSTG)
4848 PY = PHEP(2,IDXSTG)
4849 PZ = PHEP(3,IDXSTG)
4850 PE = PHEP(4,IDXSTG)
4851 IF (MODE.LT.0) THEN
4852 ISTAT = 70000+IPJE
4853 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4854 & PX,PY,PZ,PE,0,0,0)
4855 IF (LEMCCK) THEN
4856 PX = -PX
4857 PY = -PY
4858 PZ = -PZ
4859 PE = -PE
4860 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4861 ENDIF
4862 ELSE
4863 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4864 & PPX,PPY,PPZ,PPE)
4865 ISTAT = 70000+IPJE
4866 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4867 & PPX,PPY,PPZ,PPE,0,0,0)
4868 IF (LEMCCK) THEN
4869 PX = -PPX
4870 PY = -PPY
4871 PZ = -PPZ
4872 PE = -PPE
4873 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4874 ENDIF
4875 ENDIF
4876 NOBAM(NHKK) = 0
4877 IHIST(1,NHKK) = 0
4878 IHIST(2,NHKK) = 0
4879 DO 18 KK=1,4
4880 VHKK(KK,NHKK) = VHKK(KK,MO2)
4881 WHKK(KK,NHKK) = WHKK(KK,MO1)
4882 18 CONTINUE
4883 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4884 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4885 ENDIF
4886 11 CONTINUE
4887
4888 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4889 NHKK = INHKK
4890 LFLIP = .FALSE.
4891 GOTO 1
4892 ENDIF
4893
4894 IF (LEMCCK) THEN
4895 IF (UMO.GT.1.0D5) THEN
4896 CHKLEV = 1.0D0
4897 ELSE
4898 CHKLEV = TINY1
4899 ENDIF
4900 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4901
4902 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4903
4904 ENDIF
4905
4906* internal statistics
4907* dble-Po statistics.
4908 IF (IPROCE.NE.4) IPOPO = 0
4909
4910 INTFLG = IPROCE
4911 IDCHSY = IDCH(MO1)
4912 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4913 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4914 ELSE
4915 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4916 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4917 & ') at evt(chain) ',I6,'(',I2,')')
4918 ENDIF
4919 IF (IPROCE.EQ.5) THEN
4920 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4921 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4922 ELSE
4923C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4924 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4925 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4926 ENDIF
4927 ELSEIF (IPROCE.EQ.6) THEN
4928 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4929 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4930 ELSE
4931C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4932 ENDIF
4933 ELSEIF (IPROCE.EQ.7) THEN
4934 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4935 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4936 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4937 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4938 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4939 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4940 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4941 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4942 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4943 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4944 ELSE
4945 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4946 ENDIF
4947 ENDIF
4948 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4949 & THEN
4950 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4951 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4952 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4953 ENDIF
4954 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4955 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4956 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4957 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4958 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4959
4960 RETURN
4961
4962 9999 CONTINUE
4963 IREJ = 1
4964 RETURN
4965 END
4966
4967*$ CREATE DT_PHOINI.FOR
4968*COPY DT_PHOINI
4969*
4970*===phoini=============================================================*
4971*
4972 SUBROUTINE DT_PHOINI
4973
4974************************************************************************
4975* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4976* This version dated 16.11.95 is written by S. Roesler *
4977* *
4978* Last change 27.12.2006 by S. Roesler. *
4979************************************************************************
4980
4981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982 SAVE
4983
4984 PARAMETER ( LINP = 10 ,
4985 & LOUT = 6 ,
4986 & LDAT = 9 )
4987
4988 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4989
4990* nucleon-nucleon event-generator
4991 CHARACTER*8 CMODEL
4992 LOGICAL LPHOIN
4993 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4994
4995* particle properties (BAMJET index convention)
4996 CHARACTER*8 ANAME
4997 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4998 & IICH(210),IIBAR(210),K1(210),K2(210)
4999
5000* Lorentz-parameters of the current interaction
5001 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5002 & UMO,PPCM,EPROJ,PPROJ
5003
5004* properties of interacting particles
5005 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5006
5007* properties of photon/lepton projectiles
5008 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5009
5010 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5011
5012* emulsion treatment
5013 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5014 & NCOMPO,IEMUL
5015
5016* VDM parameter for photon-nucleus interactions
5017 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5018
5019* nuclear potential
5020 LOGICAL LFERMI
5021 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5022 & EBINDP(2),EBINDN(2),EPOT(2,210),
5023 & ETACOU(2),ICOUL,LFERMI
5024
5025* Glauber formalism: flags and parameters for statistics
5026 LOGICAL LPROD
5027 CHARACTER*8 CGLB
5028 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5029*
5030* parameters for cascade calculations:
5031* maximum mumber of PDF's which can be defined in phojet (limited
5032* by the dimension of ipdfs in pho_setpdf)
5033 PARAMETER (MAXPDF = 20)
5034* PDF parametrization and number of set for the first 30 hadrons in
5035* the bamjet-code list
5036* negative numbers mean that the PDF is set in phojet,
5037* zero stands for "not a hadron"
5038 DIMENSION IPARPD(30),ISETPD(30)
5039* PDF parametrization
5040 DATA IPARPD /
5041 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5042 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5043* number of set
5044 DATA ISETPD /
5045 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5046 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5047
5048**PHOJET105a
5049C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5050C PARAMETER ( MAXPRO = 16 )
5051C PARAMETER ( MAXTAB = 20 )
5052C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5053C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5054C CHARACTER*8 MDLNA
5055C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5056C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5057**PHOJET110
5058
5059C global event kinematics and particle IDs
5060 INTEGER IFPAP,IFPAB
5061 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5062 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5063
5064C hard cross sections and MC selection weights
5065 INTEGER Max_pro_2
5066 PARAMETER ( Max_pro_2 = 16 )
5067 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5068 & MH_acc_1,MH_acc_2
5069 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5070 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5071 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5072 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5073 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5074 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5075
5076C model switches and parameters
5077 CHARACTER*8 MDLNA
5078 INTEGER ISWMDL,IPAMDL
5079 DOUBLE PRECISION PARMDL
5080 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5081
5082C general process information
5083 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5084 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5085**
5086 DIMENSION PP(4),PT(4)
5087
5088 LOGICAL LSTART
5089 DATA LSTART /.TRUE./
5090
5091 IJP = IJPROJ
5092 IJT = IJTARG
5093 Q2 = VIRT
5094* lepton-projectiles: initialize real photon instead
5095 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5096 IJP = 7
5097 Q2 = ZERO
5098 ENDIF
5099
5100 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5101
5102* switch Reggeon off
5103C IPAMDL(3)= 0
5104 IF (IP.EQ.1) THEN
5105 IFPAP(1) = IDT_IPDGHA(IJP)
5106 IFPAB(1) = IJP
5107 ELSE
5108 IFPAP(1) = 2212
5109 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5110 ENDIF
5111 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5112 PVIRT(1) = PMASS(1)**2
5113 IF (IT.EQ.1) THEN
5114 IFPAP(2) = IDT_IPDGHA(IJT)
5115 IFPAB(2) = IJT
5116 ELSE
5117 IFPAP(2) = 2212
5118 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5119 ENDIF
5120 PMASS(2) = AAM(IFPAB(2))
5121 PVIRT(2) = ZERO
5122 DO 1 K=1,4
5123 PP(K) = ZERO
5124 PT(K) = ZERO
5125 1 CONTINUE
5126* get max. possible momenta of incoming particles to be used for PHOJET ini.
5127 PPF = ZERO
5128 PTF = ZERO
5129 SCPF= 1.5D0
5130 IF (UMO.GE.1.E5) THEN
5131 SCPF= 5.0D0
5132 ENDIF
5133 IF (NCOMPO.GT.0) THEN
5134 DO 2 I=1,NCOMPO
5135 IF (IT.GT.1) THEN
5136 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5137 ELSE
5138 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5139 ENDIF
5140 PPFTMP = MAX(PFERMP(1),PFERMN(1))
5141 PTFTMP = MAX(PFERMP(2),PFERMN(2))
5142 IF (PPFTMP.GT.PPF) PPF = PPFTMP
5143 IF (PTFTMP.GT.PTF) PTF = PTFTMP
5144 2 CONTINUE
5145 ELSE
5146 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5147 PPF = MAX(PFERMP(1),PFERMN(1))
5148 PTF = MAX(PFERMP(2),PFERMN(2))
5149 ENDIF
5150 PTF = -PTF
5151 PPF = SCPF*PPF
5152 PTF = SCPF*PTF
5153 IF (IJP.EQ.7) THEN
5154 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5155 PP(3) = PPCM
5156 PP(4) = SQRT(AMP2+PP(3)**2)
5157 ELSE
5158 EPF = SQRT(PPF**2+PMASS(1)**2)
5159 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5160 ENDIF
5161 ETF = SQRT(PTF**2+PMASS(2)**2)
5162 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5163 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5164 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5165 IF (LSTART) THEN
5166 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5167 1001 FORMAT(
5168 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
5169 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5170 IF (NCOMPO.GT.0) THEN
5171 WRITE(LOUT,1002) SCPF,PTF,PT
5172 ELSE
5173 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5174 ENDIF
5175 1002 FORMAT(
5176 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
5177 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5178 1003 FORMAT(
5179 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
5180 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5181 WRITE(LOUT,1004) ECMINI
5182 1004 FORMAT(' E_cm = ',E10.3)
5183 IF (IJP.EQ.8) WRITE(LOUT,1005)
5184 1005 FORMAT(
5185 & ' DT_PHOINI: warning! proton parameters used for neutron',
5186 & ' projectile')
5187 LSTART = .FALSE.
5188 ENDIF
5189* switch off new diffractive cross sections at low energies for nuclei
5190* (temporary solution)
5191 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5192 WRITE(LOUT,'(1X,A)')
5193 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5194 CALL PHO_SETMDL(30,0,1)
5195 ENDIF
5196*
5197C IF (IJP.EQ.7) THEN
5198C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5199C PP(3) = PPCM
5200C PP(4) = SQRT(AMP2+PP(3)**2)
5201C ELSE
5202C PFERMX = ZERO
5203C IF (IP.GT.1) PFERMX = 0.5D0
5204C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5205C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5206C ENDIF
5207C PFERMX = ZERO
5208C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5209C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5210C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5211**sr 26.10.96
5212 ISAV = IPAMDL(13)
5213 IF ((ISHAD(2).EQ.1).AND.
5214 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5215 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5216**
5217
5218 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5219
5220**sr 26.10.96
5221 IPAMDL(13) = ISAV
5222**
5223*
5224* patch for cascade calculations:
5225* define parton distribution functions for other hadrons, i.e. other
5226* then defined already in phojet
5227 IF (IOGLB.EQ.100) THEN
5228 WRITE(LOUT,1006)
5229 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5230 & ' assiged (ID,IPAR,ISET)',/)
5231 NPDF = 0
5232 DO 3 I=1,30
5233 IF (IPARPD(I).NE.0) THEN
5234 NPDF = NPDF+1
5235 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5236 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5237 IDPDG = IDT_IPDGHA(I)
5238 IPAR = IPARPD(I)
5239 ISET = ISETPD(I)
5240 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5241 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5242 ENDIF
5243 ENDIF
5244 3 CONTINUE
5245 ENDIF
5246
5247C CALL PHO_PHIST(-1,SIGMAX)
5248
5249 IF (IREJ1.NE.0) THEN
5250 WRITE(LOUT,1000)
5251 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
5252 STOP
5253 ENDIF
5254
5255 RETURN
5256 END
5257
5258*$ CREATE DT_EVENTD.FOR
5259*COPY DT_EVENTD
5260*
5261*===eventd=============================================================*
5262*
5263 SUBROUTINE DT_EVENTD(IREJ)
5264
5265************************************************************************
5266* Quasi-elastic neutrino nucleus scattering. *
5267* This version dated 29.04.00 is written by S. Roesler. *
5268************************************************************************
5269
5270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5271 SAVE
5272
5273 PARAMETER ( LINP = 10 ,
5274 & LOUT = 6 ,
5275 & LDAT = 9 )
5276
5277 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5278 PARAMETER (SQTINF=1.0D+15)
5279
5280 LOGICAL LFIRST
5281
5282* event history
5283
5284 PARAMETER (NMXHKK=200000)
5285
5286 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5287 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5288 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5289
5290* extended event history
5291 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5292 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5293 & IHIST(2,NMXHKK)
5294
5295* flags for input different options
5296 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5297 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5298 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5299 PARAMETER (MAXLND=4000)
5300 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5301
5302* properties of interacting particles
5303 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5304
5305* Lorentz-parameters of the current interaction
5306 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5307 & UMO,PPCM,EPROJ,PPROJ
5308
5309* nuclear potential
5310 LOGICAL LFERMI
5311 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5312 & EBINDP(2),EBINDN(2),EPOT(2,210),
5313 & ETACOU(2),ICOUL,LFERMI
5314
5315* steering flags for qel neutrino scattering modules
5316 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5317
5318 COMMON /QNPOL/ POLARX(4),PMODUL
5319
5320 INTEGER PYK
5321
5322 DATA LFIRST /.TRUE./
5323
5324 IREJ = 0
5325
5326 IF (LFIRST) THEN
5327 LFIRST = .FALSE.
5328 CALL DT_MASS_INI
5329 ENDIF
5330
5331* JETSET parameter
5332 CALL DT_INITJS(0)
5333
5334* interacting target nucleon
5335 LTYP = NEUTYP
5336 IF (NEUDEC.LE.9) THEN
5337 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5338 NUCTYP = 2112
5339 NUCTOP = 2
5340 ELSE
5341 NUCTYP = 2212
5342 NUCTOP = 1
5343 ENDIF
5344 ELSE
5345 RTYP = DT_RNDM(RTYP)
5346 ZFRAC = DBLE(ITZ)/DBLE(IT)
5347 IF (RTYP.LE.ZFRAC) THEN
5348 NUCTYP = 2212
5349 NUCTOP = 1
5350 ELSE
5351 NUCTYP = 2112
5352 NUCTOP = 2
5353 ENDIF
5354 ENDIF
5355
5356* select first nucleon in list with matching id and reset all other
5357* nucleons which have been marked as "wounded" by ININUC
5358 IFOUND = 0
5359 DO 1 I=1,NHKK
5360 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5361 ISTHKK(I) = 12
5362 IFOUND = 1
5363 IDX = I
5364 ELSE
5365 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5366 ENDIF
5367 1 CONTINUE
5368 IF (IFOUND.EQ.0)
5369 & STOP ' EVENTD: interacting target nucleon not found! '
5370
5371* correct position of proj. lepton: assume position of target nucleon
5372 DO 3 I=1,4
5373 VHKK(I,1) = VHKK(I,IDX)
5374 WHKK(I,1) = WHKK(I,IDX)
5375 3 CONTINUE
5376
5377* load initial momenta for conservation check
5378 IF (LEMCCK) THEN
5379 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5380 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5381 & 2,IDUM,IDUM)
5382 ENDIF
5383
5384* quasi-elastic scattering
5385 IF (NEUDEC.LT.9) THEN
5386 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5387 & PHKK(4,IDX),PHKK(5,IDX))
5388* CC event on p or n
5389 ELSEIF (NEUDEC.EQ.10) THEN
5390 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5391 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392* NC event on p or n
5393 ELSEIF (NEUDEC.EQ.11) THEN
5394 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5395 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5396 ENDIF
5397
5398* get final state particles from Lund-common and write them into HKKEVT
5399 NPOINT(1) = NHKK+1
5400 NPOINT(4) = NHKK+1
5401
5402 NLINES = PYK(0,1)
5403
5404 NHKK0 = NHKK+1
5405 DO 4 I=4,NLINES
5406 IF (K(I,1).EQ.1) THEN
5407 ID = K(I,2)
5408 PX = P(I,1)
5409 PY = P(I,2)
5410 PZ = P(I,3)
5411 PE = P(I,4)
5412 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5413 IDBJ = IDT_ICIHAD(ID)
5414 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5415 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5416 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5417 ENDIF
5418 VHKK(1,NHKK) = VHKK(1,IDX)
5419 VHKK(2,NHKK) = VHKK(2,IDX)
5420 VHKK(3,NHKK) = VHKK(3,IDX)
5421 VHKK(4,NHKK) = VHKK(4,IDX)
5422C IF (I.EQ.4) THEN
5423C WHKK(1,NHKK) = POLARX(1)
5424C WHKK(2,NHKK) = POLARX(2)
5425C WHKK(3,NHKK) = POLARX(3)
5426C WHKK(4,NHKK) = POLARX(4)
5427C ELSE
5428 WHKK(1,NHKK) = WHKK(1,IDX)
5429 WHKK(2,NHKK) = WHKK(2,IDX)
5430 WHKK(3,NHKK) = WHKK(3,IDX)
5431 WHKK(4,NHKK) = WHKK(4,IDX)
5432C ENDIF
5433 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5434 ENDIF
5435 4 CONTINUE
5436
5437 IF (LEMCCK) THEN
5438 CHKLEV = TINY5
5439 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5440 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5441 ENDIF
5442
5443* transform momenta into cms (as required for inc etc.)
5444 DO 5 I=NHKK0,NHKK
5445 IF (ISTHKK(I).EQ.1) THEN
5446 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5447 PHKK(3,I) = PZ
5448 PHKK(4,I) = PE
5449 ENDIF
5450 5 CONTINUE
5451
5452 RETURN
5453 END
5454*$ CREATE DT_KKEVNT.FOR
5455*COPY DT_KKEVNT
5456*
5457*===kkevnt=============================================================*
5458*
5459 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5460
5461************************************************************************
5462* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5463* without nuclear effects (one event). *
5464* This subroutine is an update of the previous version (KKEVT) written *
5465* by J. Ranft/ H.-J. Moehring. *
5466* This version dated 20.04.95 is written by S. Roesler *
5467************************************************************************
5468
5469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5470 SAVE
5471
5472 PARAMETER ( LINP = 10 ,
5473 & LOUT = 6 ,
5474 & LDAT = 9 )
5475
5476 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5477
5478 PARAMETER ( MAXNCL = 260,
5479
5480 & MAXVQU = MAXNCL,
5481 & MAXSQU = 20*MAXVQU,
5482 & MAXINT = MAXVQU+MAXSQU)
5483
5484* event history
5485
5486 PARAMETER (NMXHKK=200000)
5487
5488 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5489 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5490 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5491
5492* extended event history
5493 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5494 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5495 & IHIST(2,NMXHKK)
5496
5497* flags for input different options
5498 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5499 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5500 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5501
5502* rejection counter
5503 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5504 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5505 & IREXCI(3),IRDIFF(2),IRINC
5506
5507* statistics
5508 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5509 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5510 & ICEVTG(8,0:30)
5511
5512* properties of interacting particles
5513 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5514
5515* Lorentz-parameters of the current interaction
5516 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5517 & UMO,PPCM,EPROJ,PPROJ
5518
5519* flags for diffractive interactions (DTUNUC 1.x)
5520 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5521
5522* interface HADRIN-DPM
5523 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5524
5525* nucleon-nucleon event-generator
5526 CHARACTER*8 CMODEL
5527 LOGICAL LPHOIN
5528 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5529
5530* coordinates of nucleons
5531 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5532
5533* interface between Glauber formalism and DPM
5534 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5535 & INTER1(MAXINT),INTER2(MAXINT)
5536
5537* Glauber formalism: collision properties
5538 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
ebb0c0e0 5539 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5540 & NCP,NCT
7b076c76 5541
5542* central particle production, impact parameter biasing
5543 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5544**temporary
5545
5546* statistics: Glauber-formalism
5547 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5548**
5549
5550 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5551
5552 IREJ = 0
5553 ICREQU = ICREQU+1
5554 NC = 0
ebb0c0e0 5555 NCP = 0
5556 NCT = 0
7b076c76 5557
5558 1 CONTINUE
5559 ICSAMP = ICSAMP+1
5560 NC = NC+1
5561 IF (MOD(NC,10).EQ.0) THEN
5562 WRITE(LOUT,1000) NEVHKK
5563 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5564 GOTO 9999
5565 ENDIF
5566
5567* initialize DTEVT1/DTEVT2
5568 CALL DT_EVTINI
5569
5570* We need the following only in order to sample nucleon coordinates.
5571* However we don't have parameters (cross sections, slope etc.)
5572* for neutrinos available. Therefore switch projectile to proton
5573* in this case.
5574 IF (MCGENE.EQ.4) THEN
5575 JJPROJ = 1
5576 ELSE
5577 JJPROJ = IJPROJ
5578 ENDIF
5579
5580 10 CONTINUE
5581 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5582* make sure that Glauber-formalism is called each time the interaction
5583* configuration changed
5584 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5585 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5586* sample number of nucleon-nucleon coll. according to Glauber-form.
5587 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5588 NWTSAM = NN
5589 NWASAM = NP
5590 NWBSAM = NT
5591 NEVOLD = NEVHKK
5592 IPOLD = IP
5593 ITOLD = IT
5594 JJPOLD = JJPROJ
5595 EPROLD = EPROJ
7d5a4d62 5596 DO 8 I=1, IP
ebb0c0e0 5597 NCP = NCP+JSSH(I)
5598* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5599 8 CONTINUE
7d5a4d62 5600 DO 9 I=1, IT
ebb0c0e0 5601 NCT = NCT+JTSH(I)
5602* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5603 9 CONTINUE
7b076c76 5604 ENDIF
5605
5606* force diffractive particle production in h-K interactions
5607 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5608 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5609 NEVOLD = 0
5610 GOTO 10
5611 ENDIF
5612
5613* check number of involved proj. nucl. (NP) if central prod.is requested
5614 IF (ICENTR.GT.0) THEN
5615 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5616 IF (IBACK.GT.0) GOTO 10
5617 ENDIF
5618
5619* get initial nucleon-configuration in projectile and target
5620* rest-system (including Fermi-momenta if requested)
5621 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5622 MODE = 2
5623 IF (EPROJ.LE.EHADTH) MODE = 3
5624 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5625
5626 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5627
5628* activate HADRIN at low energies (implemented for h-N scattering only)
5629 IF (EPROJ.LE.EHADHI) THEN
5630 IF (EHADTH.LT.ZERO) THEN
5631* smooth transition btwn. DPM and HADRIN
5632 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5633 RR = DT_RNDM(FRAC)
5634 IF (RR.GT.FRAC) THEN
5635 IF (IP.EQ.1) THEN
5636 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5637 IF (IREJ1.GT.0) GOTO 1
5638 RETURN
5639 ELSE
5640 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5641 ENDIF
5642 ENDIF
5643 ELSE
5644* fixed threshold for onset of production via HADRIN
5645 IF (EPROJ.LE.EHADTH) THEN
5646 IF (IP.EQ.1) THEN
5647 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5648 IF (IREJ1.GT.0) GOTO 1
5649 RETURN
5650 ELSE
5651 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5652 ENDIF
5653 ENDIF
5654 ENDIF
5655 ENDIF
5656 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5657 & I3,') with target (m=',I3,')',/,11X,
5658 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5659 & 'GeV) cannot be handled')
5660
5661* sampling of momentum-x fractions & flavors of chain ends
5662 CALL DT_SPLPTN(NN)
5663
5664* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5665 CALL DT_NUC2CM
5666
5667* collect momenta of chain ends and put them into DTEVT1
5668 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5669 IF (IREJ1.NE.0) GOTO 1
5670
5671 ENDIF
5672
5673* handle chains including fragmentation (two-chain approximation)
5674 IF (MCGENE.EQ.1) THEN
5675* two-chain approximation
5676 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5677 IF (IREJ1.NE.0) THEN
5678 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5679 GOTO 1
5680 ENDIF
5681 ELSEIF (MCGENE.EQ.2) THEN
5682* multiple-Po exchange including minijets
5683 CALL DT_EVENTB(NCSY,IREJ1)
5684 IF (IREJ1.NE.0) THEN
5685 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5686 GOTO 1
5687 ENDIF
5688 ELSEIF (MCGENE.EQ.3) THEN
5689 STOP ' This version does not contain LEPTO !'
5690
5691 ELSEIF (MCGENE.EQ.4) THEN
5692* quasi-elastic neutrino scattering
5693 CALL DT_EVENTD(IREJ1)
5694 IF (IREJ1.NE.0) THEN
5695 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5696 GOTO 1
5697 ENDIF
5698 ELSE
5699 WRITE(LOUT,1002) MCGENE
5700 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5701 & ' not available - program stopped')
5702 STOP
5703 ENDIF
5704
5705 RETURN
5706
5707 9999 CONTINUE
5708 IREJ = 1
5709 RETURN
5710 END
5711
5712*$ CREATE DT_CHKCEN.FOR
5713*COPY DT_CHKCEN
5714*
5715*===chkcen=============================================================*
5716*
5717 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5718
5719************************************************************************
5720* Check of number of involved projectile nucleons if central production*
5721* is requested. *
5722* Adopted from a part of the old KKEVT routine which was written by *
5723* J. Ranft/H.-J.Moehring. *
5724* This version dated 13.01.95 is written by S. Roesler *
5725************************************************************************
5726
5727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5728 SAVE
5729
5730 PARAMETER ( LINP = 10 ,
5731 & LOUT = 6 ,
5732 & LDAT = 9 )
5733
5734* statistics
5735 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5736 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5737 & ICEVTG(8,0:30)
5738
5739* central particle production, impact parameter biasing
5740 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5741
5742 IBACK = 0
5743
5744* old version
5745 IF (ICENTR.EQ.2) THEN
5746 IF (IP.LT.IT) THEN
5747 IF (IP.LE.8) THEN
5748 IF (NP.LT.IP-1) IBACK = 1
5749 ELSEIF (IP.LE.16) THEN
5750 IF (NP.LT.IP-2) IBACK = 1
5751 ELSEIF (IP.LE.32) THEN
5752 IF (NP.LT.IP-3) IBACK = 1
5753 ELSEIF (IP.GE.33) THEN
5754 IF (NP.LT.IP-5) IBACK = 1
5755 ENDIF
5756 ELSEIF (IP.EQ.IT) THEN
5757 IF (IP.EQ.32) THEN
5758 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5759 ELSE
5760 IF (NP.LT.IP-IP/8) IBACK = 1
5761 ENDIF
5762 ELSEIF (ABS(IP-IT).LT.3) THEN
5763 IF (NP.LT.IP-IP/8) IBACK = 1
5764 ENDIF
5765 ELSE
5766* new version (DPMJET, 5.6.99)
5767 IF (IP.LT.IT) THEN
5768 IF (IP.LE.8) THEN
5769 IF (NP.LT.IP-1) IBACK = 1
5770 ELSEIF (IP.LE.16) THEN
5771 IF (NP.LT.IP-2) IBACK = 1
5772 ELSEIF (IP.LT.32) THEN
5773 IF (NP.LT.IP-3) IBACK = 1
5774 ELSEIF (IP.GE.32) THEN
5775 IF (IT.LE.150) THEN
5776* Example: S-Ag
5777 IF (NP.LT.IP-1) IBACK = 1
5778 ELSE
5779* Example: S-Au
5780 IF (NP.LT.IP) IBACK = 1
5781 ENDIF
5782 ENDIF
5783 ELSEIF (IP.EQ.IT) THEN
5784* Example: S-S
5785 IF (IP.EQ.32) THEN
5786 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5787* Example: Pb-Pb
5788 ELSE
5789 IF (NP.LT.IP-IP/4) IBACK = 1
5790 ENDIF
5791 ELSEIF (ABS(IP-IT).LT.3) THEN
5792 IF (NP.LT.IP-IP/8) IBACK = 1
5793 ENDIF
5794 ENDIF
5795
5796 ICCPRO = ICCPRO+1
5797
5798 RETURN
5799 END
5800
5801*$ CREATE DT_ININUC.FOR
5802*COPY DT_ININUC
5803*
5804*===ininuc=============================================================*
5805*
5806 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5807
5808************************************************************************
5809* Samples initial configuration of nucleons in nucleus with mass NMASS *
5810* including Fermi-momenta (if reqested). *
5811* ID BAMJET-code for hadrons (instead of nuclei) *
5812* NMASS mass number of nucleus (number of nucleons) *
5813* NCH charge of nucleus *
5814* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5815* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5816* IMODE = 1 projectile nucleus *
5817* = 2 target nucleus *
5818* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5819* Adopted from a part of the old KKEVT routine which was written by *
5820* J. Ranft/H.-J.Moehring. *
5821* This version dated 13.01.95 is written by S. Roesler *
5822************************************************************************
5823
5824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5825 SAVE
5826
5827 PARAMETER ( LINP = 10 ,
5828 & LOUT = 6 ,
5829 & LDAT = 9 )
5830
5831 PARAMETER (FM2MM=1.0D-12)
5832
5833 PARAMETER ( MAXNCL = 260,
5834
5835 & MAXVQU = MAXNCL,
5836 & MAXSQU = 20*MAXVQU,
5837 & MAXINT = MAXVQU+MAXSQU)
5838
5839* event history
5840
5841 PARAMETER (NMXHKK=200000)
5842
5843 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5844 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5845 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5846
5847* extended event history
5848 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5849 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5850 & IHIST(2,NMXHKK)
5851
5852* flags for input different options
5853 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5854 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5855 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5856
5857* auxiliary common for chain system storage (DTUNUC 1.x)
5858 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5859
5860* nuclear potential
5861 LOGICAL LFERMI
5862 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5863 & EBINDP(2),EBINDN(2),EPOT(2,210),
5864 & ETACOU(2),ICOUL,LFERMI
5865
5866* properties of photon/lepton projectiles
5867 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5868
5869* particle properties (BAMJET index convention)
5870 CHARACTER*8 ANAME
5871 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5872 & IICH(210),IIBAR(210),K1(210),K2(210)
5873
5874* Glauber formalism: collision properties
5875 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 5876 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5877 & NCP,NCT
7b076c76 5878
5879* flavors of partons (DTUNUC 1.x)
5880 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5881 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5882 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5883 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5884 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5885 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5886 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5887
5888* interface HADRIN-DPM
5889 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5890
5891 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5892
5893* number of neutrons
5894 NNEU = NMASS-NCH
5895* initializations
5896 NP = 0
5897 NN = 0
5898 DO 1 K=1,4
5899 PFTOT(K) = 0.0D0
5900 1 CONTINUE
5901 MODE = IMODE
5902 IF (IMODE.GT.2) MODE = 2
5903**sr 29.5. new NPOINT(1)-definition
5904C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5905**
5906 NHADRI = 0
5907 NC = NHKK
5908
5909* get initial configuration
5910 DO 2 I=1,NMASS
5911 NHKK = NHKK+1
5912 IF (JS(I).GT.0) THEN
5913 ISTHKK(NHKK) = 10+MODE
5914 IF (IMODE.EQ.3) THEN
5915* additional treatment if HADRIN-generator is requested
5916 NHADRI = NHADRI+1
5917 IF (NHADRI.EQ.1) IDXTA = NHKK
5918 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5919 ENDIF
5920 ELSE
5921 ISTHKK(NHKK) = 12+MODE
5922 ENDIF
5923 IF (NMASS.GE.2) THEN
5924* treatment for nuclei
5925 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5926 RR = DT_RNDM(FRAC)
5927 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5928 IDX = 8
5929 NN = NN+1
5930 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5931 IDX = 1
5932 NP = NP+1
5933 ELSEIF (NN.LT.NNEU) THEN
5934 IDX = 8
5935 NN = NN+1
5936 ELSEIF (NP.LT.NCH) THEN
5937 IDX = 1
5938 NP = NP+1
5939 ENDIF
5940 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5941 IDBAM(NHKK) = IDX
5942 IF (MODE.EQ.1) THEN
5943 IPOSP(I) = NHKK
5944 KKPROJ(I) = IDX
5945 ELSE
5946 IPOST(I) = NHKK
5947 KKTARG(I) = IDX
5948 ENDIF
5949 IF (IDX.EQ.1) THEN
5950 PFER = PFERMP(MODE)
5951 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5952 ELSE
5953 PFER = PFERMN(MODE)
5954 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5955 ENDIF
5956 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5957 DO 3 K=1,4
5958 PFTOT(K) = PFTOT(K)+PF(K)
5959 PHKK(K,NHKK) = PF(K)
5960 3 CONTINUE
5961 PHKK(5,NHKK) = AAM(IDX)
5962 ELSE
5963* treatment for hadrons
5964 IDHKK(NHKK) = IDT_IPDGHA(ID)
5965 IDBAM(NHKK) = ID
5966 PHKK(4,NHKK) = AAM(ID)
5967 PHKK(5,NHKK) = AAM(ID)
5968C* VDM assumption
5969C IF (IDHKK(NHKK).EQ.22) THEN
5970C PHKK(4,NHKK) = AAM(33)
5971C PHKK(5,NHKK) = AAM(33)
5972C ENDIF
5973 IF (MODE.EQ.1) THEN
5974 IPOSP(I) = NHKK
5975 KKPROJ(I) = ID
5976 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5977 ELSE
5978 IPOST(I) = NHKK
5979 KKTARG(I) = ID
5980 ENDIF
5981 ENDIF
5982 DO 4 K=1,3
5983 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5984 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5985 4 CONTINUE
5986 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5987 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5988 VHKK(4,NHKK) = 0.0D0
5989 WHKK(4,NHKK) = 0.0D0
5990 2 CONTINUE
5991
5992* balance Fermi-momenta
5993 IF (NMASS.GE.2) THEN
5994 DO 5 I=1,NMASS
5995 NC = NC+1
5996 DO 6 K=1,3
5997 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5998 6 CONTINUE
5999 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
6000 & PHKK(2,NC)**2+PHKK(3,NC)**2)
6001 5 CONTINUE
6002 ENDIF
6003
6004 RETURN
6005 END
6006
6007*$ CREATE DT_FER4M.FOR
6008*COPY DT_FER4M
6009*
6010*===fer4m==============================================================*
6011*
6012 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6013
6014************************************************************************
6015* Sampling of nucleon Fermi-momenta from distributions at T=0. *
6016* processed by S. Roesler, 17.10.95 *
6017************************************************************************
6018
6019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6020 SAVE
6021
6022 PARAMETER ( LINP = 10 ,
6023 & LOUT = 6 ,
6024 & LDAT = 9 )
6025
6026 LOGICAL LSTART
6027
6028* particle properties (BAMJET index convention)
6029 CHARACTER*8 ANAME
6030 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6031 & IICH(210),IIBAR(210),K1(210),K2(210)
6032
6033* nuclear potential
6034 LOGICAL LFERMI
6035 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6036 & EBINDP(2),EBINDN(2),EPOT(2,210),
6037 & ETACOU(2),ICOUL,LFERMI
6038
6039 DATA LSTART /.TRUE./
6040
6041 ILOOP = 0
6042 IF (LFERMI) THEN
6043 IF (LSTART) THEN
6044 WRITE(LOUT,1000)
6045 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6046 LSTART = .FALSE.
6047 ENDIF
6048 1 CONTINUE
6049 CALL DT_DFERMI(PABS)
6050 PABS = PFERM*PABS
6051C IF (PABS.GE.PBIND) THEN
6052C ILOOP = ILOOP+1
6053C IF (MOD(ILOOP,500).EQ.0) THEN
6054C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6055C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6056C & ' energy ',2E12.3,I6)
6057C ENDIF
6058C GOTO 1
6059C ENDIF
6060 CALL DT_DPOLI(POLC,POLS)
6061 CALL DT_DSFECF(SFE,CFE)
6062 CXTA = POLS*CFE
6063 CYTA = POLS*SFE
6064 CZTA = POLC
6065 ET = SQRT(PABS*PABS+AAM(KT)**2)
6066 PXT = CXTA*PABS
6067 PYT = CYTA*PABS
6068 PZT = CZTA*PABS
6069 ELSE
6070 ET = AAM(KT)
6071 PXT = 0.0D0
6072 PYT = 0.0D0
6073 PZT = 0.0D0
6074 ENDIF
6075
6076 RETURN
6077 END
6078
6079*$ CREATE DT_NUC2CM.FOR
6080*COPY DT_NUC2CM
6081*
6082*===nuc2cm=============================================================*
6083*
6084 SUBROUTINE DT_NUC2CM
6085
6086************************************************************************
6087* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6088* nucl. cms. (This subroutine replaces NUCMOM.) *
6089* This version dated 15.01.95 is written by S. Roesler *
6090************************************************************************
6091
6092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6093 SAVE
6094
6095 PARAMETER ( LINP = 10 ,
6096 & LOUT = 6 ,
6097 & LDAT = 9 )
6098
6099 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6100
6101* event history
6102
6103 PARAMETER (NMXHKK=200000)
6104
6105 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6106 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6107 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6108
6109* extended event history
6110 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6111 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6112 & IHIST(2,NMXHKK)
6113
6114* statistics
6115 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6116 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6117 & ICEVTG(8,0:30)
6118
6119* properties of photon/lepton projectiles
6120 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6121
6122* particle properties (BAMJET index convention)
6123 CHARACTER*8 ANAME
6124 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6125 & IICH(210),IIBAR(210),K1(210),K2(210)
6126
6127* Glauber formalism: collision properties
6128 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 6129 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
6130 & NCP,NCT
7b076c76 6131**temporary
6132
6133* statistics: Glauber-formalism
6134 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6135**
6136
6137 ICWP = 0
6138 ICWT = 0
6139 NWTACC = 0
6140 NWAACC = 0
6141 NWBACC = 0
6142
6143 NPOINT(1) = NHKK+1
6144 NEND = NHKK
6145 DO 1 I=1,NEND
6146 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6147 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6148 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6149 MODE = ISTHKK(I)-9
6150C IF (IDHKK(I).EQ.22) THEN
6151C* VDM assumption
6152C PEIN = AAM(33)
6153C IDB = 33
6154C ELSE
6155C PEIN = PHKK(4,I)
6156C IDB = IDBAM(I)
6157C ENDIF
6158C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6159C & PX,PY,PZ,PE,IDB,MODE)
6160 IF (PHKK(5,I).GT.ZERO) THEN
6161 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6162 & PX,PY,PZ,PE,IDBAM(I),MODE)
6163 ELSE
6164 PX = PGAMM(1)
6165 PY = PGAMM(2)
6166 PZ = PGAMM(3)
6167 PE = PGAMM(4)
6168 ENDIF
6169 IST = ISTHKK(I)-2
6170 ID = IDHKK(I)
6171C* VDM assumption
6172C IF (ID.EQ.22) ID = 113
6173 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6174 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6175 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6176 ENDIF
6177 1 CONTINUE
6178
6179 NWTACC = MAX(NWAACC,NWBACC)
6180 ICDPR = ICDPR+ICWP
6181 ICDTA = ICDTA+ICWT
6182**temporary
6183 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6184 CALL DT_EVTOUT(4)
6185 STOP
6186 ENDIF
6187
6188 RETURN
6189 END
6190
6191*$ CREATE DT_SPLPTN.FOR
6192*COPY DT_SPLPTN
6193*
6194*===splptn=============================================================*
6195*
6196 SUBROUTINE DT_SPLPTN(NN)
6197
6198************************************************************************
6199* SamPLing of ParToN momenta and flavors. *
6200* This version dated 15.01.95 is written by S. Roesler *
6201************************************************************************
6202
6203 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6204 SAVE
6205
6206 PARAMETER ( LINP = 10 ,
6207 & LOUT = 6 ,
6208 & LDAT = 9 )
6209
6210* Lorentz-parameters of the current interaction
6211 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6212 & UMO,PPCM,EPROJ,PPROJ
6213
6214* sample flavors of sea-quarks
6215 CALL DT_SPLFLA(NN,1)
6216
6217* sample x-values of partons at chain ends
6218 ECM = UMO
6219 CALL DT_XKSAMP(NN,ECM)
6220
6221* samle flavors
6222 CALL DT_SPLFLA(NN,2)
6223
6224 RETURN
6225 END
6226
6227*$ CREATE DT_SPLFLA.FOR
6228*COPY DT_SPLFLA
6229*
6230*===splfla=============================================================*
6231*
6232 SUBROUTINE DT_SPLFLA(NN,MODE)
6233
6234************************************************************************
6235* SamPLing of FLAvors of partons at chain ends. *
6236* This subroutine replaces FLKSAA/FLKSAM. *
6237* NN number of nucleon-nucleon interactions *
6238* MODE = 1 sea-flavors *
6239* = 2 valence-flavors *
6240* Based on the original version written by J. Ranft/H.-J. Moehring. *
6241* This version dated 16.01.95 is written by S. Roesler *
6242************************************************************************
6243
6244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6245 SAVE
6246
6247 PARAMETER ( LINP = 10 ,
6248 & LOUT = 6 ,
6249 & LDAT = 9 )
6250
6251 PARAMETER ( MAXNCL = 260,
6252
6253 & MAXVQU = MAXNCL,
6254 & MAXSQU = 20*MAXVQU,
6255 & MAXINT = MAXVQU+MAXSQU)
6256
6257* flavors of partons (DTUNUC 1.x)
6258 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6259 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6260 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6261 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6262 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6263 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6264 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6265
6266* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6267 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6268 & IXPV,IXPS,IXTV,IXTS,
6269 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6270 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6271 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6272 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6273 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6274 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6275 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6276 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6277
6278* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6279 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6280 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6281
6282* particle properties (BAMJET index convention)
6283 CHARACTER*8 ANAME
6284 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6285 & IICH(210),IIBAR(210),K1(210),K2(210)
6286
6287* various options for treatment of partons (DTUNUC 1.x)
6288* (chain recombination, Cronin,..)
6289 LOGICAL LCO2CR,LINTPT
6290 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6291 & LCO2CR,LINTPT
6292
6293 IF (MODE.EQ.1) THEN
6294* sea-flavors
6295 DO 1 I=1,NN
6296 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6297 IPSAQ(I) = -IPSQ(I)
6298 1 CONTINUE
6299 DO 2 I=1,NN
6300 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6301 ITSAQ(I)= -ITSQ(I)
6302 2 CONTINUE
6303 ELSEIF (MODE.EQ.2) THEN
6304* valence flavors
6305 DO 3 I=1,IXPV
6306 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6307 3 CONTINUE
6308 DO 4 I=1,IXTV
6309 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6310 4 CONTINUE
6311 ENDIF
6312
6313 RETURN
6314 END
6315
6316*$ CREATE DT_GETPTN.FOR
6317*COPY DT_GETPTN
6318*
6319*===getptn=============================================================*
6320*
6321 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6322
6323************************************************************************
6324* This subroutine collects partons at chain ends from temporary *
6325* commons and puts them into DTEVT1. *
6326* This version dated 15.01.95 is written by S. Roesler *
6327************************************************************************
6328
6329 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6330 SAVE
6331
6332 PARAMETER ( LINP = 10 ,
6333 & LOUT = 6 ,
6334 & LDAT = 9 )
6335
6336 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6337
6338 LOGICAL LCHK
6339
6340 PARAMETER ( MAXNCL = 260,
6341
6342 & MAXVQU = MAXNCL,
6343 & MAXSQU = 20*MAXVQU,
6344 & MAXINT = MAXVQU+MAXSQU)
6345
6346* event history
6347
6348 PARAMETER (NMXHKK=200000)
6349
6350 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6351 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6352 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6353
6354* extended event history
6355 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6356 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6357 & IHIST(2,NMXHKK)
6358
6359* flags for input different options
6360 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6361 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6362 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6363
6364* auxiliary common for chain system storage (DTUNUC 1.x)
6365 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6366
6367* statistics
6368 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6369 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6370 & ICEVTG(8,0:30)
6371
6372* flags for diffractive interactions (DTUNUC 1.x)
6373 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6374
6375* x-values of partons (DTUNUC 1.x)
6376 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6377 & XTVQ(MAXVQU),XTVD(MAXVQU),
6378 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6379 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6380
6381* flavors of partons (DTUNUC 1.x)
6382 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6383 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6384 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6385 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6386 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6387 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6388 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6389
6390* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6391 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6392 & IXPV,IXPS,IXTV,IXTS,
6393 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6394 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6395 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6396 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6397 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6398 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6399 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6400 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6401
6402* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6403 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6404 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6405
6406 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6407
6408 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6409
6410 IREJ = 0
6411 NCSY = 0
6412 NPOINT(2) = NHKK+1
6413
6414* sea-sea chains
6415 DO 10 I=1,NSS
6416 IF (ISKPCH(1,I).EQ.99) GOTO 10
6417 ICCHAI(1,1) = ICCHAI(1,1)+2
6418 IDXP = INTSS1(I)
6419 IDXT = INTSS2(I)
6420 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6421 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6422 DO 11 K=1,4
6423 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6424 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6425 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6426 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6427 11 CONTINUE
6428 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6429 & +(PP1(3)+PT1(3))**2)
6430 ECH = PP1(4)+PT1(4)
6431 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6432 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6433 & +(PP2(3)+PT2(3))**2)
6434 ECH = PP2(4)+PT2(4)
6435 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6436 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6437 AM1 = SQRT(AM1)
6438 AM2 = SQRT(AM2)
6439 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6440C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6441 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6442 ENDIF
6443 ELSE
6444 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6445 ENDIF
6446 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6447 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6448 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6449 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6450 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6451 & 0,0,1)
6452 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6453 & 0,0,1)
6454 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6455 & 0,0,1)
6456 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6457 & 0,0,1)
6458 NCSY = NCSY+1
6459 10 CONTINUE
6460
6461* disea-sea chains
6462 DO 20 I=1,NDS
6463 IF (ISKPCH(2,I).EQ.99) GOTO 20
6464 ICCHAI(1,2) = ICCHAI(1,2)+2
6465 IDXP = INTDS1(I)
6466 IDXT = INTDS2(I)
6467 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6468 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6469 DO 21 K=1,4
6470 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6471 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6472 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6473 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6474 21 CONTINUE
6475 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6476 & +(PP1(3)+PT1(3))**2)
6477 ECH = PP1(4)+PT1(4)
6478 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6479 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6480 & +(PP2(3)+PT2(3))**2)
6481 ECH = PP2(4)+PT2(4)
6482 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6483 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6484 AM1 = SQRT(AM1)
6485 AM2 = SQRT(AM2)
6486 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6487C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6488 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6489 ENDIF
6490 ELSE
6491 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6492 ENDIF
6493 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6494 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6495 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6496 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6497 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6498 & 0,0,2)
6499 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6500 & 0,0,2)
6501 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6502 & 0,0,2)
6503 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6504 & 0,0,2)
6505 NCSY = NCSY+1
6506 20 CONTINUE
6507
6508* sea-disea chains
6509 DO 30 I=1,NSD
6510 IF (ISKPCH(3,I).EQ.99) GOTO 30
6511 ICCHAI(1,3) = ICCHAI(1,3)+2
6512 IDXP = INTSD1(I)
6513 IDXT = INTSD2(I)
6514 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6515 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6516 DO 31 K=1,4
6517 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6518 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6519 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6520 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6521 31 CONTINUE
6522 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6523 & +(PP1(3)+PT1(3))**2)
6524 ECH = PP1(4)+PT1(4)
6525 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6526 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6527 & +(PP2(3)+PT2(3))**2)
6528 ECH = PP2(4)+PT2(4)
6529 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6530 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6531 AM1 = SQRT(AM1)
6532 AM2 = SQRT(AM2)
6533 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6534C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6535 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6536 ENDIF
6537 ELSE
6538 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6539 ENDIF
6540 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6541 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6542 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6543 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6544 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6545 & 0,0,3)
6546 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6547 & 0,0,3)
6548 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6549 & 0,0,3)
6550 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6551 & 0,0,3)
6552 NCSY = NCSY+1
6553 30 CONTINUE
6554
6555* disea-valence chains
6556 DO 50 I=1,NDV
6557 IF (ISKPCH(5,I).EQ.99) GOTO 50
6558 ICCHAI(1,5) = ICCHAI(1,5)+2
6559 IDXP = INTDV1(I)
6560 IDXT = INTDV2(I)
6561 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6562 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6563 DO 51 K=1,4
6564 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6565 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6566 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6567 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6568 51 CONTINUE
6569 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6570 & +(PP1(3)+PT1(3))**2)
6571 ECH = PP1(4)+PT1(4)
6572 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6573 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6574 & +(PP2(3)+PT2(3))**2)
6575 ECH = PP2(4)+PT2(4)
6576 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6577 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6578 AM1 = SQRT(AM1)
6579 AM2 = SQRT(AM2)
6580 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6581C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6582 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6583 ENDIF
6584 ELSE
6585 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6586 ENDIF
6587 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6588 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6589 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6590 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6591 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6592 & 0,0,5)
6593 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6594 & 0,0,5)
6595 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6596 & 0,0,5)
6597 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6598 & 0,0,5)
6599 NCSY = NCSY+1
6600 50 CONTINUE
6601
6602* valence-sea chains
6603 DO 60 I=1,NVS
6604 IF (ISKPCH(6,I).EQ.99) GOTO 60
6605 ICCHAI(1,6) = ICCHAI(1,6)+2
6606 IDXP = INTVS1(I)
6607 IDXT = INTVS2(I)
6608 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6609 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6610 DO 61 K=1,4
6611 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6612 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6613 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6614 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6615 61 CONTINUE
6616 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6617 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6618 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6619 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6620 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6621 IF (LCHK) THEN
6622 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6623 & 0,0,6)
6624 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6625 & 0,0,6)
6626 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6627 & 0,0,6)
6628 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6629 & 0,0,6)
6630 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6631 & +(PP1(3)+PT1(3))**2)
6632 ECH = PP1(4)+PT1(4)
6633 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6634 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6635 & +(PP2(3)+PT2(3))**2)
6636 ECH = PP2(4)+PT2(4)
6637 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6638 ELSE
6639 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6640 & 0,0,6)
6641 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6642 & 0,0,6)
6643 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6644 & 0,0,6)
6645 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6646 & 0,0,6)
6647 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6648 & +(PP1(3)+PT2(3))**2)
6649 ECH = PP1(4)+PT2(4)
6650 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6651 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6652 & +(PP2(3)+PT1(3))**2)
6653 ECH = PP2(4)+PT1(4)
6654 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6655 ENDIF
6656 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6657 AM1 = SQRT(AM1)
6658 AM2 = SQRT(AM2)
6659 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6660C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6661 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6662 ENDIF
6663 ELSE
6664 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6665 ENDIF
6666 NCSY = NCSY+1
6667 60 CONTINUE
6668
6669* sea-valence chains
6670 DO 40 I=1,NSV
6671 IF (ISKPCH(4,I).EQ.99) GOTO 40
6672 ICCHAI(1,4) = ICCHAI(1,4)+2
6673 IDXP = INTSV1(I)
6674 IDXT = INTSV2(I)
6675 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6676 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6677 DO 41 K=1,4
6678 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6679 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6680 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6681 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6682 41 CONTINUE
6683 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6684 & +(PP1(3)+PT1(3))**2)
6685 ECH = PP1(4)+PT1(4)
6686 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6687 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6688 & +(PP2(3)+PT2(3))**2)
6689 ECH = PP2(4)+PT2(4)
6690 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6691 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6692 AM1 = SQRT(AM1)
6693 AM2 = SQRT(AM2)
6694 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6695C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6696 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6697 ENDIF
6698 ELSE
6699 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6700 ENDIF
6701 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6702 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6703 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6704 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6705 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6706 & 0,0,4)
6707 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6708 & 0,0,4)
6709 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6710 & 0,0,4)
6711 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6712 & 0,0,4)
6713 NCSY = NCSY+1
6714 40 CONTINUE
6715
6716* valence-disea chains
6717 DO 70 I=1,NVD
6718 IF (ISKPCH(7,I).EQ.99) GOTO 70
6719 ICCHAI(1,7) = ICCHAI(1,7)+2
6720 IDXP = INTVD1(I)
6721 IDXT = INTVD2(I)
6722 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6723 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6724 DO 71 K=1,4
6725 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6726 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6727 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6728 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6729 71 CONTINUE
6730 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6731 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6732 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6733 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6734 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6735 IF (LCHK) THEN
6736 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6737 & 0,0,7)
6738 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6739 & 0,0,7)
6740 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6741 & 0,0,7)
6742 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6743 & 0,0,7)
6744 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6745 & +(PP1(3)+PT1(3))**2)
6746 ECH = PP1(4)+PT1(4)
6747 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6748 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6749 & +(PP2(3)+PT2(3))**2)
6750 ECH = PP2(4)+PT2(4)
6751 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6752 ELSE
6753 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6754 & 0,0,7)
6755 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6756 & 0,0,7)
6757 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6758 & 0,0,7)
6759 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6760 & 0,0,7)
6761 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6762 & +(PP1(3)+PT2(3))**2)
6763 ECH = PP1(4)+PT2(4)
6764 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6765 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6766 & +(PP2(3)+PT1(3))**2)
6767 ECH = PP2(4)+PT1(4)
6768 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6769 ENDIF
6770 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6771 AM1 = SQRT(AM1)
6772 AM2 = SQRT(AM2)
6773 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6774C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6775 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6776 ENDIF
6777 ELSE
6778 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6779 ENDIF
6780 NCSY = NCSY+1
6781 70 CONTINUE
6782
6783* valence-valence chains
6784 DO 80 I=1,NVV
6785 IF (ISKPCH(8,I).EQ.99) GOTO 80
6786 ICCHAI(1,8) = ICCHAI(1,8)+2
6787 IDXP = INTVV1(I)
6788 IDXT = INTVV2(I)
6789 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6790 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6791 DO 81 K=1,4
6792 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6793 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6794 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6795 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6796 81 CONTINUE
6797 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6798 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6799 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6800 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6801
6802* check for diffractive event
6803 IDIFF = 0
6804 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6805 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6806 DO 800 K=1,4
6807 PP(K) = PP1(K)+PP2(K)
6808 PT(K) = PT1(K)+PT2(K)
6809 800 CONTINUE
6810 ISTCK = NHKK
6811 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6812 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6813C IF (IREJ1.NE.0) GOTO 9999
6814 IF (IREJ1.NE.0) THEN
6815 IDIFF = 0
6816 NHKK = ISTCK
6817 ENDIF
6818 ELSE
6819 IDIFF = 0
6820 ENDIF
6821
6822 IF (IDIFF.EQ.0) THEN
6823* valence-valence chain system
6824 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6825 IF (LCHK) THEN
6826* baryon-baryon
6827 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6828 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6829 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6830 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6831 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6832 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6833 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6834 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6835 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6836 & +(PP1(3)+PT1(3))**2)
6837 ECH = PP1(4)+PT1(4)
6838 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6839 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6840 & +(PP2(3)+PT2(3))**2)
6841 ECH = PP2(4)+PT2(4)
6842 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6843 ELSE
6844* antibaryon-baryon
6845 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6846 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6847 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6848 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6849 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6850 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6851 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6852 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6853 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6854 & +(PP1(3)+PT2(3))**2)
6855 ECH = PP1(4)+PT2(4)
6856 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6857 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6858 & +(PP2(3)+PT1(3))**2)
6859 ECH = PP2(4)+PT1(4)
6860 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6861 ENDIF
6862 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6863 AM1 = SQRT(AM1)
6864 AM2 = SQRT(AM2)
6865 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6866C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6867 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6868 ENDIF
6869 ELSE
6870 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6871 ENDIF
6872 NCSY = NCSY+1
6873 ENDIF
6874 80 CONTINUE
6875 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6876
6877* energy-momentum & flavor conservation check
6878 IF (ABS(IDIFF).NE.1) THEN
6879 IF (IDIFF.NE.0) THEN
6880 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6881 & 1,3,10,IREJ)
6882 ELSE
6883 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6884 & 1,3,10,IREJ)
6885 ENDIF
6886 IF (IREJ.NE.0) THEN
6887 CALL DT_EVTOUT(4)
6888 STOP
6889 ENDIF
6890 ENDIF
6891
6892 RETURN
6893
6894 9999 CONTINUE
6895 IREJ = 1
6896 RETURN
6897 END
6898
6899*$ CREATE DT_CHKCSY.FOR
6900*COPY DT_CHKCSY
6901*
6902*===chkcsy=============================================================*
6903*
6904 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6905
6906************************************************************************
6907* CHeCk Chain SYstem for consistency of partons at chain ends. *
6908* ID1,ID2 PDG-numbers of partons at chain ends *
6909* LCHK = .true. consistent chain *
6910* = .false. inconsistent chain *
6911* This version dated 18.01.95 is written by S. Roesler *
6912************************************************************************
6913
6914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6915 SAVE
6916
6917 PARAMETER ( LINP = 10 ,
6918 & LOUT = 6 ,
6919 & LDAT = 9 )
6920
6921 LOGICAL LCHK
6922
6923 LCHK = .TRUE.
6924
6925* q-aq chain
6926 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6927 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6928* q-qq, aq-aqaq chain
6929 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6930 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6931 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6932* qq-aqaq chain
6933 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6934 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6935 ENDIF
6936
6937 RETURN
6938 END
6939
6940*$ CREATE DT_EVENTA.FOR
6941*COPY DT_EVENTA
6942*
6943*===eventa=============================================================*
6944*
6945 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6946
6947************************************************************************
6948* Treatment of nucleon-nucleon interactions in a two-chain *
6949* approximation. *
6950* (input) ID BAMJET-index of projectile hadron (in case of *
6951* h-K scattering) *
6952* IP/IT mass number of projectile/target nucleus *
6953* NCSY number of two chain systems *
6954* IREJ rejection flag *
6955* This version dated 15.01.95 is written by S. Roesler *
6956************************************************************************
6957
6958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6959 SAVE
6960
6961 PARAMETER ( LINP = 10 ,
6962 & LOUT = 6 ,
6963 & LDAT = 9 )
6964
6965 PARAMETER (TINY10=1.0D-10)
6966
6967* event history
6968
6969 PARAMETER (NMXHKK=200000)
6970
6971 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6972 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6973 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6974
6975* extended event history
6976 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6977 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6978 & IHIST(2,NMXHKK)
6979
6980* rejection counter
6981 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6982 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6983 & IREXCI(3),IRDIFF(2),IRINC
6984
6985* flags for diffractive interactions (DTUNUC 1.x)
6986 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6987
6988* particle properties (BAMJET index convention)
6989 CHARACTER*8 ANAME
6990 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6991 & IICH(210),IIBAR(210),K1(210),K2(210)
6992
6993* flags for input different options
6994 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6995 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6996 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6997
6998* various options for treatment of partons (DTUNUC 1.x)
6999* (chain recombination, Cronin,..)
7000 LOGICAL LCO2CR,LINTPT
7001 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7002 & LCO2CR,LINTPT
7003
7004 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7005
7006 IREJ = 0
7007 NPOINT(3) = NHKK+1
7008
7009* skip following treatment for low-mass diffraction
7010 IF (ABS(IFLAGD).EQ.1) THEN
7011 NPOINT(3) = NPOINT(2)
7012 GOTO 5
7013 ENDIF
7014
7015* multiple scattering of chain ends
7016 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7017 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7018
7019 NC = NPOINT(2)
7020* get a two-chain system from DTEVT1
7021 DO 3 I=1,NCSY
7022 IFP1 = IDHKK(NC)
7023 IFT1 = IDHKK(NC+1)
7024 IFP2 = IDHKK(NC+2)
7025 IFT2 = IDHKK(NC+3)
7026 DO 4 K=1,4
7027 PP1(K) = PHKK(K,NC)
7028 PT1(K) = PHKK(K,NC+1)
7029 PP2(K) = PHKK(K,NC+2)
7030 PT2(K) = PHKK(K,NC+3)
7031 4 CONTINUE
7032 MOP1 = NC
7033 MOT1 = NC+1
7034 MOP2 = NC+2
7035 MOT2 = NC+3
7036 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7037 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7038 IF (IREJ1.GT.0) THEN
7039 IRHHA = IRHHA+1
7040 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7041 GOTO 9999
7042 ENDIF
7043 NC = NC+4
7044 3 CONTINUE
7045
7046* meson/antibaryon projectile:
7047* sample single-chain valence-valence systems (Reggeon contrib.)
7048 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7049 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7050 ENDIF
7051
7052 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7053* check DTEVT1 for remaining resonance mass corrections
7054 CALL DT_EVTRES(IREJ1)
7055 IF (IREJ1.GT.0) THEN
7056 IRRES(1) = IRRES(1)+1
7057 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7058 GOTO 9999
7059 ENDIF
7060 ENDIF
7061
7062* assign p_t to two-"chain" systems consisting of two resonances only
7063* since only entries for chains will be affected, this is obsolete
7064* in case of JETSET-fragmetation
7065 CALL DT_RESPT
7066
7067* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7068 IF (LCO2CR) CALL DT_COM2CR
7069
7070 5 CONTINUE
7071
7072* fragmentation of the complete event
7073**uncomment for internal phojet-fragmentation
7074C CALL DT_EVTFRA(IREJ1)
7075 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7076 IF (IREJ1.GT.0) THEN
7077 IRFRAG = IRFRAG+1
7078 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7079 GOTO 9999
7080 ENDIF
7081
7082* decay of possible resonances (should be obsolete)
7083 CALL DT_DECAY1
7084
7085 RETURN
7086
7087 9999 CONTINUE
7088 IREVT = IREVT+1
7089 IREJ = 1
7090 RETURN
7091 END
7092
7093*$ CREATE DT_GETCSY.FOR
7094*COPY DT_GETCSY
7095*
7096*===getcsy=============================================================*
7097*
7098 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7099 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7100
7101************************************************************************
7102* This version dated 15.01.95 is written by S. Roesler *
7103************************************************************************
7104
7105 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7106 SAVE
7107
7108 PARAMETER ( LINP = 10 ,
7109 & LOUT = 6 ,
7110 & LDAT = 9 )
7111
7112 PARAMETER (TINY10=1.0D-10)
7113
7114* event history
7115
7116 PARAMETER (NMXHKK=200000)
7117
7118 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7119 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7120 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7121
7122* extended event history
7123 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7124 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7125 & IHIST(2,NMXHKK)
7126
7127* rejection counter
7128 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7129 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7130 & IREXCI(3),IRDIFF(2),IRINC
7131
7132* flags for input different options
7133 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7134 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7135 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7136
7137* flags for diffractive interactions (DTUNUC 1.x)
7138 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7139
7140 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7141 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7142
7143 IREJ = 0
7144
7145* get quark content of partons
7146 DO 1 I=1,2
7147 IFP1(I) = 0
7148 IFP2(I) = 0
7149 IFT1(I) = 0
7150 IFT2(I) = 0
7151 1 CONTINUE
7152 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7153 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7154 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7155 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7156 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7157 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7158 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7159 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7160
7161* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7162 IDCH1 = 2
7163 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7164 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7165 IDCH2 = 2
7166 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7167 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7168
7169* store initial configuration for energy-momentum cons. check
7170 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7171
7172* sample intrinsic p_t at chain-ends
7173 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7174 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7175 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7176 IF (IREJ1.NE.0) THEN
7177 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7178 IRPT = IRPT+1
7179 GOTO 9999
7180 ENDIF
7181
7182C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7183C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7184C* check second chain for resonance
7185C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7186C & AMCH2,AMCH2N,IDCH2,IREJ1)
7187C IF (IREJ1.NE.0) GOTO 9999
7188C IF (IDR2.NE.0) THEN
7189C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7190C & AMCH2,AMCH2N,AMCH1,IREJ1)
7191C IF (IREJ1.NE.0) GOTO 9999
7192C ENDIF
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) IDR1 = 100*IDR1
7198C ELSE
7199C* check first chain for resonance
7200C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7201C & AMCH1,AMCH1N,IDCH1,IREJ1)
7202C IF (IREJ1.NE.0) GOTO 9999
7203C IF (IDR1.NE.0) THEN
7204C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7205C & AMCH1,AMCH1N,AMCH2,IREJ1)
7206C IF (IREJ1.NE.0) GOTO 9999
7207C ENDIF
7208C* check second chain for resonance
7209C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7210C & AMCH2,AMCH2N,IDCH2,IREJ1)
7211C IF (IREJ1.NE.0) GOTO 9999
7212C IF (IDR2.NE.0) IDR2 = 100*IDR2
7213C ENDIF
7214C ENDIF
7215
7216 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7217* check chains for resonances
7218 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7219 & AMCH1,AMCH1N,IDCH1,IREJ1)
7220 IF (IREJ1.NE.0) GOTO 9999
7221 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7222 & AMCH2,AMCH2N,IDCH2,IREJ1)
7223 IF (IREJ1.NE.0) GOTO 9999
7224* change kinematics corresponding to resonance-masses
7225 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7226 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7227 & AMCH1,AMCH1N,AMCH2,IREJ1)
7228 IF (IREJ1.GT.0) GOTO 9999
7229 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7230 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7231 & AMCH2,AMCH2N,IDCH2,IREJ1)
7232 IF (IREJ1.NE.0) GOTO 9999
7233 IF (IDR2.NE.0) IDR2 = 100*IDR2
7234 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7235 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7236 & AMCH2,AMCH2N,AMCH1,IREJ1)
7237 IF (IREJ1.GT.0) GOTO 9999
7238 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7239 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7240 & AMCH1,AMCH1N,IDCH1,IREJ1)
7241 IF (IREJ1.NE.0) GOTO 9999
7242 IF (IDR1.NE.0) IDR1 = 100*IDR1
7243 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7244 AMDIF1 = ABS(AMCH1-AMCH1N)
7245 AMDIF2 = ABS(AMCH2-AMCH2N)
7246 IF (AMDIF2.LT.AMDIF1) THEN
7247 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7248 & AMCH2,AMCH2N,AMCH1,IREJ1)
7249 IF (IREJ1.GT.0) GOTO 9999
7250 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7251 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7252 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7253 IF (IREJ1.NE.0) GOTO 9999
7254 IF (IDR1.NE.0) IDR1 = 100*IDR1
7255 ELSE
7256 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7257 & AMCH1,AMCH1N,AMCH2,IREJ1)
7258 IF (IREJ1.GT.0) GOTO 9999
7259 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7260 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7261 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7262 IF (IREJ1.NE.0) GOTO 9999
7263 IF (IDR2.NE.0) IDR2 = 100*IDR2
7264 ENDIF
7265 ENDIF
7266 ENDIF
7267
7268* store final configuration for energy-momentum cons. check
7269 IF (LEMCCK) THEN
7270 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7271 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7272 IF (IREJ1.NE.0) GOTO 9999
7273 ENDIF
7274
7275* put partons and chains into DTEVT1
7276 DO 10 I=1,4
7277 PCH1(I) = PP1(I)+PT1(I)
7278 PCH2(I) = PP2(I)+PT2(I)
7279 10 CONTINUE
7280 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7281 & PP1(3),PP1(4),0,0,0)
7282 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7283 & PT1(3),PT1(4),0,0,0)
7284 KCH = 100+IDCH(MOP1)*10+1
7285 CALL DT_EVTPUT(KCH,88888,-2,-1,
7286 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7287 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7288 & PP2(3),PP2(4),0,0,0)
7289 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7290 & PT2(3),PT2(4),0,0,0)
7291 KCH = KCH+1
7292 CALL DT_EVTPUT(KCH,88888,-2,-1,
7293 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7294
7295 RETURN
7296
7297 9999 CONTINUE
7298 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7299* "cancel" sea-sea chains
7300 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7301 IF (IREJ1.NE.0) GOTO 9998
7302**sr 16.5. flag for EVENTB
7303 IREJ = -1
7304 RETURN
7305 ENDIF
7306 9998 CONTINUE
7307 IREJ = 1
7308 RETURN
7309 END
7310
7311*$ CREATE DT_CHKINE.FOR
7312*COPY DT_CHKINE
7313*
7314*===chkine=============================================================*
7315*
7316 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7317 & AMCH1,AMCH1N,AMCH2,IREJ)
7318
7319************************************************************************
7320* This subroutine replaces CORMOM. *
7321* This version dated 05.01.95 is written by S. Roesler *
7322************************************************************************
7323
7324 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7325 SAVE
7326
7327 PARAMETER ( LINP = 10 ,
7328 & LOUT = 6 ,
7329 & LDAT = 9 )
7330
7331 PARAMETER (TINY10=1.0D-10)
7332
7333* flags for input different options
7334 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7335 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7336 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7337
7338* rejection counter
7339 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7340 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7341 & IREXCI(3),IRDIFF(2),IRINC
7342
7343 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7344 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7345
7346 IREJ = 0
7347 JMSHL = IMSHL
7348
7349 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7350 DO 10 I=1,4
7351 PP1(I) = PP1I(I)
7352 PP2(I) = PP2I(I)
7353 PT1(I) = PT1I(I)
7354 PT2(I) = PT2I(I)
7355 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7356 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7357 PP1(I) = SCALE*PP1(I)
7358 PT1(I) = SCALE*PT1(I)
7359 10 CONTINUE
7360 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7361 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7362
7363 ECH = PP2(4)+PT2(4)
7364 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7365 & (PP2(3)+PT2(3))**2 )
7366 AMCH22 = (ECH-PCH)*(ECH+PCH)
7367 IF (AMCH22.LT.0.0D0) THEN
7368 IF (IOULEV(1).GT.0)
7369 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7370 GOTO 9997
7371 ENDIF
7372
7373 AMCH1 = AMCH1N
7374 AMCH2 = SQRT(AMCH22)
7375
7376* put partons again on mass shell
7377 13 CONTINUE
7378 XM1 = 0.0D0
7379 XM2 = 0.0D0
7380 IF (JMSHL.EQ.1) THEN
7381
7382 XM1 = PYMASS(IFP1)
7383 XM2 = PYMASS(IFT1)
7384
7385 ENDIF
7386 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7387 IF (IREJ1.NE.0) THEN
7388 IF (JMSHL.EQ.0) GOTO 9998
7389 JMSHL = 0
7390 GOTO 13
7391 ENDIF
7392 JMSHL = IMSHL
7393 DO 11 I=1,4
7394 PP1(I) = P1(I)
7395 PT1(I) = P2(I)
7396 11 CONTINUE
7397 14 CONTINUE
7398 XM1 = 0.0D0
7399 XM2 = 0.0D0
7400 IF (JMSHL.EQ.1) THEN
7401
7402 XM1 = PYMASS(IFP2)
7403 XM2 = PYMASS(IFT2)
7404
7405 ENDIF
7406 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7407 IF (IREJ1.NE.0) THEN
7408 IF (JMSHL.EQ.0) GOTO 9998
7409 JMSHL = 0
7410 GOTO 14
7411 ENDIF
7412 DO 12 I=1,4
7413 PP2(I) = P1(I)
7414 PT2(I) = P2(I)
7415 12 CONTINUE
7416 DO 15 I=1,4
7417 PP1I(I) = PP1(I)
7418 PP2I(I) = PP2(I)
7419 PT1I(I) = PT1(I)
7420 PT2I(I) = PT2(I)
7421 15 CONTINUE
7422 RETURN
7423
7424 9997 IRCHKI(1) = IRCHKI(1)+1
7425**sr
7426C GOTO 9999
7427 IREJ = -1
7428 RETURN
7429**
7430 9998 IRCHKI(2) = IRCHKI(2)+1
7431
7432 9999 CONTINUE
7433 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7434 IREJ = 1
7435 RETURN
7436 END
7437
7438*$ CREATE DT_CH2RES.FOR
7439*COPY DT_CH2RES
7440*
7441*===ch2res=============================================================*
7442*
7443 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7444 & AM,AMN,IMODE,IREJ)
7445
7446************************************************************************
7447* Check chains for resonance production. *
7448* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7449* input: *
7450* IF1,2,3,4 input flavors (q,aq in any order) *
7451* AM chain mass *
7452* MODE = 1 check q-aq chain for meson-resonance *
7453* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7454* = 3 check qq-aqaq chain for lower mass cut *
7455* output: *
7456* IDR = 0 no resonances found *
7457* = -1 pseudoscalar meson/octet baryon *
7458* = 1 vector-meson/decuplet baryon *
7459* IDXR BAMJET-index of corresponding resonance *
7460* AMN mass of corresponding resonance *
7461* *
7462* IREJ rejection flag *
7463* This version dated 06.01.95 is written by S. Roesler *
7464************************************************************************
7465
7466 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7467 SAVE
7468
7469 PARAMETER ( LINP = 10 ,
7470 & LOUT = 6 ,
7471 & LDAT = 9 )
7472
7473* particle properties (BAMJET index convention)
7474 CHARACTER*8 ANAME
7475 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7476 & IICH(210),IIBAR(210),K1(210),K2(210)
7477
7478* quark-content to particle index conversion (DTUNUC 1.x)
7479 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7480 & IA08(6,21),IA10(6,21)
7481
7482* rejection counter
7483 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7484 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7485 & IREXCI(3),IRDIFF(2),IRINC
7486
7487* flags for input different options
7488 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7489 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7490 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7491
7492 DIMENSION IF(4),JF(4)
7493
7494**sr 4.7. test
7495C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7496 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7497**
7498C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7499
7500 MODE = ABS(IMODE)
7501
7502 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7503 WRITE(LOUT,1000) MODE
7504 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7505 & 1X,' program stopped')
7506 STOP
7507 ENDIF
7508
7509 AMX = AM
7510 IREJ = 0
7511 IDR = 0
7512 IDXR = 0
7513 AMN = AMX
7514 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7515 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7516
7517 IF(1) = IF1
7518 IF(2) = IF2
7519 IF(3) = IF3
7520 IF(4) = IF4
7521 NF = 0
7522 DO 100 I=1,4
7523 IF (IF(I).NE.0) THEN
7524 NF = NF+1
7525 JF(NF) = IF(I)
7526 ENDIF
7527 100 CONTINUE
7528 IF (NF.LE.MODE) THEN
7529 WRITE(LOUT,1001) MODE,IF
7530 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7531 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7532 GOTO 9999
7533 ENDIF
7534
7535 GOTO (1,2,3) MODE
7536
7537* check for meson resonance
7538 1 CONTINUE
7539 IFQ = JF(1)
7540 IFAQ = ABS(JF(2))
7541 IF (JF(2).GT.0) THEN
7542 IFQ = JF(2)
7543 IFAQ = ABS(JF(1))
7544 ENDIF
7545 IFPS = IMPS(IFAQ,IFQ)
7546 IFV = IMVE(IFAQ,IFQ)
7547 AMPS = AAM(IFPS)
7548 AMV = AAM(IFV)
7549 AMHI = AMV+0.3D0
7550 IF (AMX.LT.AMV) THEN
7551 IF (AMX.LT.AMPS) THEN
7552 IF (IMODE.GT.0) THEN
7553 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7554 ELSE
7555 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7556 ENDIF
7557 LOMRES = LOMRES+1
7558 ENDIF
7559* replace chain by pseudoscalar meson
7560 IDR = -1
7561 IDXR = IFPS
7562 AMN = AMPS
7563 ELSEIF (AMX.LT.AMHI) THEN
7564* replace chain by vector-meson
7565 IDR = 1
7566 IDXR = IFV
7567 AMN = AMV
7568 ENDIF
7569 RETURN
7570
7571* check for baryon resonance
7572 2 CONTINUE
7573 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7574 AM8 = AAM(JB8)
7575 AM10 = AAM(JB10)
7576 AMHI = AM10+0.3D0
7577 IF (AMX.LT.AM10) THEN
7578 IF (AMX.LT.AM8) THEN
7579 IF (IMODE.GT.0) THEN
7580 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7581 ELSE
7582 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7583 ENDIF
7584 LOBRES = LOBRES+1
7585 ENDIF
7586* replace chain by oktet baryon
7587 IDR = -1
7588 IDXR = JB8
7589 AMN = AM8
7590 ELSEIF (AMX.LT.AMHI) THEN
7591 IDR = 1
7592 IDXR = JB10
7593 AMN = AM10
7594 ENDIF
7595 RETURN
7596
7597* check qq-aqaq for lower mass cut
7598 3 CONTINUE
7599* empirical definition of AMHI to allow for (b-antib)-pair prod.
7600 AMHI = 2.5D0
7601 IF (AMX.LT.AMHI) GOTO 9999
7602 RETURN
7603
7604 9999 CONTINUE
7605 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7606 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7607 IREJ = 1
7608 IRRES(2) = IRRES(2)+1
7609 RETURN
7610 END
7611
7612*$ CREATE DT_RJSEAC.FOR
7613*COPY DT_RJSEAC
7614*
7615*===rjseac=============================================================*
7616*
7617 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7618
7619************************************************************************
7620* ReJection of SEA-sea Chains. *
7621* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7622* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7623* This version dated 16.01.95 is written by S. Roesler *
7624************************************************************************
7625
7626 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7627 SAVE
7628
7629 PARAMETER ( LINP = 10 ,
7630 & LOUT = 6 ,
7631 & LDAT = 9 )
7632
7633 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7634
7635* event history
7636
7637 PARAMETER (NMXHKK=200000)
7638
7639 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7640 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7641 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7642
7643* extended event history
7644 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7645 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7646 & IHIST(2,NMXHKK)
7647
7648* statistics
7649 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7650 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7651 & ICEVTG(8,0:30)
7652
7653 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7654
7655 IREJ = 0
7656
7657* projectile sea q-aq-pair
7658* indices of sea-pair
7659 IDXSEA(1,1) = MOP1
7660 IDXSEA(1,2) = MOP2
7661* index of mother-nucleon
7662 IDXNUC(1) = JMOHKK(1,MOP1)
7663* status of valence quarks to be corrected
7664 ISTVAL(1) = -21
7665
7666* target sea q-aq-pair
7667* indices of sea-pair
7668 IDXSEA(2,1) = MOT1
7669 IDXSEA(2,2) = MOT2
7670* index of mother-nucleon
7671 IDXNUC(2) = JMOHKK(1,MOT1)
7672* status of valence quarks to be corrected
7673 ISTVAL(2) = -22
7674
7675 DO 1 N=1,2
7676 IDONE = 0
7677 DO 2 I=NPOINT(2),NHKK
7678 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7679 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7680* valence parton found
7681* inrease 4-momentum by sea 4-momentum
7682 DO 3 K=1,4
7683 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7684 & PHKK(K,IDXSEA(N,2))
7685 3 CONTINUE
7686 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7687 & PHKK(2,I)**2-PHKK(3,I)**2))
7688* "cancel" sea-pair
7689 DO 4 J=1,2
7690 ISTHKK(IDXSEA(N,J)) = 100
7691 IDHKK(IDXSEA(N,J)) = 0
7692 JMOHKK(1,IDXSEA(N,J)) = 0
7693 JMOHKK(2,IDXSEA(N,J)) = 0
7694 JDAHKK(1,IDXSEA(N,J)) = 0
7695 JDAHKK(2,IDXSEA(N,J)) = 0
7696 DO 5 K=1,4
7697 PHKK(K,IDXSEA(N,J)) = ZERO
7698 VHKK(K,IDXSEA(N,J)) = ZERO
7699 WHKK(K,IDXSEA(N,J)) = ZERO
7700 5 CONTINUE
7701 PHKK(5,IDXSEA(N,J)) = ZERO
7702 4 CONTINUE
7703 IDONE = 1
7704 ENDIF
7705 2 CONTINUE
7706 IF (IDONE.NE.1) THEN
7707 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7708 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7709 & '-record!',/,1X,' sea-quark pairs ',
7710 & 2I5,4X,2I5,' could not be canceled!')
7711 GOTO 9999
7712 ENDIF
7713 1 CONTINUE
7714 ICRJSS = ICRJSS+1
7715 RETURN
7716
7717 9999 CONTINUE
7718 IREJ = 1
7719 RETURN
7720 END
7721
7722*$ CREATE DT_VV2SCH.FOR
7723*COPY DT_VV2SCH
7724*
7725*===vv2sch=============================================================*
7726*
7727 SUBROUTINE DT_VV2SCH
7728
7729************************************************************************
7730* Change Valence-Valence chain systems to Single CHain systems for *
7731* hadron-nucleus collisions with meson or antibaryon projectile. *
7732* (Reggeon contribution) *
7733* The single chain system is approximately treated as one chain and a *
7734* meson at rest. *
7735* This version dated 18.01.95 is written by S. Roesler *
7736************************************************************************
7737
7738 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7739 SAVE
7740
7741 PARAMETER ( LINP = 10 ,
7742 & LOUT = 6 ,
7743 & LDAT = 9 )
7744
7745 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7746
7747 LOGICAL LSTART
7748
7749* event history
7750
7751 PARAMETER (NMXHKK=200000)
7752
7753 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7754 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7755 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7756
7757* extended event history
7758 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7759 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7760 & IHIST(2,NMXHKK)
7761
7762* flags for input different options
7763 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7764 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7765 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7766
7767* statistics
7768 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7769 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7770 & ICEVTG(8,0:30)
7771
7772 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7773 & PCH2(4)
7774
7775 DATA LSTART /.TRUE./
7776
7777 IFSC = 0
7778 IF (LSTART) THEN
7779 WRITE(LOUT,1000)
7780 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7781 & 'valence chains treated')
7782 LSTART = .FALSE.
7783 ENDIF
7784
7785 NSTOP = NHKK
7786
7787* get index of first chain
7788 DO 1 I=NPOINT(3),NHKK
7789 IF (IDHKK(I).EQ.88888) THEN
7790 NC = I
7791 GOTO 2
7792 ENDIF
7793 1 CONTINUE
7794
7795 2 CONTINUE
7796 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7797 & .AND.(NC.LT.NSTOP)) THEN
7798* get valence-valence chains
7799 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7800* get "mother"-hadron indices
7801 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7802 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7803 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7804 KTARG = IDT_ICIHAD(IDHKK(MO2))
7805* Lab momentum of projectile hadron
7806 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7807 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7808 & PHKK(3,MO1)**2)
7809
7810 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7811 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7812 ICVV2S = ICVV2S+1
7813* single chain requested
7814* get flavors of chain-end partons
7815 MO(1) = JMOHKK(1,NC)
7816 MO(2) = JMOHKK(2,NC)
7817 MO(3) = JMOHKK(1,NC+3)
7818 MO(4) = JMOHKK(2,NC+3)
7819 DO 3 I=1,4
7820 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7821 IF(I,2) = 0
7822 IF (ABS(IDHKK(MO(I))).GE.1000)
7823 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7824 3 CONTINUE
7825* which one is the q-aq chain?
7826* N1,N1+1 - DTEVT1-entries for q-aq system
7827* N2,N2+1 - DTEVT1-entries for the other chain
7828 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7829 K1 = 1
7830 K2 = 3
7831 N1 = NC-2
7832 N2 = NC+1
7833 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7834 K1 = 3
7835 K2 = 1
7836 N1 = NC+1
7837 N2 = NC-2
7838 ELSE
7839 GOTO 10
7840 ENDIF
7841 DO 4 K=1,4
7842 PP1(K) = PHKK(K,N1)
7843 PT1(K) = PHKK(K,N1+1)
7844 PP2(K) = PHKK(K,N2)
7845 PT2(K) = PHKK(K,N2+1)
7846 4 CONTINUE
7847 AMCH1 = PHKK(5,N1+2)
7848 AMCH2 = PHKK(5,N2+2)
7849* get meson-identity corresponding to flavors of q-aq chain
7850 ITMP = IRESRJ
7851 IRESRJ = 0
7852 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7853 & ZERO,AMCH1N,1,IDUM)
7854 IRESRJ = ITMP
7855* change kinematics of chains
7856 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7857 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7858 & AMCH1,AMCH1N,AMCH2,IREJ1)
7859 IF (IREJ1.NE.0) GOTO 10
7860* check second chain for resonance
7861 IDCHAI = 2
7862 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7863 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7864 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7865 IF (IREJ1.NE.0) GOTO 10
7866 IF (IDR2.NE.0) IDR2 = 100*IDR2
7867* add partons and chains to DTEVT1
7868 DO 5 K=1,4
7869 PCH1(K) = PP1(K)+PT1(K)
7870 PCH2(K) = PP2(K)+PT2(K)
7871 5 CONTINUE
7872 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7873 & PP1(3),PP1(4),0,0,0)
7874 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7875 & PT1(2),PT1(3),PT1(4),0,0,0)
7876 KCH = ISTHKK(N1+2)+100
7877 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7878 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7879 IDHKK(N1+2) = 22222
7880 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7881 & PP2(3),PP2(4),0,0,0)
7882 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7883 & PT2(2),PT2(3),PT2(4),0,0,0)
7884 KCH = ISTHKK(N2+2)+100
7885 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7886 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7887 IDHKK(N2+2) = 22222
7888 ENDIF
7889 ENDIF
7890 ELSE
7891 GOTO 11
7892 ENDIF
7893 10 CONTINUE
7894 NC = NC+6
7895 GOTO 2
7896
7897 11 CONTINUE
7898
7899 RETURN
7900 END
7901
7902*$ CREATE DT_PHNSCH.FOR
7903*COPY DT_PHNSCH
7904*
7905*=== phnsch ===========================================================*
7906*
7907 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7908
7909*----------------------------------------------------------------------*
7910* *
7911* Probability for Hadron Nucleon Single CHain interactions: *
7912* *
7913* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7914* Infn - Milan *
7915* *
7916* Last change on 04-jan-94 by Alfredo Ferrari *
7917* *
7918* modified by J.R.for use in DTUNUC 6.1.94 *
7919* *
7920* Input variables: *
7921* Kp = hadron projectile index (Part numbering *
7922* scheme) *
7923* Ktarg = target nucleon index (1=proton, 8=neutron) *
7924* Plab = projectile laboratory momentum (GeV/c) *
7925* Output variable: *
7926* Phnsch = probability per single chain (particle *
7927* exchange) interactions *
7928* *
7929*----------------------------------------------------------------------*
7930
7931 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7932 SAVE
7933
7934 PARAMETER ( LUNOUT = 6 )
7935 PARAMETER ( LUNERR = 6 )
7936 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7937 PARAMETER ( ZERZER = 0.D+00 )
7938 PARAMETER ( ONEONE = 1.D+00 )
7939 PARAMETER ( TWOTWO = 2.D+00 )
7940 PARAMETER ( FIVFIV = 5.D+00 )
7941 PARAMETER ( HLFHLF = 0.5D+00 )
7942
7943 PARAMETER ( NALLWP = 39 )
7944 PARAMETER ( IDMAXP = 210 )
7945
7946 DIMENSION ICHRGE(39),AM(39)
7947
7948* particle properties (BAMJET index convention)
7949 CHARACTER*8 ANAME
7950 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7951 & IICH(210),IIBAR(210),K1(210),K2(210)
7952
7953 DIMENSION KPTOIP(210)
7954
7955* auxiliary common for reggeon exchange (DTUNUC 1.x)
7956 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7957 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7958 & IQTCHR(-6:6),MQUARK(3,39)
7959
7960 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7961 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7962 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7963 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7964 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7965
7966* Conversion from part to paprop numbering
7967 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7968 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7969 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7970
7971* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7972 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7973 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7974C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7975 DATA SGTCO1 /
7976* 1st reaction: gamma p total
7977 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7978* 2nd reaction: gamma d total
7979 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7980* 3rd reaction: pi+ p total
7981 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7982* 4th reaction: pi- p total
7983 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7984* 5th reaction: pi+/- d total
7985 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7986* 6th reaction: K+ p total
7987 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7988* 7th reaction: K+ n total
7989 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7990* 8th reaction: K+ d total
7991 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7992* 9th reaction: K- p total
7993 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7994* 10th reaction: K- n total
7995 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7996C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7997 DATA SGTCO2 /
7998* 11th reaction: K- d total
7999 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
8000* 12th reaction: p p total
8001 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
8002* 13th reaction: p n total
8003 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
8004* 14th reaction: p d total
8005 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
8006* 15th reaction: pbar p total
8007 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
8008* 16th reaction: pbar n total
8009 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
8010* 17th reaction: pbar d total
8011 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
8012* 18th reaction: Lamda p total
8013 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
8014C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8015 DATA SGTCO3 /
8016* 19th reaction: pi+ p elastic
8017 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8018* 20th reaction: pi- p elastic
8019 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8020* 21st reaction: K+ p elastic
8021 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8022* 22nd reaction: K- p elastic
8023 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8024* 23rd reaction: p p elastic
8025 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8026* 24th reaction: p d elastic
8027 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8028* 25th reaction: pbar p elastic
8029 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8030* 26th reaction: pbar p elastic bis
8031 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8032* 27th reaction: pbar n elastic
8033 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8034* 28th reaction: Lamda p elastic
8035 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8036* 29th reaction: K- p ela bis
8037 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8038* 30th reaction: pi- p cx
8039 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8040* 31st reaction: K- p cx
8041 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8042* 32nd reaction: K+ n cx
8043 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8044* 33rd reaction: pbar p cx
8045 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8046*
8047* +-------------------------------------------------------------------*
8048 ICHRGE(KTARG)=IICH(KTARG)
8049 AM (KTARG)=AAM (KTARG)
8050* | Check for pi0 (d-dbar)
8051 IF ( KP .NE. 26 ) THEN
8052 IP = KPTOIP (KP)
8053 IF(IP.EQ.0)IP=1
8054 ICHRGE(IP)=IICH(KP)
8055 AM (IP)=AAM (KP)
8056* |
8057* +-------------------------------------------------------------------*
8058* |
8059 ELSE
8060 IP = 23
8061 ICHRGE(IP)=0
8062 END IF
8063* |
8064* +-------------------------------------------------------------------*
8065* +-------------------------------------------------------------------*
8066* | No such interactions for baryon-baryon
8067 IF ( IIBAR (KP) .GT. 0 ) THEN
8068 DT_PHNSCH = ZERZER
8069 RETURN
8070* |
8071* +-------------------------------------------------------------------*
8072* | No "annihilation" diagram possible for K+ p/n
8073 ELSE IF ( IP .EQ. 15 ) THEN
8074 DT_PHNSCH = ZERZER
8075 RETURN
8076* |
8077* +-------------------------------------------------------------------*
8078* | No "annihilation" diagram possible for K0 p/n
8079 ELSE IF ( IP .EQ. 24 ) THEN
8080 DT_PHNSCH = ZERZER
8081 RETURN
8082* |
8083* +-------------------------------------------------------------------*
8084* | No "annihilation" diagram possible for Omebar p/n
8085 ELSE IF ( IP .GE. 38 ) THEN
8086 DT_PHNSCH = ZERZER
8087 RETURN
8088 END IF
8089* |
8090* +-------------------------------------------------------------------*
8091* +-------------------------------------------------------------------*
8092* | If the momentum is larger than 50 GeV/c, compute the single
8093* | chain probability at 50 GeV/c and extrapolate to the present
8094* | momentum according to 1/sqrt(s)
8095* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8096* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8097* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8098* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8099* | x sqrt(s/s(50))
8100* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8101 IF ( PLAB .GT. 50.D+00 ) THEN
8102 PLA = 50.D+00
8103 AMPSQ = AM (IP)**2
8104 AMTSQ = AM (KTARG)**2
8105 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8106 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8107 EPROJ = SQRT ( PLA**2 + AMPSQ )
8108 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8109 UMORAT = SQRT ( UMOSQ / UMO50 )
8110* |
8111* +-------------------------------------------------------------------*
8112* | P < 3 GeV/c
8113 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8114 PLA = 3.D+00
8115 AMPSQ = AM (IP)**2
8116 AMTSQ = AM (KTARG)**2
8117 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8118 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8119 EPROJ = SQRT ( PLA**2 + AMPSQ )
8120 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8121 UMORAT = SQRT ( UMOSQ / UMO50 )
8122* |
8123* +-------------------------------------------------------------------*
8124* | P < 50 GeV/c
8125 ELSE
8126 PLA = PLAB
8127 UMORAT = ONEONE
8128 END IF
8129* |
8130* +-------------------------------------------------------------------*
8131 ALGPLA = LOG (PLA)
8132* +-------------------------------------------------------------------*
8133* | Pions:
8134 IF ( IHLP (IP) .EQ. 2 ) THEN
8135 ACOF = SGTCOE (1,3)
8136 BCOF = SGTCOE (2,3)
8137 ENNE = SGTCOE (3,3)
8138 CCOF = SGTCOE (4,3)
8139 DCOF = SGTCOE (5,3)
8140* | Compute the pi+ p total cross section:
8141 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8142 & + DCOF * ALGPLA
8143 ACOF = SGTCOE (1,19)
8144 BCOF = SGTCOE (2,19)
8145 ENNE = SGTCOE (3,19)
8146 CCOF = SGTCOE (4,19)
8147 DCOF = SGTCOE (5,19)
8148* | Compute the pi+ p elastic cross section:
8149 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8150 & + DCOF * ALGPLA
8151* | Compute the pi+ p inelastic cross section:
8152 SPPPIN = SPPPTT - SPPPEL
8153 ACOF = SGTCOE (1,4)
8154 BCOF = SGTCOE (2,4)
8155 ENNE = SGTCOE (3,4)
8156 CCOF = SGTCOE (4,4)
8157 DCOF = SGTCOE (5,4)
8158* | Compute the pi- p total cross section:
8159 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8160 & + DCOF * ALGPLA
8161 ACOF = SGTCOE (1,20)
8162 BCOF = SGTCOE (2,20)
8163 ENNE = SGTCOE (3,20)
8164 CCOF = SGTCOE (4,20)
8165 DCOF = SGTCOE (5,20)
8166* | Compute the pi- p elastic cross section:
8167 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8168 & + DCOF * ALGPLA
8169* | Compute the pi- p inelastic cross section:
8170 SPMPIN = SPMPTT - SPMPEL
8171 SIGDIA = SPMPIN - SPPPIN
8172* | +----------------------------------------------------------------*
8173* | | Charged pions: besides isospin consideration it is supposed
8174* | | that (pi+ n)el is almost equal to (pi- p)el
8175* | | and (pi+ p)el " " " " (pi- n)el
8176* | | and all are almost equal among each others
8177* | | (reasonable above 5 GeV/c)
8178 IF ( ICHRGE (IP) .NE. 0 ) THEN
8179 KHELP = KTARG / 8
8180 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8181 ACOF = SGTCOE (1,JREAC)
8182 BCOF = SGTCOE (2,JREAC)
8183 ENNE = SGTCOE (3,JREAC)
8184 CCOF = SGTCOE (4,JREAC)
8185 DCOF = SGTCOE (5,JREAC)
8186* | | Compute the total cross section:
8187 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8188 & + DCOF * ALGPLA
8189 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8190 ACOF = SGTCOE (1,JREAC)
8191 BCOF = SGTCOE (2,JREAC)
8192 ENNE = SGTCOE (3,JREAC)
8193 CCOF = SGTCOE (4,JREAC)
8194 DCOF = SGTCOE (5,JREAC)
8195* | | Compute the elastic cross section:
8196 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8197 & + DCOF * ALGPLA
8198* | | Compute the inelastic cross section:
8199 SHNCIN = SHNCTT - SHNCEL
8200* | | Number of diagrams:
8201 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8202* | | Now compute the chain end (anti)quark-(anti)diquark
8203 IQFSC1 = 1 + IP - 13
8204 IQFSC2 = 0
8205 IQBSC1 = 1 + KHELP
8206 IQBSC2 = 1 + IP - 13
8207* | |
8208* | +----------------------------------------------------------------*
8209* | | pi0: besides isospin consideration it is supposed that the
8210* | | elastic cross section is not very different from
8211* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8212 ELSE
8213 KHELP = KTARG / 8
8214 K2HLP = ( KP - 23 ) / 3
8215* | | Number of diagrams:
8216* | | For u ubar (k2hlp=0):
8217* NDIAGR = 2 - KHELP
8218* | | For d dbar (k2hlp=1):
8219* NDIAGR = 2 + KHELP - K2HLP
8220 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8221 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8222* | | Now compute the chain end (anti)quark-(anti)diquark
8223 IQFSC1 = 1 + K2HLP
8224 IQFSC2 = 0
8225 IQBSC1 = 1 + KHELP
8226 IQBSC2 = 2 - K2HLP
8227 END IF
8228* | |
8229* | +----------------------------------------------------------------*
8230* | end pi's
8231* +-------------------------------------------------------------------*
8232* | Kaons:
8233 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8234 ACOF = SGTCOE (1,6)
8235 BCOF = SGTCOE (2,6)
8236 ENNE = SGTCOE (3,6)
8237 CCOF = SGTCOE (4,6)
8238 DCOF = SGTCOE (5,6)
8239* | Compute the K+ p total cross section:
8240 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8241 & + DCOF * ALGPLA
8242 ACOF = SGTCOE (1,21)
8243 BCOF = SGTCOE (2,21)
8244 ENNE = SGTCOE (3,21)
8245 CCOF = SGTCOE (4,21)
8246 DCOF = SGTCOE (5,21)
8247* | Compute the K+ p elastic cross section:
8248 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8249 & + DCOF * ALGPLA
8250* | Compute the K+ p inelastic cross section:
8251 SKPPIN = SKPPTT - SKPPEL
8252 ACOF = SGTCOE (1,9)
8253 BCOF = SGTCOE (2,9)
8254 ENNE = SGTCOE (3,9)
8255 CCOF = SGTCOE (4,9)
8256 DCOF = SGTCOE (5,9)
8257* | Compute the K- p total cross section:
8258 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8259 & + DCOF * ALGPLA
8260 ACOF = SGTCOE (1,22)
8261 BCOF = SGTCOE (2,22)
8262 ENNE = SGTCOE (3,22)
8263 CCOF = SGTCOE (4,22)
8264 DCOF = SGTCOE (5,22)
8265* | Compute the K- p elastic cross section:
8266 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8267 & + DCOF * ALGPLA
8268* | Compute the K- p inelastic cross section:
8269 SKMPIN = SKMPTT - SKMPEL
8270 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8271* | +----------------------------------------------------------------*
8272* | | Charged Kaons: actually only K-
8273 IF ( ICHRGE (IP) .NE. 0 ) THEN
8274 KHELP = KTARG / 8
8275* | | +-------------------------------------------------------------*
8276* | | | Proton target:
8277 IF ( KHELP .EQ. 0 ) THEN
8278 SHNCIN = SKMPIN
8279* | | | Number of diagrams:
8280 NDIAGR = 2
8281* | | |
8282* | | +-------------------------------------------------------------*
8283* | | | Neutron target: besides isospin consideration it is supposed
8284* | | | that (K- n)el is almost equal to (K- p)el
8285* | | | (reasonable above 5 GeV/c)
8286 ELSE
8287 ACOF = SGTCOE (1,10)
8288 BCOF = SGTCOE (2,10)
8289 ENNE = SGTCOE (3,10)
8290 CCOF = SGTCOE (4,10)
8291 DCOF = SGTCOE (5,10)
8292* | | | Compute the total cross section:
8293 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8294 & + DCOF * ALGPLA
8295* | | | Compute the elastic cross section:
8296 SHNCEL = SKMPEL
8297* | | | Compute the inelastic cross section:
8298 SHNCIN = SHNCTT - SHNCEL
8299* | | | Number of diagrams:
8300 NDIAGR = 1
8301 END IF
8302* | | |
8303* | | +-------------------------------------------------------------*
8304* | | Now compute the chain end (anti)quark-(anti)diquark
8305 IQFSC1 = 3
8306 IQFSC2 = 0
8307 IQBSC1 = 1 + KHELP
8308 IQBSC2 = 2
8309* | |
8310* | +----------------------------------------------------------------*
8311* | | K0's: (actually only K0bar)
8312 ELSE
8313 KHELP = KTARG / 8
8314* | | +-------------------------------------------------------------*
8315* | | | Proton target: (K0bar p)in supposed to be given by
8316* | | | (K- p)in - Sig_diagr
8317 IF ( KHELP .EQ. 0 ) THEN
8318 SHNCIN = SKMPIN - SIGDIA
8319* | | | Number of diagrams:
8320 NDIAGR = 1
8321* | | |
8322* | | +-------------------------------------------------------------*
8323* | | | Neutron target: (K0bar n)in supposed to be given by
8324* | | | (K- n)in + Sig_diagr
8325* | | | besides isospin consideration it is supposed
8326* | | | that (K- n)el is almost equal to (K- p)el
8327* | | | (reasonable above 5 GeV/c)
8328 ELSE
8329 ACOF = SGTCOE (1,10)
8330 BCOF = SGTCOE (2,10)
8331 ENNE = SGTCOE (3,10)
8332 CCOF = SGTCOE (4,10)
8333 DCOF = SGTCOE (5,10)
8334* | | | Compute the total cross section:
8335 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8336 & + DCOF * ALGPLA
8337* | | | Compute the elastic cross section:
8338 SHNCEL = SKMPEL
8339* | | | Compute the inelastic cross section:
8340 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8341* | | | Number of diagrams:
8342 NDIAGR = 2
8343 END IF
8344* | | |
8345* | | +-------------------------------------------------------------*
8346* | | Now compute the chain end (anti)quark-(anti)diquark
8347 IQFSC1 = 3
8348 IQFSC2 = 0
8349 IQBSC1 = 1
8350 IQBSC2 = 1 + KHELP
8351 END IF
8352* | |
8353* | +----------------------------------------------------------------*
8354* | end Kaon's
8355* +-------------------------------------------------------------------*
8356* | Antinucleons:
8357 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8358* | For momenta between 3 and 5 GeV/c the use of tabulated data
8359* | should be implemented!
8360 ACOF = SGTCOE (1,15)
8361 BCOF = SGTCOE (2,15)
8362 ENNE = SGTCOE (3,15)
8363 CCOF = SGTCOE (4,15)
8364 DCOF = SGTCOE (5,15)
8365* | Compute the pbar p total cross section:
8366 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8367 & + DCOF * ALGPLA
8368 IF ( PLA .LT. FIVFIV ) THEN
8369 JREAC = 26
8370 ELSE
8371 JREAC = 25
8372 END IF
8373 ACOF = SGTCOE (1,JREAC)
8374 BCOF = SGTCOE (2,JREAC)
8375 ENNE = SGTCOE (3,JREAC)
8376 CCOF = SGTCOE (4,JREAC)
8377 DCOF = SGTCOE (5,JREAC)
8378* | Compute the pbar p elastic cross section:
8379 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8380 & + DCOF * ALGPLA
8381* | Compute the pbar p inelastic cross section:
8382 SAPPIN = SAPPTT - SAPPEL
8383 ACOF = SGTCOE (1,12)
8384 BCOF = SGTCOE (2,12)
8385 ENNE = SGTCOE (3,12)
8386 CCOF = SGTCOE (4,12)
8387 DCOF = SGTCOE (5,12)
8388* | Compute the p p total cross section:
8389 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8390 & + DCOF * ALGPLA
8391 ACOF = SGTCOE (1,23)
8392 BCOF = SGTCOE (2,23)
8393 ENNE = SGTCOE (3,23)
8394 CCOF = SGTCOE (4,23)
8395 DCOF = SGTCOE (5,23)
8396* | Compute the p p elastic cross section:
8397 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8398 & + DCOF * ALGPLA
8399* | Compute the K- p inelastic cross section:
8400 SPPINE = SPPTOT - SPPELA
8401 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8402 KHELP = KTARG / 8
8403* | +----------------------------------------------------------------*
8404* | | Pbar:
8405 IF ( ICHRGE (IP) .NE. 0 ) THEN
8406 NDIAGR = 5 - KHELP
8407* | | +-------------------------------------------------------------*
8408* | | | Proton target:
8409 IF ( KHELP .EQ. 0 ) THEN
8410* | | | Number of diagrams:
8411 SHNCIN = SAPPIN
8412 PUUBAR = 0.8D+00
8413* | | |
8414* | | +-------------------------------------------------------------*
8415* | | | Neutron target: it is supposed that (ap n)el is almost equal
8416* | | | to (ap p)el (reasonable above 5 GeV/c)
8417 ELSE
8418 ACOF = SGTCOE (1,16)
8419 BCOF = SGTCOE (2,16)
8420 ENNE = SGTCOE (3,16)
8421 CCOF = SGTCOE (4,16)
8422 DCOF = SGTCOE (5,16)
8423* | | | Compute the total cross section:
8424 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8425 & + DCOF * ALGPLA
8426* | | | Compute the elastic cross section:
8427 SHNCEL = SAPPEL
8428* | | | Compute the inelastic cross section:
8429 SHNCIN = SHNCTT - SHNCEL
8430 PUUBAR = HLFHLF
8431 END IF
8432* | | |
8433* | | +-------------------------------------------------------------*
8434* | | Now compute the chain end (anti)quark-(anti)diquark
8435* | | there are different possibilities, make a random choiche:
8436 IQFSC1 = -1
8437 RNCHEN = DT_RNDM(PUUBAR)
8438 IF ( RNCHEN .LT. PUUBAR ) THEN
8439 IQFSC2 = -2
8440 ELSE
8441 IQFSC2 = -1
8442 END IF
8443 IQBSC1 = -IQFSC1 + KHELP
8444 IQBSC2 = -IQFSC2
8445* | |
8446* | +----------------------------------------------------------------*
8447* | | nbar:
8448 ELSE
8449 NDIAGR = 4 + KHELP
8450* | | +-------------------------------------------------------------*
8451* | | | Proton target: (nbar p)in supposed to be given by
8452* | | | (pbar p)in - Sig_diagr
8453 IF ( KHELP .EQ. 0 ) THEN
8454 SHNCIN = SAPPIN - SIGDIA
8455 PDDBAR = HLFHLF
8456* | | |
8457* | | +-------------------------------------------------------------*
8458* | | | Neutron target: (nbar n)el is supposed to be equal to
8459* | | | (pbar p)el (reasonable above 5 GeV/c)
8460 ELSE
8461* | | | Compute the total cross section:
8462 SHNCTT = SAPPTT
8463* | | | Compute the elastic cross section:
8464 SHNCEL = SAPPEL
8465* | | | Compute the inelastic cross section:
8466 SHNCIN = SHNCTT - SHNCEL
8467 PDDBAR = 0.8D+00
8468 END IF
8469* | | |
8470* | | +-------------------------------------------------------------*
8471* | | Now compute the chain end (anti)quark-(anti)diquark
8472* | | there are different possibilities, make a random choiche:
8473 IQFSC1 = -2
8474 RNCHEN = DT_RNDM(RNCHEN)
8475 IF ( RNCHEN .LT. PDDBAR ) THEN
8476 IQFSC2 = -1
8477 ELSE
8478 IQFSC2 = -2
8479 END IF
8480 IQBSC1 = -IQFSC1 + KHELP - 1
8481 IQBSC2 = -IQFSC2
8482 END IF
8483* | |
8484* | +----------------------------------------------------------------*
8485* |
8486* +-------------------------------------------------------------------*
8487* | Others: not yet implemented
8488 ELSE
8489 SIGDIA = ZERZER
8490 SHNCIN = ONEONE
8491 NDIAGR = 0
8492 DT_PHNSCH = ZERZER
8493 RETURN
8494 END IF
8495* | end others
8496* +-------------------------------------------------------------------*
8497 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8498 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8499 & + IQECHR (IQBSC2)
8500 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8501 & + IQBCHR (IQBSC2)
8502 IQECHC = IQECHC / 3
8503 IQBCHC = IQBCHC / 3
8504 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8505 & + IQSCHR (IQBSC2)
8506 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8507 & + IQSCHR (MQUARK(3,IP))
8508* +-------------------------------------------------------------------*
8509* | Consistency check:
8510 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8511 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8512 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8513 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8514 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8515 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8516 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8517 END IF
8518* |
8519* +-------------------------------------------------------------------*
8520* +-------------------------------------------------------------------*
8521* | Consistency check:
8522 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8523 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8524 WRITE (LUNOUT,*)
8525 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8526 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8527 WRITE (LUNERR,*)
8528 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8529 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8530 END IF
8531* |
8532* +-------------------------------------------------------------------*
8533* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8534 IF ( UMORAT .GT. ONEPLS )
8535 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8536 & - ONEONE ) * UMORAT + ONEONE )
8537 RETURN
8538*
8539 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8540 DT_SCHQUA = ONEONE
8541 JQFSC1 = IQFSC1
8542 JQFSC2 = IQFSC2
8543 JQBSC1 = IQBSC1
8544 JQBSC2 = IQBSC2
8545*=== End of function Phnsch ===========================================*
8546 RETURN
8547 END
8548
8549*$ CREATE DT_RESPT.FOR
8550*COPY DT_RESPT
8551*
8552*===respt==============================================================*
8553*
8554 SUBROUTINE DT_RESPT
8555
8556************************************************************************
8557* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8558* This version dated 18.01.95 is written by S. Roesler *
8559************************************************************************
8560
8561 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8562 SAVE
8563
8564 PARAMETER ( LINP = 10 ,
8565 & LOUT = 6 ,
8566 & LDAT = 9 )
8567
8568 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8569
8570* event history
8571
8572 PARAMETER (NMXHKK=200000)
8573
8574 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8575 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8576 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8577
8578* extended event history
8579 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8580 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8581 & IHIST(2,NMXHKK)
8582
8583* get index of first chain
8584 DO 1 I=NPOINT(3),NHKK
8585 IF (IDHKK(I).EQ.88888) THEN
8586 NC = I
8587 GOTO 2
8588 ENDIF
8589 1 CONTINUE
8590
8591 2 CONTINUE
8592 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8593C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8594* skip VV-,SS- systems
8595 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8596 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8597* check if both "chains" are resonances
8598 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8599 CALL DT_SAPTRE(NC,NC+3)
8600 ENDIF
8601 ENDIF
8602 ELSE
8603 GOTO 3
8604 ENDIF
8605 NC = NC+6
8606 GOTO 2
8607
8608 3 CONTINUE
8609
8610 RETURN
8611 END
8612
8613*$ CREATE DT_EVTRES.FOR
8614*COPY DT_EVTRES
8615*
8616*===evtres=============================================================*
8617*
8618 SUBROUTINE DT_EVTRES(IREJ)
8619
8620************************************************************************
8621* This version dated 14.12.94 is written by S. Roesler *
8622************************************************************************
8623
8624 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8625 SAVE
8626
8627 PARAMETER ( LINP = 10 ,
8628 & LOUT = 6 ,
8629 & LDAT = 9 )
8630
8631 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8632
8633* event history
8634
8635 PARAMETER (NMXHKK=200000)
8636
8637 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8638 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8639 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8640
8641* extended event history
8642 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8643 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8644 & IHIST(2,NMXHKK)
8645
8646* flags for input different options
8647 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8648 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8649 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8650
8651* particle properties (BAMJET index convention)
8652 CHARACTER*8 ANAME
8653 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8654 & IICH(210),IIBAR(210),K1(210),K2(210)
8655
8656 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8657
8658 IREJ = 0
8659
8660 DO 1 I=NPOINT(3),NHKK
8661 IF (ABS(IDRES(I)).GE.100) THEN
8662 AMMX = 0.0D0
8663 DO 2 J=NPOINT(3),NHKK
8664 IF (IDHKK(J).EQ.88888) THEN
8665 IF (PHKK(5,J).GT.AMMX) THEN
8666 AMMX = PHKK(5,J)
8667 IMMX = J
8668 ENDIF
8669 ENDIF
8670 2 CONTINUE
8671 IF (IDRES(IMMX).NE.0) THEN
8672 IF (IOULEV(3).GT.0) THEN
8673 WRITE(LOUT,'(1X,A)')
8674 & 'EVTRES: no chain for correc. found'
8675C GOTO 6
8676 GOTO 9999
8677 ELSE
8678 GOTO 9999
8679 ENDIF
8680 ENDIF
8681 IMO11 = JMOHKK(1,I)
8682 IMO12 = JMOHKK(2,I)
8683 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8684 IMO11 = JMOHKK(2,I)
8685 IMO12 = JMOHKK(1,I)
8686 ENDIF
8687 IMO21 = JMOHKK(1,IMMX)
8688 IMO22 = JMOHKK(2,IMMX)
8689 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8690 IMO21 = JMOHKK(2,IMMX)
8691 IMO22 = JMOHKK(1,IMMX)
8692 ENDIF
8693 AMCH1 = PHKK(5,I)
8694 AMCH1N = AAM(IDXRES(I))
8695
8696 IFPR1 = IDHKK(IMO11)
8697 IFPR2 = IDHKK(IMO21)
8698 IFTA1 = IDHKK(IMO12)
8699 IFTA2 = IDHKK(IMO22)
8700 DO 4 J=1,4
8701 PP1(J) = PHKK(J,IMO11)
8702 PP2(J) = PHKK(J,IMO21)
8703 PT1(J) = PHKK(J,IMO12)
8704 PT2(J) = PHKK(J,IMO22)
8705 4 CONTINUE
8706* store initial configuration for energy-momentum cons. check
8707 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8708* correct kinematics of second chain
8709 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8710 & AMCH1,AMCH1N,AMCH2,IREJ1)
8711 IF (IREJ1.NE.0) GOTO 9999
8712* check now this chain for resonance mass
8713 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8714 IFP(2) = 0
8715 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8716 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8717 IFT(2) = 0
8718 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8719 IDCH2 = 2
8720 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8721 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8722 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8723 & AMCH2,AMCH2N,IDCH2,IREJ1)
8724 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8725 IF (IOULEV(1).GT.0)
8726 & WRITE(LOUT,*) ' correction for resonance not poss.'
8727**sr test
8728C GOTO 1
8729C GOTO 9999
8730**
8731 ENDIF
8732* store final configuration for energy-momentum cons. check
8733 IF (LEMCCK) THEN
8734 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8735 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8736 IF (IREJ1.NE.0) GOTO 9999
8737 ENDIF
8738 DO 5 J=1,4
8739 PHKK(J,IMO11) = PP1(J)
8740 PHKK(J,IMO21) = PP2(J)
8741 PHKK(J,IMO12) = PT1(J)
8742 PHKK(J,IMO22) = PT2(J)
8743 5 CONTINUE
8744* correct entries of chains
8745 DO 3 K=1,4
8746 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8747 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8748 3 CONTINUE
8749 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8750 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8751 & PHKK(3,IMMX)**2
8752* ?? the following should now be obsolete
8753**sr test
8754C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8755 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8756**
8757 WRITE(LOUT,'(1X,A,4G10.3)')
8758 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8759C GOTO 9999
8760 GOTO 1
8761 ENDIF
8762 PHKK(5,I) = SQRT(AM1)
8763 PHKK(5,IMMX) = SQRT(AM2)
8764 IDRES(I) = IDRES(I)/100
8765 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8766 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8767 WRITE(LOUT,'(1X,A,4G10.3)')
8768 & 'EVTRES: inconsistent chain-masses',
8769 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8770 GOTO 9999
8771 ENDIF
8772 ENDIF
8773 1 CONTINUE
8774 6 CONTINUE
8775 RETURN
8776
8777 9999 CONTINUE
8778 IREJ = 1
8779 RETURN
8780 END
8781
8782*$ CREATE DT_GETSPT.FOR
8783*COPY DT_GETSPT
8784*
8785*===getspt=============================================================*
8786*
8787 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8788 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8789 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8790
8791************************************************************************
8792* This version dated 12.12.94 is written by S. Roesler *
8793************************************************************************
8794
8795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8796 SAVE
8797
8798 PARAMETER ( LINP = 10 ,
8799 & LOUT = 6 ,
8800 & LDAT = 9 )
8801
8802 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8803
8804* various options for treatment of partons (DTUNUC 1.x)
8805* (chain recombination, Cronin,..)
8806 LOGICAL LCO2CR,LINTPT
8807 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8808 & LCO2CR,LINTPT
8809
8810* flags for input different options
8811 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8812 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8813 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8814
8815* flags for diffractive interactions (DTUNUC 1.x)
8816 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8817
8818 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8819 & PT2(4),PT2I(4),P1(4),P2(4),
8820 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8821 & PTOTI(4),PTOTF(4),DIFF(4)
8822
8823 IC = 0
8824 IREJ = 0
8825C B33P = 4.0D0
8826C B33T = 4.0D0
8827C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8828C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8829 REDU = 1.0D0
8830C B33P = 3.5D0
8831C B33T = 3.5D0
8832 B33P = 4.0D0
8833 B33T = 4.0D0
8834 IF (IDIFF.NE.0) THEN
8835 B33P = 16.0D0
8836 B33T = 16.0D0
8837 ENDIF
8838
8839 DO 1 I=1,4
8840 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8841 PP1(I) = PP1I(I)
8842 PP2(I) = PP2I(I)
8843 PT1(I) = PT1I(I)
8844 PT2(I) = PT2I(I)
8845 1 CONTINUE
8846* get initial chain masses
8847 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8848 & +(PP1(3)+PT1(3))**2)
8849 ECH = PP1(4)+PT1(4)
8850 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8851 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8852 & +(PP2(3)+PT2(3))**2)
8853 ECH = PP2(4)+PT2(4)
8854 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8855 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8856 IF (IOULEV(1).GT.0)
8857 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8858 & AM1,AM2
8859 GOTO 9999
8860 ENDIF
8861 AM1 = SQRT(AM1)
8862 AM2 = SQRT(AM2)
8863 AM1N = ZERO
8864 AM2N = ZERO
8865
8866 MODE = 0
8867C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8868C MODE = 0
8869C ELSE
8870C MODE = 1
8871C IF (AM1.LT.0.6) THEN
8872C B33P = 10.0D0
8873C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8874CC B33P = 4.0D0
8875C ENDIF
8876C IF (AM2.LT.0.6) THEN
8877C B33T = 10.0D0
8878C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8879CC B33T = 4.0D0
8880C ENDIF
8881C ENDIF
8882
8883* check chain masses for very low mass chains
8884C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8885C & AM1,DUM,-IDCH1,IREJ1)
8886C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8887C & AM2,DUM,-IDCH2,IREJ2)
8888C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8889C B33P = 20.0D0
8890C B33T = 20.0D0
8891C ENDIF
8892
8893 JMSHL = IMSHL
8894
8895 2 CONTINUE
8896 IC = IC+1
8897 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8898 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8899 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8900C IF (MOD(IC,19).EQ.0) JMSHL = 0
8901 IF (MOD(IC,20).EQ.0) GOTO 7
8902C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8903C RETURN
8904C GOTO 9999
8905C ENDIF
8906
8907* get transverse momentum
8908 IF (LINTPT) THEN
8909 ES = -2.0D0/(B33P**2)
8910 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8911 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8912 HPSP = HPSP*REDU
8913 ES = -2.0D0/(B33T**2)
8914 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8915 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8916 HPST = HPST*REDU
8917 ELSE
8918 HPSP = ZERO
8919 HPST = ZERO
8920 ENDIF
8921 CALL DT_DSFECF(SFE1,CFE1)
8922 CALL DT_DSFECF(SFE2,CFE2)
8923 IF (MODE.EQ.0) THEN
8924 PP1(1) = PP1I(1)+HPSP*CFE1
8925 PP1(2) = PP1I(2)+HPSP*SFE1
8926 PP2(1) = PP2I(1)-HPSP*CFE1
8927 PP2(2) = PP2I(2)-HPSP*SFE1
8928 PT1(1) = PT1I(1)+HPST*CFE2
8929 PT1(2) = PT1I(2)+HPST*SFE2
8930 PT2(1) = PT2I(1)-HPST*CFE2
8931 PT2(2) = PT2I(2)-HPST*SFE2
8932 ELSE
8933 PP1(1) = PP1I(1)+HPSP*CFE1
8934 PP1(2) = PP1I(2)+HPSP*SFE1
8935 PT1(1) = PT1I(1)-HPSP*CFE1
8936 PT1(2) = PT1I(2)-HPSP*SFE1
8937 PP2(1) = PP2I(1)+HPST*CFE2
8938 PP2(2) = PP2I(2)+HPST*SFE2
8939 PT2(1) = PT2I(1)-HPST*CFE2
8940 PT2(2) = PT2I(2)-HPST*SFE2
8941 ENDIF
8942
8943* put partons on mass shell
8944 XMP1 = 0.0D0
8945 XMT1 = 0.0D0
8946 IF (JMSHL.EQ.1) THEN
8947
8948 XMP1 = PYMASS(IFPR1)
8949 XMT1 = PYMASS(IFTA1)
8950
8951 ENDIF
8952 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8953 IF (IREJ1.NE.0) GOTO 2
8954 DO 3 I=1,4
8955 PTOTF(I) = P1(I)+P2(I)
8956 PP1(I) = P1(I)
8957 PT1(I) = P2(I)
8958 3 CONTINUE
8959 XMP2 = 0.0D0
8960 XMT2 = 0.0D0
8961 IF (JMSHL.EQ.1) THEN
8962
8963 XMP2 = PYMASS(IFPR2)
8964 XMT2 = PYMASS(IFTA2)
8965
8966 ENDIF
8967 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8968 IF (IREJ1.NE.0) GOTO 2
8969 DO 4 I=1,4
8970 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8971 PP2(I) = P1(I)
8972 PT2(I) = P2(I)
8973 4 CONTINUE
8974
8975* check consistency
8976 DO 5 I=1,4
8977 DIFF(I) = PTOTI(I)-PTOTF(I)
8978 5 CONTINUE
8979 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8980 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8981 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8982 GOTO 9999
8983 ENDIF
8984 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8985 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8986 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8987 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8988 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8989 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8990 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8991 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8992 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8993 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8994 & THEN
8995 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8996 & 'GETSPT: inconsistent masses',
8997 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8998* sr 22.11.00: commented. It should only have inconsistent masses for
8999* ultrahigh energies due to rounding problems
9000C GOTO 9999
9001 ENDIF
9002
9003* get chain masses
9004 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9005 & +(PP1(3)+PT1(3))**2)
9006 ECH = PP1(4)+PT1(4)
9007 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
9008 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9009 & +(PP2(3)+PT2(3))**2)
9010 ECH = PP2(4)+PT2(4)
9011 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
9012 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9013 IF (IOULEV(1).GT.0)
9014 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9015 & AM1N,AM2N
9016 GOTO 2
9017 ENDIF
9018 AM1N = SQRT(AM1N)
9019 AM2N = SQRT(AM2N)
9020
9021* check chain masses for very low mass chains
9022 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9023 & AM1N,DUM,-IDCH1,IREJ1)
9024 IF (IREJ1.NE.0) GOTO 2
9025 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9026 & AM2N,DUM,-IDCH2,IREJ2)
9027 IF (IREJ2.NE.0) GOTO 2
9028
9029 7 CONTINUE
9030 IF (AM1N.GT.ZERO) THEN
9031 AM1 = AM1N
9032 AM2 = AM2N
9033 ENDIF
9034 DO 6 I=1,4
9035 PP1I(I) = PP1(I)
9036 PP2I(I) = PP2(I)
9037 PT1I(I) = PT1(I)
9038 PT2I(I) = PT2(I)
9039 6 CONTINUE
9040
9041 RETURN
9042
9043 9999 CONTINUE
9044 IREJ = 1
9045 RETURN
9046 END
9047
9048*$ CREATE DT_SAPTRE.FOR
9049*COPY DT_SAPTRE
9050*
9051*===saptre=============================================================*
9052*
9053 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9054
9055************************************************************************
9056* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9057* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9058* Adopted from the original SAPTRE written by J. Ranft. *
9059* This version dated 18.01.95 is written by S. Roesler *
9060************************************************************************
9061
9062 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9063 SAVE
9064
9065 PARAMETER ( LINP = 10 ,
9066 & LOUT = 6 ,
9067 & LDAT = 9 )
9068
9069 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9070
9071* event history
9072
9073 PARAMETER (NMXHKK=200000)
9074
9075 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9076 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9077 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9078
9079* extended event history
9080 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9081 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9082 & IHIST(2,NMXHKK)
9083
9084* flags for input different options
9085 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9086 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9087 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9088
9089 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9090
9091 DATA B3 /4.0D0/
9092
9093 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9094 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9095 ESMAX = MIN(ESMAX1,ESMAX2)
9096 IF (ESMAX.LE.0.05D0) RETURN
9097
9098 HMA = PHKK(5,IDX1)
9099 DO 1 K=1,4
9100 PA1(K) = PHKK(K,IDX1)
9101 PA2(K) = PHKK(K,IDX2)
9102 1 CONTINUE
9103
9104 IF (LEMCCK) THEN
9105 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9106 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9107 ENDIF
9108
9109 EXEB = 0.0D0
9110 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9111 BEXP = HMA*(1.0D0-EXEB)/B3
9112 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9113 WA = AXEXP/(BEXP+AXEXP)
9114 XAB = DT_RNDM(WA)
9115 10 CONTINUE
9116* ES is the transverse kinetic energy
9117 IF (XAB.LT.WA)THEN
9118 X = DT_RNDM(WA)
9119 Y = DT_RNDM(WA)
9120 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9121 ELSE
9122 X = DT_RNDM(Y)
9123 ES = ABS(-LOG(X+TINY7)/B3)
9124 ENDIF
9125 IF (ES.GT.ESMAX) GOTO 10
9126 ES = ES+HMA
9127* transverse momentum
9128 HPS = SQRT((ES-HMA)*(ES+HMA))
9129
9130 CALL DT_DSFECF(SFE,CFE)
9131 HPX = HPS*CFE
9132 HPY = HPS*SFE
9133 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9134 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9135 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9136
9137C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9138C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9139 PA1(1) = PA1(1)+HPX
9140 PA1(2) = PA1(2)+HPY
9141 PA2(1) = PA2(1)-HPX
9142 PA2(2) = PA2(2)-HPY
9143
9144* put resonances on mass-shell again
9145 XM1 = PHKK(5,IDX1)
9146 XM2 = PHKK(5,IDX2)
9147 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9148 IF (IREJ1.NE.0) RETURN
9149
9150 IF (LEMCCK) THEN
9151 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9152 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9153 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9154 IF (IREJ1.NE.0) RETURN
9155 ENDIF
9156
9157 DO 2 K=1,4
9158 PHKK(K,IDX1) = P1(K)
9159 PHKK(K,IDX2) = P2(K)
9160 2 CONTINUE
9161
9162 RETURN
9163 END
9164
9165*$ CREATE DT_CRONIN.FOR
9166*COPY DT_CRONIN
9167*
9168*===cronin=============================================================*
9169*
9170 SUBROUTINE DT_CRONIN(INCL)
9171
9172************************************************************************
9173* Cronin-Effect. Multiple scattering of partons at chain ends. *
9174* INCL = 1 multiple sc. in projectile *
9175* = 2 multiple sc. in target *
9176* This version dated 05.01.96 is written by S. Roesler. *
9177************************************************************************
9178
9179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9180 SAVE
9181
9182 PARAMETER ( LINP = 10 ,
9183 & LOUT = 6 ,
9184 & LDAT = 9 )
9185
9186 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9187
9188* event history
9189
9190 PARAMETER (NMXHKK=200000)
9191
9192 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9193 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9194 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9195
9196* extended event history
9197 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9198 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9199 & IHIST(2,NMXHKK)
9200
9201* rejection counter
9202 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9203 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9204 & IREXCI(3),IRDIFF(2),IRINC
9205
9206* Glauber formalism: collision properties
9207 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 9208 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9209 & NCP,NCT
7b076c76 9210 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9211
9212 DO 1 K=1,4
9213 DEV(K) = ZERO
9214 1 CONTINUE
9215
9216 DO 2 I=NPOINT(2),NHKK
9217 IF (ISTHKK(I).LT.0) THEN
9218* get z-position of the chain
9219 R(1) = VHKK(1,I)*1.0D12
9220 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9221 R(2) = VHKK(2,I)*1.0D12
9222 IDXNU = JMOHKK(1,I)
9223 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9224 & IDXNU = JMOHKK(1,I-1)
9225 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9226 & IDXNU = JMOHKK(1,I+1)
9227 R(3) = VHKK(3,IDXNU)*1.0D12
9228* position of target parton the chain is connected to
9229 DO 3 K=1,4
9230 PIN(K) = PHKK(K,I)
9231 3 CONTINUE
9232* multiple scattering of parton with DTEVT1-index I
9233 CALL DT_CROMSC(PIN,R,POUT,INCL)
9234**testprint
9235C IF (NEVHKK.EQ.5) THEN
9236C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9237C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9238C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9239C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9240C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9241C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9242C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9243C ENDIF
9244**
9245* increase accumulator by energy-momentum difference
9246 DO 4 K=1,4
9247 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9248 PHKK(K,I) = POUT(K)
9249 4 CONTINUE
9250 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9251 & PHKK(2,I)**2-PHKK(3,I)**2))
9252 ENDIF
9253 2 CONTINUE
9254
9255* dump accumulator to momenta of valence partons
9256 NVAL = 0
9257 ETOT = 0.0D0
9258 DO 5 I=NPOINT(2),NHKK
9259 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9260 NVAL = NVAL+1
9261 ETOT = ETOT+PHKK(4,I)
9262 ENDIF
9263 5 CONTINUE
9264C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9265 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9266 & 9X,4E12.4)
9267 DO 6 I=NPOINT(2),NHKK
9268 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9269 E = PHKK(4,I)
9270 DO 7 K=1,4
9271C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9272 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9273 7 CONTINUE
9274 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9275 & PHKK(2,I)**2-PHKK(3,I)**2))
9276 ENDIF
9277 6 CONTINUE
9278
9279 RETURN
9280 END
9281
9282*$ CREATE DT_CROMSC.FOR
9283*COPY DT_CROMSC
9284*
9285*===cromsc=============================================================*
9286*
9287 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9288
9289************************************************************************
9290* Cronin-Effect. Multiple scattering of one parton passing through *
9291* nuclear matter. *
9292* PIN(4) input 4-momentum of parton *
9293* POUT(4) 4-momentum of parton after mult. scatt. *
9294* R(3) spatial position of parton in target nucleus *
9295* INCL = 1 multiple sc. in projectile *
9296* = 2 multiple sc. in target *
9297* This is a revised version of the original version written by J. Ranft*
9298* This version dated 17.01.95 is written by S. Roesler. *
9299************************************************************************
9300
9301 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9302 SAVE
9303
9304 PARAMETER ( LINP = 10 ,
9305 & LOUT = 6 ,
9306 & LDAT = 9 )
9307
9308 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9309
9310 LOGICAL LSTART
9311
9312* rejection counter
9313 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9314 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9315 & IREXCI(3),IRDIFF(2),IRINC
9316
9317* Glauber formalism: collision properties
9318 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 9319 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9320 & NCP,NCT
7b076c76 9321
9322* various options for treatment of partons (DTUNUC 1.x)
9323* (chain recombination, Cronin,..)
9324 LOGICAL LCO2CR,LINTPT
9325 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9326 & LCO2CR,LINTPT
9327
9328 DIMENSION PIN(4),POUT(4),R(3)
9329
9330 DATA LSTART /.TRUE./
9331
9332 IRCRON(1) = IRCRON(1)+1
9333
9334 IF (LSTART) THEN
9335 WRITE(LOUT,1000) CRONCO
9336 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9337 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9338 LSTART = .FALSE.
9339 ENDIF
9340
9341 NCBACK = 0
9342 RNCL = RPROJ
9343 IF (INCL.EQ.2) RNCL = RTARG
9344
9345* Lorentz-transformation into Lab.
9346 MODE = -(INCL+1)
9347 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9348
9349 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9350 IF (PTOT.LE.8.0D0) GOTO 9997
9351
9352* direction cosines of parton before mult. scattering
9353 COSX = PIN(1)/PTOT
9354 COSY = PIN(2)/PTOT
9355 COSZ = PZ/PTOT
9356
9357 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9358 IF (RTESQ.GE.-TINY3) GOTO 9999
9359
9360* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9361* in the direction of particle motion
9362
9363 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9364 TMP = A**2-RTESQ
9365 IF (TMP.LT.ZERO) GOTO 9998
9366 DIST = -A+SQRT(TMP)
9367
9368* multiple scattering angle
9369 THETO = CRONCO*SQRT(DIST)/PTOT
9370 IF (THETO.GT.0.1D0) THETO=0.1D0
9371
9372 1 CONTINUE
9373* Gaussian sampling of spatial angle
9374 CALL DT_RANNOR(R1,R2)
9375 THETA = ABS(R1*THETO)
9376 IF (THETA.GT.0.3D0) GOTO 9997
9377 CALL DT_DSFECF(SFE,CFE)
9378 COSTH = COS(THETA)
9379 SINTH = SIN(THETA)
9380
9381* new direction cosines
9382 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9383 & COSXN,COSYN,COSZN)
9384
9385 POUT(1) = COSXN*PTOT
9386 POUT(2) = COSYN*PTOT
9387 PZ = COSZN*PTOT
9388* Lorentz-transformation into nucl.-nucl. cms
9389 MODE = INCL+1
9390 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9391
9392C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9393C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9394 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9395 THETO = THETO/2.0D0
9396 NCBACK = NCBACK+1
9397 IF (MOD(NCBACK,200).EQ.0) THEN
9398 WRITE(LOUT,1001) THETO,PIN,POUT
9399 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9400 & E12.4,/,1X,' PIN :',4E12.4,/,
9401 & 1X,' POUT:',4E12.4)
9402 GOTO 9997
9403 ENDIF
9404 GOTO 1
9405 ENDIF
9406
9407 RETURN
9408
9409 9997 IRCRON(2) = IRCRON(2)+1
9410 GOTO 9999
9411 9998 IRCRON(3) = IRCRON(3)+1
9412
9413 9999 CONTINUE
9414 DO 100 K=1,4
9415 POUT(K) = PIN(K)
9416 100 CONTINUE
9417 RETURN
9418 END
9419
9420*$ CREATE DT_COM2CR.FOR
9421*COPY DT_COM2CR
9422*
9423*===com2sr=============================================================*
9424*
9425 SUBROUTINE DT_COM2CR
9426
9427************************************************************************
9428* COMbine q-aq chains to Color Ropes (qq-aqaq). *
9429* CUTOF parameter determining minimum number of not *
9430* combined q-aq chains *
9431* This subroutine replaces KKEVCC etc. *
9432* This version dated 11.01.95 is written by S. Roesler. *
9433************************************************************************
9434
9435 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9436 SAVE
9437
9438 PARAMETER ( LINP = 10 ,
9439 & LOUT = 6 ,
9440 & LDAT = 9 )
9441
9442* event history
9443
9444 PARAMETER (NMXHKK=200000)
9445
9446 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9447 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9448 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9449
9450* extended event history
9451 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9452 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9453 & IHIST(2,NMXHKK)
9454
9455* statistics
9456 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9457 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9458 & ICEVTG(8,0:30)
9459
9460* various options for treatment of partons (DTUNUC 1.x)
9461* (chain recombination, Cronin,..)
9462 LOGICAL LCO2CR,LINTPT
9463 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9464 & LCO2CR,LINTPT
9465
9466 DIMENSION IDXQA(248),IDXAQ(248)
9467
9468 ICCHAI(1,9) = ICCHAI(1,9)+1
9469 NQA = 0
9470 NAQ = 0
9471* scan DTEVT1 for q-aq, aq-q chains
9472 DO 10 I=NPOINT(3),NHKK
9473* skip "chains" which are resonances
9474 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9475 MO1 = JMOHKK(1,I)
9476 MO2 = JMOHKK(2,I)
9477 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9478* q-aq, aq-q chain found, keep index
9479 IF (IDHKK(MO1).GT.0) THEN
9480 NQA = NQA+1
9481 IDXQA(NQA) = I
9482 ELSE
9483 NAQ = NAQ+1
9484 IDXAQ(NAQ) = I
9485 ENDIF
9486 ENDIF
9487 ENDIF
9488 10 CONTINUE
9489
9490* minimum number of q-aq chains requested for the same projectile/
9491* target
9492 NCHMIN = IDT_NPOISS(CUTOF)
9493
9494* combine q-aq chains of the same projectile
9495 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9496* combine q-aq chains of the same target
9497 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9498* combine aq-q chains of the same projectile
9499 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9500* combine aq-q chains of the same target
9501 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9502
9503 RETURN
9504 END
9505
9506*$ CREATE DT_SCN4CR.FOR
9507*COPY DT_SCN4CR
9508*
9509*===scn4cr=============================================================*
9510*
9511 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9512
9513************************************************************************
9514* SCan q-aq chains for Color Ropes. *
9515* This version dated 11.01.95 is written by S. Roesler. *
9516************************************************************************
9517
9518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9519 SAVE
9520
9521 PARAMETER ( LINP = 10 ,
9522 & LOUT = 6 ,
9523 & LDAT = 9 )
9524
9525* event history
9526
9527 PARAMETER (NMXHKK=200000)
9528
9529 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9530 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9531 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9532
9533* extended event history
9534 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9535 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9536 & IHIST(2,NMXHKK)
9537
9538 DIMENSION IDXCH(248),IDXJN(248)
9539
9540 DO 1 I=1,NCH
9541 IF (IDXCH(I).GT.0) THEN
9542 NJOIN = 1
9543 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9544 IDXJN(NJOIN) = I
9545 IF (I.LT.NCH) THEN
9546 DO 2 J=I+1,NCH
9547 IF (IDXCH(J).GT.0) THEN
9548 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9549 IF (IDXMO.EQ.IDXMO1) THEN
9550 NJOIN = NJOIN+1
9551 IDXJN(NJOIN) = J
9552 ENDIF
9553 ENDIF
9554 2 CONTINUE
9555 ENDIF
9556 IF (NJOIN.GE.NCHMIN+2) THEN
9557 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9558 DO 3 J=1,2*NJ,2
9559 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9560 IF (IREJ1.NE.0) GOTO 3
9561 IDXCH(IDXJN(J)) = 0
9562 IDXCH(IDXJN(J+1)) = 0
9563 3 CONTINUE
9564 ENDIF
9565 ENDIF
9566 1 CONTINUE
9567
9568 RETURN
9569 END
9570
9571*$ CREATE DT_JOIN.FOR
9572*COPY DT_JOIN
9573*
9574*===join===============================================================*
9575*
9576 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9577
9578************************************************************************
9579* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9580* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9581* This version dated 11.01.95 is written by S. Roesler. *
9582************************************************************************
9583
9584 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9585 SAVE
9586
9587 PARAMETER ( LINP = 10 ,
9588 & LOUT = 6 ,
9589 & LDAT = 9 )
9590
9591* event history
9592
9593 PARAMETER (NMXHKK=200000)
9594
9595 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9596 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9597 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9598
9599* extended event history
9600 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9601 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9602 & IHIST(2,NMXHKK)
9603
9604* flags for input different options
9605 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9606 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9607 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9608
9609* statistics
9610 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9611 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9612 & ICEVTG(8,0:30)
9613
9614 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9615
9616 IREJ = 0
9617
9618 IDX(1) = IDX1
9619 IDX(2) = IDX2
9620 DO 1 I=1,2
9621 DO 2 J=1,2
9622 MO(I,J) = JMOHKK(J,IDX(I))
9623 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9624 2 CONTINUE
9625 1 CONTINUE
9626
9627* check consistency
9628 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9629 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9630 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9631 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9632 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9633 & MO(2,2)
9634 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9635 & 2I5,' chain ',I4,':',2I5)
9636 ENDIF
9637
9638* join chains
9639 DO 3 K=1,4
9640 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9641 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9642 3 CONTINUE
9643 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9644 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9645 IST1 = ISTHKK(MO(1,1))
9646 IST2 = ISTHKK(MO(1,2))
9647
9648* put partons again on mass shell
9649 XM1 = 0.0D0
9650 XM2 = 0.0D0
9651 IF (IMSHL.EQ.1) THEN
9652
9653 XM1 = PYMASS(IF1)
9654 XM2 = PYMASS(IF2)
9655
9656 ENDIF
9657 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9658 IF (IREJ1.NE.0) GOTO 9999
9659 DO 4 I=1,4
9660 PP(I) = P1(I)
9661 PT(I) = P2(I)
9662 4 CONTINUE
9663
9664* store new partons in DTEVT1
9665 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9666 & 0,0,0)
9667 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9668 & 0,0,0)
9669 DO 5 K=1,4
9670 PCH(K) = PP(K)+PT(K)
9671 5 CONTINUE
9672
9673* check new chain for lower mass limit
9674 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9675 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9676 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9677 & AMCH,AMCHN,3,IREJ1)
9678 IF (IREJ1.NE.0) THEN
9679 NHKK = NHKK-2
9680 GOTO 9999
9681 ENDIF
9682 ENDIF
9683
9684 ICCHAI(2,9) = ICCHAI(2,9)+1
9685* store new chain in DTEVT1
9686 KCH = 191
9687 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9688 IDHKK(IDX(1)) = 22222
9689 IDHKK(IDX(2)) = 22222
9690* special treatment for space-time coordinates
9691 DO 6 K=1,4
9692 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9693 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9694 6 CONTINUE
9695 RETURN
9696
9697 9999 CONTINUE
9698 IREJ = 1
9699 RETURN
9700 END
9701*$ CREATE DT_XSGLAU.FOR
9702*COPY DT_XSGLAU
9703*
9704*===xsglau=============================================================*
9705*
9706 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9707
9708************************************************************************
9709* Total, elastic, quasi-elastic, inelastic cross sections according to *
9710* Glauber's approach. *
9711* NA / NB mass numbers of proj./target nuclei *
9712* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9713* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9714* IE,IQ indices of energy and virtuality (the latter for gamma *
9715* projectiles only) *
9716* NIDX index of projectile/target nucleus *
9717* This version dated 17.3.98 is written by S. Roesler *
9718************************************************************************
9719
9720 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9721 SAVE
9722
9723 PARAMETER ( LINP = 10 ,
9724 & LOUT = 6 ,
9725 & LDAT = 9 )
9726
9727 COMPLEX*16 CZERO,CONE,CTWO
9728 CHARACTER*12 CFILE
9729 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9730 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9731 PARAMETER (TWOPI = 6.283185307179586454D+00,
9732 & PI = TWOPI/TWO,
9733 & GEV2MB = 0.38938D0,
9734 & GEV2FM = 0.1972D0,
9735 & ALPHEM = ONE/137.0D0,
9736* proton mass
9737 & AMP = 0.938D0,
9738 & AMP2 = AMP**2,
9739* approx. nucleon radius
9740 & RNUCLE = 1.12D0)
9741
9742* particle properties (BAMJET index convention)
9743 CHARACTER*8 ANAME
9744 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9745 & IICH(210),IIBAR(210),K1(210),K2(210)
9746
9747 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9748
9749 PARAMETER ( MAXNCL = 260,
9750
9751 & MAXVQU = MAXNCL,
9752 & MAXSQU = 20*MAXVQU,
9753 & MAXINT = MAXVQU+MAXSQU)
9754
9755* Glauber formalism: parameters
9756 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9757 & BMAX(NCOMPX),BSTEP(NCOMPX),
9758 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9759 & NSITEB,NSTATB
9760
9761* Glauber formalism: cross sections
9762 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9763 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9764 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9765 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9766 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9767 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9768 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9769 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9770 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9771 & BSLOPE,NEBINI,NQBINI
9772
9773* Glauber formalism: flags and parameters for statistics
9774 LOGICAL LPROD
9775 CHARACTER*8 CGLB
9776 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9777
9778* nucleon-nucleon event-generator
9779 CHARACTER*8 CMODEL
9780 LOGICAL LPHOIN
9781 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9782
9783* VDM parameter for photon-nucleus interactions
9784 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9785
9786* parameters for hA-diffraction
9787 COMMON /DTDIHA/ DIBETA,DIALPH
9788
9789 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9790 & OMPP11,OMPP12,OMPP21,OMPP22,
9791 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9792 & PPTMP1,PPTMP2
9793 COMPLEX*16 C,CA,CI
9794 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9795 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9796 & BPROD(KSITEB)
9797
9798 PARAMETER (NPOINT=16)
9799 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9800
9801 LOGICAL LFIRST,LOPEN
9802 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9803
9804 NTARG = ABS(NIDX)
9805* for quasi-elastic neutrino scattering set projectile to proton
9806* it should not have an effect since the whole Glauber-formalism is
9807* not needed for these interactions..
9808 IF (MCGENE.EQ.4) THEN
9809 IJPROJ = 1
9810 ELSE
9811 IJPROJ = JJPROJ
9812 ENDIF
9813
9814 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9815 I = INDEX(CGLB,' ')
9816 IF (I.EQ.0) THEN
9817 CFILE = CGLB//'.glb'
9818 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9819 ELSEIF (I.GT.1) THEN
9820 CFILE = CGLB(1:I-1)//'.glb'
9821 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9822 ELSE
9823 STOP 'XSGLAU 1'
9824 ENDIF
9825 LOPEN = .TRUE.
9826 ENDIF
9827
9828 CZERO = DCMPLX(ZERO,ZERO)
9829 CONE = DCMPLX(ONE,ZERO)
9830 CTWO = DCMPLX(TWO,ZERO)
9831 NEBINI = IE
9832 NQBINI = IQ
9833
9834* re-define kinematics
9835 S = ECMI**2
9836 Q2 = Q2I
9837 X = XI
9838* g(Q2=0)-A, h-A, A-A scattering
9839 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9840 Q2 = 0.0001D0
9841 X = Q2/(S+Q2-AMP2)
9842* g(Q2>0)-A scattering
9843 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9844 X = Q2/(S+Q2-AMP2)
9845 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9846 Q2 = (S-AMP2)*X/(ONE-X)
9847 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9848 S = Q2*(ONE-X)/X+AMP2
9849 ELSE
9850 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9851 STOP
9852 ENDIF
9853 ECMNN(IE) = SQRT(S)
9854 Q2G(IQ) = Q2
9855 XNU = (S+Q2-AMP2)/(TWO*AMP)
9856
9857* parameters determining statistics in evaluating Glauber-xsection
9858 NSTATB = JSTATB
9859 NSITEB = JBINSB
9860 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9861
9862* set up interaction geometry (common /DTGLAM/)
9863* projectile/target radii
9864 RPRNCL = DT_RNCLUS(NA)
9865 RTANCL = DT_RNCLUS(NB)
9866 IF (IJPROJ.EQ.7) THEN
9867 RASH(1) = ZERO
9868 RBSH(NTARG) = RTANCL
9869 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9870 ELSE
9871 IF (NIDX.LE.-1) THEN
9872 RASH(1) = RPRNCL
9873 RBSH(NTARG) = RTANCL
9874 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9875 ELSE
9876 RASH(NTARG) = RPRNCL
9877 RBSH(1) = RTANCL
9878 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9879 ENDIF
9880 ENDIF
9881* maximum impact-parameter
9882 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9883
9884* slope, rho ( Re(f(0))/Im(f(0)) )
9885 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9886 IF (MCGENE.EQ.2) THEN
9887 ZERO1 = ZERO
9888 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9889 & BSLOPE,0)
9890 ELSE
9891 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9892 ENDIF
9893 IF (ECMNN(IE).LE.3.0D0) THEN
9894 ROSH = -0.43D0
9895 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9896 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9897 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9898 ROSH = 0.1D0
9899 ENDIF
9900 ELSEIF (IJPROJ.EQ.7) THEN
9901 ROSH = 0.1D0
9902 ELSE
9903 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9904 ROSH = 0.01D0
9905 ENDIF
9906
9907* projectile-nucleon xsection (in fm)
9908 IF (IJPROJ.EQ.7) THEN
9909 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9910 ELSE
9911 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9912 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9913C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9914 DUMZER = ZERO
9915 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9916 SIGSH = SIGSH/10.0D0
9917 ENDIF
9918
9919* parameters for projectile diffraction (hA scattering only)
9920 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9921 & .AND.(DIBETA.GE.ZERO)) THEN
9922 ZERO1 = ZERO
9923 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9924C DIBETA = SDIF1/STOT
9925 DIBETA = 0.2D0
9926 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9927 IF (DIBETA.LE.ZERO) THEN
9928 ALPGAM = ONE
9929 ELSE
9930 ALPGAM = DIALPH/DIGAMM
9931 ENDIF
9932 FACDI1 = ONE-ALPGAM
9933 FACDI2 = ONE+ALPGAM
9934 FACDI = SQRT(FACDI1*FACDI2)
9935 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9936 ELSE
9937 DIBETA = -1.0D0
9938 DIALPH = ZERO
9939 DIGAMM = ZERO
9940 FACDI1 = ZERO
9941 FACDI2 = 2.0D0
9942 FACDI = ZERO
9943 ENDIF
9944
9945* initializations
9946 DO 10 I=1,NSITEB
9947 BSITE( 0,IQ,NTARG,I) = ZERO
9948 BSITE(IE,IQ,NTARG,I) = ZERO
9949 BPROD(I) = ZERO
9950 10 CONTINUE
9951 STOT = ZERO
9952 STOT2 = ZERO
9953 SELA = ZERO
9954 SELA2 = ZERO
9955 SQEP = ZERO
9956 SQEP2 = ZERO
9957 SQET = ZERO
9958 SQET2 = ZERO
9959 SQE2 = ZERO
9960 SQE22 = ZERO
9961 SPRO = ZERO
9962 SPRO2 = ZERO
9963 SDEL = ZERO
9964 SDEL2 = ZERO
9965 SDQE = ZERO
9966 SDQE2 = ZERO
9967 FACN = ONE/DBLE(NSTATB)
9968
9969 IPNT = 0
9970 RPNT = ZERO
9971
9972* initialize Gauss-integration for photon-proj.
9973 JPOINT = 1
9974 IF (IJPROJ.EQ.7) THEN
9975 IF (INTRGE(1).EQ.1) THEN
9976 AMLO2 = (3.0D0*AAM(13))**2
9977 ELSEIF (INTRGE(1).EQ.2) THEN
9978 AMLO2 = AAM(33)**2
9979 ELSE
9980 AMLO2 = AAM(96)**2
9981 ENDIF
9982 IF (INTRGE(2).EQ.1) THEN
9983 AMHI2 = S/TWO
9984 ELSEIF (INTRGE(2).EQ.2) THEN
9985 AMHI2 = S/4.0D0
9986 ELSE
9987 AMHI2 = S
9988 ENDIF
9989 AMHI20 = (ECMNN(IE)-AMP)**2
9990 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9991 XAMLO = LOG( AMLO2+Q2 )
9992 XAMHI = LOG( AMHI2+Q2 )
9993**PHOJET105a
9994C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9995**PHOJET112
9996
9997 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9998
9999**
10000 JPOINT = NPOINT
10001* ratio direct/total photon-nucleon xsection
10002 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10003 ENDIF
10004
10005* read pre-initialized profile-function from file
10006 IF (IOGLB.EQ.1) THEN
10007 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10008 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10009 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10010 & NA,NB,NSTATB,NSITEB
10011 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10012 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10013 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
10014 STOP
10015 ENDIF
10016 IF (LFIRST) WRITE(LOUT,1001) CFILE
10017 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10018 & 'file ',A12,/)
10019 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10020 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10021 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10022 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10023 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10024 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10025 NLINES = INT(DBLE(NSITEB)/7.0D0)
10026 IF (NLINES.GT.0) THEN
10027 DO 21 I=1,NLINES
10028 ISTART = 7*I-6
10029 READ(LDAT,'(7E11.4)')
10030 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10031 21 CONTINUE
10032 ENDIF
10033 ISTART = 7*NLINES+1
10034 IF (ISTART.LE.NSITEB) THEN
10035 READ(LDAT,'(7E11.4)')
10036 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10037 ENDIF
10038 LFIRST = .FALSE.
10039 GOTO 100
10040* variable projectile/target/energy runs:
10041* read pre-initialized profile-functions from file
10042 ELSEIF (IOGLB.EQ.100) THEN
10043 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10044 GOTO 100
10045 ENDIF
10046
10047* cross sections averaged over NSTATB nucleon configurations
10048 DO 11 IS=1,NSTATB
10049C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10050 STOTN = ZERO
10051 SELAN = ZERO
10052 SQEPN = ZERO
10053 SQETN = ZERO
10054 SQE2N = ZERO
10055 SPRON = ZERO
10056 SDELN = ZERO
10057 SDQEN = ZERO
10058
10059 IF (NIDX.LE.-1) THEN
10060 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10061 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10062 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10063 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10064 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10065 ENDIF
10066 ELSE
10067 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10068 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10069 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10070 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10071 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10072 ENDIF
10073 ENDIF
10074
10075* integration over impact parameter B
10076 DO 12 IB=1,NSITEB-1
10077 STOTB = ZERO
10078 SELAB = ZERO
10079 SQEPB = ZERO
10080 SQETB = ZERO
10081 SQE2B = ZERO
10082 SPROB = ZERO
10083 SDIR = ZERO
10084 SDELB = ZERO
10085 SDQEB = ZERO
10086 B = DBLE(IB)*BSTEP(NTARG)
10087 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10088
10089* integration over M_V^2 for photon-proj.
10090 DO 14 IM=1,JPOINT
10091 PP11(1) = CONE
10092 PP12(1) = CONE
10093 PP21(1) = CONE
10094 PP22(1) = CONE
10095 IF (IJPROJ.EQ.7) THEN
10096 DO 13 K=2,NB
10097 PP11(K) = CONE
10098 PP12(K) = CONE
10099 PP21(K) = CONE
10100 PP22(K) = CONE
10101 13 CONTINUE
10102 ENDIF
10103 SHI = ZERO
10104 FACM = ONE
10105 DCOH = 1.0D10
10106
10107 IF (IJPROJ.EQ.7) THEN
10108 AMV2 = EXP(ABSZX(IM))-Q2
10109 AMV = SQRT(AMV2)
10110 IF (AMV2.LT.16.0D0) THEN
10111 R = TWO
10112 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10113 R = 10.0D0/3.0D0
10114 ELSE
10115 R = 11.0D0/3.0D0
10116 ENDIF
10117* define M_V dependent properties of nucleon scattering amplitude
10118* V_M-nucleon xsection
10119 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10120 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10121* slope-parametrisation a la Kaidalov
10122 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10123 & +0.25D0*LOG(S/(AMV2+Q2)))
10124* coherence length
10125 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10126* integration weight factor
10127 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10128 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10129 ENDIF
10130 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10131 GAM = GSH
10132 IF (IJPROJ.EQ.7) THEN
10133 RCA = GAM*SIGMV/TWOPI
10134 ELSE
10135 RCA = GAM*SIGSH/TWOPI
10136 ENDIF
10137 FCA = -ROSH*RCA
10138 CA = DCMPLX(RCA,FCA)
10139 CI = CONE
10140
10141 DO 15 INA=1,NA
10142 KK1 = 1
10143 INT1 = 1
10144 KK2 = 1
10145 INT2 = 1
10146 DO 16 INB=1,NB
10147* photon-projectile: check for supression by coherence length
10148 IF (IJPROJ.EQ.7) THEN
10149 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10150 KK1 = INB
10151 INT1 = INT1+1
10152 ENDIF
10153 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10154 KK2 = INB
10155 INT2 = INT2+1
10156 ENDIF
10157 ENDIF
10158
10159 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10160 Y11 = COOT1(2,INB)-COOP1(2,INA)
10161 XY11 = GAM*(X11*X11+Y11*Y11)
10162 IF (XY11.LE.15.0D0) THEN
10163 C = CONE-CA*EXP(-XY11)
10164 AR = DBLE(PP11(INT1))
10165 AI = DIMAG(PP11(INT1))
10166 IF (ABS(AR).LT.TINY25) AR = ZERO
10167 IF (ABS(AI).LT.TINY25) AI = ZERO
10168 PP11(INT1) = DCMPLX(AR,AI)
10169 PP11(INT1) = PP11(INT1)*C
10170 AR = DBLE(C)
10171 AI = DIMAG(C)
10172 SHI = SHI+LOG(AR*AR+AI*AI)
10173 ENDIF
10174 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10175 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10176 Y12 = COOT2(2,INB)-COOP1(2,INA)
10177 XY12 = GAM*(X12*X12+Y12*Y12)
10178 IF (XY12.LE.15.0D0) THEN
10179 C = CONE-CA*EXP(-XY12)
10180 AR = DBLE(PP12(INT2))
10181 AI = DIMAG(PP12(INT2))
10182 IF (ABS(AR).LT.TINY25) AR = ZERO
10183 IF (ABS(AI).LT.TINY25) AI = ZERO
10184 PP12(INT2) = DCMPLX(AR,AI)
10185 PP12(INT2) = PP12(INT2)*C
10186 ENDIF
10187 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10188 Y21 = COOT1(2,INB)-COOP2(2,INA)
10189 XY21 = GAM*(X21*X21+Y21*Y21)
10190 IF (XY21.LE.15.0D0) THEN
10191 C = CONE-CA*EXP(-XY21)
10192 AR = DBLE(PP21(INT1))
10193 AI = DIMAG(PP21(INT1))
10194 IF (ABS(AR).LT.TINY25) AR = ZERO
10195 IF (ABS(AI).LT.TINY25) AI = ZERO
10196 PP21(INT1) = DCMPLX(AR,AI)
10197 PP21(INT1) = PP21(INT1)*C
10198 ENDIF
10199 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10200 Y22 = COOT2(2,INB)-COOP2(2,INA)
10201 XY22 = GAM*(X22*X22+Y22*Y22)
10202 IF (XY22.LE.15.0D0) THEN
10203 C = CONE-CA*EXP(-XY22)
10204 AR = DBLE(PP22(INT2))
10205 AI = DIMAG(PP22(INT2))
10206 IF (ABS(AR).LT.TINY25) AR = ZERO
10207 IF (ABS(AI).LT.TINY25) AI = ZERO
10208 PP22(INT2) = DCMPLX(AR,AI)
10209 PP22(INT2) = PP22(INT2)*C
10210 ENDIF
10211 ENDIF
10212 16 CONTINUE
10213 15 CONTINUE
10214
10215 OMPP11 = CZERO
10216 OMPP21 = CZERO
10217 DIPP11 = CZERO
10218 DIPP21 = CZERO
10219 DO 17 K=1,INT1
10220 IF (PP11(K).EQ.CZERO) THEN
10221 PPTMP1 = CZERO
10222 PPTMP2 = CZERO
10223 ELSE
10224 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10225 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10226 ENDIF
10227 AVDIPP = 0.5D0*
10228 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10229 OMPP11 = OMPP11+AVDIPP
10230C OMPP11 = OMPP11+(CONE-PP11(K))
10231 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10232 DIPP11 = DIPP11+AVDIPP
10233 IF (PP21(K).EQ.CZERO) THEN
10234 PPTMP1 = CZERO
10235 PPTMP2 = CZERO
10236 ELSE
10237 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10238 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10239 ENDIF
10240 AVDIPP = 0.5D0*
10241 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10242 OMPP21 = OMPP21+AVDIPP
10243C OMPP21 = OMPP21+(CONE-PP21(K))
10244 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10245 DIPP21 = DIPP21+AVDIPP
10246 17 CONTINUE
10247 OMPP12 = CZERO
10248 OMPP22 = CZERO
10249 DIPP12 = CZERO
10250 DIPP22 = CZERO
10251 DO 18 K=1,INT2
10252 IF (PP12(K).EQ.CZERO) THEN
10253 PPTMP1 = CZERO
10254 PPTMP2 = CZERO
10255 ELSE
10256 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10257 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10258 ENDIF
10259 AVDIPP = 0.5D0*
10260 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10261 OMPP12 = OMPP12+AVDIPP
10262C OMPP12 = OMPP12+(CONE-PP12(K))
10263 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10264 DIPP12 = DIPP12+AVDIPP
10265 IF (PP22(K).EQ.CZERO) THEN
10266 PPTMP1 = CZERO
10267 PPTMP2 = CZERO
10268 ELSE
10269 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10270 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10271 ENDIF
10272 AVDIPP = 0.5D0*
10273 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10274 OMPP22 = OMPP22+AVDIPP
10275C OMPP22 = OMPP22+(CONE-PP22(K))
10276 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10277 DIPP22 = DIPP22+AVDIPP
10278 18 CONTINUE
10279
10280 SPROM = ONE-EXP(SHI)
10281 SPROB = SPROB+FACM*SPROM
10282 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10283 STOTM = DBLE(OMPP11+OMPP22)
10284 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10285 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10286 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10287 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10288 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10289 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10290 STOTB = STOTB+FACM*STOTM
10291 SELAB = SELAB+FACM*SELAM
10292 SDELB = SDELB+FACM*SDELM
10293 IF (NB.GT.1) THEN
10294 SQEPB = SQEPB+FACM*SQEPM
10295 SDQEB = SDQEB+FACM*SDQEM
10296 ENDIF
10297 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10298 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10299 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10300 ENDIF
10301
10302 14 CONTINUE
10303
10304 STOTN = STOTN+FACB*STOTB
10305 SELAN = SELAN+FACB*SELAB
10306 SQEPN = SQEPN+FACB*SQEPB
10307 SQETN = SQETN+FACB*SQETB
10308 SQE2N = SQE2N+FACB*SQE2B
10309 SPRON = SPRON+FACB*SPROB
10310 SDELN = SDELN+FACB*SDELB
10311 SDQEN = SDQEN+FACB*SDQEB
10312
10313 IF (IJPROJ.EQ.7) THEN
10314 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10315 ELSE
10316 IF (DIBETA.GT.ZERO) THEN
10317 BPROD(IB+1)= BPROD(IB+1)
10318 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10319 ELSE
10320 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10321 ENDIF
10322 ENDIF
10323
10324 12 CONTINUE
10325
10326 STOT = STOT +FACN*STOTN
10327 STOT2 = STOT2+FACN*STOTN**2
10328 SELA = SELA +FACN*SELAN
10329 SELA2 = SELA2+FACN*SELAN**2
10330 SQEP = SQEP +FACN*SQEPN
10331 SQEP2 = SQEP2+FACN*SQEPN**2
10332 SQET = SQET +FACN*SQETN
10333 SQET2 = SQET2+FACN*SQETN**2
10334 SQE2 = SQE2 +FACN*SQE2N
10335 SQE22 = SQE22+FACN*SQE2N**2
10336 SPRO = SPRO +FACN*SPRON
10337 SPRO2 = SPRO2+FACN*SPRON**2
10338 SDEL = SDEL +FACN*SDELN
10339 SDEL2 = SDEL2+FACN*SDELN**2
10340 SDQE = SDQE +FACN*SDQEN
10341 SDQE2 = SDQE2+FACN*SDQEN**2
10342
10343 11 CONTINUE
10344
10345* final cross sections
10346* 1) total
10347 XSTOT(IE,IQ,NTARG) = STOT
10348 IF (IJPROJ.EQ.7)
10349 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10350* 2) elastic
10351 XSELA(IE,IQ,NTARG) = SELA
10352* 3) quasi-el.: A+B-->A+X (excluding 2)
10353 XSQEP(IE,IQ,NTARG) = SQEP
10354* 4) quasi-el.: A+B-->X+B (excluding 2)
10355 XSQET(IE,IQ,NTARG) = SQET
10356* 5) quasi-el.: A+B-->X (excluding 2-4)
10357 XSQE2(IE,IQ,NTARG) = SQE2
10358* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10359 IF (SDEL.GT.ZERO) THEN
10360 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10361 ELSE
10362 XSPRO(IE,IQ,NTARG) = SPRO
10363 ENDIF
10364* 7) projectile diffraction (el. scatt. off target)
10365 XSDEL(IE,IQ,NTARG) = SDEL
10366* 8) projectile diffraction (quasi-el. scatt. off target)
10367 XSDQE(IE,IQ,NTARG) = SDQE
10368* stat. errors
10369 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10370 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10371 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10372 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10373 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10374 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10375 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10376 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10377
10378 IF (IJPROJ.EQ.7) THEN
10379 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10380 & -XSQEP(IE,IQ,NTARG)
10381 ELSE
10382 BNORM = XSPRO(IE,IQ,NTARG)
10383 ENDIF
10384 DO 19 I=2,NSITEB
10385 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10386 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10387 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10388 19 CONTINUE
10389
10390* write profile function data into file
10391 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10392 WRITE(LDAT,'(5I10,1P,E15.5)')
10393 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10394 WRITE(LDAT,'(1P,6E12.5)')
10395 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10396 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10397 WRITE(LDAT,'(1P,6E12.5)')
10398 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10399 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10400 NLINES = INT(DBLE(NSITEB)/7.0D0)
10401 IF (NLINES.GT.0) THEN
10402 DO 20 I=1,NLINES
10403 ISTART = 7*I-6
10404 WRITE(LDAT,'(1P,7E11.4)')
10405 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10406 20 CONTINUE
10407 ENDIF
10408 ISTART = 7*NLINES+1
10409 IF (ISTART.LE.NSITEB) THEN
10410 WRITE(LDAT,'(1P,7E11.4)')
10411 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10412 ENDIF
10413 ENDIF
10414
10415 100 CONTINUE
10416
10417C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10418
10419 RETURN
10420 END
10421
10422*$ CREATE DT_GETBXS.FOR
10423*COPY DT_GETBXS
10424*
10425*===getbxs=============================================================*
10426*
10427 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10428
10429************************************************************************
10430* Biasing in impact parameter space. *
10431* XSFRAC = 0 : BLO - minimum impact parameter (input) *
10432* BHI - maximum impact parameter (input) *
10433* XSFRAC - fraction of cross section corresponding *
10434* to impact parameter range (BLO,BHI) *
10435* (output) *
10436* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10437* BHI - maximum impact parameter giving requested *
10438* fraction of cross section in impact *
10439* parameter range (0,BMAX) (output) *
10440* This version dated 17.03.00 is written by S. Roesler *
10441************************************************************************
10442
10443 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10444 SAVE
10445
10446 PARAMETER ( LINP = 10 ,
10447 & LOUT = 6 ,
10448 & LDAT = 9 )
10449
10450 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10451
10452* Glauber formalism: parameters
10453 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10454 & BMAX(NCOMPX),BSTEP(NCOMPX),
10455 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10456 & NSITEB,NSTATB
10457
10458 NTARG = ABS(NIDX)
10459 IF (XSFRAC.LE.0.0D0) THEN
10460 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10461 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10462 IF (ILO.GE.IHI) THEN
10463 XSFRAC = 0.0D0
10464 RETURN
10465 ENDIF
10466 IF (ILO.EQ.NSITEB-1) THEN
10467 FRCLO = BSITE(0,1,NTARG,NSITEB)
10468 ELSE
10469 FRCLO = BSITE(0,1,NTARG,ILO+1)
10470 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10471 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10472 ENDIF
10473 IF (IHI.EQ.NSITEB-1) THEN
10474 FRCHI = BSITE(0,1,NTARG,NSITEB)
10475 ELSE
10476 FRCHI = BSITE(0,1,NTARG,IHI+1)
10477 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10478 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10479 ENDIF
10480 XSFRAC = FRCHI-FRCLO
10481 ELSE
10482 BLO = 0.0D0
10483 BHI = BMAX(NTARG)
10484 DO 1 I=1,NSITEB-1
10485 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10486 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10487 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10488 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10489 GOTO 2
10490 ENDIF
10491 1 CONTINUE
10492 2 CONTINUE
10493 ENDIF
10494
10495 RETURN
10496 END
10497
10498*$ CREATE DT_CONUCL.FOR
10499*COPY DT_CONUCL
10500*
10501*===conucl=============================================================*
10502*
10503 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10504
10505************************************************************************
10506* Calculation of coordinates of nucleons within nuclei. *
10507* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10508* N / R number of nucleons / radius of nucleus (input) *
10509* MODE = 0 coordinates not sorted *
10510* = 1 coordinates sorted with increasing X(3,i) *
10511* = 2 coordinates sorted with decreasing X(3,i) *
10512* This version dated 26.10.95 is revised by S. Roesler *
10513************************************************************************
10514
10515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10516 SAVE
10517
10518 PARAMETER ( LINP = 10 ,
10519 & LOUT = 6 ,
10520 & LDAT = 9 )
10521
10522 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10523 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10524
10525 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10526
10527 PARAMETER (NSRT=10)
10528 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10529 DIMENSION X(3,N),XTMP(3,260)
10530
10531 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10532
10533 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10534 K = 0
10535 DO 1 I=1,NSRT
10536 IF (MODE.EQ.2) THEN
10537 ISRT = NSRT+1-I
10538 ELSE
10539 ISRT = I
10540 ENDIF
10541 K1 = K
10542 DO 2 J=1,ICSRT(ISRT)
10543 K = K+1
10544 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10545 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10546 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10547 2 CONTINUE
10548 IF (ICSRT(ISRT).GT.1) THEN
10549 I0 = K1+1
10550 I1 = K
10551 CALL DT_SORT(X,N,I0,I1,MODE)
10552 ENDIF
10553 1 CONTINUE
10554 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10555 DO 3 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 3 CONTINUE
10560 CALL DT_SORT(X,N,1,N,MODE)
10561 ELSE
10562 DO 4 I=1,N
10563 X(1,I) = XTMP(1,I)
10564 X(2,I) = XTMP(2,I)
10565 X(3,I) = XTMP(3,I)
10566 4 CONTINUE
10567 ENDIF
10568
10569 RETURN
10570 END
10571
10572*$ CREATE DT_COORDI.FOR
10573*COPY DT_COORDI
10574*
10575*===coordi=============================================================*
10576*
10577 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10578
10579************************************************************************
10580* Calculation of coordinates of nucleons within nuclei. *
10581* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10582* N / R number of nucleons / radius of nucleus (input) *
10583* Based on the original version by Shmakov et al. *
10584* This version dated 26.10.95 is revised by S. Roesler *
10585************************************************************************
10586
10587 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10588 SAVE
10589
10590 PARAMETER ( LINP = 10 ,
10591 & LOUT = 6 ,
10592 & LDAT = 9 )
10593
10594 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10595 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10596
10597 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10598
10599 LOGICAL LSTART
10600
10601 PARAMETER (NSRT=10)
10602 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10603 DIMENSION X(3,260),WD(4),RD(3)
10604
10605 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10606 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10607 DATA RD /2.09D0, 0.935D0, 0.697D0/
10608
10609 X1SUM = ZERO
10610 X2SUM = ZERO
10611 X3SUM = ZERO
10612
10613 IF (N.EQ.1) THEN
10614 X(1,1) = ZERO
10615 X(2,1) = ZERO
10616 X(3,1) = ZERO
10617 ELSEIF (N.EQ.2) THEN
10618 EPS = DT_RNDM(RD(1))
10619 DO 30 I=1,3
10620 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10621 30 CONTINUE
10622 40 CONTINUE
10623 DO 50 J=1,3
10624 CALL DT_RANNOR(X1,X2)
10625 X(J,1) = RD(I)*X1
10626 X(J,2) = -X(J,1)
10627 50 CONTINUE
10628 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10629 SIGMA = R/SQRTWO
10630 LSTART = .TRUE.
10631 CALL DT_RANNOR(X3,X4)
10632 DO 100 I=1,N
10633 CALL DT_RANNOR(X1,X2)
10634 X(1,I) = SIGMA*X1
10635 X(2,I) = SIGMA*X2
10636 IF (LSTART) GOTO 80
10637 X(3,I) = SIGMA*X4
10638 CALL DT_RANNOR(X3,X4)
10639 GOTO 90
10640 80 CONTINUE
10641 X(3,I) = SIGMA*X3
10642 90 CONTINUE
10643 LSTART = .NOT.LSTART
10644 X1SUM = X1SUM+X(1,I)
10645 X2SUM = X2SUM+X(2,I)
10646 X3SUM = X3SUM+X(3,I)
10647 100 CONTINUE
10648 X1SUM = X1SUM/DBLE(N)
10649 X2SUM = X2SUM/DBLE(N)
10650 X3SUM = X3SUM/DBLE(N)
10651 DO 101 I=1,N
10652 X(1,I) = X(1,I)-X1SUM
10653 X(2,I) = X(2,I)-X2SUM
10654 X(3,I) = X(3,I)-X3SUM
10655 101 CONTINUE
10656 ELSE
10657
10658* maximum nuclear radius for coordinate sampling
10659 RMAX = R+4.605D0*PDIF
10660
10661* initialize pre-sorting
10662 DO 121 I=1,NSRT
10663 ICSRT(I) = 0
10664 121 CONTINUE
10665 DR = TWO*RMAX/DBLE(NSRT)
10666
10667* sample coordinates for N nucleons
10668 DO 140 I=1,N
10669 120 CONTINUE
10670 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10671 F = DT_DENSIT(N,RAD,R)
10672 IF (DT_RNDM(RAD).GT.F) GOTO 120
10673* theta, phi uniformly distributed
10674 CT = ONE-TWO*DT_RNDM(F)
10675 ST = SQRT((ONE-CT)*(ONE+CT))
10676 CALL DT_DSFECF(SFE,CFE)
10677 X(1,I) = RAD*ST*CFE
10678 X(2,I) = RAD*ST*SFE
10679 X(3,I) = RAD*CT
10680* ensure that distance between two nucleons is greater than R2MIN
10681 IF (I.LT.2) GOTO 122
10682 I1 = I-1
10683 DO 130 I2=1,I1
10684 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10685 & (X(3,I)-X(3,I2))**2
10686 IF (DIST2.LE.R2MIN) GOTO 120
10687 130 CONTINUE
10688 122 CONTINUE
10689* save index according to z-bin
10690 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10691 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10692 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10693 X1SUM = X1SUM+X(1,I)
10694 X2SUM = X2SUM+X(2,I)
10695 X3SUM = X3SUM+X(3,I)
10696 140 CONTINUE
10697 X1SUM = X1SUM/DBLE(N)
10698 X2SUM = X2SUM/DBLE(N)
10699 X3SUM = X3SUM/DBLE(N)
10700 DO 141 I=1,N
10701 X(1,I) = X(1,I)-X1SUM
10702 X(2,I) = X(2,I)-X2SUM
10703 X(3,I) = X(3,I)-X3SUM
10704 141 CONTINUE
10705
10706 ENDIF
10707
10708 RETURN
10709 END
10710
10711*$ CREATE DT_DENSIT.FOR
10712*COPY DT_DENSIT
10713*
10714*===densit=============================================================*
10715*
10716 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10717
10718 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10719 SAVE
10720
10721 PARAMETER ( LINP = 10 ,
10722 & LOUT = 6 ,
10723 & LDAT = 9 )
10724
10725 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10726 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10727 & PI = TWOPI/TWO)
10728
10729 DIMENSION R0(18),FNORM(18)
10730 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10731 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10732 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10733 & 2.72D0, 2.66D0, 2.79D0/
10734 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10735 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10736 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10737 & .1214D+01,.1265D+01,.1318D+01/
10738 DATA PDIF /0.545D0/
10739
10740 DT_DENSIT = ZERO
10741* shell model
10742 IF (NA.LE.4) THEN
10743 STOP 'DT_DENSIT-0'
10744 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10745 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10746 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10747 & *EXP(-(R/R1)**2)/FNORM(NA)
10748* Woods-Saxon
10749 ELSEIF (NA.GT.18) THEN
10750 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10751 ENDIF
10752
10753 RETURN
10754 END
10755
10756*$ CREATE DT_RNCLUS.FOR
10757*COPY DT_RNCLUS
10758*
10759*===rnclus=============================================================*
10760*
10761 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10762
10763************************************************************************
10764* Nuclear radius for nucleus with mass number N. *
10765* This version dated 26.9.00 is written by S. Roesler *
10766************************************************************************
10767
10768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10769 SAVE
10770
10771 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10772
10773* nucleon radius
10774 PARAMETER (RNUCLE = 1.12D0)
10775
10776* nuclear radii for selected nuclei
10777 DIMENSION RADNUC(18)
10778 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10779 & 2.58D0,2.71D0,2.66D0,2.71D0/
10780
10781 IF (N.LE.18) THEN
10782 IF (RADNUC(N).GT.0.0D0) THEN
10783 DT_RNCLUS = RADNUC(N)
10784 ELSE
10785 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10786 ENDIF
10787 ELSE
10788 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10789 ENDIF
10790
10791 RETURN
10792 END
10793
10794*$ CREATE DT_DENTST.FOR
10795*COPY DT_DENTST
10796*
10797*===dentst=============================================================*
10798*
10799C PROGRAM DT_DENTST
10800 SUBROUTINE DT_DENTST
10801
10802 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10803 SAVE
10804
10805 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10806 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10807
10808 RMIN = 0.0D0
10809 RMAX = 8.0D0
10810 NBINS = 500.0D0
10811 DR = (RMAX-RMIN)/DBLE(NBINS)
10812 DO 1 IA=5,18
10813 FMAX = 0.0D0
10814 DO 2 IR=1,NBINS+1
10815 R = RMIN+DBLE(IR-1)*DR
10816 F = DT_DENSIT(IA,R,R)
10817 IF (F.GT.FMAX) FMAX = F
10818 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10819 2 CONTINUE
10820 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10821 1 CONTINUE
10822
10823 CLOSE(40)
10824 CLOSE(41)
10825
10826 END
10827
10828*$ CREATE DT_SHMAKI.FOR
10829*COPY DT_SHMAKI
10830*
10831*===shmaki=============================================================*
10832*
10833 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10834
10835************************************************************************
10836* Initialisation of Glauber formalism. This subroutine has to be *
10837* called once (in case of target emulsions as often as many different *
10838* target nuclei are considered) before events are sampled. *
10839* NA / NCA mass number/charge of projectile nucleus *
10840* NB / NCB mass number/charge of target nucleus *
10841* IJP identity of projectile (hadrons/leptons/photons) *
10842* PPN projectile momentum (for projectile nuclei: *
10843* momentum per nucleon) in target rest system *
10844* MODE = 0 Glauber formalism invoked *
10845* = 1 fitted results are loaded from data-file *
10846* = 99 NTARG is forced to be 1 *
10847* (used in connection with GLAUBERI-card only) *
10848* This version dated 22.03.96 is based on the original SHMAKI-routine *
10849* and revised by S. Roesler. *
10850************************************************************************
10851
10852 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10853 SAVE
10854
10855 PARAMETER ( LINP = 10 ,
10856 & LOUT = 6 ,
10857 & LDAT = 9 )
10858
10859 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10860 & THREE=3.0D0)
10861
10862 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10863
10864* Glauber formalism: parameters
10865 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10866 & BMAX(NCOMPX),BSTEP(NCOMPX),
10867 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10868 & NSITEB,NSTATB
10869
10870* Lorentz-parameters of the current interaction
10871 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10872 & UMO,PPCM,EPROJ,PPROJ
10873
10874* properties of photon/lepton projectiles
10875 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10876
10877* kinematical cuts for lepton-nucleus interactions
10878 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10879 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10880
10881* Glauber formalism: cross sections
10882 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10883 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10884 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10885 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10886 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10887 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10888 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10889 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10890 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10891 & BSLOPE,NEBINI,NQBINI
10892
10893* cuts for variable energy runs
10894 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10895
10896* nucleon-nucleon event-generator
10897 CHARACTER*8 CMODEL
10898 LOGICAL LPHOIN
10899 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10900
10901* Glauber formalism: flags and parameters for statistics
10902 LOGICAL LPROD
10903 CHARACTER*8 CGLB
10904 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10905
10906 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10907
10908C CALL DT_HISHAD
10909C STOP
10910
10911 NTARG = NTARG+1
10912 IF (MODE.EQ.99) NTARG = 1
10913 NIDX = -NTARG
10914 IF (MODE.EQ.-1) NIDX = NTARG
10915
10916 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10917 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10918 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10919 & ' initialization',/,12X,'--------------------------',
10920 & '-------------------------',/)
10921
10922 IF (MODE.EQ.2) THEN
10923 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10924 CALL DT_SHFAST(MODE,PPN,IBACK)
10925 STOP ' Glauber pre-initialization done'
10926 ENDIF
10927 IF (MODE.EQ.1) THEN
10928 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10929 ELSE
10930 IBACK = 1
10931 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10932 IF (IBACK.EQ.1) THEN
10933* lepton-nucleus (variable energy runs)
10934 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10935 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10936 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10937 & WRITE(LOUT,1002) NB,NCB
10938 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10939 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10940 & 'E_cm (GeV) Q^2 (GeV^2)',
10941 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10942 & '--------------------------------',
10943 & '------------------------------')
10944 AECMLO = LOG10(MIN(UMO,ECMLI))
10945 AECMHI = LOG10(MIN(UMO,ECMHI))
10946 IESTEP = NEB-1
10947 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10948 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10949 DO 1 I=1,IESTEP+1
10950 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10951 IF (Q2HI.GT.0.1D0) THEN
10952 IF (Q2LI.LT.0.01D0) THEN
10953 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10954 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10955 & WRITE(LOUT,1003)
10956 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10957 Q2LI = 0.01D0
10958 IBIN = 2
10959 ELSE
10960 IBIN = 1
10961 ENDIF
10962 IQSTEP = NQB-IBIN
10963 AQ2LO = LOG10(Q2LI)
10964 AQ2HI = LOG10(Q2HI)
10965 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10966 DO 2 J=IBIN,IQSTEP+IBIN
10967 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10968 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10969 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10970 & WRITE(LOUT,1003) ECMNN(I),
10971 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10972 2 CONTINUE
10973 ELSE
10974 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10975 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10976 & WRITE(LOUT,1003)
10977 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10978 ENDIF
10979 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10980 1 CONTINUE
10981 IVEOUT = 1
10982 ELSE
10983* hadron/photon/nucleus-nucleus
10984 IF ((ABS(VAREHI).GT.ZERO).AND.
10985 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10986 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10987 WRITE(LOUT,1004) NA,NB,NCB
10988 1004 FORMAT(1X,'variable energy run: projectile-id:',
10989 & I3,' target A/Z: ',I3,' /',I3,/)
10990 WRITE(LOUT,1005)
10991 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10992 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10993 & ' -------------------------------------',
10994 & '--------------------------------------')
10995 ENDIF
10996 AECMLO = LOG10(VARCLO)
10997 AECMHI = LOG10(VARCHI)
10998 IESTEP = NEB-1
10999 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
11000 IF (AECMLO.EQ.AECMHI) IESTEP = 0
11001 DO 3 I=1,IESTEP+1
11002 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11003 AMP = 0.938D0
11004 AMT = 0.938D0
11005 AMP2 = AMP**2
11006 AMT2 = AMT**2
11007 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11008 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11009 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11010 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11011 & WRITE(LOUT,1006)
11012 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11013 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11014 3 CONTINUE
11015 IVEOUT = 1
11016 ELSE
11017 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11018 ENDIF
11019 ENDIF
11020 ENDIF
11021 ENDIF
11022
11023 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11024 & (IOGLB.NE.100)) THEN
11025 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11026 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11027 1001 FORMAT(38X,'projectile',
11028 & ' target',/,1X,'Mass number / charge',
11029 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11030 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11031 & 'Parameters of elastic scattering amplitude:',/,5X,
11032 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11033 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11034 & 'statistics at each b-step',4X,I5,/,/,1X,
11035 & 'Prod. cross section ',5X,F10.4,' mb',/)
11036 ENDIF
11037
11038 RETURN
11039 END
11040
11041*$ CREATE DT_PROFBI.FOR
11042*COPY DT_PROFBI
11043*
11044*===profbi=============================================================*
11045*
11046 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11047
11048************************************************************************
11049* Integral over profile function (to be used for impact-parameter *
11050* sampling during event generation). *
11051* Fitted results are used. *
11052* NA / NB mass numbers of proj./target nuclei *
11053* PPN projectile momentum (for projectile nuclei: *
11054* momentum per nucleon) in target rest system *
11055* NTARG index of target material (i.e. kind of nucleus) *
11056* This version dated 31.05.95 is revised by S. Roesler *
11057************************************************************************
11058
11059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11060 SAVE
11061
11062 PARAMETER ( LINP = 10 ,
11063 & LOUT = 6 ,
11064 & LDAT = 9 )
11065
11066 SAVE
11067
11068 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11069
11070 LOGICAL LSTART
11071 CHARACTER CNAME*80
11072
11073 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11074
11075* Glauber formalism: parameters
11076 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11077 & BMAX(NCOMPX),BSTEP(NCOMPX),
11078 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11079 & NSITEB,NSTATB
11080
11081* Glauber formalism: cross sections
11082 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11083 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11084 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11085 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11086 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11087 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11088 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11089 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11090 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11091 & BSLOPE,NEBINI,NQBINI
11092
11093 PARAMETER (NGLMAX=8000)
11094 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11095 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11096
11097 DATA LSTART /.TRUE./
11098
11099 IF (LSTART) THEN
11100* read fit-parameters from file
11101 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11102 I = 0
11103 1 CONTINUE
11104 READ(47,'(A80)') CNAME
11105 IF (CNAME.EQ.'STOP') GOTO 2
11106 I = I+1
11107 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11108 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11109 & GLAFIT(4,I),GLAFIT(5,I)
11110 IF (I+1.GT.NGLMAX) THEN
11111 WRITE(LOUT,1000)
11112 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11113 & 'program stopped')
11114 STOP
11115 ENDIF
11116 GOTO 1
11117 2 CONTINUE
11118 NGLPAR = I
11119 LSTART = .FALSE.
11120 ENDIF
11121
11122 NNA = NA
11123 NNB = NB
11124 IF (NA.GT.NB) THEN
11125 NNA = NB
11126 NNB = NA
11127 ENDIF
11128 IDXGLA = 0
11129 DO 3 J=1,NGLPAR
11130 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11131 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11132 DO 4 K=1,J-1
11133 IPOINT = J-K
11134 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11135 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11136 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11137 IF (IPOINT.EQ.1) IPOINT = 0
11138 NATMP = NGLIP(IPOINT+1)
11139 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11140 IDXGLA = IPOINT+1
11141 GOTO 6
11142 ELSE
11143 J1BEG = IPOINT+1
11144 J1END = J
11145C IF (J.EQ.NGLPAR) THEN
11146C J1BEG = IPOINT
11147C J1END = J
11148C ENDIF
11149 DO 5 J1=J1BEG,J1END
11150 IF (NGLIP(J1).EQ.NATMP) THEN
11151 IF (PPN.LT.GLAPPN(J1)) THEN
11152 IDXGLA = J1
11153 GOTO 6
11154 ENDIF
11155 ELSE
11156 IDXGLA = J1-1
11157 GOTO 6
11158 ENDIF
11159 5 CONTINUE
11160 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11161 & IDXGLA = NGLPAR
11162 ENDIF
11163 ENDIF
11164 4 CONTINUE
11165 ENDIF
11166 3 CONTINUE
11167
11168 6 CONTINUE
11169 IF (IDXGLA.EQ.0) THEN
11170 WRITE(LOUT,1001) NNA,NNB,PPN
11171 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11172 & 2I4,F6.0,') not found ')
11173 STOP
11174 ENDIF
11175
11176* no interpolation yet available
11177 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11178
11179 BSITE(1,1,NTARG,1) = ZERO
11180 DO 10 I=2,NSITEB
11181 XX = DBLE(I)
11182 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11183 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11184 & GLAFIT(5,IDXGLA)*XX**4
11185 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11186 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11187 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11188 10 CONTINUE
11189
11190 RETURN
11191 END
11192
11193*$ CREATE DT_GLAUBE.FOR
11194*COPY DT_GLAUBE
11195*
11196*===glaube=============================================================*
11197*
11198 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11199
11200************************************************************************
11201* Calculation of configuartion of interacting nucleons for one event. *
11202* NB / NB mass numbers of proj./target nuclei (input) *
11203* B impact parameter (output) *
11204* INTT total number of wounded nucleons " *
11205* INTA / INTB number of wounded nucleons in proj. / target " *
11206* JS / JT(i) number of collisions proj. / target nucleon i is *
11207* involved (output) *
11208* NIDX index of projectile/target material (input) *
11209* = -2 call within FLUKA transport calculation *
11210* This is an update of the original routine SHMAKO by J.Ranft/HJM *
11211* This version dated 22.03.96 is revised by S. Roesler *
11212* *
11213* Last change 27.12.2006 by S. Roesler. *
11214************************************************************************
11215
11216 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11217 SAVE
11218
11219 PARAMETER ( LINP = 10 ,
11220 & LOUT = 6 ,
11221 & LDAT = 9 )
11222
11223 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11224 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11225
11226 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11227
11228 PARAMETER ( MAXNCL = 260,
11229
11230 & MAXVQU = MAXNCL,
11231 & MAXSQU = 20*MAXVQU,
11232 & MAXINT = MAXVQU+MAXSQU)
11233
11234* Glauber formalism: parameters
11235 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11236 & BMAX(NCOMPX),BSTEP(NCOMPX),
11237 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11238 & NSITEB,NSTATB
11239
11240* Glauber formalism: cross sections
11241 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11242 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11243 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11244 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11245 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11246 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11247 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11248 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11249 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11250 & BSLOPE,NEBINI,NQBINI
11251
11252* Lorentz-parameters of the current interaction
11253 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11254 & UMO,PPCM,EPROJ,PPROJ
11255
11256* properties of photon/lepton projectiles
11257 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11258
11259* Glauber formalism: collision properties
11260 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 11261 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
11262 & NCP,NCT
7b076c76 11263* Glauber formalism: flags and parameters for statistics
11264 LOGICAL LPROD
11265 CHARACTER*8 CGLB
11266 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11267
11268 DIMENSION JS(MAXNCL),JT(MAXNCL)
11269
11270 NTARG = ABS(NIDX)
11271
11272* get actual energy from /DTLTRA/
11273 ECMNOW = UMO
11274 Q2 = VIRT
11275*
11276* new patch for pre-initialized variable projectile/target/energy runs,
11277* bypassed for use within FLUKA (Nidx=-2)
11278 IF (IOGLB.EQ.100) THEN
11279 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11280*
11281* variable energy run, interpolate profile function
11282 ELSE
11283 I1 = 1
11284 I2 = 1
11285 RATE = ONE
11286 IF (NEBINI.GT.1) THEN
11287 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11288 I1 = NEBINI
11289 I2 = NEBINI
11290 RATE = ONE
11291 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11292 DO 1 I=2,NEBINI
11293 IF (ECMNOW.LT.ECMNN(I)) THEN
11294 I1 = I-1
11295 I2 = I
11296 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11297 GOTO 2
11298 ENDIF
11299 1 CONTINUE
11300 2 CONTINUE
11301 ENDIF
11302 ENDIF
11303 J1 = 1
11304 J2 = 1
11305 RATQ = ONE
11306 IF (NQBINI.GT.1) THEN
11307 IF (Q2.GE.Q2G(NQBINI)) THEN
11308 J1 = NQBINI
11309 J2 = NQBINI
11310 RATQ = ONE
11311 ELSEIF (Q2.GT.Q2G(1)) THEN
11312 DO 3 I=2,NQBINI
11313 IF (Q2.LT.Q2G(I)) THEN
11314 J1 = I-1
11315 J2 = I
11316 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11317 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11318C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11319 GOTO 4
11320 ENDIF
11321 3 CONTINUE
11322 4 CONTINUE
11323 ENDIF
11324 ENDIF
11325
11326 DO 5 I=1,KSITEB
11327 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11328 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11329 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11330 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11331 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11332 5 CONTINUE
11333 ENDIF
11334
11335 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11336 IF (NIDX.LE.-1) THEN
11337 RPROJ = RASH(1)
11338 RTARG = RBSH(NTARG)
11339 ELSE
11340 RPROJ = RASH(NTARG)
11341 RTARG = RBSH(1)
11342 ENDIF
11343
11344 RETURN
11345 END
11346
11347*$ CREATE DT_DIAGR.FOR
11348*COPY DT_DIAGR
11349*
11350*===diagr==============================================================*
11351*
11352 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11353 & NIDX)
11354
11355************************************************************************
11356* Based on the original version by Shmakov et al. *
11357* This version dated 21.04.95 is revised by S. Roesler *
11358************************************************************************
11359
11360 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11361 SAVE
11362
11363 PARAMETER ( LINP = 10 ,
11364 & LOUT = 6 ,
11365 & LDAT = 9 )
11366
11367 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11368 PARAMETER (TWOPI = 6.283185307179586454D+00,
11369 & PI = TWOPI/TWO,
11370 & GEV2MB = 0.38938D0,
11371 & GEV2FM = 0.1972D0,
11372 & ALPHEM = ONE/137.0D0,
11373* proton mass
11374 & AMP = 0.938D0,
11375 & AMP2 = AMP**2,
11376* rho0 mass
11377 & AMRHO0 = 0.77D0)
11378
11379 COMPLEX*16 C,CA,CI
11380
11381 PARAMETER ( MAXNCL = 260,
11382
11383 & MAXVQU = MAXNCL,
11384 & MAXSQU = 20*MAXVQU,
11385 & MAXINT = MAXVQU+MAXSQU)
11386
11387* particle properties (BAMJET index convention)
11388 CHARACTER*8 ANAME
11389 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11390 & IICH(210),IIBAR(210),K1(210),K2(210)
11391
11392 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393
11394* emulsion treatment
11395 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11396 & NCOMPO,IEMUL
11397
11398* Glauber formalism: parameters
11399 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11400 & BMAX(NCOMPX),BSTEP(NCOMPX),
11401 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11402 & NSITEB,NSTATB
11403
11404* Glauber formalism: cross sections
11405 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11406 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11407 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11408 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11409 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11410 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11411 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11412 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11413 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11414 & BSLOPE,NEBINI,NQBINI
11415
11416* VDM parameter for photon-nucleus interactions
11417 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11418
11419* nucleon-nucleon event-generator
11420 CHARACTER*8 CMODEL
11421 LOGICAL LPHOIN
11422 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11423**PHOJET105a
11424C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11425**PHOJET112
11426
11427C obsolete cut-off information
11428 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11429 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11430**
11431
11432* coordinates of nucleons
11433 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11434
11435* interface between Glauber formalism and DPM
11436 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11437 & INTER1(MAXINT),INTER2(MAXINT)
11438
11439* statistics: Glauber-formalism
11440 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11441
11442* n-n cross section fluctuations
11443 PARAMETER (NBINS = 1000)
11444 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11445
11446 DIMENSION JS(MAXNCL),JT(MAXNCL),
11447 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11448 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11449 DIMENSION NWA(0:210),NWB(0:210)
11450
11451 LOGICAL LFIRST
11452 DATA LFIRST /.TRUE./
11453
11454 DATA NTARGO,ICNT /0,0/
11455
11456 NTARG = ABS(NIDX)
11457
11458 IF (LFIRST) THEN
11459 LFIRST = .FALSE.
11460 IF (NCOMPO.EQ.0) THEN
11461 NCALL = 0
11462 NWAMAX = NA
11463 NWBMAX = NB
11464 DO 17 I=0,210
11465 NWA(I) = 0
11466 NWB(I) = 0
11467 17 CONTINUE
11468 ENDIF
11469 ENDIF
11470 IF (NTARG.EQ.-1) THEN
11471 IF (NCOMPO.EQ.0) THEN
11472 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11473 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11474 & NCALL,NWAMAX,NWBMAX
11475 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11476 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11477 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11478 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11479 18 CONTINUE
11480 ENDIF
11481 RETURN
11482 ENDIF
11483
11484 DCOH = 1.0D10
11485 IPNT = 0
11486
11487 SQ2 = Q2
11488 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11489 S = ECMNOW**2
11490 X = SQ2/(S+SQ2-AMP2)
11491 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11492* photon projectiles: recalculate photon-nucleon amplitude
11493 IF (IJPROJ.EQ.7) THEN
11494 15 CONTINUE
11495* VDM assumption: mass of V-meson
11496 AMV2 = DT_SAM2(SQ2,ECMNOW)
11497 AMV = SQRT(AMV2)
11498 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11499* check for pointlike interaction
11500 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11501**sr 27.10.
11502C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11503 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11504**
11505 ROSH = 0.1D0
11506 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11507 & +0.25D0*LOG(S/(AMV2+SQ2)))
11508* coherence length
11509 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11510 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11511 IF (MCGENE.EQ.2) THEN
11512 ZERO1 = ZERO
11513 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11514 & BSLOPE,0)
11515 ELSE
11516 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11517 ENDIF
11518 IF (ECMNOW.LE.3.0D0) THEN
11519 ROSH = -0.43D0
11520 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11521 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11522 ELSEIF (ECMNOW.GT.50.0D0) THEN
11523 ROSH = 0.1D0
11524 ENDIF
11525 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11526 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11527 IF (MCGENE.EQ.2) THEN
11528 ZERO1 = ZERO
11529 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11530 & BDUM,0)
11531 SIGSH = SIGSH/10.0D0
11532 ELSE
11533C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11534 DUMZER = ZERO
11535 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11536 SIGSH = SIGSH/10.0D0
11537 ENDIF
11538 ELSE
11539 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11540 ROSH = 0.01D0
11541 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11542 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11543C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11544 DUMZER = ZERO
11545 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11546 SIGSH = SIGSH/10.0D0
11547 ENDIF
11548 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11549 GAM = GSH
11550 RCA = GAM*SIGSH/TWOPI
11551 FCA = -ROSH*RCA
11552 CA = DCMPLX(RCA,FCA)
11553 CI = DCMPLX(ONE,ZERO)
11554
11555 16 CONTINUE
11556* impact parameter
11557 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11558
11559 NTRY = 0
11560 3 CONTINUE
11561 NTRY = NTRY+1
11562* initializations
11563 JNT = 0
11564 DO 1 I=1,NA
11565 JS(I) = 0
11566 1 CONTINUE
11567 DO 2 I=1,NB
11568 JT(I) = 0
11569 2 CONTINUE
11570 IF (IJPROJ.EQ.7) THEN
11571 DO 8 I=1,MAXNCL
11572 JS0(I) = 0
11573 JNT0(I)= 0
11574 DO 9 J=1,NB
11575 JT0(I,J) = 0
11576 9 CONTINUE
11577 8 CONTINUE
11578 ENDIF
11579
11580* nucleon configuration
11581C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11582 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11583C CALL DT_CONUCL(PKOO,NA,RASH,2)
11584C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11585 IF (NIDX.LE.-1) THEN
11586 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11587 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11588 ELSE
11589 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11590 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11591 ENDIF
11592 NTARGO = NTARG
11593 ENDIF
11594 ICNT = ICNT+1
11595
11596* LEPTO: pick out one struck nucleon
11597 IF (MCGENE.EQ.3) THEN
11598 JNT = 1
11599 JS(1) = 1
11600 IDX = INT(DT_RNDM(X)*NB)+1
11601 JT(IDX) = 1
11602 B = ZERO
11603 GOTO 19
11604 ENDIF
11605
11606 DO 4 INA=1,NA
11607* cross section fluctuations
11608 AFLUC = ONE
11609 IF (IFLUCT.EQ.1) THEN
11610 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11611 AFLUC = FLUIXX(IFLUK)
11612 ENDIF
11613 KK1 = 1
11614 KINT = 1
11615 DO 5 INB=1,NB
11616* photon-projectile: check for supression by coherence length
11617 IF (IJPROJ.EQ.7) THEN
11618 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11619 KK1 = INB
11620 KINT = KINT+1
11621 ENDIF
11622 ENDIF
11623 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11624 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11625 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11626 IF (XY.LE.15.0D0) THEN
11627 C = CI-CA*AFLUC*EXP(-XY)
11628 AR = DBLE(C)
11629 AI = DIMAG(C)
11630 P = AR*AR+AI*AI
11631 IF (DT_RNDM(XY).GE.P) THEN
11632 JNT = JNT+1
11633 IF (IJPROJ.EQ.7) THEN
11634 JNT0(KINT) = JNT0(KINT)+1
11635 IF (JNT0(KINT).GT.MAXNCL) THEN
11636 WRITE(LOUT,1001) MAXNCL
11637 1001 FORMAT(1X,
11638 & 'DIAGR: no. of requested interactions',
11639 & ' exceeds array dimensions ',I4)
11640 STOP
11641 ENDIF
11642 JS0(KINT) = JS0(KINT)+1
11643 JT0(KINT,INB) = JT0(KINT,INB)+1
11644 JI1(KINT,JNT0(KINT)) = INA
11645 JI2(KINT,JNT0(KINT)) = INB
11646 ELSE
11647 IF (JNT.GT.MAXINT) THEN
11648 WRITE(LOUT,1000) JNT, MAXINT
11649 1000 FORMAT(1X,
11650 & 'DIAGR: no. of requested interactions ('
11651 & ,I4,') exceeds array dimensions (',I4,')')
11652 STOP
11653 ENDIF
11654 JS(INA) = JS(INA)+1
11655 JT(INB) = JT(INB)+1
11656 INTER1(JNT) = INA
11657 INTER2(JNT) = INB
11658 ENDIF
11659 ENDIF
11660 ENDIF
11661 5 CONTINUE
11662 4 CONTINUE
11663
11664 IF (JNT.EQ.0) THEN
11665 IF (NTRY.LT.500) THEN
11666 GOTO 3
11667 ELSE
11668C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11669 GOTO 16
11670 ENDIF
11671 ENDIF
11672
11673 IDIREC = 0
11674 IF (IJPROJ.EQ.7) THEN
11675 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11676 10 CONTINUE
11677 IF (JNT0(K).EQ.0) THEN
11678 K = K+1
11679 IF (K.GT.KINT) K = 1
11680 GOTO 10
11681 ENDIF
11682* supress Glauber-cascade by direct photon processes
11683 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11684 IF (IPNT.GT.0) THEN
11685 JNT = 1
11686 JS(1) = 1
11687 DO 11 INB=1,NB
11688 JT(INB) = JT0(K,INB)
11689 IF (JT(INB).GT.0) GOTO 12
11690 11 CONTINUE
11691 12 CONTINUE
11692 INTER1(1) = 1
11693 INTER2(1) = INB
11694 IDIREC = IPNT
11695 ELSE
11696 JNT = JNT0(K)
11697 JS(1) = JS0(K)
11698 DO 13 INB=1,NB
11699 JT(INB) = JT0(K,INB)
11700 13 CONTINUE
11701 DO 14 I=1,JNT
11702 INTER1(I) = JI1(K,I)
11703 INTER2(I) = JI2(K,I)
11704 14 CONTINUE
11705 ENDIF
11706 ENDIF
11707
11708 19 CONTINUE
11709 INTA = 0
11710 INTB = 0
11711 DO 6 I=1,NA
11712 IF (JS(I).NE.0) INTA=INTA+1
11713 6 CONTINUE
11714 DO 7 I=1,NB
11715 IF (JT(I).NE.0) INTB=INTB+1
11716 7 CONTINUE
11717 ICWPG = INTA
11718 ICWTG = INTB
11719 ICIG = JNT
11720 IPGLB = IPGLB+INTA
11721 ITGLB = ITGLB+INTB
11722 NGLB = NGLB+1
11723
11724 IF (NCOMPO.EQ.0) THEN
11725 NCALL = NCALL+1
11726 NWA(INTA) = NWA(INTA)+1
11727 NWB(INTB) = NWB(INTB)+1
11728 ENDIF
11729
11730 RETURN
11731 END
11732
11733*$ CREATE DT_MODB.FOR
11734*COPY DT_MODB
11735*
11736*===modb===============================================================*
11737*
11738 SUBROUTINE DT_MODB(B,NIDX)
11739
11740************************************************************************
11741* Sampling of impact parameter of collision. *
11742* B impact parameter (output) *
11743* NIDX index of projectile/target material (input)*
11744* Based on the original version by Shmakov et al. *
11745* This version dated 21.04.95 is revised by S. Roesler *
11746* *
11747* Last change 27.12.2006 by S. Roesler. *
11748************************************************************************
11749
11750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11751 SAVE
11752
11753 PARAMETER ( LINP = 10 ,
11754 & LOUT = 6 ,
11755 & LDAT = 9 )
11756
11757 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11758
11759 LOGICAL LEFT,LFIRST
11760
11761* central particle production, impact parameter biasing
11762 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11763
11764 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11765
11766* Glauber formalism: parameters
11767 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11768 & BMAX(NCOMPX),BSTEP(NCOMPX),
11769 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11770 & NSITEB,NSTATB
11771
11772* Glauber formalism: cross sections
11773 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11774 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11775 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11776 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11777 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11778 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11779 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11780 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11781 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11782 & BSLOPE,NEBINI,NQBINI
11783
11784 DATA LFIRST /.TRUE./
11785
11786 NTARG = ABS(NIDX)
11787 IF (NIDX.LE.-1) THEN
11788 RA = RASH(1)
11789 RB = RBSH(NTARG)
11790 ELSE
11791 RA = RASH(NTARG)
11792 RB = RBSH(1)
11793 ENDIF
11794
11795 IF (ICENTR.EQ.2) THEN
11796 IF (RA.EQ.RB) THEN
11797 BB = DT_RNDM(B)*(0.3D0*RA)**2
11798 B = SQRT(BB)
11799 ELSEIF(RA.LT.RB)THEN
11800 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11801 B = SQRT(BB)
11802 ELSEIF(RA.GT.RB)THEN
11803 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11804 B = SQRT(BB)
11805 ENDIF
11806 ELSE
11807 9 CONTINUE
11808 Y = DT_RNDM(BB)
11809 I0 = 1
11810 I2 = NSITEB
11811 10 CONTINUE
11812 I1 = (I0+I2)/2
11813 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11814 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11815 IF (LEFT) GOTO 20
11816 I0 = I1
11817 GOTO 30
11818 20 CONTINUE
11819 I2 = I1
11820 30 CONTINUE
11821 IF (I2-I0-2) 40,50,60
11822 40 CONTINUE
11823 I1 = I2+1
11824 IF (I1.GT.NSITEB) I1 = I0-1
11825 GOTO 70
11826 50 CONTINUE
11827 I1 = I0+1
11828 GOTO 70
11829 60 CONTINUE
11830 GOTO 10
11831 70 CONTINUE
11832 X0 = DBLE(I0-1)*BSTEP(NTARG)
11833 X1 = DBLE(I1-1)*BSTEP(NTARG)
11834 X2 = DBLE(I2-1)*BSTEP(NTARG)
11835 Y0 = BSITE(0,1,NTARG,I0)
11836 Y1 = BSITE(0,1,NTARG,I1)
11837 Y2 = BSITE(0,1,NTARG,I2)
11838 80 CONTINUE
11839 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11840 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11841 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11842**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11843 B = B+0.5D0*BSTEP(NTARG)
11844 IF (B.LT.ZERO) B = X1
11845 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11846 IF (ICENTR.LT.0) THEN
11847 IF (LFIRST) THEN
11848 LFIRST = .FALSE.
11849 IF (ICENTR.LE.-100) THEN
11850 BIMIN = 0.0D0
11851 ELSE
11852 XSFRAC = 0.0D0
11853 ENDIF
11854 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11855 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11856 & BIMIN,BIMAX,XSFRAC*100.0D0,
11857 & XSFRAC*XSPRO(1,1,NTARG)
11858 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11859 & /,15X,'---------------------------'/,/,4X,
11860 & 'average radii of proj / targ :',F10.3,' fm /',
11861 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11862 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11863 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11864 & ' cross section :',F10.3,' %',/,5X,
11865 & 'corresponding cross section :',F10.3,' mb',/)
11866 ENDIF
11867 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11868 B = BIMIN
11869 ELSE
11870 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11871 ENDIF
11872 ENDIF
11873 ENDIF
11874
11875 RETURN
11876 END
11877
11878*$ CREATE DT_SHFAST.FOR
11879*COPY DT_SHFAST
11880*
11881*===shfast=============================================================*
11882*
11883 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11884
11885 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11886 SAVE
11887
11888 PARAMETER ( LINP = 10 ,
11889 & LOUT = 6 ,
11890 & LDAT = 9 )
11891
11892 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11893 & ONE=1.0D0,TWO=2.0D0)
11894
11895 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11896
11897* Glauber formalism: parameters
11898 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11899 & BMAX(NCOMPX),BSTEP(NCOMPX),
11900 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11901 & NSITEB,NSTATB
11902
11903* properties of interacting particles
11904 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11905
11906* Glauber formalism: cross sections
11907 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11908 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11909 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11910 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11911 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11912 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11913 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11914 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11915 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11916 & BSLOPE,NEBINI,NQBINI
11917
11918 IBACK = 0
11919
11920 IF (MODE.EQ.2) THEN
11921 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11922 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11923 1000 FORMAT(1X,8I5,E15.5)
11924 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11925 1001 FORMAT(1X,4E15.5)
11926 WRITE(47,1002) SIGSH,ROSH,GSH
11927 1002 FORMAT(1X,3E15.5)
11928 DO 10 I=1,100
11929 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11930 10 CONTINUE
11931 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11932 1003 FORMAT(1X,2I10,3E15.5)
11933 CLOSE(47)
11934 ELSE
11935 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11936 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11937 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11938 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11939 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11940 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11941 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11942 READ(47,1002) SIGSH,ROSH,GSH
11943 DO 11 I=1,100
11944 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11945 11 CONTINUE
11946 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11947 ELSE
11948 IBACK = 1
11949 ENDIF
11950 CLOSE(47)
11951 ENDIF
11952
11953 RETURN
11954 END
11955
11956*$ CREATE DT_POILIK.FOR
11957*COPY DT_POILIK
11958*
11959*===poilik=============================================================*
11960*
11961 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11962
11963 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11964 SAVE
11965
11966 PARAMETER ( LINP = 10 ,
11967 & LOUT = 6 ,
11968 & LDAT = 9 )
11969
11970 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11971 PARAMETER (NE = 8)
11972
11973**PHOJET105a
11974C CHARACTER*8 MDLNA
11975C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11976C PARAMETER (IEETAB=10)
11977C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11978**PHOJET110
11979
11980C model switches and parameters
11981 CHARACTER*8 MDLNA
11982 INTEGER ISWMDL,IPAMDL
11983 DOUBLE PRECISION PARMDL
11984 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11985
11986C energy-interpolation table
11987 INTEGER IEETA2
11988 PARAMETER ( IEETA2 = 20 )
11989 INTEGER ISIMAX
11990 DOUBLE PRECISION SIGTAB,SIGECM
11991 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11992**
11993
11994* VDM parameter for photon-nucleus interactions
11995 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11996**sr 22.7.97
11997
11998 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11999
12000* Glauber formalism: cross sections
12001 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12002 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12003 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12004 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12005 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12006 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12007 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12008 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12009 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12010 & BSLOPE,NEBINI,NQBINI
12011**
12012
12013 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12014
12015 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12016
12017* load cross sections from interpolation table
12018 IP = 1
12019 IF(ECM.LE.SIGECM(IP,1)) THEN
12020 I1 = 1
12021 I2 = 1
12022 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12023 DO 50 I=2,ISIMAX
12024 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12025 50 CONTINUE
12026 200 CONTINUE
12027 I1 = I-1
12028 I2 = I
12029 ELSE
12030 WRITE(LOUT,'(/1X,A,2E12.3)')
12031 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12032 I1 = ISIMAX
12033 I2 = ISIMAX
12034 ENDIF
12035 FAC2 = ZERO
12036 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12037 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12038 FAC1 = ONE-FAC2
12039
12040 SIGANO = DT_SANO(ECM)
12041
12042* cross section dependence on photon virtuality
12043 FSUP1 = ZERO
12044 DO 150 I=1,3
12045 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12046 & /(ONE+VIRT/PARMDL(30+I))**2
12047 150 CONTINUE
12048 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12049 FAC1 = FAC1*FSUP1
12050 FAC2 = FAC2*FSUP1
12051 FSUP2 = ONE
12052
12053 ECMOLD = ECM
12054 Q2OLD = VIRT
12055
12056 3 CONTINUE
12057
12058C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12059 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12060 IF (ISHAD(1).EQ.1) THEN
12061 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12062 ELSE
12063 SIGDIR = ZERO
12064 ENDIF
12065 SIGANO = FSUP1*FSUP2*SIGANO
12066 SIGTOT = SIGTOT-SIGDIR-SIGANO
12067 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12068 SIGANO = SIGANO/(FSUP1*FSUP2)
12069 SIGTOT = SIGTOT+SIGDIR+SIGANO
12070
12071 RR = DT_RNDM(SIGTOT)
12072 IF (RR.LT.SIGDIR/SIGTOT) THEN
12073 IPNT = 1
12074 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12075 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12076 IPNT = 2
12077 ELSE
12078 IPNT = 0
12079 ENDIF
12080 RPNT = (SIGDIR+SIGANO)/SIGTOT
12081C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12082C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12083C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12084C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12085 IF (MODE.EQ.1) RETURN
12086
12087**sr 22.7.97
12088 K1 = 1
12089 K2 = 1
12090 RATE = ZERO
12091 IF (ECM.GE.ECMNN(NEBINI)) THEN
12092 K1 = NEBINI
12093 K2 = NEBINI
12094 RATE = ONE
12095 ELSEIF (ECM.GT.ECMNN(1)) THEN
12096 DO 10 I=2,NEBINI
12097 IF (ECM.LT.ECMNN(I)) THEN
12098 K1 = I-1
12099 K2 = I
12100 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12101 GOTO 11
12102 ENDIF
12103 10 CONTINUE
12104 11 CONTINUE
12105 ENDIF
12106 J1 = 1
12107 J2 = 1
12108 RATQ = ZERO
12109 IF (NQBINI.GT.1) THEN
12110 IF (VIRT.GE.Q2G(NQBINI)) THEN
12111 J1 = NQBINI
12112 J2 = NQBINI
12113 RATQ = ONE
12114 ELSEIF (VIRT.GT.Q2G(1)) THEN
12115 DO 12 I=2,NQBINI
12116 IF (VIRT.LT.Q2G(I)) THEN
12117 J1 = I-1
12118 J2 = I
12119 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12120 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12121 GOTO 13
12122 ENDIF
12123 12 CONTINUE
12124 13 CONTINUE
12125 ENDIF
12126 ENDIF
12127 SGA = XSPRO(K1,J1,NTARG)+
12128 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12129 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12130 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12131 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12132 SDI = DBLE(NB)*SIGDIR
12133 SAN = DBLE(NB)*SIGANO
12134 SPL = SDI+SAN
12135 RR = DT_RNDM(SPL)
12136 IF (RR.LT.SDI/SGA) THEN
12137 IPNT = 1
12138 ELSEIF ((RR.GE.SDI/SGA).AND.
12139 & (RR.LT.SPL/SGA)) THEN
12140 IPNT = 2
12141 ELSE
12142 IPNT = 0
12143 ENDIF
12144 RPNT = SPL/SGA
12145C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12146**
12147
12148 RETURN
12149 END
12150
12151*$ CREATE DT_GLBINI.FOR
12152*COPY DT_GLBINI
12153*
12154*===glbini=============================================================*
12155*
12156 SUBROUTINE DT_GLBINI(WHAT)
12157
12158************************************************************************
12159* Pre-initialization of profile function *
12160* This version dated 28.11.00 is written by S. Roesler. *
12161* *
12162* Last change 27.12.2006 by S. Roesler. *
12163************************************************************************
12164
12165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12166 SAVE
12167
12168 PARAMETER ( LINP = 10 ,
12169 & LOUT = 6 ,
12170 & LDAT = 9 )
12171
12172 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12173
12174 LOGICAL LCMS
12175
12176* particle properties (BAMJET index convention)
12177 CHARACTER*8 ANAME
12178 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12179 & IICH(210),IIBAR(210),K1(210),K2(210)
12180
12181* properties of interacting particles
12182 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12183
12184 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12185
12186* emulsion treatment
12187 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12188 & NCOMPO,IEMUL
12189
12190* Glauber formalism: flags and parameters for statistics
12191 LOGICAL LPROD
12192 CHARACTER*8 CGLB
12193 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12194
12195* number of data sets other than protons and nuclei
12196* at the moment = 2 (pions and kaons)
12197 PARAMETER (MAXOFF=2)
12198 DIMENSION IJPINI(5),IOFFST(25)
12199 DATA IJPINI / 13, 15, 0, 0, 0/
12200* Glauber data-set to be used for hadron projectiles
12201* (0=proton, 1=pion, 2=kaon)
12202 DATA (IOFFST(K),K=1,25) /
12203 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12204 & 0, 0, 1, 2, 2/
12205* Acceptance interval for target nucleus mass
12206 PARAMETER (KBACC = 6)
12207
12208* flags for input different options
12209 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12210 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12211 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12212
12213 PARAMETER (MAXMSS = 100)
12214 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12215 DIMENSION WHAT(6)
12216
12217 DATA JPEACH,JPSTEP / 18, 5 /
12218
12219* temporary patch until fix has been implemented in phojet:
12220* maximum energy for pion projectile
12221 DATA ECMXPI / 100000.0D0 /
12222*
12223*--------------------------------------------------------------------------
12224* general initializations
12225*
12226* steps in projectile mass number for initialization
12227 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12228 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12229*
12230* energy range and binning
12231 ELO = ABS(WHAT(1))
12232 EHI = ABS(WHAT(2))
12233 IF (ELO.GT.EHI) ELO = EHI
12234 NEBIN = MAX(INT(WHAT(3)),1)
12235 IF (ELO.EQ.EHI) NEBIN = 0
12236 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12237 IF (LCMS) THEN
12238 ECMINI = EHI
12239 ELSE
12240 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12241 & +2.0D0*AAM(IJTARG)*EHI)
12242 ENDIF
12243*
12244* default arguments for Glauber-routine
12245 XI = ZERO
12246 Q2I = ZERO
12247*
12248* initialize nuclear parameters, etc.
12249
12250* initialize evaporation if the code is not used as Fluka event generator
12251 IF (ITRSPT.NE.1) THEN
12252 CALL NCDTRD
12253 CALL INCINI
12254 ENDIF
12255
12256*
12257* open Glauber-data output file
12258 IDX = INDEX(CGLB,' ')
12259 K = 12
12260 IF (IDX.GT.1) K = IDX-1
12261 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12262*
12263*--------------------------------------------------------------------------
12264* Glauber-initialization for proton and nuclei projectiles
12265*
12266* initialize phojet for proton-proton interactions
12267 ELAB = ZERO
12268 PLAB = ZERO
12269 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12270 CALL DT_PHOINI
12271*
12272* record projectile masses
12273 NASAV = 0
12274 NPROJ = MIN(IP,JPEACH)
12275 DO 10 KPROJ=1,NPROJ
12276 NASAV = NASAV+1
12277 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278 IASAV(NASAV) = KPROJ
12279 10 CONTINUE
12280 IF (IP.GT.JPEACH) THEN
12281 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12282 IF (NPROJ.EQ.0) THEN
12283 NASAV = NASAV+1
12284 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12285 IASAV(NASAV) = IP
12286 ELSE
12287 DO 11 IPROJ=1,NPROJ
12288 KPROJ = JPEACH+IPROJ*JPSTEP
12289 NASAV = NASAV+1
12290 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12291 IASAV(NASAV) = KPROJ
12292 11 CONTINUE
12293 IF (KPROJ.LT.IP) THEN
12294 NASAV = NASAV+1
12295 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12296 IASAV(NASAV) = IP
12297 ENDIF
12298 ENDIF
12299 ENDIF
12300*
12301* record target masses
12302 NBSAV = 0
12303 NTARG = 1
12304 IF (NCOMPO.GT.0) NTARG = NCOMPO
12305 DO 12 ITARG=1,NTARG
12306 NBSAV = NBSAV+1
12307 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12308 IF (NCOMPO.GT.0) THEN
12309 IBSAV(NBSAV) = IEMUMA(ITARG)
12310 ELSE
12311 IBSAV(NBSAV) = IT
12312 ENDIF
12313 12 CONTINUE
12314*
12315* print masses
12316 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12317 1000 FORMAT(I4,A,1P,2E13.5)
12318 NLINES = DBLE(NASAV)/18.0D0
12319 IF (NLINES.GT.0) THEN
12320 DO 13 I=1,NLINES
12321 IF (I.EQ.1) THEN
12322 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12323 ELSE
12324 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12325 ENDIF
12326 13 CONTINUE
12327 ENDIF
12328 I0 = 18*NLINES+1
12329 IF (I0.LE.NASAV) THEN
12330 IF (I0.EQ.1) THEN
12331 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12332 ELSE
12333 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12334 ENDIF
12335 ENDIF
12336 NLINES = DBLE(NBSAV)/18.0D0
12337 IF (NLINES.GT.0) THEN
12338 DO 14 I=1,NLINES
12339 IF (I.EQ.1) THEN
12340 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12341 ELSE
12342 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12343 ENDIF
12344 14 CONTINUE
12345 ENDIF
12346 I0 = 18*NLINES+1
12347 IF (I0.LE.NBSAV) THEN
12348 IF (I0.EQ.1) THEN
12349 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12350 ELSE
12351 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12352 ENDIF
12353 ENDIF
12354*
12355* calculate Glauber-data for each energy and mass combination
12356*
12357* loop over energy bins
12358 ELO = LOG10(ELO)
12359 EHI = LOG10(EHI)
12360 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12361 DO 1 IE=1,NEBIN+1
12362 E = ELO+DBLE(IE-1)*DEBIN
12363 E = 10**E
12364 IF (LCMS) THEN
12365 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12366 ECM = E
12367 ELSE
12368 PLAB = ZERO
12369 ECM = ZERO
12370 E = MAX(AAM(IJPROJ)+0.1D0,E)
12371 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12372 ENDIF
12373*
12374* loop over projectile and target masses
12375 DO 2 ITARG=1,NBSAV
12376 DO 3 IPROJ=1,NASAV
12377 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12378 & XI,Q2I,ECM,1,1,-1)
12379 3 CONTINUE
12380 2 CONTINUE
12381*
12382 1 CONTINUE
12383*
12384*--------------------------------------------------------------------------
12385* Glauber-initialization for pion, kaon, ... projectiles
12386*
12387 DO 6 IJ=1,MAXOFF
12388*
12389* initialize phojet for this interaction
12390 ELAB = ZERO
12391 PLAB = ZERO
12392 IJPROJ = IJPINI(IJ)
12393 IP = 1
12394 IPZ = 1
12395*
12396* temporary patch until fix has been implemented in phojet:
12397 IF (ECMINI.GT.ECMXPI) THEN
12398 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12399 ELSE
12400 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12401 ENDIF
12402 CALL DT_PHOINI
12403*
12404* calculate Glauber-data for each energy and mass combination
12405*
12406* loop over energy bins
12407 DO 4 IE=1,NEBIN+1
12408 E = ELO+DBLE(IE-1)*DEBIN
12409 E = 10**E
12410 IF (LCMS) THEN
12411 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12412 ECM = E
12413 ELSE
12414 PLAB = ZERO
12415 ECM = ZERO
12416 E = MAX(AAM(IJPROJ)+TINY14,E)
12417 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12418 ENDIF
12419*
12420* loop over projectile and target masses
12421 DO 5 ITARG=1,NBSAV
12422 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12423 5 CONTINUE
12424*
12425 4 CONTINUE
12426*
12427 6 CONTINUE
12428
12429*--------------------------------------------------------------------------
12430* close output unit(s), etc.
12431*
12432 CLOSE(LDAT)
12433
12434 RETURN
12435 END
12436
12437*$ CREATE DT_GLBSET.FOR
12438*COPY DT_GLBSET
12439*
12440*===glbset=============================================================*
12441*
12442 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12443************************************************************************
12444* Interpolation of pre-initialized profile functions *
12445* This version dated 28.11.00 is written by S. Roesler. *
12446************************************************************************
12447
12448 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12449 SAVE
12450
12451 PARAMETER ( LINP = 10 ,
12452 & LOUT = 6 ,
12453 & LDAT = 9 )
12454
12455 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12456
12457 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12458
12459* particle properties (BAMJET index convention)
12460 CHARACTER*8 ANAME
12461 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12462 & IICH(210),IIBAR(210),K1(210),K2(210)
12463
12464* Glauber formalism: flags and parameters for statistics
12465 LOGICAL LPROD
12466 CHARACTER*8 CGLB
12467 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12468
12469 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12470
12471* Glauber formalism: parameters
12472 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12473 & BMAX(NCOMPX),BSTEP(NCOMPX),
12474 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12475 & NSITEB,NSTATB
12476
12477* Glauber formalism: cross sections
12478 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12479 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12480 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12481 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12482 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12483 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12484 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12485 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12486 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12487 & BSLOPE,NEBINI,NQBINI
12488
12489* number of data sets other than protons and nuclei
12490* at the moment = 2 (pions and kaons)
12491 PARAMETER (MAXOFF=2)
12492 DIMENSION IJPINI(5),IOFFST(25)
12493 DATA IJPINI / 13, 15, 0, 0, 0/
12494* Glauber data-set to be used for hadron projectiles
12495* (0=proton, 1=pion, 2=kaon)
12496 DATA (IOFFST(K),K=1,25) /
12497 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12498 & 0, 0, 1, 2, 2/
12499* Acceptance interval for target nucleus mass
12500 PARAMETER (KBACC = 6)
12501
12502* emulsion treatment
12503 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12504 & NCOMPO,IEMUL
12505
12506 PARAMETER (MAXSET=5000,
12507 & MAXBIN=100)
12508 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12509 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12510 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12511 & IAIDX(10)
12512
12513 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12514*
12515* read data from file
12516*
12517 IF (MODE.EQ.0) THEN
12518
12519 IF (LREAD) RETURN
12520
12521 DO 1 I=1,MAXSET
12522 DO 2 J=1,6
12523 XSIG(I,J) = ZERO
12524 XERR(I,J) = ZERO
12525 2 CONTINUE
12526 DO 3 J=1,KSITEB
12527 BPROFL(I,J) = ZERO
12528 3 CONTINUE
12529 1 CONTINUE
12530 DO 4 I=1,MAXBIN
12531 IABIN(I) = 0
12532 IBBIN(I) = 0
12533 4 CONTINUE
12534 DO 5 I=1,KSITEB
12535 BPRO0(I) = ZERO
12536 BPRO1(I) = ZERO
12537 BPRO(I) = ZERO
12538 5 CONTINUE
12539
12540 IDX = INDEX(CGLB,' ')
12541 K = 12
12542 IF (IDX.GT.1) K = IDX-1
12543 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12544 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12545 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12546 & 'file ',A12,/)
12547*
12548* read binning information
12549 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12550* return lower energy threshold to Fluka-interface
12551 ELAB = ELO
12552 LCMS = ELO.LT.ZERO
12553 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12554 IF (LCMS) THEN
12555 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12556 ELSE
12557 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12558 ENDIF
12559 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12560 & 'No. of bins:',I5,/)
12561 ELO = LOG10(ABS(ELO))
12562 EHI = LOG10(ABS(EHI))
12563 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12564 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12565 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12566 IF (NABIN.LT.18) THEN
12567 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12568 ELSE
12569 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12570 ENDIF
12571 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12572 IF (NABIN.GT.18) THEN
12573 NLINES = DBLE(NABIN-18)/18.0D0
12574 IF (NLINES.GT.0) THEN
12575 DO 7 I=1,NLINES
12576 I0 = 18*(I+1)-17
12577 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12578 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12579 7 CONTINUE
12580 ENDIF
12581 I0 = 18*(NLINES+1)+1
12582 IF (I0.LE.NABIN) THEN
12583 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12584 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12585 ENDIF
12586 ENDIF
12587 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12588 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12589 IF (NBBIN.LT.18) THEN
12590 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12591 ELSE
12592 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12593 ENDIF
12594 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12595 IF (NBBIN.GT.18) THEN
12596 NLINES = DBLE(NBBIN-18)/18.0D0
12597 IF (NLINES.GT.0) THEN
12598 DO 8 I=1,NLINES
12599 I0 = 18*(I+1)-17
12600 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12601 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12602 8 CONTINUE
12603 ENDIF
12604 I0 = 18*(NLINES+1)+1
12605 IF (I0.LE.NBBIN) THEN
12606 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12607 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12608 ENDIF
12609 ENDIF
12610* number of data sets to follow in the Glauber data file
12611* this variable is used for checks of consistency of projectile
12612* and target mass configurations given in header of Glauber data
12613* file and the data-sets which follow in this file
12614 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12615*
12616* read profile function data
12617 NSET = 0
12618 NAIDX = 0
12619 IPOLD = 0
12620 10 CONTINUE
12621 NSET = NSET+1
12622 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12623 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12624 1002 FORMAT(5I10,E15.5)
12625 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12626 NAIDX = NAIDX+1
12627 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12628 IAIDX(NAIDX) = IP
12629 IPOLD = IP
12630 ENDIF
12631 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12632 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12633 NLINES = INT(DBLE(ISITEB)/7.0D0)
12634 IF (NLINES.GT.0) THEN
12635 DO 11 I=1,NLINES
12636 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12637 11 CONTINUE
12638 ENDIF
12639 I0 = 7*NLINES+1
12640 IF (I0.LE.ISITEB)
12641 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12642 GOTO 10
12643 100 CONTINUE
12644 NSET = NSET-1
12645 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12646 WRITE(LOUT,'(/,1X,A)')
12647 & ' projectiles other than protons and nuclei: (particle index)'
12648 IF (NAIDX.GT.0) THEN
12649 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12650 ELSE
12651 WRITE(LOUT,'(6X,A)') 'none'
12652 ENDIF
12653*
12654 CLOSE(LDAT)
12655 WRITE(LOUT,*)
12656 LREAD = .TRUE.
12657
12658 IF (NCOMPO.EQ.0) THEN
12659 DO 12 J=1,NBBIN
12660 NCOMPO = NCOMPO+1
12661 IEMUMA(NCOMPO) = IBBIN(J)
12662 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12663 EMUFRA(NCOMPO) = 1.0D0
12664 12 CONTINUE
12665 IEMUL = 1
12666 ENDIF
12667*
12668* calculate profile function for certain set of parameters
12669*
12670 ELSE
12671
12672c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12673*
12674* check for type of projectile and set index-offset to entry in
12675* Glauber data array correspondingly
12676 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12677 IF (IOFFST(IDPROJ).EQ.-1) THEN
12678 STOP ' GLBSET: no data for this projectile !'
12679 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12680 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12681 ELSE
12682 IDXOFF = 0
12683 ENDIF
12684*
12685* get energy bin and interpolation factor
12686 IF (LCMS) THEN
12687 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12688 ELSE
12689 E = ELAB
12690 ENDIF
12691 E = LOG10(E)
12692 IF (E.LT.ELO) THEN
12693 IF (LFRST1) THEN
12694 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12695 LFRST1 = .FALSE.
12696 ENDIF
12697 E = ELO
12698 ENDIF
12699 IF (E.GT.EHI) THEN
12700 IF (LFRST2) THEN
12701 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12702 LFRST2 = .FALSE.
12703 ENDIF
12704 E = EHI
12705 ENDIF
12706 IE0 = (E-ELO)/DEBIN+1
12707 IE1 = IE0+1
12708 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12709*
12710* get target nucleus index
12711 KB = 0
12712 NBACC = KBACC
12713 DO 20 I=1,NBBIN
12714 NBDIFF = ABS(NB-IBBIN(I))
12715 IF (NB.EQ.IBBIN(I)) THEN
12716 KB = I
12717 GOTO 21
12718 ELSEIF (NBDIFF.LE.NBACC) THEN
12719 KB = I
12720 NBACC = NBDIFF
12721 ENDIF
12722 20 CONTINUE
12723 IF (KB.NE.0) GOTO 21
12724 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12725 STOP
12726 21 CONTINUE
12727*
12728* get projectile nucleus bin and interpolation factor
12729 KA0 = 0
12730 KA1 = 0
12731 FACNA = 0
12732 IF (IDXOFF.GT.0) THEN
12733 KA0 = 1
12734 KA1 = 1
12735 KABIN = 1
12736 ELSE
12737 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12738 DO 22 I=1,NABIN
12739 IF (NA.EQ.IABIN(I)) THEN
12740 KA0 = I
12741 KA1 = I
12742 GOTO 23
12743 ELSEIF (NA.LT.IABIN(I)) THEN
12744 KA0 = I-1
12745 KA1 = I
12746 GOTO 23
12747 ENDIF
12748 22 CONTINUE
12749 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12750 STOP
12751 23 CONTINUE
12752 IF (KA0.NE.KA1)
12753 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12754 KABIN = NABIN
12755 ENDIF
12756*
12757* interpolate profile functions for interactions ka0-kb and ka1-kb
12758* for energy E separately
12759 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12760 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12761 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12762 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12763 DO 30 I=1,ISITEB
12764 BPRO0(I) = BPROFL(IDX0,I)
12765 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12766 BPRO1(I) = BPROFL(IDY0,I)
12767 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12768 30 CONTINUE
12769 RADB = DT_RNCLUS(NB)
12770 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12771 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12772*
12773* interpolate cross sections for energy E and projectile mass
12774 DO 31 I=1,6
12775 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12776 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12777 XS(I) = XS0+FACNA*(XS1-XS0)
12778 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12779 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12780 XE(I) = XE0+FACNA*(XE1-XE0)
12781 31 CONTINUE
12782*
12783* interpolate between ka0 and ka1
12784 RADA = DT_RNCLUS(NA)
12785 BMX = 2.0D0*(RADA+RADB)
12786 BSTP = BMX/DBLE(ISITEB-1)
12787 BPRO(1) = ZERO
12788 DO 32 I=1,ISITEB-1
12789 B = DBLE(I)*BSTP
12790*
12791* calculate values of profile functions at B
12792 IDX0 = B/BSTP0+1
12793 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12794 IDX1 = MIN(IDX0+1,ISITEB)
12795 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12796 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12797 IDX0 = B/BSTP1+1
12798 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12799 IDX1 = MIN(IDX0+1,ISITEB)
12800 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12801 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12802*
12803 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12804 32 CONTINUE
12805*
12806* fill common dtglam
12807 NSITEB = ISITEB
12808 RASH(1) = RADA
12809 RBSH(1) = RADB
12810 BMAX(1) = BMX
12811 BSTEP(1) = BSTP
12812 DO 33 I=1,KSITEB
12813 BSITE(0,1,1,I) = BPRO(I)
12814 33 CONTINUE
12815*
12816* fill common dtglxs
12817 XSTOT(1,1,1) = XS(1)
12818 XSELA(1,1,1) = XS(2)
12819 XSQEP(1,1,1) = XS(3)
12820 XSQET(1,1,1) = XS(4)
12821 XSQE2(1,1,1) = XS(5)
12822 XSPRO(1,1,1) = XS(6)
12823 XETOT(1,1,1) = XE(1)
12824 XEELA(1,1,1) = XE(2)
12825 XEQEP(1,1,1) = XE(3)
12826 XEQET(1,1,1) = XE(4)
12827 XEQE2(1,1,1) = XE(5)
12828 XEPRO(1,1,1) = XE(6)
12829
12830 ENDIF
12831
12832 RETURN
12833 END
12834*$ CREATE DT_XKSAMP.FOR
12835*COPY DT_XKSAMP
12836*
12837*===xksamp=============================================================*
12838*
12839 SUBROUTINE DT_XKSAMP(NN,ECM)
12840
12841************************************************************************
12842* Sampling of parton x-values and chain system for one interaction. *
12843* processed by S. Roesler, 9.8.95 *
12844************************************************************************
12845
12846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12847 SAVE
12848
12849 PARAMETER ( LINP = 10 ,
12850 & LOUT = 6 ,
12851 & LDAT = 9 )
12852
12853 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12854 SAVE
12855
12856 PARAMETER (
12857* lower cuts for (valence-sea/sea-valence) chain masses
12858* antiquark-quark (u/d-sea quark) (s-sea quark)
12859 & AMIU = 0.5D0, AMIS = 0.8D0,
12860* quark-diquark (u/d-sea quark) (s-sea quark)
12861 & AMAU = 2.6D0, AMAS = 2.6D0,
12862* maximum lower valence-x threshold
12863 & XVMAX = 0.98D0,
12864* fraction of sea-diquarks sampled out of sea-partons
12865**test
12866C & FRCDIQ = 0.9D0,
12867**
12868*
12869 & SQMA = 0.7D0,
12870*
12871* maximum number of trials to generate x's for the required number
12872* of sea quark pairs for a given hadron
12873 & NSEATY = 12
12874C & NSEATY = 3
12875 & )
12876
12877 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12878
12879 PARAMETER ( MAXNCL = 260,
12880
12881 & MAXVQU = MAXNCL,
12882 & MAXSQU = 20*MAXVQU,
12883 & MAXINT = MAXVQU+MAXSQU)
12884
12885* event history
12886
12887 PARAMETER (NMXHKK=200000)
12888
12889 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12890 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12891 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12892
12893* particle properties (BAMJET index convention)
12894 CHARACTER*8 ANAME
12895 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12896 & IICH(210),IIBAR(210),K1(210),K2(210)
12897
12898* interface between Glauber formalism and DPM
12899 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12900 & INTER1(MAXINT),INTER2(MAXINT)
12901
12902* properties of interacting particles
12903 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12904
12905* threshold values for x-sampling (DTUNUC 1.x)
12906 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12907 & SSMIMQ,VVMTHR
12908
12909* x-values of partons (DTUNUC 1.x)
12910 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12911 & XTVQ(MAXVQU),XTVD(MAXVQU),
12912 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12913 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12914
12915* flavors of partons (DTUNUC 1.x)
12916 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12917 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12918 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12919 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12920 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12921 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12922 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12923
12924* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12925 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12926 & IXPV,IXPS,IXTV,IXTS,
12927 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12928 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12929 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12930 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12931 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12932 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12933 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12934 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12935
12936* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12937 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12938 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12939
12940* auxiliary common for chain system storage (DTUNUC 1.x)
12941 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12942
12943* flags for input different options
12944 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12945 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12946 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12947
12948* various options for treatment of partons (DTUNUC 1.x)
12949* (chain recombination, Cronin,..)
12950 LOGICAL LCO2CR,LINTPT
12951 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12952 & LCO2CR,LINTPT
12953
12954 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12955 & INTLO(MAXINT)
12956
12957* (1) initializations
12958*-----------------------------------------------------------------------
12959
12960**test
12961 IF (ECM.LT.4.5D0) THEN
12962C FRCDIQ = 0.6D0
12963 FRCDIQ = 0.4D0
12964 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12965C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12966 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12967 ELSE
12968C FRCDIQ = 0.9D0
12969 FRCDIQ = 0.7D0
12970 ENDIF
12971**
12972 DO 30 I=1,MAXSQU
12973 ZUOSP(I) = .FALSE.
12974 ZUOST(I) = .FALSE.
12975 IF (I.LE.MAXVQU) THEN
12976 ZUOVP(I) = .FALSE.
12977 ZUOVT(I) = .FALSE.
12978 ENDIF
12979 30 CONTINUE
12980
12981* lower thresholds for x-selection
12982* sea-quarks (default: CSEA=0.2)
12983 IF (ECM.LT.10.0D0) THEN
12984**!!test
12985 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12986C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12987 NSEA = NSEATY
12988C XSTHR = ONE/ECM**2
12989 ELSE
12990**sr 30.3.98
12991C XSTHR = CSEA/ECM
12992 XSTHR = CSEA/ECM**2
12993C XSTHR = ONE/ECM**2
12994**
12995 IF ((IP.GE.150).AND.(IT.GE.150))
12996 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12997 NSEA = NSEATY
12998 ENDIF
12999* (default: SSMIMA=0.14) used for sea-diquarks (?)
13000 XSSTHR = SSMIMA/ECM
13001 BSQMA = SQMA/ECM
13002* valence-quarks (default: CVQ=1.0)
13003 XVTHR = CVQ/ECM
13004* valence-diquarks (default: CDQ=2.0)
13005 XDTHR = CDQ/ECM
13006
13007* maximum-x for sea-quarks
13008 XVCUT = XVTHR+XDTHR
13009 IF (XVCUT.GT.XVMAX) THEN
13010 XVCUT = XVMAX
13011 XVTHR = XVCUT/3.0D0
13012 XDTHR = XVCUT-XVTHR
13013 ENDIF
13014 XXSEAM = ONE-XVCUT
13015**sr 18.4. test: DPMJET
13016C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13017C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13018C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13019**
13020* maximum number of sea-pairs allowed kinematically
13021C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13022 RNSMAX = OHALF*XXSEAM/XSTHR
13023 IF (RNSMAX.GT.10000.0D0) THEN
13024 NSMAX = 10000
13025 ELSE
13026 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13027 ENDIF
13028* check kinematical limit for valence-x thresholds
13029* (should be obsolete now)
13030 IF (XVCUT.GT.XVMAX) THEN
13031 WRITE(LOUT,1000) XVCUT,ECM
13032 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13033 & ' thresholds not allowed (',2E9.3,')')
13034C XVTHR = XVMAX-XDTHR
13035C IF (XVTHR.LT.ZERO) STOP
13036 STOP
13037 ENDIF
13038
13039* set eta for valence-x sampling (BETREJ)
13040* (UNON per default, UNOM used for projectile mesons only)
13041 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13042 UNOPRV = UNOM
13043 ELSE
13044 UNOPRV = UNON
13045 ENDIF
13046
13047* (2) select parton x-values of interacting projectile nucleons
13048*-----------------------------------------------------------------------
13049
13050 IXPV = 0
13051 IXPS = 0
13052
13053 DO 100 IPP=1,IP
13054* get interacting projectile nucleon as sampled by Glauber
13055 IF (JSSH(IPP).NE.0) THEN
13056 IXSTMP = IXPS
13057 IXVTMP = IXPV
13058 99 CONTINUE
13059 IXPS = IXSTMP
13060 IXPV = IXVTMP
13061* JIPP is the actual number of sea-pairs sampled for this nucleon
13062 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13063 41 CONTINUE
13064 XXSEA = ZERO
13065 IF (JIPP.GT.0) THEN
13066 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13067*???
13068 IF (XSTHR.GE.XSMAX) THEN
13069 JIPP = JIPP-1
13070 GOTO 41
13071 ENDIF
13072
13073*>>>get x-values of sea-quark pairs
13074 NSCOUN = 0
13075 PLW = 0.5D0
13076 40 CONTINUE
13077* accumulator for sea x-values
13078 XXSEA = ZERO
13079 NSCOUN = NSCOUN+1
13080 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13081 IF (NSCOUN.GT.NSEA) THEN
13082* decrease the number of interactions after NSEA trials
13083 JIPP = JIPP-1
13084 NSCOUN = 0
13085 ENDIF
13086 DO 70 ISQ=1,JIPP
13087* sea-quarks
13088 IF (IPSQ(IXPS+1).LE.2) THEN
13089**sr 8.4.98 (1/sqrt(x))
13090C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13091C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13092 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13093**
13094 ELSE
13095 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13096 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13097 ELSE
13098**sr 8.4.98 (1/sqrt(x))
13099C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13100C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13101 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13102**
13103 ENDIF
13104 ENDIF
13105* sea-antiquarks
13106 IF (IPSAQ(IXPS+1).GE.-2) THEN
13107**sr 8.4.98 (1/sqrt(x))
13108C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13109C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13110 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13111**
13112 ELSE
13113 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13114 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13115 ELSE
13116**sr 8.4.98 (1/sqrt(x))
13117C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13118C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13119 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13120**
13121 ENDIF
13122 ENDIF
13123 XXSEA = XXSEA+XPSQI+XPSAQI
13124* check for maximum allowed sea x-value
13125 IF (XXSEA.GE.XXSEAM) THEN
13126 IXPS = IXPS-ISQ+1
13127 GOTO 40
13128 ENDIF
13129* accept this sea-quark pair
13130 IXPS = IXPS+1
13131 XPSQ(IXPS) = XPSQI
13132 XPSAQ(IXPS) = XPSAQI
13133 IFROSP(IXPS) = IPP
13134 ZUOSP(IXPS) = .TRUE.
13135 70 CONTINUE
13136 ENDIF
13137
13138*>>>get x-values of valence partons
13139* valence quark
13140 IF (XVTHR.GT.0.05D0) THEN
13141 XVHI = ONE-XXSEA-XDTHR
13142 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13143 ELSE
13144 90 CONTINUE
13145 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13146 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13147 & GOTO 90
13148 ENDIF
13149* valence diquark
13150 XPVDI = ONE-XPVQI-XXSEA
13151* reject according to x**1.5
13152 XDTMP = XPVDI**1.5D0
13153 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13154* accept these valence partons
13155 IXPV = IXPV+1
13156 XPVQ(IXPV) = XPVQI
13157 XPVD(IXPV) = XPVDI
13158 IFROVP(IXPV) = IPP
13159 ITOVP(IPP) = IXPV
13160 ZUOVP(IXPV) = .TRUE.
13161
13162 ENDIF
13163 100 CONTINUE
13164
13165* (3) select parton x-values of interacting target nucleons
13166*-----------------------------------------------------------------------
13167
13168 IXTV = 0
13169 IXTS = 0
13170
13171 DO 170 ITT=1,IT
13172* get interacting target nucleon as sampled by Glauber
13173 IF (JTSH(ITT).NE.0) THEN
13174 IXSTMP = IXTS
13175 IXVTMP = IXTV
13176 169 CONTINUE
13177 IXTS = IXSTMP
13178 IXTV = IXVTMP
13179* JITT is the actual number of sea-pairs sampled for this nucleon
13180 JITT = MIN(JTSH(ITT)-1,NSMAX)
13181 111 CONTINUE
13182 XXSEA = ZERO
13183 IF (JITT.GT.0) THEN
13184 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13185*???
13186 IF (XSTHR.GE.XSMAX) THEN
13187 JITT = JITT-1
13188 GOTO 111
13189 ENDIF
13190
13191*>>>get x-values of sea-quark pairs
13192 NSCOUN = 0
13193 PLW = 0.5D0
13194 110 CONTINUE
13195* accumulator for sea x-values
13196 XXSEA = ZERO
13197 NSCOUN = NSCOUN+1
13198 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13199 IF (NSCOUN.GT.NSEA)THEN
13200* decrease the number of interactions after NSEA trials
13201 JITT = JITT-1
13202 NSCOUN = 0
13203 ENDIF
13204 DO 140 ISQ=1,JITT
13205* sea-quarks
13206 IF (ITSQ(IXTS+1).LE.2) THEN
13207**sr 8.4.98 (1/sqrt(x))
13208C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13209C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13210 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13211**
13212 ELSE
13213 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13214 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13215 ELSE
13216**sr 8.4.98 (1/sqrt(x))
13217C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13218C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13219 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13220**
13221 ENDIF
13222 ENDIF
13223* sea-antiquarks
13224 IF (ITSAQ(IXTS+1).GE.-2) THEN
13225**sr 8.4.98 (1/sqrt(x))
13226C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13227C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13228 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13229**
13230 ELSE
13231 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13232 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13233 ELSE
13234**sr 8.4.98 (1/sqrt(x))
13235C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13236C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13237 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13238**
13239 ENDIF
13240 ENDIF
13241 XXSEA = XXSEA+XTSQI+XTSAQI
13242* check for maximum allowed sea x-value
13243 IF (XXSEA.GE.XXSEAM) THEN
13244 IXTS = IXTS-ISQ+1
13245 GOTO 110
13246 ENDIF
13247* accept this sea-quark pair
13248 IXTS = IXTS+1
13249 XTSQ(IXTS) = XTSQI
13250 XTSAQ(IXTS) = XTSAQI
13251 IFROST(IXTS) = ITT
13252 ZUOST(IXTS) = .TRUE.
13253 140 CONTINUE
13254 ENDIF
13255
13256*>>>get x-values of valence partons
13257* valence quark
13258 IF (XVTHR.GT.0.05D0) THEN
13259 XVHI = ONE-XXSEA-XDTHR
13260 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13261 ELSE
13262 160 CONTINUE
13263 XTVQI = DT_DBETAR(OHALF,UNON)
13264 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13265 & GOTO 160
13266 ENDIF
13267* valence diquark
13268 XTVDI = ONE-XTVQI-XXSEA
13269* reject according to x**1.5
13270 XDTMP = XTVDI**1.5D0
13271 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13272* accept these valence partons
13273 IXTV = IXTV+1
13274 XTVQ(IXTV) = XTVQI
13275 XTVD(IXTV) = XTVDI
13276 IFROVT(IXTV) = ITT
13277 ITOVT(ITT) = IXTV
13278 ZUOVT(IXTV) = .TRUE.
13279
13280 ENDIF
13281 170 CONTINUE
13282
13283* (4) get valence-valence chains
13284*-----------------------------------------------------------------------
13285
13286 NVV = 0
13287 DO 240 I=1,NN
13288 INTLO(I) = .TRUE.
13289 IPVAL = ITOVP(INTER1(I))
13290 ITVAL = ITOVT(INTER2(I))
13291 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13292 INTLO(I) = .FALSE.
13293 ZUOVP(IPVAL) = .FALSE.
13294 ZUOVT(ITVAL) = .FALSE.
13295 NVV = NVV+1
13296 ISKPCH(8,NVV) = 0
13297 INTVV1(NVV) = IPVAL
13298 INTVV2(NVV) = ITVAL
13299 ENDIF
13300 240 CONTINUE
13301
13302* (5) get sea-valence chains
13303*-----------------------------------------------------------------------
13304
13305 NSV = 0
13306 NDV = 0
13307 PLW = 0.5D0
13308 DO 270 I=1,NN
13309 IF (INTLO(I)) THEN
13310 IPVAL = ITOVP(INTER1(I))
13311 ITVAL = ITOVT(INTER2(I))
13312 DO 250 J=1,IXPS
13313 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13314 & ZUOVT(ITVAL)) THEN
13315 ZUOSP(J) = .FALSE.
13316 ZUOVT(ITVAL) = .FALSE.
13317 INTLO(I) = .FALSE.
13318 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13319* sample sea-diquark pair
13320 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13321 IF (IREJ1.EQ.0) GOTO 260
13322 ENDIF
13323 NSV = NSV+1
13324 ISKPCH(4,NSV) = 0
13325 INTSV1(NSV) = J
13326 INTSV2(NSV) = ITVAL
13327
13328*>>>correct chain kinematics according to minimum chain masses
13329* the actual chain masses
13330 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13331 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13332* get lower mass cuts
13333 IF (IPSQ(J).EQ.3) THEN
13334* q being s-quark
13335 AMCHK1 = AMAS
13336 AMCHK2 = AMIS
13337 ELSE
13338* q being u/d-quark
13339 AMCHK1 = AMAU
13340 AMCHK2 = AMIU
13341 ENDIF
13342* q-qq chain
13343* chain mass above minimum - resampling of sea-q x-value
13344 IF (AMSVQ1.GT.AMCHK1) THEN
13345 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13346**sr 8.4.98 (1/sqrt(x))
13347C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13348C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13349 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13350**
13351 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13352 XPSQ(J) = XPSQXX
13353* chain mass below minimum - reset sea-q x-value and correct
13354* diquark-x of the same nucleon
13355 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13356 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13357 DXPSQ = XPSQW-XPSQ(J)
13358 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13359 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13360 XPSQ(J) = XPSQW
13361 ENDIF
13362 ENDIF
13363* aq-q chain
13364* chain mass below minimum - reset sea-aq x-value and correct
13365* diquark-x of the same nucleon
13366 IF (AMSVQ2.LT.AMCHK2) THEN
13367 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13368 DXPSQ = XPSQW-XPSAQ(J)
13369 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13370 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13371 XPSAQ(J) = XPSQW
13372 ENDIF
13373 ENDIF
13374*>>>end of chain mass correction
13375
13376 GOTO 260
13377 ENDIF
13378 250 CONTINUE
13379 ENDIF
13380 260 CONTINUE
13381 270 CONTINUE
13382
13383* (6) get valence-sea chains
13384*-----------------------------------------------------------------------
13385
13386 NVS = 0
13387 NVD = 0
13388 DO 300 I=1,NN
13389 IF (INTLO(I)) THEN
13390 IPVAL = ITOVP(INTER1(I))
13391 ITVAL = ITOVT(INTER2(I))
13392 DO 280 J=1,IXTS
13393 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13394 & (IFROST(J).EQ.INTER2(I))) THEN
13395 ZUOST(J) = .FALSE.
13396 ZUOVP(IPVAL) = .FALSE.
13397 INTLO(I) = .FALSE.
13398 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13399* sample sea-diquark pair
13400 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13401 IF (IREJ1.EQ.0) GOTO 290
13402 ENDIF
13403 NVS = NVS + 1
13404 ISKPCH(6,NVS) = 0
13405 INTVS1(NVS) = IPVAL
13406 INTVS2(NVS) = J
13407
13408*>>>correct chain kinematics according to minimum chain masses
13409* the actual chain masses
13410 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13411 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13412* get lower mass cuts
13413 IF (ITSQ(J).EQ.3) THEN
13414* q being s-quark
13415 AMCHK1 = AMIS
13416 AMCHK2 = AMAS
13417 ELSE
13418* q being u/d-quark
13419 AMCHK1 = AMIU
13420 AMCHK2 = AMAU
13421 ENDIF
13422* q-aq chain
13423* chain mass below minimum - reset sea-aq x-value and correct
13424* diquark-x of the same nucleon
13425 IF (AMVSQ1.LT.AMCHK1) THEN
13426 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13427 DXTSQ = XTSQW-XTSAQ(J)
13428 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13429 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13430 XTSAQ(J) = XTSQW
13431 ENDIF
13432 ENDIF
13433* qq-q chain
13434* chain mass above minimum - resampling of sea-q x-value
13435 IF (AMVSQ2.GT.AMCHK2) THEN
13436 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13437**sr 8.4.98 (1/sqrt(x))
13438C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13439C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13440 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13441**
13442 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13443 XTSQ(J) = XTSQXX
13444* chain mass below minimum - reset sea-q x-value and correct
13445* diquark-x of the same nucleon
13446 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13447 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13448 DXTSQ = XTSQW-XTSQ(J)
13449 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13450 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13451 XTSQ(J) = XTSQW
13452 ENDIF
13453 ENDIF
13454*>>>end of chain mass correction
13455
13456 GOTO 290
13457 ENDIF
13458 280 CONTINUE
13459 ENDIF
13460 290 CONTINUE
13461 300 CONTINUE
13462
13463* (7) get sea-sea chains
13464*-----------------------------------------------------------------------
13465
13466 NSS = 0
13467 NDS = 0
13468 NSD = 0
13469 DO 420 I=1,NN
13470 IF (INTLO(I)) THEN
13471 IPVAL = ITOVP(INTER1(I))
13472 ITVAL = ITOVT(INTER2(I))
13473* loop over target partons not yet matched
13474 DO 400 J=1,IXTS
13475 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13476* loop over projectile partons not yet matched
13477 DO 390 JJ=1,IXPS
13478 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13479 ZUOSP(JJ) = .FALSE.
13480 ZUOST(J) = .FALSE.
13481 INTLO(I) = .FALSE.
13482 NSS = NSS+1
13483 ISKPCH(1,NSS) = 0
13484 INTSS1(NSS) = JJ
13485 INTSS2(NSS) = J
13486
13487*---->chain recombination option
13488 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13489 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13490 & THEN
13491* sea-sea chains may recombine with valence-valence chains
13492* only if they have the same projectile or target nucleon
13493 DO 4201 IVV=1,NVV
13494 IF (ISKPCH(8,IVV).NE.99) THEN
13495 IXVPR = INTVV1(IVV)
13496 IXVTA = INTVV2(IVV)
13497 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13498 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13499* recombination possible, drop old v-v and s-s chains
13500 ISKPCH(1,NSS) = 99
13501 ISKPCH(8,IVV) = 99
13502
13503* (a) assign new s-v chains
13504* ~~~~~~~~~~~~~~~~~~~~~~~~~
13505 IF (LSEADI.AND.
13506 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13507 & THEN
13508* sample sea-diquark pair
13509 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13510 & IREJ1)
13511 IF (IREJ1.EQ.0) GOTO 4202
13512 ENDIF
13513 NSV = NSV+1
13514 ISKPCH(4,NSV) = 0
13515 INTSV1(NSV) = JJ
13516 INTSV2(NSV) = IXVTA
13517*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13518* the actual chain masses
13519 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13520 & *ECM**2
13521 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13522 & *ECM**2
13523* get lower mass cuts
13524 IF (IPSQ(JJ).EQ.3) THEN
13525* q being s-quark
13526 AMCHK1 = AMAS
13527 AMCHK2 = AMIS
13528 ELSE
13529* q being u/d-quark
13530 AMCHK1 = AMAU
13531 AMCHK2 = AMIU
13532 ENDIF
13533* q-qq chain
13534* chain mass above minimum - resampling of sea-q x-value
13535 IF (AMSVQ1.GT.AMCHK1) THEN
13536 XPSQTH =
13537 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13538**sr 8.4.98 (1/sqrt(x))
13539 XPSQXX =
13540 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13541C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13542C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13543**
13544 XPVD(IPVAL) =
13545 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13546 XPSQ(JJ) = XPSQXX
13547* chain mass below minimum - reset sea-q x-value and correct
13548* diquark-x of the same nucleon
13549 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13550 XPSQW =
13551 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13552 DXPSQ = XPSQW-XPSQ(JJ)
13553 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13554 & THEN
13555 XPVD(IPVAL) =
13556 & XPVD(IPVAL)-DXPSQ
13557 XPSQ(JJ) = XPSQW
13558 ENDIF
13559 ENDIF
13560* aq-q chain
13561* chain mass below minimum - reset sea-aq x-value and correct
13562* diquark-x of the same nucleon
13563 IF (AMSVQ2.LT.AMCHK2) THEN
13564 XPSQW =
13565 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13566 DXPSQ = XPSQW-XPSAQ(JJ)
13567 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13568 & THEN
13569 XPVD(IPVAL) =
13570 & XPVD(IPVAL)-DXPSQ
13571 XPSAQ(JJ) = XPSQW
13572 ENDIF
13573 ENDIF
13574*>>>>>>>>>>>end of chain mass correction
13575 4202 CONTINUE
13576
13577* (b) assign new v-s chains
13578* ~~~~~~~~~~~~~~~~~~~~~~~~~
13579 IF (LSEADI.AND.(
13580 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13581 & THEN
13582* sample sea-diquark pair
13583 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13584 & IREJ1)
13585 IF (IREJ1.EQ.0) GOTO 4203
13586 ENDIF
13587 NVS = NVS+1
13588 ISKPCH(6,NVS) = 0
13589 INTVS1(NVS) = IXVPR
13590 INTVS2(NVS) = J
13591*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13592* the actual chain masses
13593 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13594 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13595* get lower mass cuts
13596 IF (ITSQ(J).EQ.3) THEN
13597* q being s-quark
13598 AMCHK1 = AMIS
13599 AMCHK2 = AMAS
13600 ELSE
13601* q being u/d-quark
13602 AMCHK1 = AMIU
13603 AMCHK2 = AMAU
13604 ENDIF
13605* q-aq chain
13606* chain mass below minimum - reset sea-aq x-value and correct
13607* diquark-x of the same nucleon
13608 IF (AMVSQ1.LT.AMCHK1) THEN
13609 XTSQW =
13610 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13611 DXTSQ = XTSQW-XTSAQ(J)
13612 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13613 & THEN
13614 XTVD(ITVAL) =
13615 & XTVD(ITVAL)-DXTSQ
13616 XTSAQ(J) = XTSQW
13617 ENDIF
13618 ENDIF
13619 IF (AMVSQ2.GT.AMCHK2) THEN
13620 XTSQTH =
13621 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13622**sr 8.4.98 (1/sqrt(x))
13623 XTSQXX =
13624 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13625C & DT_SAMSQX(XTSQTH,XTSQ(J))
13626C & DT_SAMPEX(XTSQTH,XTSQ(J))
13627**
13628 XTVD(ITVAL) =
13629 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13630 XTSQ(J) = XTSQXX
13631 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13632 XTSQW =
13633 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13634 DXTSQ = XTSQW-XTSQ(J)
13635 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13636 & THEN
13637 XTVD(ITVAL) =
13638 & XTVD(ITVAL)-DXTSQ
13639 XTSQ(J) = XTSQW
13640 ENDIF
13641 ENDIF
13642*>>>>>>>>>end of chain mass correction
13643 4203 CONTINUE
13644* jump out of s-s chain loop
13645 GOTO 420
13646 ENDIF
13647 ENDIF
13648 4201 CONTINUE
13649 ENDIF
13650*---->end of chain recombination option
13651
13652* sample sea-diquark pair (projectile)
13653 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13654 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13655 IF (IREJ1.EQ.0) THEN
13656 ISKPCH(1,NSS) = 99
13657 GOTO 410
13658 ENDIF
13659 ENDIF
13660* sample sea-diquark pair (target)
13661 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13662 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13663 IF (IREJ1.EQ.0) THEN
13664 ISKPCH(1,NSS) = 99
13665 GOTO 410
13666 ENDIF
13667 ENDIF
13668*>>>>>correct chain kinematics according to minimum chain masses
13669* the actual chain masses
13670 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13671 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13672* check for lower mass cuts
13673 IF ((SSMA1Q.LT.SSMIMQ).OR.
13674 & (SSMA2Q.LT.SSMIMQ)) THEN
13675 IPVAL = ITOVP(INTER1(I))
13676 ITVAL = ITOVT(INTER2(I))
13677 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13678 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13679* maximum allowed x values for sea quarks
13680 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13681 & 1.2D0*XSSTHR
13682 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13683 & 1.2D0*XSSTHR
13684* resampling of x values not possible - skip sea-sea chains
13685 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13686 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13687* resampling of x for projectile sea quark pair
13688 ICOUS = 0
13689 310 CONTINUE
13690 ICOUS = ICOUS+1
13691 IF (XSSTHR.GT.0.05D0) THEN
13692 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13693 & XSPMAX)
13694 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13695 & XSPMAX)
13696 ELSE
13697 320 CONTINUE
13698 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13699 IF ((XPSQI.LT.XSSTHR).OR.
13700 & (XPSQI.GT.XSPMAX)) GOTO 320
13701 330 CONTINUE
13702 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13703 IF ((XPSAQI.LT.XSSTHR).OR.
13704 & (XPSAQI.GT.XSPMAX)) GOTO 330
13705 ENDIF
13706* final test of remaining x for projectile diquark
13707 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13708 & +XPSQ(JJ)+XPSAQ(JJ)
13709 IF (XPVDCO.LE.XDTHR) THEN
13710*!!!
13711C IF (ICOUS.LT.5) GOTO 310
13712 IF (ICOUS.LT.0.5D0) GOTO 310
13713 GOTO 380
13714 ENDIF
13715* resampling of x for target sea quark pair
13716 ICOUS = 0
13717 350 CONTINUE
13718 ICOUS = ICOUS+1
13719 IF (XSSTHR.GT.0.05D0) THEN
13720 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13721 & XSTMAX)
13722 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13723 & XSTMAX)
13724 ELSE
13725 360 CONTINUE
13726 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13727 IF ((XTSQI.LT.XSSTHR).OR.
13728 & (XTSQI.GT.XSTMAX)) GOTO 360
13729 370 CONTINUE
13730 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13731 IF ((XTSAQI.LT.XSSTHR).OR.
13732 & (XTSAQI.GT.XSTMAX)) GOTO 370
13733 ENDIF
13734* final test of remaining x for target diquark
13735 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13736 & +XTSQ(J)+XTSAQ(J)
13737 IF (XTVDCO.LT.XDTHR) THEN
13738 IF (ICOUS.LT.5) GOTO 350
13739 GOTO 380
13740 ENDIF
13741 XPVD(IPVAL) = XPVDCO
13742 XTVD(ITVAL) = XTVDCO
13743 XPSQ(JJ) = XPSQI
13744 XPSAQ(JJ) = XPSAQI
13745 XTSQ(J) = XTSQI
13746 XTSAQ(J) = XTSAQI
13747*>>>>>end of chain mass correction
13748 GOTO 410
13749 ENDIF
13750* come here to discard s-s interaction
13751* resampling of x values not allowed or unsuccessful
13752 380 CONTINUE
13753 INTLO(I) = .FALSE.
13754 ZUOST(J) = .TRUE.
13755 ZUOSP(JJ) = .TRUE.
13756 NSS = NSS-1
13757 ENDIF
13758* consider next s-s interaction
13759 GOTO 410
13760 ENDIF
13761 390 CONTINUE
13762 ENDIF
13763 400 CONTINUE
13764 ENDIF
13765 410 CONTINUE
13766 420 CONTINUE
13767
13768* correct x-values of valence quarks for non-matching sea quarks
13769 DO 430 I=1,IXPS
13770 IF (ZUOSP(I)) THEN
13771 IPVAL = ITOVP(IFROSP(I))
13772 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13773 XPSQ(I) = ZERO
13774 XPSAQ(I) = ZERO
13775 ZUOSP(I) = .FALSE.
13776 ENDIF
13777 430 CONTINUE
13778 DO 440 I=1,IXTS
13779 IF (ZUOST(I)) THEN
13780 ITVAL = ITOVT(IFROST(I))
13781 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13782 XTSQ(I) = ZERO
13783 XTSAQ(I) = ZERO
13784 ZUOST(I) = .FALSE.
13785 ENDIF
13786 440 CONTINUE
13787 DO 450 I=1,IXPV
13788 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13789 450 CONTINUE
13790 DO 460 I=1,IXTV
13791 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13792 460 CONTINUE
13793
13794 RETURN
13795 END
13796
13797*$ CREATE DT_SAMSDQ.FOR
13798*COPY DT_SAMSDQ
13799*
13800*===samsdq=============================================================*
13801*
13802 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13803
13804************************************************************************
13805* SAMpling of Sea-DiQuarks *
13806* ECM cm-energy of the nucleon-nucleon system *
13807* IDX1,2 indices of x-values of the participating *
13808* partons (IDX2 is always the sea-q-pair to be *
13809* changed to sea-qq-pair) *
13810* MODE = 1 valence-q - sea-diq *
13811* = 2 sea-diq - valence-q *
13812* = 3 sea-q - sea-diq *
13813* = 4 sea-diq - sea-q *
13814* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13815* This version dated 17.10.95 is written by S. Roesler *
13816************************************************************************
13817
13818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13819 SAVE
13820
13821 PARAMETER (ZERO=0.0D0)
13822
13823* threshold values for x-sampling (DTUNUC 1.x)
13824 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13825 & SSMIMQ,VVMTHR
13826
13827* various options for treatment of partons (DTUNUC 1.x)
13828* (chain recombination, Cronin,..)
13829 LOGICAL LCO2CR,LINTPT
13830 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13831 & LCO2CR,LINTPT
13832
13833 PARAMETER ( MAXNCL = 260,
13834
13835 & MAXVQU = MAXNCL,
13836 & MAXSQU = 20*MAXVQU,
13837 & MAXINT = MAXVQU+MAXSQU)
13838
13839* x-values of partons (DTUNUC 1.x)
13840 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13841 & XTVQ(MAXVQU),XTVD(MAXVQU),
13842 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13843 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13844
13845* flavors of partons (DTUNUC 1.x)
13846 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13847 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13848 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13849 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13850 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13851 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13852 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13853
13854* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13855 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13856 & IXPV,IXPS,IXTV,IXTS,
13857 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13858 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13859 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13860 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13861 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13862 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13863 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13864 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13865
13866* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13867 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13868 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13869
13870* auxiliary common for chain system storage (DTUNUC 1.x)
13871 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13872
13873 IREJ = 0
13874* threshold-x for valence diquarks
13875 XDTHR = CDQ/ECM
13876
13877 GOTO (1,2,3,4) MODE
13878
13879*---------------------------------------------------------------------
13880* proj. valence partons - targ. sea partons
13881* get x-values and flavors for target sea-diquark pair
13882
13883 1 CONTINUE
13884 IDXVP = IDX1
13885 IDXST = IDX2
13886
13887* index of corr. val-diquark-x in target nucleon
13888 IDXVT = ITOVT(IFROST(IDXST))
13889* available x above diquark thresholds for valence- and sea-diquarks
13890 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13891
13892 IF (XXD.GE.ZERO) THEN
13893* x-values for the three diquarks of the target nucleon
13894 RR1 = DT_RNDM(XXD)
13895 RR2 = DT_RNDM(RR1)
13896 RR3 = DT_RNDM(RR2)
13897 SR123 = RR1+RR2+RR3
13898 XXTV = XDTHR+RR1*XXD/SR123
13899 XXTSQ = XDTHR+RR2*XXD/SR123
13900 XXTSAQ = XDTHR+RR3*XXD/SR123
13901 ELSE
13902 XXTV = XTVD(IDXVT)
13903 XXTSQ = XTSQ(IDXST)
13904 XXTSAQ = XTSAQ(IDXST)
13905 ENDIF
13906* flavor of the second quarks in the sea-diquark pair
13907 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13908 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13909* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13910 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13911 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13912 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13913* ss-asas pair
13914 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13915 IREJ = 1
13916 RETURN
13917 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13918* at least one strange quark
13919 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13920 IREJ = 1
13921 RETURN
13922 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13923 IREJ = 1
13924 RETURN
13925 ENDIF
13926* accept the new sea-diquark
13927 XTVD(IDXVT) = XXTV
13928 XTSQ(IDXST) = XXTSQ
13929 XTSAQ(IDXST) = XXTSAQ
13930 NVD = NVD+1
13931 INTVD1(NVD) = IDXVP
13932 INTVD2(NVD) = IDXST
13933 ISKPCH(7,NVD) = 0
13934 RETURN
13935
13936*---------------------------------------------------------------------
13937* proj. sea partons - targ. valence partons
13938* get x-values and flavors for projectile sea-diquark pair
13939
13940 2 CONTINUE
13941 IDXSP = IDX2
13942 IDXVT = IDX1
13943
13944* index of corr. val-diquark-x in projectile nucleon
13945 IDXVP = ITOVP(IFROSP(IDXSP))
13946* available x above diquark thresholds for valence- and sea-diquarks
13947 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13948
13949 IF (XXD.GE.ZERO) THEN
13950* x-values for the three diquarks of the projectile nucleon
13951 RR1 = DT_RNDM(XXD)
13952 RR2 = DT_RNDM(RR1)
13953 RR3 = DT_RNDM(RR2)
13954 SR123 = RR1+RR2+RR3
13955 XXPV = XDTHR+RR1*XXD/SR123
13956 XXPSQ = XDTHR+RR2*XXD/SR123
13957 XXPSAQ = XDTHR+RR3*XXD/SR123
13958 ELSE
13959 XXPV = XPVD(IDXVP)
13960 XXPSQ = XPSQ(IDXSP)
13961 XXPSAQ = XPSAQ(IDXSP)
13962 ENDIF
13963* flavor of the second quarks in the sea-diquark pair
13964 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13965 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13966* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13967 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13968 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13969 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13970* ss-asas pair
13971 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13972 IREJ = 1
13973 RETURN
13974 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13975* at least one strange quark
13976 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13977 IREJ = 1
13978 RETURN
13979 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13980 IREJ = 1
13981 RETURN
13982 ENDIF
13983* accept the new sea-diquark
13984 XPVD(IDXVP) = XXPV
13985 XPSQ(IDXSP) = XXPSQ
13986 XPSAQ(IDXSP) = XXPSAQ
13987 NDV = NDV+1
13988 INTDV1(NDV) = IDXSP
13989 INTDV2(NDV) = IDXVT
13990 ISKPCH(5,NDV) = 0
13991 RETURN
13992
13993*---------------------------------------------------------------------
13994* proj. sea partons - targ. sea partons
13995* get x-values and flavors for target sea-diquark pair
13996
13997 3 CONTINUE
13998 IDXSP = IDX1
13999 IDXST = IDX2
14000
14001* index of corr. val-diquark-x in target nucleon
14002 IDXVT = ITOVT(IFROST(IDXST))
14003* available x above diquark thresholds for valence- and sea-diquarks
14004 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14005
14006 IF (XXD.GE.ZERO) THEN
14007* x-values for the three diquarks of the target nucleon
14008 RR1 = DT_RNDM(XXD)
14009 RR2 = DT_RNDM(RR1)
14010 RR3 = DT_RNDM(RR2)
14011 SR123 = RR1+RR2+RR3
14012 XXTV = XDTHR+RR1*XXD/SR123
14013 XXTSQ = XDTHR+RR2*XXD/SR123
14014 XXTSAQ = XDTHR+RR3*XXD/SR123
14015 ELSE
14016 XXTV = XTVD(IDXVT)
14017 XXTSQ = XTSQ(IDXST)
14018 XXTSAQ = XTSAQ(IDXST)
14019 ENDIF
14020* flavor of the second quarks in the sea-diquark pair
14021 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14022 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14023* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14024 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14025 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14026 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14027* ss-asas pair
14028 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14029 IREJ = 1
14030 RETURN
14031 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14032* at least one strange quark
14033 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14034 IREJ = 1
14035 RETURN
14036 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14037 IREJ = 1
14038 RETURN
14039 ENDIF
14040* accept the new sea-diquark
14041 XTVD(IDXVT) = XXTV
14042 XTSQ(IDXST) = XXTSQ
14043 XTSAQ(IDXST) = XXTSAQ
14044 NSD = NSD+1
14045 INTSD1(NSD) = IDXSP
14046 INTSD2(NSD) = IDXST
14047 ISKPCH(3,NSD) = 0
14048 RETURN
14049
14050*---------------------------------------------------------------------
14051* proj. sea partons - targ. sea partons
14052* get x-values and flavors for projectile sea-diquark pair
14053
14054 4 CONTINUE
14055 IDXSP = IDX2
14056 IDXST = IDX1
14057
14058* index of corr. val-diquark-x in projectile nucleon
14059 IDXVP = ITOVP(IFROSP(IDXSP))
14060* available x above diquark thresholds for valence- and sea-diquarks
14061 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14062
14063 IF (XXD.GE.ZERO) THEN
14064* x-values for the three diquarks of the projectile nucleon
14065 RR1 = DT_RNDM(XXD)
14066 RR2 = DT_RNDM(RR1)
14067 RR3 = DT_RNDM(RR2)
14068 SR123 = RR1+RR2+RR3
14069 XXPV = XDTHR+RR1*XXD/SR123
14070 XXPSQ = XDTHR+RR2*XXD/SR123
14071 XXPSAQ = XDTHR+RR3*XXD/SR123
14072 ELSE
14073 XXPV = XPVD(IDXVP)
14074 XXPSQ = XPSQ(IDXSP)
14075 XXPSAQ = XPSAQ(IDXSP)
14076 ENDIF
14077* flavor of the second quarks in the sea-diquark pair
14078 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14079 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14080* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14081 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14082 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14083 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14084* ss-asas pair
14085 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14086 IREJ = 1
14087 RETURN
14088 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14089* at least one strange quark
14090 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14091 IREJ = 1
14092 RETURN
14093 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14094 IREJ = 1
14095 RETURN
14096 ENDIF
14097* accept the new sea-diquark
14098 XPVD(IDXVP) = XXPV
14099 XPSQ(IDXSP) = XXPSQ
14100 XPSAQ(IDXSP) = XXPSAQ
14101 NDS = NDS+1
14102 INTDS1(NDS) = IDXSP
14103 INTDS2(NDS) = IDXST
14104 ISKPCH(2,NDS) = 0
14105 RETURN
14106 END
14107*$ CREATE DT_DIFEVT.FOR
14108*COPY DT_DIFEVT
14109*
14110*===difevt=============================================================*
14111*
14112 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14113 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14114
14115************************************************************************
14116* Interface to treatment of diffractive interactions. *
14117* (input) IFP1/2 PDG-indizes of projectile partons *
14118* (baryon: IFP2 - adiquark) *
14119* PP(4) projectile 4-momentum *
14120* IFT1/2 PDG-indizes of target partons *
14121* (baryon: IFT1 - adiquark) *
14122* PT(4) target 4-momentum *
14123* (output) JDIFF = 0 no diffraction *
14124* = 1/-1 LMSD/LMDD *
14125* = 2/-2 HMSD/HMDD *
14126* NCSY counter for two-chain systems *
14127* dumped to DTEVT1 *
14128* This version dated 14.02.95 is written by S. Roesler *
14129************************************************************************
14130
14131 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14132 SAVE
14133
14134 PARAMETER ( LINP = 10 ,
14135 & LOUT = 6 ,
14136 & LDAT = 9 )
14137
14138 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14139 & OHALF=0.5D0)
14140
14141* event history
14142
14143 PARAMETER (NMXHKK=200000)
14144
14145 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14146 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14147 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14148
14149* extended event history
14150 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14151 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14152 & IHIST(2,NMXHKK)
14153
14154* flags for diffractive interactions (DTUNUC 1.x)
14155 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14156
14157 DIMENSION PP(4),PT(4)
14158
14159 LOGICAL LFIRST
14160 DATA LFIRST /.TRUE./
14161
14162 IREJ = 0
14163 JDIFF = 0
14164 IFLAGD = JDIFF
14165
14166* cm. energy
14167 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14168 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14169* identities of projectile hadron / target nucleon
14170 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14171 KTARG = IDT_ICIHAD(IDHKK(MOT))
14172
14173* single diffractive xsections
14174 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14175* double diffractive xsections
14176**!! no double diff yet
14177C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14178 DDTOT = 0.0D0
14179 DDHM = 0.0D0
14180**!!
14181* total inelastic xsection
14182C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14183 DUMZER = ZERO
14184 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14185 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14186
14187* fraction of diffractive processes
14188 FRADIF = (SDTOT+DDTOT)/SIGIN
14189
14190 IF (LFIRST) THEN
14191 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14192 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14193 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14194 & F5.1,' mb',/)
14195 LFIRST = .FALSE.
14196 ENDIF
14197
14198 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14199 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14200* diffractive interaction requested by x-section or by user
14201 FRASD = SDTOT/(SDTOT+DDTOT)
14202 FRASDH = SDHM/SDTOT
14203**sr needs to be specified!!
14204C FRADDH = DDHM/DDTOT
14205 FRADDH = 1.0D0
14206**
14207 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14208* single diffraction
14209 KDIFF = 1
14210 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14211 KP = 2
14212 KT = 0
14213 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14214 & ISINGD.NE.3) THEN
14215 KP = 0
14216 KT = 2
14217 ENDIF
14218 ELSE
14219 KP = 1
14220 KT = 0
14221 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14222 & ISINGD.NE.3) THEN
14223 KP = 0
14224 KT = 1
14225 ENDIF
14226 ENDIF
14227 ELSE
14228* double diffraction
14229 KDIFF = -1
14230 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14231 KP = 2
14232 KT = 2
14233 ELSE
14234 KP = 1
14235 KT = 1
14236 ENDIF
14237 ENDIF
14238 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14239 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14240 IF (IREJ1.EQ.0) THEN
14241 IFLAGD = 2*KDIFF
14242 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14243 ELSE
14244 GOTO 9999
14245 ENDIF
14246 ENDIF
14247 JDIFF = IFLAGD
14248
14249 RETURN
14250
14251 9999 CONTINUE
14252 IREJ = 1
14253 RETURN
14254 END
14255
14256*$ CREATE DT_DIFFKI.FOR
14257*COPY DT_DIFFKI
14258*
14259*===difkin=============================================================*
14260*
14261 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14262 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14263
14264************************************************************************
14265* Kinematics of diffractive nucleon-nucleon interaction. *
14266* IFP1/2 PDG-indizes of projectile partons *
14267* (baryon: IFP2 - adiquark) *
14268* PP(4) projectile 4-momentum *
14269* IFT1/2 PDG-indizes of target partons *
14270* (baryon: IFT1 - adiquark) *
14271* PT(4) target 4-momentum *
14272* KP = 0 projectile quasi-elastically scattered *
14273* = 1 excited to low-mass diff. state *
14274* = 2 excited to high-mass diff. state *
14275* KT = 0 target quasi-elastically scattered *
14276* = 1 excited to low-mass diff. state *
14277* = 2 excited to high-mass diff. state *
14278* This version dated 12.02.95 is written by S. Roesler *
14279************************************************************************
14280
14281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14282 SAVE
14283
14284 PARAMETER ( LINP = 10 ,
14285 & LOUT = 6 ,
14286 & LDAT = 9 )
14287
14288 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14289
14290 LOGICAL LSTART
14291
14292* particle properties (BAMJET index convention)
14293 CHARACTER*8 ANAME
14294 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14295 & IICH(210),IIBAR(210),K1(210),K2(210)
14296
14297* flags for input different options
14298 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14299 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14300 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14301
14302* rejection counter
14303 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14304 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14305 & IREXCI(3),IRDIFF(2),IRINC
14306
14307* kinematics of diffractive interactions (DTUNUC 1.x)
14308 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14309 & PPF(4),PTF(4),
14310 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14311 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14312
14313 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14314 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14315
14316 DATA LSTART /.TRUE./
14317
14318 IF (LSTART) THEN
14319 WRITE(LOUT,2000)
14320 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14321 LSTART = .FALSE.
14322 ENDIF
14323
14324 IREJ = 0
14325
14326* initialize common /DTDIKI/
14327 CALL DT_DIFINI
14328* store momenta of initial incoming particles for emc-check
14329 IF (LEMCCK) THEN
14330 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14331 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14332 ENDIF
14333
14334* masses of initial particles
14335 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14336 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14337 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14338 XMP = SQRT(XMP2)
14339 XMT = SQRT(XMT2)
14340* check quark-input (used to adjust coherence cond. for M-selection)
14341 IBP = 0
14342 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14343 IBT = 0
14344 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14345
14346* parameter for Lorentz-transformation into nucleon-nucleon cms
14347 DO 3 K=1,4
14348 PITOT(K) = PP(K)+PT(K)
14349 3 CONTINUE
14350 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14351 IF (XMTOT2.LE.ZERO) THEN
14352 WRITE(LOUT,1000) XMTOT2
14353 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14354 & 'XMTOT2 = ',E12.3)
14355 GOTO 9999
14356 ENDIF
14357 XMTOT = SQRT(XMTOT2)
14358 DO 4 K=1,4
14359 BGTOT(K) = PITOT(K)/XMTOT
14360 4 CONTINUE
14361* transformation of nucleons into cms
14362 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14363 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14364 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14365 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14366* rotation angles
14367 COD = PP1(3)/PPTOT
14368C SID = SQRT((ONE-COD)*(ONE+COD))
14369 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14370 SID = PPT/PPTOT
14371 COF = ONE
14372 SIF = ZERO
14373 IF(PPTOT*SID.GT.TINY10) THEN
14374 COF = PP1(1)/(SID*PPTOT)
14375 SIF = PP1(2)/(SID*PPTOT)
14376 ANORF = SQRT(COF*COF+SIF*SIF)
14377 COF = COF/ANORF
14378 SIF = SIF/ANORF
14379 ENDIF
14380* check consistency
14381 DO 5 K=1,4
14382 DEV1(K) = ABS(PP1(K)+PT1(K))
14383 5 CONTINUE
14384 DEV1(4) = ABS(DEV1(4)-XMTOT)
14385 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14386 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14387 WRITE(LOUT,1001) DEV1
14388 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14389 & /,8X,4E12.3)
14390 GOTO 9999
14391 ENDIF
14392
14393* select x-fractions in high-mass diff. interactions
14394 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14395
14396* select diffractive masses
14397* - projectile
14398 IF (KP.EQ.1) THEN
14399 XMPF = DT_XMLMD(XMTOT)
14400 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14401 IF (IREJ1.GT.0) GOTO 9999
14402 ELSEIF (KP.EQ.2) THEN
14403 XMPF = DT_XMHMD(XMTOT,IBP,1)
14404 ELSE
14405 XMPF = XMP
14406 ENDIF
14407* - target
14408 IF (KT.EQ.1) THEN
14409 XMTF = DT_XMLMD(XMTOT)
14410 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14411 IF (IREJ1.GT.0) GOTO 9999
14412 ELSEIF (KT.EQ.2) THEN
14413 XMTF = DT_XMHMD(XMTOT,IBT,2)
14414 ELSE
14415 XMTF = XMT
14416 ENDIF
14417
14418* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14419 XMPF2 = XMPF**2
14420 XMTF2 = XMTF**2
14421 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14422 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14423
14424* select momentum transfer (all t-values used here are <0)
14425* minimum absolute value to produce diffractive masses
14426 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14427 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14428 IF (IREJ1.GT.0) GOTO 9999
14429
14430* longitudinal momentum of excited/elastically scattered projectile
14431 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14432* total transverse momentum due to t-selection
14433 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14434 IF (PPBLT2.LT.ZERO) THEN
14435 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14436 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14437 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14438 GOTO 9999
14439 ENDIF
14440 CALL DT_DSFECF(SINPHI,COSPHI)
14441 PPBLT = SQRT(PPBLT2)
14442 PPBLOB(1) = COSPHI*PPBLT
14443 PPBLOB(2) = SINPHI*PPBLT
14444
14445* rotate excited/elastically scattered projectile into n-n cms.
14446 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14447 & XX,YY,ZZ)
14448 PPBLOB(1) = XX
14449 PPBLOB(2) = YY
14450 PPBLOB(3) = ZZ
14451
14452* 4-momentum of excited/elastically scattered target and of exchanged
14453* Pomeron
14454 DO 6 K=1,4
14455 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14456 PPOM1(K) = PP1(K)-PPBLOB(K)
14457 6 CONTINUE
14458 PTBLOB(4) = XMTOT-PPBLOB(4)
14459
14460* Lorentz-transformation back into system of initial diff. collision
14461 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14462 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14463 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14464 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14465 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14466 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14467 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14468 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14469 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14470
14471* store 4-momentum of elastically scattered particle (in single diff.
14472* events)
14473 IF (KP.EQ.0) THEN
14474 DO 7 K=1,4
14475 PSC(K) = PPF(K)
14476 7 CONTINUE
14477 ELSEIF (KT.EQ.0) THEN
14478 DO 8 K=1,4
14479 PSC(K) = PTF(K)
14480 8 CONTINUE
14481 ENDIF
14482
14483* check consistency of kinematical treatment so far
14484 IF (LEMCCK) THEN
14485 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14486 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14487 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14488 IF (IREJ1.NE.0) GOTO 9999
14489 ENDIF
14490 DO 9 K=1,4
14491 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14492 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14493 9 CONTINUE
14494 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14495 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14496 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14497 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14498 WRITE(LOUT,1003) DEV1,DEV2
14499 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14500 & 2(/,8X,4E12.3))
14501 GOTO 9999
14502 ENDIF
14503
14504* kinematical treatment for low-mass diffraction
14505 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14506 IF (IREJ1.NE.0) GOTO 9999
14507
14508* dump diffractive chains into DTEVT1
14509 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14510 IF (IREJ1.NE.0) GOTO 9999
14511
14512 RETURN
14513
14514 9999 CONTINUE
14515 IRDIFF(1) = IRDIFF(1)+1
14516 IREJ = 1
14517 RETURN
14518 END
14519
14520*$ CREATE DT_XMHMD.FOR
14521*COPY DT_XMHMD
14522*
14523*===xmhmd==============================================================*
14524*
14525 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14526
14527************************************************************************
14528* Diffractive mass in high mass single/double diffractive events. *
14529* This version dated 11.02.95 is written by S. Roesler *
14530************************************************************************
14531
14532 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14533 SAVE
14534
14535 PARAMETER ( LINP = 10 ,
14536 & LOUT = 6 ,
14537 & LDAT = 9 )
14538
14539 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14540
14541* kinematics of diffractive interactions (DTUNUC 1.x)
14542 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14543 & PPF(4),PTF(4),
14544 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14545 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14546
14547C DATA XCOLOW /0.05D0/
14548 DATA XCOLOW /0.15D0/
14549
14550 DT_XMHMD = ZERO
14551 XH = XPH(2)
14552 IF (MODE.EQ.2) XH = XTH(2)
14553
14554* minimum Pomeron-x for high-mass diffraction
14555* (adjusted to get a smooth transition between HM and LM component)
14556 R = DT_RNDM(XH)
14557 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14558 IF (ECM.LE.300.0D0) THEN
14559 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14560 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14561 ENDIF
14562* maximum Pomeron-x for high-mass diffraction
14563* (coherence condition, adjusted to fit to experimental data)
14564 IF (IB.NE.0) THEN
14565* baryon-diffraction
14566 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14567 ELSE
14568* meson-diffraction
14569 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14570 ENDIF
14571* check boundaries
14572 IF (XDIMIN.GE.XDIMAX) THEN
14573 XDIMIN = OHALF*XDIMAX
14574 ENDIF
14575
14576 KLOOP = 0
14577 1 CONTINUE
14578 KLOOP = KLOOP+1
14579 IF (KLOOP.GT.20) RETURN
14580* sample Pomeron-x from 1/x-distribution (critical Pomeron)
14581 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14582* corr. diffr. mass
14583 DT_XMHMD = ECM*SQRT(XDIFF)
14584 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14585
14586 RETURN
14587 END
14588
14589*$ CREATE DT_XMLMD.FOR
14590*COPY DT_XMLMD
14591*
14592*===xmlmd==============================================================*
14593*
14594 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14595
14596************************************************************************
14597* Diffractive mass in high mass single/double diffractive events. *
14598* This version dated 11.02.95 is written by S. Roesler *
14599************************************************************************
14600
14601 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14602 SAVE
14603
14604 PARAMETER ( LINP = 10 ,
14605 & LOUT = 6 ,
14606 & LDAT = 9 )
14607
14608* minimum Pomeron-x for low-mass diffraction
14609C AMO = 1.5D0
14610 AMO = 2.0D0
14611* maximum Pomeron-x for low-mass diffraction
14612* (adjusted to get a smooth transition between HM and LM component)
14613 R = DT_RNDM(AMO)
14614 SAM = 1.0D0
14615 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14616 R = DT_RNDM(AMO)*SAM
14617 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14618 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14619
14620* selection of diffractive mass
14621* (adjusted to get a smooth transition between HM and LM component)
14622 R = DT_RNDM(AMU)
14623 IF (ECM.LE.50.0D0) THEN
14624 DT_XMLMD = AMO*(AMU/AMO)**R
14625 ELSE
14626 A = 0.7D0
14627 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14628 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14629 ENDIF
14630
14631 RETURN
14632 END
14633
14634*$ CREATE DT_TDIFF.FOR
14635*COPY DT_TDIFF
14636*
14637*===tdiff==============================================================*
14638*
14639 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14640
14641************************************************************************
14642* t-selection for single/double diffractive interactions. *
14643* ECM cm. energy *
14644* TMIN minimum momentum transfer to produce diff. masses *
14645* XM1/XM2 diffractively produced masses *
14646* (for single diffraction XM2 is obsolete) *
14647* K1/K2= 0 not excited *
14648* = 1 low-mass excitation *
14649* = 2 high-mass excitation *
14650* This version dated 11.02.95 is written by S. Roesler *
14651************************************************************************
14652
14653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14654 SAVE
14655
14656 PARAMETER ( LINP = 10 ,
14657 & LOUT = 6 ,
14658 & LDAT = 9 )
14659
14660 PARAMETER (ZERO=0.0D0)
14661
14662 PARAMETER ( BTP0 = 3.7D0,
14663 & ALPHAP = 0.24D0 )
14664
14665 IREJ = 0
14666 NCLOOP = 0
14667 DT_TDIFF = ZERO
14668
14669 IF (K1.GT.0) THEN
14670 XM1 = XM1I
14671 XM2 = XM2I
14672 ELSE
14673 XM1 = XM2I
14674 ENDIF
14675 XDI = (XM1/ECM)**2
14676 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14677* slope for single diffraction
14678 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14679 ELSE
14680* slope for double diffraction
14681 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14682 ENDIF
14683
14684 1 CONTINUE
14685 NCLOOP = NCLOOP+1
14686 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14687 Y = DT_RNDM(XDI)
14688 T = -LOG(1.0D0-Y)/SLOPE
14689 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14690 DT_TDIFF = -ABS(T)
14691
14692 RETURN
14693
14694 9999 CONTINUE
14695 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14696 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14697 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14698 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14699 IREJ = 1
14700 RETURN
14701 END
14702
14703*$ CREATE DT_XVALHM.FOR
14704*COPY DT_XVALHM
14705*
14706*===xvalhm=============================================================*
14707*
14708 SUBROUTINE DT_XVALHM(KP,KT)
14709
14710************************************************************************
14711* Sampling of parton x-values in high-mass diffractive interactions. *
14712* This version dated 12.02.95 is written by S. Roesler *
14713************************************************************************
14714
14715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14716 SAVE
14717
14718 PARAMETER ( LINP = 10 ,
14719 & LOUT = 6 ,
14720 & LDAT = 9 )
14721
14722 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14723
14724* kinematics of diffractive interactions (DTUNUC 1.x)
14725 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14726 & PPF(4),PTF(4),
14727 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14728 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14729
14730* various options for treatment of partons (DTUNUC 1.x)
14731* (chain recombination, Cronin,..)
14732 LOGICAL LCO2CR,LINTPT
14733 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14734 & LCO2CR,LINTPT
14735
14736 DATA UNON,XVQTHR /2.0D0,0.8D0/
14737
14738 IF (KP.EQ.2) THEN
14739* x-fractions of projectile valence partons
14740 1 CONTINUE
14741 XPH(1) = DT_DBETAR(OHALF,UNON)
14742 IF (XPH(1).GE.XVQTHR) GOTO 1
14743 XPH(2) = ONE-XPH(1)
14744* x-fractions of Pomeron q-aq-pair
14745 XPOLO = TINY2
14746 XPOHI = ONE-TINY2
14747 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14748 XPPO(2) = ONE-XPPO(1)
14749* flavors of Pomeron q-aq-pair
14750 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14751 IFPPO(1) = IFLAV
14752 IFPPO(2) = -IFLAV
14753 IF (DT_RNDM(UNON).GT.OHALF) THEN
14754 IFPPO(1) = -IFLAV
14755 IFPPO(2) = IFLAV
14756 ENDIF
14757 ENDIF
14758
14759 IF (KT.EQ.2) THEN
14760* x-fractions of projectile target partons
14761 2 CONTINUE
14762 XTH(1) = DT_DBETAR(OHALF,UNON)
14763 IF (XTH(1).GE.XVQTHR) GOTO 2
14764 XTH(2) = ONE-XTH(1)
14765* x-fractions of Pomeron q-aq-pair
14766 XPOLO = TINY2
14767 XPOHI = ONE-TINY2
14768 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14769 XTPO(2) = ONE-XTPO(1)
14770* flavors of Pomeron q-aq-pair
14771 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14772 IFTPO(1) = IFLAV
14773 IFTPO(2) = -IFLAV
14774 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14775 IFTPO(1) = -IFLAV
14776 IFTPO(2) = IFLAV
14777 ENDIF
14778 ENDIF
14779
14780 RETURN
14781 END
14782
14783*$ CREATE DT_LM2RES.FOR
14784*COPY DT_LM2RES
14785*
14786*===lm2res=============================================================*
14787*
14788 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14789
14790************************************************************************
14791* Check low-mass diffractive excitation for resonance mass. *
14792* (input) IF1/2 PDG-indizes of valence partons *
14793* (in/out) XM diffractive mass requested/corrected *
14794* (output) IDR/IDXR id./BAMJET-index of resonance *
14795* This version dated 12.02.95 is written by S. Roesler *
14796************************************************************************
14797
14798 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14799 SAVE
14800
14801 PARAMETER ( LINP = 10 ,
14802 & LOUT = 6 ,
14803 & LDAT = 9 )
14804
14805 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14806
14807* kinematics of diffractive interactions (DTUNUC 1.x)
14808 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14809 & PPF(4),PTF(4),
14810 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14811 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14812
14813 IREJ = 0
14814 IF1B = 0
14815 IF2B = 0
14816 XMI = XM
14817
14818* BAMJET indices of partons
14819 IF1A = IDT_IPDG2B(IF1,1,2)
14820 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14821 IF2A = IDT_IPDG2B(IF2,1,2)
14822 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14823
14824* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14825 IDCH = 2
14826 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14827
14828* check for resonance mass
14829 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14830 IF (IREJ1.NE.0) GOTO 9999
14831
14832 XM = XMN
14833 RETURN
14834
14835 9999 CONTINUE
14836 IREJ = 1
14837 RETURN
14838 END
14839
14840*$ CREATE DT_LMKINE.FOR
14841*COPY DT_LMKINE
14842*
14843*===lmkine=============================================================*
14844*
14845 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14846
14847************************************************************************
14848* Kinematical treatment of low-mass excitations. *
14849* This version dated 12.02.95 is written by S. Roesler *
14850************************************************************************
14851
14852 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14853 SAVE
14854
14855 PARAMETER ( LINP = 10 ,
14856 & LOUT = 6 ,
14857 & LDAT = 9 )
14858
14859 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14860
14861* flags for input different options
14862 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14863 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14864 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14865
14866* kinematics of diffractive interactions (DTUNUC 1.x)
14867 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14868 & PPF(4),PTF(4),
14869 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14870 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14871
14872 DIMENSION P1(4),P2(4)
14873
14874 IREJ = 0
14875
14876 IF (KP.EQ.1) THEN
14877 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14878 POE = PPF(4)/PABS
14879 FAC1 = OHALF*(POE+ONE)
14880 FAC2 = -OHALF*(POE-ONE)
14881 DO 1 K=1,3
14882 PPLM1(K) = FAC1*PPF(K)
14883 PPLM2(K) = FAC2*PPF(K)
14884 1 CONTINUE
14885 PPLM1(4) = FAC1*PABS
14886 PPLM2(4) = -FAC2*PABS
14887 IF (IMSHL.EQ.1) THEN
14888
14889 XM1 = PYMASS(IFP1)
14890 XM2 = PYMASS(IFP2)
14891
14892 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14893 IF (IREJ1.NE.0) GOTO 9999
14894 DO 2 K=1,4
14895 PPLM1(K) = P1(K)
14896 PPLM2(K) = P2(K)
14897 2 CONTINUE
14898 ENDIF
14899 ENDIF
14900
14901 IF (KT.EQ.1) THEN
14902 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14903 POE = PTF(4)/PABS
14904 FAC1 = OHALF*(POE+ONE)
14905 FAC2 = -OHALF*(POE-ONE)
14906 DO 3 K=1,3
14907 PTLM2(K) = FAC1*PTF(K)
14908 PTLM1(K) = FAC2*PTF(K)
14909 3 CONTINUE
14910 PTLM2(4) = FAC1*PABS
14911 PTLM1(4) = -FAC2*PABS
14912 IF (IMSHL.EQ.1) THEN
14913
14914 XM1 = PYMASS(IFT1)
14915 XM2 = PYMASS(IFT2)
14916
14917 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14918 IF (IREJ1.NE.0) GOTO 9999
14919 DO 4 K=1,4
14920 PTLM1(K) = P1(K)
14921 PTLM2(K) = P2(K)
14922 4 CONTINUE
14923 ENDIF
14924 ENDIF
14925
14926 RETURN
14927
14928 9999 CONTINUE
14929 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14930 IREJ = 1
14931 RETURN
14932 END
14933
14934*$ CREATE DT_DIFINI.FOR
14935*COPY DT_DIFINI
14936*
14937*===difini=============================================================*
14938*
14939 SUBROUTINE DT_DIFINI
14940
14941************************************************************************
14942* Initialization of common /DTDIKI/ *
14943* This version dated 12.02.95 is written by S. Roesler *
14944************************************************************************
14945
14946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14947 SAVE
14948
14949 PARAMETER ( LINP = 10 ,
14950 & LOUT = 6 ,
14951 & LDAT = 9 )
14952
14953 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14954
14955* kinematics of diffractive interactions (DTUNUC 1.x)
14956 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14957 & PPF(4),PTF(4),
14958 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14959 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14960
14961 DO 1 K=1,4
14962 PPOM(K) = ZERO
14963 PSC(K) = ZERO
14964 PPF(K) = ZERO
14965 PTF(K) = ZERO
14966 PPLM1(K) = ZERO
14967 PPLM2(K) = ZERO
14968 PTLM1(K) = ZERO
14969 PTLM2(K) = ZERO
14970 1 CONTINUE
14971 DO 2 K=1,2
14972 XPH(K) = ZERO
14973 XPPO(K) = ZERO
14974 XTH(K) = ZERO
14975 XTPO(K) = ZERO
14976 IFPPO(K) = 0
14977 IFTPO(K) = 0
14978 2 CONTINUE
14979 IDPR = 0
14980 IDXPR = 0
14981 IDTR = 0
14982 IDXTR = 0
14983
14984 RETURN
14985 END
14986
14987*$ CREATE DT_DIFPUT.FOR
14988*COPY DT_DIFPUT
14989*
14990*===difput=============================================================*
14991*
14992 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14993 & IREJ)
14994
14995************************************************************************
14996* Dump diffractive chains into DTEVT1 *
14997* This version dated 12.02.95 is written by S. Roesler *
14998************************************************************************
14999
15000 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15001 SAVE
15002
15003 PARAMETER ( LINP = 10 ,
15004 & LOUT = 6 ,
15005 & LDAT = 9 )
15006
15007 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15008
15009 LOGICAL LCHK
15010
15011* kinematics of diffractive interactions (DTUNUC 1.x)
15012 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15013 & PPF(4),PTF(4),
15014 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15015 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15016
15017* event history
15018
15019 PARAMETER (NMXHKK=200000)
15020
15021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15024
15025* extended event history
15026 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15027 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15028 & IHIST(2,NMXHKK)
15029
15030* rejection counter
15031 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15032 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15033 & IREXCI(3),IRDIFF(2),IRINC
15034
15035 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15036 & P1(4),P2(4),P3(4),P4(4)
15037
15038 IREJ = 0
15039
15040 IF (KP.EQ.1) THEN
15041 DO 1 K=1,4
15042 PCH(K) = PPLM1(K)+PPLM2(K)
15043 1 CONTINUE
15044 ID1 = IFP1
15045 ID2 = IFP2
15046 IF (DT_RNDM(PT).GT.OHALF) THEN
15047 ID1 = IFP2
15048 ID2 = IFP1
15049 ENDIF
15050 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15051 & PPLM1(4),0,0,0)
15052 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15053 & PPLM2(4),0,0,0)
15054 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15055 & IDPR,IDXPR,8)
15056 ELSEIF (KP.EQ.2) THEN
15057 DO 2 K=1,4
15058 PP1(K) = XPH(1)*PP(K)
15059 PP2(K) = XPH(2)*PP(K)
15060 PT1(K) = -XPPO(1)*PPOM(K)
15061 PT2(K) = -XPPO(2)*PPOM(K)
15062 2 CONTINUE
15063 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15064 XM1 = ZERO
15065 XM2 = ZERO
15066 IF (LCHK) THEN
15067 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15068 IF (IREJ1.NE.0) GOTO 9999
15069 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15070 IF (IREJ1.NE.0) GOTO 9999
15071 DO 3 K=1,4
15072 PP1(K) = P1(K)
15073 PT1(K) = P2(K)
15074 PP2(K) = P3(K)
15075 PT2(K) = P4(K)
15076 3 CONTINUE
15077 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15078 & 0,0,8)
15079 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15080 & PT1(4),0,0,8)
15081 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15082 & 0,0,8)
15083 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15084 & PT2(4),0,0,8)
15085 ELSE
15086 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15087 IF (IREJ1.NE.0) GOTO 9999
15088 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15089 IF (IREJ1.NE.0) GOTO 9999
15090 DO 4 K=1,4
15091 PP1(K) = P1(K)
15092 PT2(K) = P2(K)
15093 PP2(K) = P3(K)
15094 PT1(K) = P4(K)
15095 4 CONTINUE
15096 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15097 & 0,0,8)
15098 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15099 & PT2(4),0,0,8)
15100 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15101 & 0,0,8)
15102 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15103 & PT1(4),0,0,8)
15104 ENDIF
15105 NCSY = NCSY+1
15106 ELSE
15107 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15108 & 0,0,0)
15109 ENDIF
15110
15111 IF (KT.EQ.1) THEN
15112 DO 5 K=1,4
15113 PCH(K) = PTLM1(K)+PTLM2(K)
15114 5 CONTINUE
15115 ID1 = IFT1
15116 ID2 = IFT2
15117 IF (DT_RNDM(PT).GT.OHALF) THEN
15118 ID1 = IFT2
15119 ID2 = IFT1
15120 ENDIF
15121 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15122 & PTLM1(4),0,0,0)
15123 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15124 & PTLM2(4),0,0,0)
15125 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15126 & IDTR,IDXTR,8)
15127 ELSEIF (KT.EQ.2) THEN
15128 DO 6 K=1,4
15129 PP1(K) = XTPO(1)*PPOM(K)
15130 PP2(K) = XTPO(2)*PPOM(K)
15131 PT1(K) = XTH(2)*PT(K)
15132 PT2(K) = XTH(1)*PT(K)
15133 6 CONTINUE
15134 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15135 XM1 = ZERO
15136 XM2 = ZERO
15137 IF (LCHK) THEN
15138 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15139 IF (IREJ1.NE.0) GOTO 9999
15140 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15141 IF (IREJ1.NE.0) GOTO 9999
15142 DO 7 K=1,4
15143 PP1(K) = P1(K)
15144 PT1(K) = P2(K)
15145 PP2(K) = P3(K)
15146 PT2(K) = P4(K)
15147 7 CONTINUE
15148 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15149 & PP1(4),0,0,8)
15150 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15151 & 0,0,8)
15152 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15153 & PP2(4),0,0,8)
15154 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15155 & 0,0,8)
15156 ELSE
15157 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15158 IF (IREJ1.NE.0) GOTO 9999
15159 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15160 IF (IREJ1.NE.0) GOTO 9999
15161 DO 8 K=1,4
15162 PP1(K) = P1(K)
15163 PT2(K) = P2(K)
15164 PP2(K) = P3(K)
15165 PT1(K) = P4(K)
15166 8 CONTINUE
15167 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15168 & PP1(4),0,0,8)
15169 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15170 & 0,0,8)
15171 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15172 & PP2(4),0,0,8)
15173 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15174 & 0,0,8)
15175 ENDIF
15176 NCSY = NCSY+1
15177 ELSE
15178 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15179 & 0,0,0)
15180 ENDIF
15181
15182 RETURN
15183
15184 9999 CONTINUE
15185 IRDIFF(2) = IRDIFF(2)+1
15186 IREJ = 1
15187 RETURN
15188 END
15189*$ CREATE DT_EVTFRG.FOR
15190*COPY DT_EVTFRG
15191*
15192*===evtfrg=============================================================*
15193*
15194 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15195
15196************************************************************************
15197* Hadronization of chains in DTEVT1. *
15198* *
15199* Input: *
15200* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15201* = 2 hadronization of DTUNUC-chains (id=88xxx) *
15202* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15203* hadronized with one PYEXEC call *
15204* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15205* with one PYEXEC call *
15206* Output: *
15207* NPYMEM number of entries in JETSET-common after hadronization *
15208* IREJ rejection flag *
15209* *
15210* This version dated 17.09.00 is written by S. Roesler *
15211************************************************************************
15212
15213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15214 SAVE
15215
15216 PARAMETER ( LINP = 10 ,
15217 & LOUT = 6 ,
15218 & LDAT = 9 )
15219
15220 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15221 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15222
15223 LOGICAL LACCEP
15224
15225 PARAMETER (MXJOIN=200)
15226
15227* event history
15228
15229 PARAMETER (NMXHKK=200000)
15230
15231 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15232 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15233 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15234
15235* extended event history
15236 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15237 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15238 & IHIST(2,NMXHKK)
15239
15240* flags for input different options
15241 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15242 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15243 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15244
15245* statistics
15246 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15247 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15248 & ICEVTG(8,0:30)
15249
15250* flags for diffractive interactions (DTUNUC 1.x)
15251 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15252
15253* nucleon-nucleon event-generator
15254 CHARACTER*8 CMODEL
15255 LOGICAL LPHOIN
15256 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15257* phojet
15258
15259C model switches and parameters
15260 CHARACTER*8 MDLNA
15261 INTEGER ISWMDL,IPAMDL
15262 DOUBLE PRECISION PARMDL
15263 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15264* jetset
15265
15266 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15267 PARAMETER (MAXLND=4000)
15268 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15269
15270 INTEGER PYK
15271
15272 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15273
15274 MODE = KMODE
15275 ISTSTG = 7
15276 IF (MODE.NE.1) ISTSTG = 8
15277 IREJ = 0
15278
15279 IP = 0
15280 ISH = 0
15281 INIEMC = 1
15282 NEND = NHKK
15283 NACCEP = 0
15284 IFRG = 0
15285 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15286 DO 10 I=NPOINT(3),NEND
15287* sr 14.02.00: seems to be not necessary anymore, commented
15288C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15289C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15290 LACCEP = .TRUE.
15291* pick up chains from dtevt1
15292 IDCHK = IDHKK(I)/10000
15293 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15294 IF (IDCHK.EQ.7) THEN
15295 IPJE = IDHKK(I)-IDCHK*10000
15296 IF (IPJE.NE.IFRG) THEN
15297 IFRG = IPJE
15298 IF (IFRG.GT.NFRG) GOTO 16
15299 ENDIF
15300 ELSE
15301 IPJE = 1
15302 IFRG = IFRG+1
15303 IF (IFRG.GT.NFRG) THEN
15304 NFRG = -1
15305 GOTO 16
15306 ENDIF
15307 ENDIF
15308* statistics counter
15309c IF (IDCH(I).LE.8)
15310c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15311c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15312* special treatment for small chains already corrected to hadrons
15313 IF (IDRES(I).NE.0) THEN
15314 IF (IDRES(I).EQ.11) THEN
15315 ID = IDXRES(I)
15316 ELSE
15317 ID = IDT_IPDGHA(IDXRES(I))
15318 ENDIF
15319 IF (LEMCCK) THEN
15320 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15321 & PHKK(4,I),INIEMC,IDUM,IDUM)
15322 INIEMC = 2
15323 ENDIF
15324 IP = IP+1
15325 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15326 P(IP,1) = PHKK(1,I)
15327 P(IP,2) = PHKK(2,I)
15328 P(IP,3) = PHKK(3,I)
15329 P(IP,4) = PHKK(4,I)
15330 P(IP,5) = PHKK(5,I)
15331 K(IP,1) = 1
15332 K(IP,2) = ID
15333 K(IP,3) = 0
15334 K(IP,4) = 0
15335 K(IP,5) = 0
15336 IHIST(2,I) = 10000*IPJE+IP
15337 IF (IHIST(1,I).LE.-100) THEN
15338 ISH = ISH+1
15339 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15340 ISJOIN(ISH) = I
15341 ENDIF
15342 N = IP
15343 IHISMO(IP) = I
15344 ELSE
15345 IJ = 0
15346 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15347 IF (LEMCCK) THEN
15348 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15349 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15350 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15351 INIEMC = 2
15352 ENDIF
15353 ID = IDHKK(KK)
15354 IF (ID.EQ.0) ID = 21
15355c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15356c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15357
15358c AMRQ = PYMASS(ID)
15359
15360c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15361c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15362c & (ABS(IDIFF).EQ.0)) THEN
15363cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15364c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15365c PHKK(4,KK) = PHKK(4,KK)+DELTA
15366c PTOT1 = PTOT-DELTA
15367c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15368c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15369c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15370c PHKK(5,KK) = AMRQ
15371c ENDIF
15372 IP = IP+1
15373 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15374 P(IP,1) = PHKK(1,KK)
15375 P(IP,2) = PHKK(2,KK)
15376 P(IP,3) = PHKK(3,KK)
15377 P(IP,4) = PHKK(4,KK)
15378 P(IP,5) = PHKK(5,KK)
15379 K(IP,1) = 1
15380 K(IP,2) = ID
15381 K(IP,3) = 0
15382 K(IP,4) = 0
15383 K(IP,5) = 0
15384 IHIST(2,KK) = 10000*IPJE+IP
15385 IF (IHIST(1,KK).LE.-100) THEN
15386 ISH = ISH+1
15387 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15388 ISJOIN(ISH) = KK
15389 ENDIF
15390 IJ = IJ+1
15391 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15392 IJOIN(IJ) = IP
15393 IHISMO(IP) = I
15394 11 CONTINUE
15395 N = IP
15396* join the two-parton system
15397
15398 CALL PYJOIN(IJ,IJOIN)
15399
15400 ENDIF
15401 IDHKK(I) = 99999
15402 ENDIF
15403 10 CONTINUE
15404 16 CONTINUE
15405 N = IP
15406
15407 IF (IP.GT.0) THEN
15408
15409* final state parton shower
15410 DO 136 NPJE=1,IPJE
15411 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15412 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15413 DO 130 K1=1,ISH
15414 IF (ISJOIN(K1).EQ.0) GOTO 130
15415 I = ISJOIN(K1)
15416 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15417 & GOTO 130
15418 IH1 = IHIST(2,I)/10000
15419 IF (IH1.NE.NPJE) GOTO 130
15420 IH1 = IHIST(2,I)-IH1*10000
15421 DO 135 K2=K1+1,ISH
15422 IF (ISJOIN(K2).EQ.0) GOTO 135
15423 II = ISJOIN(K2)
15424 IH2 = IHIST(2,II)/10000
15425 IF (IH2.NE.NPJE) GOTO 135
15426 IH2 = IHIST(2,II)-IH2*10000
15427 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15428 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15429 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15430
15431 RQLUN = MIN(PT1,PT2)
15432 CALL PYSHOW(IH1,IH2,RQLUN)
15433
15434 ISJOIN(K1) = 0
15435 ISJOIN(K2) = 0
15436 GOTO 130
15437 ENDIF
15438 135 CONTINUE
15439 130 CONTINUE
15440 ENDIF
15441 ENDIF
15442 136 CONTINUE
15443
15444 CALL DT_INITJS(MODE)
15445* hadronization
15446
15447 CALL PYEXEC
15448
15449 IF (MSTU(24).NE.0) THEN
15450 WRITE(LOUT,*) ' JETSET-reject at event',
15451 & NEVHKK,MSTU(24),KMODE
15452C CALL DT_EVTOUT(4)
15453
15454C CALL PYLIST(2)
15455
15456 GOTO 9999
15457 ENDIF
15458
15459* number of entries in LUJETS
15460
15461 NLINES = PYK(0,1)
15462
15463 NPYMEM = NLINES
15464
15465 DO 12 I=1,NLINES
15466 IFLG(I) = 0
15467 12 CONTINUE
15468
15469 DO 13 II=1,NLINES
15470
15471 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15472
15473* pick up mother resonance if possible and put it together with
15474* their decay-products into the common
15475 IDXMOR = K(II,3)
15476 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15477 KFMOR = K(IDXMOR,2)
15478 ISMOR = K(IDXMOR,1)
15479 ELSE
15480 KFMOR = 91
15481 ISMOR = 1
15482 ENDIF
15483 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15484 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15485 ID = K(IDXMOR,2)
15486 MO = IHISMO(PYK(IDXMOR,15))
15487 PX = PYP(IDXMOR,1)
15488 PY = PYP(IDXMOR,2)
15489 PZ = PYP(IDXMOR,3)
15490 PE = PYP(IDXMOR,4)
15491
15492 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15493 IFLG(IDXMOR) = 1
15494 MO = NHKK
15495 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15496 IF (PYK(JDAUG,7).EQ.1) THEN
15497 ID = PYK(JDAUG,8)
15498 PX = PYP(JDAUG,1)
15499 PY = PYP(JDAUG,2)
15500 PZ = PYP(JDAUG,3)
15501 PE = PYP(JDAUG,4)
15502
15503 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15504 IF (LEMCCK) THEN
15505 PX = -PYP(JDAUG,1)
15506 PY = -PYP(JDAUG,2)
15507 PZ = -PYP(JDAUG,3)
15508 PE = -PYP(JDAUG,4)
15509
15510 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15511 ENDIF
15512 IFLG(JDAUG) = 1
15513 ENDIF
15514 15 CONTINUE
15515 ELSE
15516* there was no mother resonance
15517 MO = IHISMO(PYK(II,15))
15518 ID = PYK(II,8)
15519 PX = PYP(II,1)
15520 PY = PYP(II,2)
15521 PZ = PYP(II,3)
15522 PE = PYP(II,4)
15523
15524 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15525 IF (LEMCCK) THEN
15526 PX = -PYP(II,1)
15527 PY = -PYP(II,2)
15528 PZ = -PYP(II,3)
15529 PE = -PYP(II,4)
15530
15531 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15532 ENDIF
15533 ENDIF
15534 ENDIF
15535 13 CONTINUE
15536 IF (LEMCCK) THEN
15537 CHKLEV = TINY1
15538 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15539C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15540 ENDIF
15541
15542* global energy-momentum & flavor conservation check
15543**sr 16.5. this check is skipped in case of phojet-treatment
15544 IF (MCGENE.EQ.1)
15545 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15546
15547* update statistics-counter for diffraction
15548c IF (IFLAGD.NE.0) THEN
15549c ICDIFF(1) = ICDIFF(1)+1
15550c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15551c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15552c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15553c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15554c ENDIF
15555
15556 ENDIF
15557
15558 RETURN
15559
15560 9999 CONTINUE
15561 IREJ = 1
15562 RETURN
15563 END
15564
15565*$ CREATE DT_DECAYS.FOR
15566*COPY DT_DECAYS
15567*
15568*===decay==============================================================*
15569*
15570 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15571
15572************************************************************************
15573* Resonance-decay. *
15574* This subroutine replaces DDECAY/DECHKK. *
15575* PIN(4) 4-momentum of resonance (input) *
15576* IDXIN BAMJET-index of resonance (input) *
15577* POUT(20,4) 4-momenta of decay-products (output) *
15578* IDXOUT(20) BAMJET-indices of decay-products (output) *
15579* NSEC number of secondaries (output) *
15580* Adopted from the original version DECHKK. *
15581* This version dated 09.01.95 is written by S. Roesler *
15582************************************************************************
15583
15584 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15585 SAVE
15586
15587 PARAMETER ( LINP = 10 ,
15588 & LOUT = 6 ,
15589 & LDAT = 9 )
15590
15591 PARAMETER (TINY17=1.0D-17)
15592
15593* HADRIN: decay channel information
15594 PARAMETER (IDMAX9=602)
15595 CHARACTER*8 ZKNAME
15596 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15597
15598* particle properties (BAMJET index convention)
15599 CHARACTER*8 ANAME
15600 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15601 & IICH(210),IIBAR(210),K1(210),K2(210)
15602
15603* flags for input different options
15604 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15605 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15606 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15607
15608 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15609 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15610 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15611
15612* ISTAB = 1 strong and weak decays
15613* = 2 strong decays only
15614* = 3 strong decays, weak decays for charmed particles and tau
15615* leptons only
15616 DATA ISTAB /2/
15617
15618 IREJ = 0
15619 NSEC = 0
15620* put initial resonance to stack
15621 NSTK = 1
15622 IDXSTK(NSTK) = IDXIN
15623 DO 5 I=1,4
15624 PI(NSTK,I) = PIN(I)
15625 5 CONTINUE
15626
15627* store initial configuration for energy-momentum cons. check
15628 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15629 & PI(NSTK,4),1,IDUM,IDUM)
15630
15631 100 CONTINUE
15632* get particle from stack
15633 IDXI = IDXSTK(NSTK)
15634* skip stable particles
15635 IF (ISTAB.EQ.1) THEN
15636 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15637 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15638 ELSEIF (ISTAB.EQ.2) THEN
15639 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15640 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15641 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15642 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15643 IF ( IDXI.EQ.109) GOTO 10
15644 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15645 ELSEIF (ISTAB.EQ.3) THEN
15646 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15647 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15648 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15649 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15650 ENDIF
15651
15652* calculate direction cosines and Lorentz-parameter of decaying part.
15653 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15654 PTOT = MAX(PTOT,TINY17)
15655 DO 1 I=1,3
15656 DCOS(I) = PI(NSTK,I)/PTOT
15657 1 CONTINUE
15658 GAM = PI(NSTK,4)/AAM(IDXI)
15659 BGAM = PTOT/AAM(IDXI)
15660
15661* get decay-channel
15662 KCHAN = K1(IDXI)-1
15663 2 CONTINUE
15664 KCHAN = KCHAN+1
15665 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15666
15667* identities of secondaries
15668 IDX(1) = NZK(KCHAN,1)
15669 IDX(2) = NZK(KCHAN,2)
15670 IF (IDX(2).LT.1) GOTO 9999
15671 IDX(3) = NZK(KCHAN,3)
15672
15673* handle decay in rest system of decaying particle
15674 IF (IDX(3).EQ.0) THEN
15675* two-particle decay
15676 NDEC = 2
15677 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15678 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15679 & AAM(IDX(1)),AAM(IDX(2)))
15680 ELSE
15681* three-particle decay
15682 NDEC = 3
15683 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15684 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15685 & CODF(3),COFF(3),SIFF(3),
15686 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15687 ENDIF
15688 NSTK = NSTK-1
15689
15690* transform decay products back
15691 DO 3 I=1,NDEC
15692 NSTK = NSTK+1
15693 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15694 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15695 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15696* add particle to stack
15697 IDXSTK(NSTK) = IDX(I)
15698 DO 4 J=1,3
15699 PI(NSTK,J) = DCOSF(J)*PFF(I)
15700 4 CONTINUE
15701 3 CONTINUE
15702 GOTO 100
15703
15704 10 CONTINUE
15705* stable particle, put to output-arrays
15706 NSEC = NSEC+1
15707 DO 6 I=1,4
15708 POUT(NSEC,I) = PI(NSTK,I)
15709 6 CONTINUE
15710 IDXOUT(NSEC) = IDXSTK(NSTK)
15711* store secondaries for energy-momentum conservation check
15712 IF (LEMCCK)
15713 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15714 & -POUT(NSEC,4),2,IDUM,IDUM)
15715 NSTK = NSTK-1
15716 IF (NSTK.GT.0) GOTO 100
15717
15718* check energy-momentum conservation
15719 IF (LEMCCK) THEN
15720 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15721 IF (IREJ1.NE.0) GOTO 9999
15722 ENDIF
15723
15724 RETURN
15725
15726 9999 CONTINUE
15727 IREJ = 1
15728 RETURN
15729 END
15730
15731*$ CREATE DT_DECAY1.FOR
15732*COPY DT_DECAY1
15733*
15734*===decay1=============================================================*
15735*
15736 SUBROUTINE DT_DECAY1
15737
15738************************************************************************
15739* Decay of resonances stored in DTEVT1. *
15740* This version dated 20.01.95 is written by S. Roesler *
15741************************************************************************
15742
15743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15744 SAVE
15745
15746 PARAMETER ( LINP = 10 ,
15747 & LOUT = 6 ,
15748 & LDAT = 9 )
15749
15750* event history
15751
15752 PARAMETER (NMXHKK=200000)
15753
15754 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15755 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15756 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15757
15758* extended event history
15759 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15760 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15761 & IHIST(2,NMXHKK)
15762
15763 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15764
15765 NEND = NHKK
15766C DO 1 I=NPOINT(5),NEND
15767 DO 1 I=NPOINT(4),NEND
15768 IF (ABS(ISTHKK(I)).EQ.1) THEN
15769 DO 2 K=1,4
15770 PIN(K) = PHKK(K,I)
15771 2 CONTINUE
15772 IDXIN = IDBAM(I)
15773 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15774 IF (NSEC.GT.1) THEN
15775 DO 3 N=1,NSEC
15776 IDHAD = IDT_IPDGHA(IDXOUT(N))
15777 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15778 & POUT(N,3),POUT(N,4),0,0,0)
15779 3 CONTINUE
15780 ENDIF
15781 ENDIF
15782 1 CONTINUE
15783
15784 RETURN
15785 END
15786
15787*$ CREATE DT_DECPI0.FOR
15788*COPY DT_DECPI0
15789*
15790*===decpi0=============================================================*
15791*
15792 SUBROUTINE DT_DECPI0
15793
15794************************************************************************
15795* Decay of pi0 handled with JETSET. *
15796* This version dated 18.02.96 is written by S. Roesler *
15797************************************************************************
15798
15799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15800 SAVE
15801
15802 PARAMETER ( LINP = 10 ,
15803 & LOUT = 6 ,
15804 & LDAT = 9 )
15805
15806 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15807
15808* event history
15809
15810 PARAMETER (NMXHKK=200000)
15811
15812 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15813 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15814 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15815
15816* extended event history
15817 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15818 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15819 & IHIST(2,NMXHKK)
15820
004932dd 15821 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 15822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15823 PARAMETER (MAXLND=4000)
15824 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15825
15826* flags for input different options
15827 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15828 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15829 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15830
15831 INTEGER PYCOMP,PYK
15832
15833 DIMENSION IHISMO(NMXHKK),P1(4)
15834
15835 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15836
15837 CALL DT_INITJS(2)
15838* allow pi0 decay
15839
15840 KC = PYCOMP(111)
15841
15842 MDCY(KC,1) = 1
15843
15844 NN = 0
15845 INI = 0
15846 DO 1 I=1,NHKK
15847 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15848 IF (INI.EQ.0) THEN
15849 INI = 1
15850 ELSE
15851 INI = 2
15852 ENDIF
15853 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15854 & PHKK(4,I),INI,IDUM,IDUM)
15855 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15856 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15857 COSTH = PHKK(3,I)/(PTOT+TINY10)
15858 IF (COSTH.GT.ONE) THEN
15859 THETA = ZERO
15860 ELSEIF (COSTH.LT.-ONE) THEN
15861 THETA = TWOPI/2.0D0
15862 ELSE
15863 THETA = ACOS(COSTH)
15864 ENDIF
15865 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15866 IF (PHKK(1,I).LT.0.0D0)
15867
15868 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15869
15870 ENER = PHKK(4,I)
15871 NN = NN+1
15872 KTEMP = MSTU(10)
15873 MSTU(10)= 1
15874 P(NN,5) = PHKK(5,I)
15875
15876 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15877
15878 MSTU(10) = KTEMP
15879 IHISMO(NN)= I
15880 ENDIF
15881 1 CONTINUE
15882 IF (NN.GT.0) THEN
15883
15884 CALL PYEXEC
15885
15886 NLINES = PYK(0,1)
15887
15888 DO 2 II=1,NLINES
15889
15890 IF (PYK(II,7).EQ.1) THEN
15891
15892 DO 3 KK=1,4
15893
15894 P1(KK) = PYP(II,KK)
15895
15896 3 CONTINUE
15897
15898 ID = PYK(II,8)
15899 MO = IHISMO(PYK(II,15))
15900
15901 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15902 IF (LEMCCK)
15903 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15904 & IDUM,IDUM)
15905*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15906 ISTHKK(MO) = -2
15907 ENDIF
15908 2 CONTINUE
15909 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15910 ENDIF
15911 MDCY(KC,1) = 0
15912
15913 RETURN
15914 END
15915
15916*$ CREATE DT_DTWOPD.FOR
15917*COPY DT_DTWOPD
15918*
15919*===dtwopd=============================================================*
15920*
15921 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15922 & COF2,SIF2,AM1,AM2)
15923
15924************************************************************************
15925* Two-particle decay. *
15926* UMO cm-energy of the decaying system (input) *
15927* AM1/AM2 masses of the decay products (input) *
15928* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15929* COD,COF,SIF direction cosines of the decay prod. (output) *
15930* Revised by S. Roesler, 20.11.95 *
15931************************************************************************
15932
15933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15934 SAVE
15935
15936 PARAMETER ( LINP = 10 ,
15937 & LOUT = 6 ,
15938 & LDAT = 9 )
15939
15940 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15941
15942 IF (UMO.LT.(AM1+AM2)) THEN
15943 WRITE(LOUT,1000) UMO,AM1,AM2
15944 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15945 & 3E12.3)
15946 STOP
15947 ENDIF
15948
15949 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15950 ECM2 = UMO-ECM1
15951 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15952 PCM2 = PCM1
15953 CALL DT_DSFECF(SIF1,COF1)
15954 COD1 = TWO*DT_RNDM(PCM2)-ONE
15955 COD2 = -COD1
15956 COF2 = -COF1
15957 SIF2 = -SIF1
15958
15959 RETURN
15960 END
15961
15962*$ CREATE DT_DTHREP.FOR
15963*COPY DT_DTHREP
15964*
15965*===dthrep=============================================================*
15966*
15967 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15968 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15969
15970************************************************************************
15971* Three-particle decay. *
15972* UMO cm-energy of the decaying system (input) *
15973* AM1/2/3 masses of the decay products (input) *
15974* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15975* COD,COF,SIF direction cosines of the decay prod. (output) *
15976* *
15977* Threpd89: slight revision by A. Ferrari *
15978* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15979* Revised by S. Roesler, 20.11.95 *
15980************************************************************************
15981
15982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15983 SAVE
15984
15985 PARAMETER ( LINP = 10 ,
15986 & LOUT = 6 ,
15987 & LDAT = 9 )
15988
15989 PARAMETER ( ANGLSQ = 2.5D-31 )
15990 PARAMETER ( AZRZRZ = 1.0D-30 )
15991 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15992 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15993 PARAMETER ( ONEONE = 1.D+00 )
15994 PARAMETER ( TWOTWO = 2.D+00 )
15995 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15996
15997 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15998
15999* flags for input different options
16000 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16001 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16002 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16003
16004 DIMENSION F(5),XX(5)
16005 DATA EPS /AZRZRZ/
16006
16007 UMOO=UMO+UMO
16008C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16009C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16010C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16011 UUMO=UMO
16012 AAM1=AM1
16013 AAM2=AM2
16014 AAM3=AM3
16015 GU=(AM2+AM3)**2
16016 GO=(UMO-AM1)**2
16017* UFAK=1.0000000000001D0
16018* IF (GU.GT.GO) UFAK=0.9999999999999D0
16019 IF (GU.GT.GO) THEN
16020 UFAK=ONEMNS
16021 ELSE
16022 UFAK=ONEPLS
16023 END IF
16024 OFAK=2.D0-UFAK
16025 GU=GU*UFAK
16026 GO=GO*OFAK
16027 DS2=(GO-GU)/99.D0
16028 AM11=AM1*AM1
16029 AM22=AM2*AM2
16030 AM33=AM3*AM3
16031 UMO2=UMO*UMO
16032 RHO2=0.D0
16033 S22=GU
16034 DO 124 I=1,100
16035 S21=S22
16036 S22=GU+(I-1.D0)*DS2
16037 RHO1=RHO2
16038 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16039 * (S22+EPS)
16040 IF(RHO2.LT.RHO1) GO TO 125
16041 124 CONTINUE
16042 125 S2SUP=(S22-S21)*.5D0+S21
16043 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16044 * (S2SUP+EPS)
16045 SUPRHO=SUPRHO*1.05D0
16046 XO=S21-DS2
16047 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16048 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16049 XX(1)=XO
16050 XX(3)=S22
16051 X1=(XO+S22)*0.5D0
16052 XX(2)=X1
16053 F(3)=RHO2
16054 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16055 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16056 DO 126 I=1,16
16057 X4=(XX(1)+XX(2))*0.5D0
16058 X5=(XX(2)+XX(3))*0.5D0
16059 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16060 * (X4+EPS)
16061 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16062 * (X5+EPS)
16063 XX(4)=X4
16064 XX(5)=X5
16065 DO 128 II=1,5
16066 IA=II
16067 DO 128 III=IA,5
16068 IF (F (II).GE.F (III)) GO TO 128
16069 FH=F(II)
16070 F(II)=F(III)
16071 F(III)=FH
16072 FH=XX(II)
16073 XX(II)=XX(III)
16074 XX(III)=FH
16075128 CONTINUE
16076 SUPRHO=F(1)
16077 S2SUP=XX(1)
16078 DO 129 II=1,3
16079 IA=II
16080 DO 129 III=IA,3
16081 IF (XX(II).GE.XX(III)) GO TO 129
16082 FH=F(II)
16083 F(II)=F(III)
16084 F(III)=FH
16085 FH=XX(II)
16086 XX(II)=XX(III)
16087 XX(III)=FH
16088129 CONTINUE
16089126 CONTINUE
16090 AM23=(AM2+AM3)**2
16091 ITH=0
16092 REDU=2.D0
16093 1 CONTINUE
16094 ITH=ITH+1
16095 IF (ITH.GT.200) REDU=-9.D0
16096 IF (ITH.GT.200) GO TO 400
16097 C=DT_RNDM(REDU)
16098* S2=AM23+C*((UMO-AM1)**2-AM23)
16099 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16100 Y=DT_RNDM(S2)
16101 Y=Y*SUPRHO
16102 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16103 IF(Y.GT.RHO) GO TO 1
16104C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16105 S1=DT_RNDM(S2)
16106 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16107 &RHO*.5D0
16108 S3=UMO2+AM11+AM22+AM33-S1-S2
16109 ECM1=(UMO2+AM11-S2)/UMOO
16110 ECM2=(UMO2+AM22-S3)/UMOO
16111 ECM3=(UMO2+AM33-S1)/UMOO
16112 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16113 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16114 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16115 CALL DT_DSFECF(SFE,CFE)
16116C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16117C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16118 PCM12 = PCM1 * PCM2
16119 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16120 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16121 GO TO 300
16122 200 CONTINUE
16123 UW=DT_RNDM(S1)
16124 COSTH=(UW-0.5D+00)*2.D+00
16125 300 CONTINUE
16126* IF(ABS(COSTH).GT.0.9999999999999999D0)
16127* &COSTH=SIGN(0.9999999999999999D0,COSTH)
16128 IF(ABS(COSTH).GT.ONEONE)
16129 &COSTH=SIGN(ONEONE,COSTH)
16130 IF (REDU.LT.1.D+00) RETURN
16131 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16132* IF(ABS(COSTH2).GT.0.9999999999999999D0)
16133* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16134 IF(ABS(COSTH2).GT.ONEONE)
16135 &COSTH2=SIGN(ONEONE,COSTH2)
16136 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16137 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16138 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16139 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16140C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16141C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16142C***THE DIRECTION OF PARTICLE 3
16143C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16144 CX11=-COSTH1
16145 CY11=SINTH1*CFE
16146 CZ11=SINTH1*SFE
16147 CX22=-COSTH2
16148 CY22=-SINTH2*CFE
16149 CZ22=-SINTH2*SFE
16150 CALL DT_DSFECF(SIF3,COF3)
16151 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16152 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16153 2 FORMAT(5F20.15)
16154 COD1=CX11*COD3+CZ11*SID3
16155 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16156 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16157 &CX11,CZ11
16158 SID1=SQRT(CHLP)
16159 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16160 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16161 COD2=CX22*COD3+CZ22*SID3
16162 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16163 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16164 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16165 400 CONTINUE
16166* === Energy conservation check: === *
16167 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16168* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16169* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16170* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16171 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16172 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16173 & + PCM3 * COF3 * SID3
16174 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16175 & + PCM3 * SIF3 * SID3
16176 EOCMPR = 1.D-12 * UMO
16177 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16178 & .GT. EOCMPR ) THEN
16179**sr 5.5.95 output-unit changed
16180 IF (IOULEV(1).GT.0) THEN
16181 WRITE(LOUT,*)
16182 & ' *** Threpd: energy/momentum conservation failure! ***',
16183 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16184 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16185 ENDIF
16186**
16187 END IF
16188 RETURN
16189 END
16190
16191*$ CREATE DT_DBKLAS.FOR
16192*COPY DT_DBKLAS
16193*
16194*===dbklas=============================================================*
16195*
16196 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16197
16198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16199 SAVE
16200
16201 PARAMETER ( LINP = 10 ,
16202 & LOUT = 6 ,
16203 & LDAT = 9 )
16204
16205* quark-content to particle index conversion (DTUNUC 1.x)
16206 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16207 & IA08(6,21),IA10(6,21)
16208
16209 IF (I) 20,20,10
16210* baryons
16211 10 CONTINUE
16212 CALL DT_INDEXD(J,K,IND)
16213 I8 = IB08(I,IND)
16214 I10 = IB10(I,IND)
16215 IF (I8.LE.0) I8 = I10
16216 RETURN
16217* antibaryons
16218 20 CONTINUE
16219 II = IABS(I)
16220 JJ = IABS(J)
16221 KK = IABS(K)
16222 CALL DT_INDEXD(JJ,KK,IND)
16223 I8 = IA08(II,IND)
16224 I10 = IA10(II,IND)
16225 IF (I8.LE.0) I8 = I10
16226
16227 RETURN
16228 END
16229
16230*$ CREATE DT_INDEXD.FOR
16231*COPY DT_INDEXD
16232*
16233*===indexd=============================================================*
16234*
16235 SUBROUTINE DT_INDEXD(KA,KB,IND)
16236
16237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16238 SAVE
16239
16240 PARAMETER ( LINP = 10 ,
16241 & LOUT = 6 ,
16242 & LDAT = 9 )
16243
16244 KP = KA*KB
16245 KS = KA+KB
16246 IF (KP.EQ.1) IND=1
16247 IF (KP.EQ.2) IND=2
16248 IF (KP.EQ.3) IND=3
16249 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16250 IF (KP.EQ.5) IND=5
16251 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16252 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16253 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16254 IF (KP.EQ.8) IND=9
16255 IF (KP.EQ.10) IND=10
16256 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16257 IF (KP.EQ.9) IND=12
16258 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16259 IF (KP.EQ.15) IND=14
16260 IF (KP.EQ.18) IND=15
16261 IF (KP.EQ.16) IND=16
16262 IF (KP.EQ.20) IND=17
16263 IF (KP.EQ.24) IND=18
16264 IF (KP.EQ.25) IND=19
16265 IF (KP.EQ.30) IND=20
16266 IF (KP.EQ.36) IND=21
16267
16268 RETURN
16269 END
16270
16271*$ CREATE DT_DCHANT.FOR
16272*COPY DT_DCHANT
16273*
16274*===dchant=============================================================*
16275*
16276 SUBROUTINE DT_DCHANT
16277
16278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16279 SAVE
16280
16281 PARAMETER ( LINP = 10 ,
16282 & LOUT = 6 ,
16283 & LDAT = 9 )
16284
16285 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16286
16287* HADRIN: decay channel information
16288 PARAMETER (IDMAX9=602)
16289 CHARACTER*8 ZKNAME
16290 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16291
16292* particle properties (BAMJET index convention)
16293 CHARACTER*8 ANAME
16294 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16295 & IICH(210),IIBAR(210),K1(210),K2(210)
16296
16297 DIMENSION HWT(IDMAX9)
16298
16299* change of weights wt from absolut values into the sum of wt of a dec.
16300 DO 10 J=1,IDMAX9
16301 HWT(J) = ZERO
16302 10 CONTINUE
16303C DO 999 KKK=1,210
16304C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16305C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16306C & K1(KKK),K2(KKK)
16307C 999 CONTINUE
16308C STOP
16309 DO 30 I=1,210
16310 IK1 = K1(I)
16311 IK2 = K2(I)
16312 HV = ZERO
16313 DO 20 J=IK1,IK2
16314 HV = HV+WT(J)
16315 HWT(J) = HV
16316**sr 13.1.95
16317 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16318 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16319 20 CONTINUE
16320 30 CONTINUE
16321 DO 40 J=1,IDMAX9
16322 WT(J) = HWT(J)
16323 40 CONTINUE
16324
16325 RETURN
16326 END
16327
16328*$ CREATE DT_DDATAR.FOR
16329*COPY DT_DDATAR
16330*
16331*===ddatar=============================================================*
16332*
16333 SUBROUTINE DT_DDATAR
16334
16335 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16336 SAVE
16337
16338 PARAMETER ( LINP = 10 ,
16339 & LOUT = 6 ,
16340 & LDAT = 9 )
16341
16342 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16343
16344* quark-content to particle index conversion (DTUNUC 1.x)
16345 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16346 & IA08(6,21),IA10(6,21)
16347
16348 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16349
16350 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16351 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16352 & 128,129,14*0/
16353 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16354 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16355 & 121,122,14*0/
16356 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16357 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16358 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16359 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16360 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16361 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16362 & 0, 0, 0,140,137,138,146, 0, 0,142,
16363 & 139,147, 0, 0,145,148, 50*0/
16364 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16365 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16366 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16367 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16368 & 0, 0,104,105,107,164, 0, 0,106,108,
16369 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16370 & 0, 0, 0,161,162,164,167, 0, 0,163,
16371 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16372 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16373 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16374 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16375 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16376 & 0, 0, 99,100,102,150, 0, 0,101,103,
16377 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16378 & 0, 0, 0,152,149,150,158, 0, 0,154,
16379 & 151,159, 0, 0,157,160, 50*0/
16380 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16381 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16382 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16383 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16384 & 0, 0,110,111,113,174, 0, 0,112,114,
16385 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16386 & 0, 0, 0,171,172,174,177, 0, 0,173,
16387 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16388
16389 L=0
16390 DO 2 I=1,6
16391 DO 1 J=1,6
16392 L = L+1
16393 IMPS(I,J) = IP(L)
16394 IMVE(I,J) = IV(L)
16395 1 CONTINUE
16396 2 CONTINUE
16397 L=0
16398 DO 4 I=1,6
16399 DO 3 J=1,21
16400 L = L+1
16401 IB08(I,J) = IB(L)
16402 IB10(I,J) = IBB(L)
16403 IA08(I,J) = IA(L)
16404 IA10(I,J) = IAA(L)
16405 3 CONTINUE
16406 4 CONTINUE
16407C A1 = 0.88D0
16408C B1 = 3.0D0
16409C B2 = 3.0D0
16410C B3 = 8.0D0
16411C LT = 0
16412C LB = 0
16413C BET = 12.0D0
16414C AS = 0.25D0
16415C B8 = 0.33D0
16416C AME = 0.95D0
16417C DIQ = 0.375D0
16418C ISU = 4
16419
16420 RETURN
16421 END
16422
16423*$ CREATE DT_INITJS.FOR
16424*COPY DT_INITJS
16425*
16426*===initjs=============================================================*
16427*
16428 SUBROUTINE DT_INITJS(MODE)
16429
16430************************************************************************
16431* Initialize JETSET paramters. *
16432* MODE = 0 default settings *
16433* = 1 PHOJET settings *
16434* = 2 DTUNUC settings *
16435* This version dated 16.02.96 is written by S. Roesler *
16436* *
16437* Last change 27.12.2006 by S. Roesler. *
16438************************************************************************
16439
16440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16441 SAVE
16442
16443 PARAMETER ( LINP = 10 ,
16444 & LOUT = 6 ,
16445 & LDAT = 9 )
16446
16447 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16448
16449 LOGICAL LFIRST,LFIRDT,LFIRPH
16450
16451* INCLUDE '(DIMPAR)'
16452* DIMPAR taken from FLUKA
16453 PARAMETER ( MXXRGN =20000 )
16454 PARAMETER ( MXXMDF = 710 )
16455 PARAMETER ( MXXMDE = 702 )
16456 PARAMETER ( MFSTCK =40000 )
16457 PARAMETER ( MESTCK = 100 )
16458 PARAMETER ( MOSTCK = 2000 )
16459 PARAMETER ( MXPRSN = 100 )
16460 PARAMETER ( MXPDPM = 800 )
16461 PARAMETER ( MXPSCS =30000 )
16462 PARAMETER ( MXGLWN = 300 )
16463 PARAMETER ( MXOUTU = 50 )
16464 PARAMETER ( NALLWP = 64 )
16465 PARAMETER ( NELEMX = 80 )
16466 PARAMETER ( MPDPDX = 18 )
16467 PARAMETER ( MXHTTR = 260 )
16468 PARAMETER ( MXSEAX = 20 )
16469 PARAMETER ( MXHTNC = MXSEAX + 1 )
16470 PARAMETER ( ICOMAX = 2400 )
16471 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16472 PARAMETER ( NSTBIS = 304 )
16473 PARAMETER ( NQSTIS = 46 )
16474 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16475 PARAMETER ( MXPABL = 120 )
16476 PARAMETER ( IDMAXP = 450 )
16477 PARAMETER ( IDMXDC = 2000 )
16478 PARAMETER ( MXMCIN = 410 )
16479 PARAMETER ( IHYPMX = 4 )
16480 PARAMETER ( MKBMX1 = 11 )
16481 PARAMETER ( MKBMX2 = 11 )
16482 PARAMETER ( MXIRRD = 2500 )
16483 PARAMETER ( MXTRDC = 1500 )
16484 PARAMETER ( NKTL = 17 )
16485 PARAMETER ( NBLNMX = 40000000 )
16486
16487* INCLUDE '(PART)'
16488* PART taken from FLUKA
16489 PARAMETER ( KPETA0 = 31 )
16490 PARAMETER ( KPRHOP = 32 )
16491 PARAMETER ( KPRHO0 = 33 )
16492 PARAMETER ( KPRHOM = 34 )
16493 PARAMETER ( KPOME0 = 35 )
16494 PARAMETER ( KPPHI0 = 96 )
16495 PARAMETER ( KPDEPP = 53 )
16496 PARAMETER ( KPDELP = 54 )
16497 PARAMETER ( KPDEL0 = 55 )
16498 PARAMETER ( KPDELM = 56 )
16499 PARAMETER ( KPN14P = 91 )
16500 PARAMETER ( KPN140 = 92 )
16501* Low mass diffraction partners:
16502 PARAMETER ( KDETA0 = 0 )
16503 PARAMETER ( KDRHOP = 0 )
16504 PARAMETER ( KDRHO0 = 210 )
16505 PARAMETER ( KDRHOM = 0 )
16506 PARAMETER ( KDOME0 = 210 )
16507 PARAMETER ( KDPHI0 = 210 )
16508 PARAMETER ( KDDEPP = 0 )
16509 PARAMETER ( KDDELP = 0 )
16510 PARAMETER ( KDDEL0 = 0 )
16511 PARAMETER ( KDDELM = 0 )
16512 PARAMETER ( KDN14P = 0 )
16513 PARAMETER ( KDN140 = 0 )
16514*
16515 CHARACTER*8 ANAME
16516 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16517 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16518 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16519 & ATXN14, ATMN14, RNRN14 (-10:10),
16520 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16521 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16522 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16523 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16524 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16525 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16526
16527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
004932dd 16529 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 16530
16531* flags for particle decays
16532 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16533 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16534 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16535
16536* flags for input different options
16537 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16538 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16539 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16540
16541 INTEGER PYCOMP
16542
16543 DIMENSION IDXSTA(40)
16544 DATA IDXSTA
16545* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16546 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16547* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16548 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16549* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16550 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16551* Ksic0 aKsic+aKsic0 sig0 asig0
16552 & 4132,-4232,-4132, 3212,-3212, 5*0/
16553
16554 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16555
16556 IF (LFIRST) THEN
16557* save default settings
16558 PDEF1 = PARJ(1)
16559 PDEF2 = PARJ(2)
16560 PDEF3 = PARJ(3)
16561 PDEF5 = PARJ(5)
16562 PDEF6 = PARJ(6)
16563 PDEF7 = PARJ(7)
16564 PDEF18 = PARJ(18)
16565 PDEF19 = PARJ(19)
16566 PDEF21 = PARJ(21)
16567 PDEF42 = PARJ(42)
16568 MDEF12 = MSTJ(12)
16569* LUJETS / PYJETS array-dimensions
16570
16571 MSTU(4) = 4000
16572
16573* increase maximum number of JETSET-error prints
16574 MSTU(22) = 50000
16575* prevent particles decaying
16576 DO 1 I=1,35
16577 IF (I.LT.34) THEN
16578
16579 KC = PYCOMP(IDXSTA(I))
16580
16581 IF (KC.GT.0) THEN
16582 IF (I.EQ.2) THEN
16583* pi0 decay
16584C MDCY(KC,1) = 1
16585 MDCY(KC,1) = 0
16586**cr mode
16587C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16588C & (I.EQ.8).OR.(I.EQ.10)) THEN
16589C ELSEIF (I.EQ.4) THEN
16590C MDCY(KC,1) = 1
16591**
16592 ELSE
16593 MDCY(KC,1) = 0
16594 ENDIF
16595 ENDIF
16596 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16597
16598 KC = PYCOMP(IDXSTA(I))
16599
16600 IF (KC.GT.0) THEN
16601 MDCY(KC,1) = 0
16602 ENDIF
16603 ENDIF
16604 1 CONTINUE
16605*
16606
16607* as Fluka event-generator: allow only paprop particles to be stable
16608* and let all other particles decay (i.e. those with strong decays)
16609 IF (ITRSPT.EQ.1) THEN
16610 DO 5 I=1,IDMAXP
16611 IF (KPTOIP(I).NE.0) THEN
16612 IDPDG = MPDGHA(I)
16613
16614 KC = PYCOMP(IDPDG)
16615
16616 IF (KC.GT.0) THEN
16617 IF (MDCY(KC,1).EQ.1) THEN
16618 WRITE(LOUT,*)
16619 & ' DT_INITJS: Decay flag for FLUKA-',
16620 & 'transport : particle should not ',
16621 & 'decay : ',IDPDG,' ',ANAME(I)
16622 MDCY(KC,1) = 0
16623 ENDIF
16624 ENDIF
16625 ENDIF
16626 5 CONTINUE
16627 DO 6 KC=1,500
16628 IDPDG = KCHG(KC,4)
16629 KP = MCIHAD(IDPDG)
16630 IF (KP.GT.0) THEN
16631 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16632 & (ANAME(KP).NE.'BLANK ').AND.
16633 & (ANAME(KP).NE.'RNDFLV ')) THEN
16634 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16635 & 'transport: particle should decay ',
16636 & ': ',IDPDG,' ',ANAME(KP)
16637 MDCY(KC,1) = 1
16638 ENDIF
16639 ENDIF
16640 6 CONTINUE
16641 ENDIF
16642
16643*
16644* popcorn:
16645 IF (PDB.LE.ZERO) THEN
16646* no popcorn-mechanism
16647 MSTJ(12) = 1
16648 ELSE
16649 MSTJ(12) = 3
16650 PARJ(5) = PDB
16651 ENDIF
16652* set JETSET-parameter requested by input cards
16653 IF (NMSTU.GT.0) THEN
16654 DO 2 I=1,NMSTU
16655 MSTU(IMSTU(I)) = MSTUX(I)
16656 2 CONTINUE
16657 ENDIF
16658 IF (NMSTJ.GT.0) THEN
16659 DO 3 I=1,NMSTJ
16660 MSTJ(IMSTJ(I)) = MSTJX(I)
16661 3 CONTINUE
16662 ENDIF
16663 IF (NPARU.GT.0) THEN
16664 DO 4 I=1,NPARU
16665 PARU(IPARU(I)) = PARUX(I)
16666 4 CONTINUE
16667 ENDIF
16668 LFIRST = .FALSE.
16669 ENDIF
16670*
16671* PARJ(1) suppression of qq-aqaq pair prod. compared to
16672* q-aq pair prod. (default: 0.1)
16673* PARJ(2) strangeness suppression (default: 0.3)
16674* PARJ(3) extra suppression of strange diquarks (default: 0.4)
16675* PARJ(6) extra suppression of sas-pair shared by B and
16676* aB in BMaB (default: 0.5)
16677* PARJ(7) extra suppression of strange meson M in BMaB
16678* configuration (default: 0.5)
16679* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16680* PARJ(21) width sigma in Gaussian p_x, p_y transverse
16681* momentum distrib. for prim. hadrons (default: 0.35)
16682* PARJ(42) b-parameter for symmetric Lund-fragmentation
16683* function (default: 0.9 GeV^-2)
16684*
16685* PHOJET settings
16686 IF (MODE.EQ.1) THEN
16687* JETSET default
16688C PARJ(1) = PDEF1
16689C PARJ(2) = PDEF2
16690C PARJ(3) = PDEF3
16691C PARJ(6) = PDEF6
16692C PARJ(7) = PDEF7
16693C PARJ(18) = PDEF18
16694C PARJ(21) = PDEF21
16695C PARJ(42) = PDEF42
16696**sr 18.11.98 parameter tuning
16697C PARJ(1) = 0.092D0
16698C PARJ(2) = 0.25D0
16699C PARJ(3) = 0.45D0
16700C PARJ(19) = 0.3D0
16701C PARJ(21) = 0.45D0
16702C PARJ(42) = 1.0D0
16703**sr 28.04.99 parameter tuning (May 99 minor modifications)
16704 PARJ(1) = 0.085D0
16705 PARJ(2) = 0.26D0
16706 PARJ(3) = 0.8D0
16707 PARJ(11) = 0.38D0
16708 PARJ(18) = 0.3D0
16709 PARJ(19) = 0.4D0
16710 PARJ(21) = 0.36D0
16711 PARJ(41) = 0.3D0
16712 PARJ(42) = 0.86D0
16713 IF (NPARJ.GT.0) THEN
16714 DO 10 I=1,NPARJ
16715 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16716 10 CONTINUE
16717 ENDIF
16718 IF (LFIRPH) THEN
16719 WRITE(LOUT,'(1X,A)')
16720 & 'DT_INITJS: JETSET-parameter for PHOJET'
16721 CALL DT_JSPARA(0)
16722 LFIRPH = .FALSE.
16723 ENDIF
16724* DTUNUC settings
16725 ELSEIF (MODE.EQ.2) THEN
16726 IF (IFRAG(2).EQ.1) THEN
16727**sr parameters before 9.3.96
16728C PARJ(2) = 0.27D0
16729C PARJ(3) = 0.6D0
16730C PARJ(6) = 0.75D0
16731C PARJ(7) = 0.75D0
16732C PARJ(21) = 0.55D0
16733C PARJ(42) = 1.3D0
16734**sr 18.11.98 parameter tuning
16735C PARJ(1) = 0.05D0
16736C PARJ(2) = 0.27D0
16737C PARJ(3) = 0.4D0
16738C PARJ(19) = 0.2D0
16739C PARJ(21) = 0.45D0
16740C PARJ(42) = 1.0D0
16741**sr 28.04.99 parameter tuning
16742 PARJ(1) = 0.11D0
16743 PARJ(2) = 0.36D0
16744 PARJ(3) = 0.8D0
16745 PARJ(19) = 0.2D0
16746 PARJ(21) = 0.3D0
16747 PARJ(41) = 0.3D0
16748 PARJ(42) = 0.58D0
16749 IF (NPARJ.GT.0) THEN
16750 DO 20 I=1,NPARJ
16751 IF (IPARJ(I).LT.0) THEN
16752 IDX = ABS(IPARJ(I))
16753 PARJ(IDX) = PARJX(I)
16754 ENDIF
16755 20 CONTINUE
16756 ENDIF
16757 IF (LFIRDT) THEN
16758 WRITE(LOUT,'(1X,A)')
16759 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16760 CALL DT_JSPARA(0)
16761 LFIRDT = .FALSE.
16762 ENDIF
16763 ELSEIF (IFRAG(2).EQ.2) THEN
16764 PARJ(1) = 0.11D0
16765 PARJ(2) = 0.27D0
16766 PARJ(3) = 0.3D0
16767 PARJ(6) = 0.35D0
16768 PARJ(7) = 0.45D0
16769 PARJ(18) = 0.66D0
16770C PARJ(21) = 0.55D0
16771C PARJ(42) = 1.0D0
16772 PARJ(21) = 0.60D0
16773 PARJ(42) = 1.3D0
16774 ELSE
16775 PARJ(1) = PDEF1
16776 PARJ(2) = PDEF2
16777 PARJ(3) = PDEF3
16778 PARJ(6) = PDEF6
16779 PARJ(7) = PDEF7
16780 PARJ(18) = PDEF18
16781 PARJ(21) = PDEF21
16782 PARJ(42) = PDEF42
16783 ENDIF
16784 ELSE
16785 PARJ(1) = PDEF1
16786 PARJ(2) = PDEF2
16787 PARJ(3) = PDEF3
16788 PARJ(5) = PDEF5
16789 PARJ(6) = PDEF6
16790 PARJ(7) = PDEF7
16791 PARJ(18) = PDEF18
16792 PARJ(19) = PDEF19
16793 PARJ(21) = PDEF21
16794 PARJ(42) = PDEF42
16795 MSTJ(12) = MDEF12
16796 ENDIF
16797
16798 RETURN
16799 END
16800
16801*$ CREATE DT_JSPARA.FOR
16802*COPY DT_JSPARA
16803*
16804*===jspara=============================================================*
16805*
16806 SUBROUTINE DT_JSPARA(MODE)
16807
16808 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16809 SAVE
16810
16811 PARAMETER ( LINP = 10 ,
16812 & LOUT = 6 ,
16813 & LDAT = 9 )
16814
16815 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16816 & ONE=1.0D0,ZERO=0.0D0)
16817
16818 LOGICAL LFIRST
16819
16820 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16821
16822 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16823
16824 DATA LFIRST /.TRUE./
16825
16826* save the default JETSET-parameter on the first call
16827 IF (LFIRST) THEN
16828 DO 1 I=1,200
16829 ISTU(I) = MSTU(I)
16830 QARU(I) = PARU(I)
16831 ISTJ(I) = MSTJ(I)
16832 QARJ(I) = PARJ(I)
16833 1 CONTINUE
16834 LFIRST = .FALSE.
16835 ENDIF
16836
16837 WRITE(LOUT,1000)
16838 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16839
16840* compare the default JETSET-parameter with the present values
16841 DO 2 I=1,200
16842 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16843 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16844C ISTU(I) = MSTU(I)
16845 ENDIF
16846 DIFF = ABS(PARU(I)-QARU(I))
16847 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16848 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16849C QARU(I) = PARU(I)
16850 ENDIF
16851 IF (MSTJ(I).NE.ISTJ(I)) THEN
16852 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16853C ISTJ(I) = MSTJ(I)
16854 ENDIF
16855 DIFF = ABS(PARJ(I)-QARJ(I))
16856 IF (DIFF.GE.1.0D-5) THEN
16857 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16858C QARJ(I) = PARJ(I)
16859 ENDIF
16860 2 CONTINUE
16861 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16862 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16863
16864 RETURN
16865 END
16866*$ CREATE DT_FOZOCA.FOR
16867*COPY DT_FOZOCA
16868*
16869*===fozoca=============================================================*
16870*
16871 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16872
16873************************************************************************
16874* This subroutine treats the complete FOrmation ZOne supressed intra- *
16875* nuclear CAscade. *
16876* LFZC = .true. cascade has been treated *
16877* = .false. cascade skipped *
16878* This is a completely revised version of the original FOZOKL. *
16879* This version dated 18.11.95 is written by S. Roesler *
16880************************************************************************
16881
16882 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16883 SAVE
16884
16885 PARAMETER ( LINP = 10 ,
16886 & LOUT = 6 ,
16887 & LDAT = 9 )
16888
16889 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16890 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16891
16892 LOGICAL LSTART,LCAS,LFZC
16893
16894* event history
16895
16896 PARAMETER (NMXHKK=200000)
16897
16898 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16899 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16900 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16901
16902* extended event history
16903 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16904 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16905 & IHIST(2,NMXHKK)
16906
16907* rejection counter
16908 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16909 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16910 & IREXCI(3),IRDIFF(2),IRINC
16911
16912* properties of interacting particles
16913 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16914
16915* Glauber formalism: collision properties
16916 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 16917 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16918 & NCP,NCT
7b076c76 16919
16920* flags for input different options
16921 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16922 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16923 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16924
16925* final state after intranuclear cascade step
16926 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16927
16928* parameter for intranuclear cascade
16929 LOGICAL LPAULI
16930 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16931
16932 DIMENSION NCWOUN(2)
16933
16934 DATA LSTART /.TRUE./
16935
16936 LFZC = .TRUE.
16937 IREJ = 0
16938
16939* skip cascade if hadron-hadron interaction or if supressed by user
16940 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16941* skip cascade if not all possible chains systems are hadronized
16942 DO 1 I=1,8
16943 IF (.NOT.LHADRO(I)) GOTO 9999
16944 1 CONTINUE
16945
16946 IF (LSTART) THEN
16947 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16948 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16949 & 'maximum of',I4,' generations',/,10X,'formation time ',
16950 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16951 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16952 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16953 1001 FORMAT(10X,'p_t dependent formation zone',/)
16954 1002 FORMAT(10X,'constant formation zone',/)
16955 LSTART = .FALSE.
16956 ENDIF
16957
16958* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16959* which may interact with final state particles are stored in a seperate
16960* array - here all proj./target nucleon-indices (just for simplicity)
16961 NOINC = 0
16962 DO 9 I=1,NPOINT(1)-1
16963 NOINC = NOINC+1
16964 IDXINC(NOINC) = I
16965 9 CONTINUE
16966
16967* initialize Pauli-principle treatment (find wounded nucleons)
16968 NWOUND(1) = 0
16969 NWOUND(2) = 0
16970 NCWOUN(1) = 0
16971 NCWOUN(2) = 0
16972 DO 2 J=1,NPOINT(1)
16973 DO 3 I=1,2
16974 IF (ISTHKK(J).EQ.10+I) THEN
16975 NWOUND(I) = NWOUND(I)+1
16976 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16977 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16978 ENDIF
16979 3 CONTINUE
16980 2 CONTINUE
16981
16982* modify nuclear potential for wounded nucleons
16983 IPRCL = IP -NWOUND(1)
16984 IPZRCL = IPZ-NCWOUN(1)
16985 ITRCL = IT -NWOUND(2)
16986 ITZRCL = ITZ-NCWOUN(2)
16987 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16988
16989 NSTART = NPOINT(4)
16990 NEND = NHKK
16991
16992 7 CONTINUE
16993 DO 8 I=NSTART,NEND
16994
16995 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16996* select nucleus the cascade starts first (proj. - 1, target - -1)
16997 NCAS = 1
16998* projectile/target with probab. 1/2
16999 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
17000 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17001* in the nucleus with highest mass
17002 ELSEIF (INCMOD.EQ.2) THEN
17003 IF (IP.GT.IT) THEN
17004 NCAS = -NCAS
17005 ELSEIF (IP.EQ.IT) THEN
17006 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17007 ENDIF
17008* the nucleus the cascade starts first is requested to be the one
17009* moving in the direction of the secondary
17010 ELSEIF (INCMOD.EQ.3) THEN
17011 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17012 ENDIF
17013* check that the selected "nucleus" is not a hadron
17014 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17015 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
17016
17017* treat intranuclear cascade in the nucleus selected first
17018 LCAS = .FALSE.
17019 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17020 IF (IREJ1.NE.0) GOTO 9998
17021* treat intranuclear cascade in the other nucleus if this isn't a had.
17022 NCAS = -NCAS
17023 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17024 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17025 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17026 IF (IREJ1.NE.0) GOTO 9998
17027 ENDIF
17028
17029 ENDIF
17030
17031 8 CONTINUE
17032 NSTART = NEND+1
17033 NEND = NHKK
17034 IF (NSTART.LE.NEND) GOTO 7
17035
17036 RETURN
17037
17038 9998 CONTINUE
17039* reject this event
17040 IRINC = IRINC+1
17041 IREJ = 1
17042
17043 9999 CONTINUE
17044* intranucl. cascade not treated because of interaction properties or
17045* it is supressed by user or it was rejected or...
17046 LFZC = .FALSE.
17047* reset flag characterizing direction of motion in n-n-cms
17048**sr14-11-95
17049C DO 9990 I=NPOINT(5),NHKK
17050C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17051C9990 CONTINUE
17052
17053 RETURN
17054 END
17055
17056*$ CREATE DT_INUCAS.FOR
17057*COPY DT_INUCAS
17058*
17059*===inucas=============================================================*
17060*
17061 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17062
17063************************************************************************
17064* Formation zone supressed IntraNUclear CAScade for one final state *
17065* particle. *
17066* IT, IP mass numbers of target, projectile nuclei *
17067* IDXCAS index of final state particle in DTEVT1 *
17068* NCAS = 1 intranuclear cascade in projectile *
17069* = -1 intranuclear cascade in target *
17070* This version dated 18.11.95 is written by S. Roesler *
17071************************************************************************
17072
17073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17074 SAVE
17075
17076 PARAMETER ( LINP = 10 ,
17077 & LOUT = 6 ,
17078 & LDAT = 9 )
17079
17080 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17081 & OHALF=0.5D0,ONE=1.0D0)
17082 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17083 PARAMETER (TWOPI=6.283185307179586454D+00)
17084 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17085
17086 LOGICAL LABSOR,LCAS
17087
17088* event history
17089
17090 PARAMETER (NMXHKK=200000)
17091
17092 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17093 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17094 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17095
17096* extended event history
17097 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17098 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17099 & IHIST(2,NMXHKK)
17100
17101* final state after inc step
17102 PARAMETER (MAXFSP=10)
17103 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17104
17105* flags for input different options
17106 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17107 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17108 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17109
17110* particle properties (BAMJET index convention)
17111 CHARACTER*8 ANAME
17112 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17113 & IICH(210),IIBAR(210),K1(210),K2(210)
17114
17115* Glauber formalism: collision properties
17116 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
031c717a
AM		 17117 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
17118 & NCP,NCT
7b076c76 17119* nuclear potential
17120 LOGICAL LFERMI
17121 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17122 & EBINDP(2),EBINDN(2),EPOT(2,210),
17123 & ETACOU(2),ICOUL,LFERMI
17124
17125* parameter for intranuclear cascade
17126 LOGICAL LPAULI
17127 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17128
17129* final state after intranuclear cascade step
17130 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17131
17132* nucleon-nucleon event-generator
17133 CHARACTER*8 CMODEL
17134 LOGICAL LPHOIN
17135 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17136
17137* statistics: residual nuclei
17138 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17139 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17140 & NINCST(2,4),NINCEV(2),
17141 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17142 & NRESPB(2),NRESCH(2),NRESEV(4),
17143 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17144 & NEVAFI(2,2)
17145
17146 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17147 & PCAS1(5),PNUC(5),BGTA(4),
17148 & BGCAS(2),GACAS(2),BECAS(2),
17149 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17150
17151 DATA PDIF /0.545D0/
17152
17153 IREJ = 0
17154
17155* update counter
17156 IF (NINCEV(1).NE.NEVHKK) THEN
17157 NINCEV(1) = NEVHKK
17158 NINCEV(2) = NINCEV(2)+1
17159 ENDIF
17160
17161* "BAMJET-index" of this hadron
17162 IDCAS = IDBAM(IDXCAS)
17163 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17164
17165* skip gammas, electrons, etc..
17166 IF (AAM(IDCAS).LT.TINY2) RETURN
17167
17168* Lorentz-trsf. into projectile rest system
17169 IF (IP.GT.1) THEN
17170 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17171 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17172 & PCAS(1,4),IDCAS,-2)
17173 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17174 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17175 IF (PCAS(1,5).GT.ZERO) THEN
17176 PCAS(1,5) = SQRT(PCAS(1,5))
17177 ELSE
17178 PCAS(1,5) = AAM(IDCAS)
17179 ENDIF
17180 DO 20 K=1,3
17181 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17182 20 CONTINUE
17183* Lorentz-parameters
17184* particle rest system --> projectile rest system
17185 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17186 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17187 BECAS(1) = BGCAS(1)/GACAS(1)
17188 ELSE
17189 DO 21 K=1,5
17190 PCAS(1,K) = ZERO
17191 IF (K.LE.3) COSCAS(1,K) = ZERO
17192 21 CONTINUE
17193 PTOCAS(1) = ZERO
17194 BGCAS(1) = ZERO
17195 GACAS(1) = ZERO
17196 BECAS(1) = ZERO
17197 ENDIF
17198* Lorentz-trsf. into target rest system
17199 IF (IT.GT.1) THEN
17200* LEPTO: final state particles are already in target rest frame
17201C IF (MCGENE.EQ.3) THEN
17202C PCAS(2,1) = PHKK(1,IDXCAS)
17203C PCAS(2,2) = PHKK(2,IDXCAS)
17204C PCAS(2,3) = PHKK(3,IDXCAS)
17205C PCAS(2,4) = PHKK(4,IDXCAS)
17206C ELSE
17207 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17208 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17209 & PCAS(2,4),IDCAS,-3)
17210C ENDIF
17211 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17212 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17213 IF (PCAS(2,5).GT.ZERO) THEN
17214 PCAS(2,5) = SQRT(PCAS(2,5))
17215 ELSE
17216 PCAS(2,5) = AAM(IDCAS)
17217 ENDIF
17218 DO 22 K=1,3
17219 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17220 22 CONTINUE
17221* Lorentz-parameters
17222* particle rest system --> target rest system
17223 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17224 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17225 BECAS(2) = BGCAS(2)/GACAS(2)
17226 ELSE
17227 DO 23 K=1,5
17228 PCAS(2,K) = ZERO
17229 IF (K.LE.3) COSCAS(2,K) = ZERO
17230 23 CONTINUE
17231 PTOCAS(2) = ZERO
17232 BGCAS(2) = ZERO
17233 GACAS(2) = ZERO
17234 BECAS(2) = ZERO
17235 ENDIF
17236
17237* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17238* potential (see CONUCL)
17239 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17240 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17241* impact parameter (the projectile moving along z)
17242 BIMPC(1) = ZERO
17243 BIMPC(2) = BIMPAC*FM2MM
17244
17245* get position of initial hadron in projectile/target rest-syst.
17246 DO 3 K=1,4
17247 VTXCAS(1,K) = WHKK(K,IDXCAS)
17248 VTXCAS(2,K) = VHKK(K,IDXCAS)
17249 3 CONTINUE
17250
17251 ICAS = 1
17252 I2 = 2
17253 IF (NCAS.EQ.-1) THEN
17254 ICAS = 2
17255 I2 = 1
17256 ENDIF
17257
17258 IF (PTOCAS(ICAS).LT.TINY10) THEN
17259 WRITE(LOUT,1000) PTOCAS
17260 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17261 & ' hadron ',/,20X,2E12.4)
17262 GOTO 9999
17263 ENDIF
17264
17265* reset spectator flags
17266 NSPE = 0
17267 IDXSPE(1) = 0
17268 IDXSPE(2) = 0
17269 IDSPE(1) = 0
17270 IDSPE(2) = 0
17271
17272* formation length (in fm)
17273C IF (LCAS) THEN
17274C DEL0 = ZERO
17275C ELSE
17276 DEL0 = TAUFOR*BGCAS(ICAS)
17277 IF (ITAUVE.EQ.1) THEN
17278 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17279 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17280 ENDIF
17281C ENDIF
17282* sample from exp(-del/del0)
17283 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17284* save formation time
17285 TAUSA1 = DEL1/BGCAS(ICAS)
17286 REL1 = TAUSA1*BGCAS(I2)
17287
17288 DEL = DEL1
17289 TAUSAM = DEL/BGCAS(ICAS)
17290 REL = TAUSAM*BGCAS(I2)
17291
17292* special treatment for negative particles unable to escape
17293* nuclear potential (implemented for ap, pi-, K- only)
17294 LABSOR = .FALSE.
17295 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17296* threshold energy = nuclear potential + Coulomb potential
17297* (nuclear potential for hadron-nucleus interactions only)
17298 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17299 IF (PCAS(ICAS,4).LT.ETHR) THEN
17300 DO 4 K=1,5
17301 PCAS1(K) = PCAS(ICAS,K)
17302 4 CONTINUE
17303* "absorb" negative particle in nucleus
17304 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17305 IF (IREJ1.NE.0) GOTO 9999
17306 IF (NSPE.GE.1) LABSOR = .TRUE.
17307 ENDIF
17308 ENDIF
17309
17310* if the initial particle has not been absorbed proceed with
17311* "normal" cascade
17312 IF (.NOT.LABSOR) THEN
17313
17314* calculate coordinates of hadron at the end of the formation zone
17315* transport-time and -step in the rest system where this step is
17316* treated
17317 DSTEP = DEL*FM2MM
17318 DTIME = DSTEP/BECAS(ICAS)
17319 RSTEP = REL*FM2MM
17320 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17321 RTIME = RSTEP/BECAS(I2)
17322 ELSE
17323 RTIME = ZERO
17324 ENDIF
17325* save step whithout considering the overlapping region
17326 DSTEP1 = DEL1*FM2MM
17327 DTIME1 = DSTEP1/BECAS(ICAS)
17328 RSTEP1 = REL1*FM2MM
17329 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17330 RTIME1 = RSTEP1/BECAS(I2)
17331 ELSE
17332 RTIME1 = ZERO
17333 ENDIF
17334* transport to the end of the formation zone in this system
17335 DO 5 K=1,3
17336 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17337 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17338 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17339 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17340 5 CONTINUE
17341 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17342 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17343 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17344 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17345
17346 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17347 XCAS = VTXCAS(ICAS,1)
17348 YCAS = VTXCAS(ICAS,2)
17349 XNCLTA = BIMPAC*FM2MM
17350 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17351 RNCLTA = (RTARG+RNUCLE)*FM2MM
17352C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17353C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17354C RNCLPR = (RPROJ)*FM2MM
17355C RNCLTA = (RTARG)*FM2MM
17356 RCASPR = SQRT( XCAS**2 +YCAS**2)
17357 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17358 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17359 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17360 ENDIF
17361 ENDIF
17362
17363* check if particle is already outside of the corresp. nucleus
17364 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17365 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17366 IF (RDIST.GE.RNUC(ICAS)) THEN
17367* here: IDCH is the generation of the final state part. starting
17368* with zero for hadronization products
17369* flag particles of generation 0 being outside the nuclei after
17370* formation time (to be used for excitation energy calculation)
17371 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17372 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17373 GOTO 9997
17374 ENDIF
17375 DIST = DLARGE
17376 DISTP = DLARGE
17377 DISTN = DLARGE
17378 IDXP = 0
17379 IDXN = 0
17380
17381* already here: skip particles being outside HADRIN "energy-window"
17382* to avoid wasting of time
17383 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17384 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17385 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17386C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17387C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17388C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17389C & E12.4,', above or below HADRIN-thresholds',I6)
17390 NSPE = 0
17391 GOTO 9997
17392 ENDIF
17393
17394 DO 7 IDXHKK=1,NOINC
17395 I = IDXINC(IDXHKK)
17396* scan DTEVT1 for unwounded or excited nucleons
17397 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17398 DO 8 K=1,3
17399 IF (ICAS.EQ.1) THEN
17400 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17401 ELSEIF (ICAS.EQ.2) THEN
17402 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17403 ENDIF
17404 8 CONTINUE
17405 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17406 & VTXDST(2)*COSCAS(ICAS,2)+
17407 & VTXDST(3)*COSCAS(ICAS,3)
17408* check if nucleon is situated in forward direction
17409 IF (POSNUC.GT.ZERO) THEN
17410* distance between hadron and this nucleon
17411 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17412 & VTXDST(3)**2)
17413* impact parameter
17414 BIMNU2 = DISTNU**2-POSNUC**2
17415 IF (BIMNU2.LT.ZERO) THEN
17416 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17417 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17418 & ' parameter ',/,20X,3E12.4)
17419 GOTO 7
17420 ENDIF
17421 BIMNU = SQRT(BIMNU2)
17422* maximum impact parameter to have interaction
17423 IDNUC = IDT_ICIHAD(IDHKK(I))
17424 IDNUC1 = IDT_MCHAD(IDNUC)
17425 IDCAS1 = IDT_MCHAD(IDCAS)
17426 DO 19 K=1,5
17427 PCAS1(K) = PCAS(ICAS,K)
17428 PNUC(K) = PHKK(K,I)
17429 19 CONTINUE
17430* Lorentz-parameter for trafo into rest-system of target
17431 DO 18 K=1,4
17432 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17433 18 CONTINUE
17434* transformation of projectile into rest-system of target
17435 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17436 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17437 & PPTOT,PX,PY,PZ,PE)
17438**
17439C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17440C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17441 DUMZER = ZERO
17442 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17443 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17444 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17445 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17446 SIGIN = SIGTOT-SIGEL-SIGAB
17447C SIGTOT = SIGIN+SIGEL+SIGAB
17448**
17449 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17450* check if interaction is possible
17451 IF (BIMNU.LE.BIMMAX) THEN
17452* get nucleon with smallest distance and kind of interaction
17453* (elastic/inelastic)
17454 IF (DISTNU.LT.DIST) THEN
17455 DIST = DISTNU
17456 BINT = BIMNU
17457 IF (IDNUC.NE.IDSPE(1)) THEN
17458 IDSPE(2) = IDSPE(1)
17459 IDXSPE(2) = IDXSPE(1)
17460 IDSPE(1) = IDNUC
17461 ENDIF
17462 IDXSPE(1) = I
17463 NSPE = 1
17464**sr
17465 SELA = SIGEL
17466 SABS = SIGAB
17467 STOT = SIGTOT
17468C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17469C SELA = SIGEL
17470C STOT = SIGIN+SIGEL
17471C ELSE
17472C SELA = SIGEL+0.75D0*SIGIN
17473C STOT = 0.25D0*SIGIN+SELA
17474C ENDIF
17475**
17476 ENDIF
17477 ENDIf
17478 ENDIF
17479 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17480 & VTXDST(3)**2)
17481 IDNUC = IDT_ICIHAD(IDHKK(I))
17482 IF (IDNUC.EQ.1) THEN
17483 IF (DISTNU.LT.DISTP) THEN
17484 DISTP = DISTNU
17485 IDXP = I
17486 POSP = POSNUC
17487 ENDIF
17488 ELSEIF (IDNUC.EQ.8) THEN
17489 IF (DISTNU.LT.DISTN) THEN
17490 DISTN = DISTNU
17491 IDXN = I
17492 POSN = POSNUC
17493 ENDIF
17494 ENDIF
17495 ENDIF
17496 7 CONTINUE
17497
17498* there is no nucleon for a secondary interaction
17499 IF (NSPE.EQ.0) GOTO 9997
17500
17501C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17502C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17503 IF (IDXSPE(2).EQ.0) THEN
17504 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17505C DO 80 K=1,3
17506C IF (ICAS.EQ.1) THEN
17507C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17508C ELSEIF (ICAS.EQ.2) THEN
17509C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17510C ENDIF
17511C 80 CONTINUE
17512C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17513C & VTXDST(3)**2)
17514C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17515 IDXSPE(2) = IDXN
17516 IDSPE(2) = 8
17517C ELSE
17518C STOT = STOT-SABS
17519C SABS = ZERO
17520C ENDIF
17521 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17522C DO 81 K=1,3
17523C IF (ICAS.EQ.1) THEN
17524C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17525C ELSEIF (ICAS.EQ.2) THEN
17526C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17527C ENDIF
17528C 81 CONTINUE
17529C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17530C & VTXDST(3)**2)
17531C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17532 IDXSPE(2) = IDXP
17533 IDSPE(2) = 1
17534C ELSE
17535C STOT = STOT-SABS
17536C SABS = ZERO
17537C ENDIF
17538 ELSE
17539 STOT = STOT-SABS
17540 SABS = ZERO
17541 ENDIF
17542 ENDIF
17543 RR = DT_RNDM(DIST)
17544 IF (RR.LT.SELA/STOT) THEN
17545 IPROC = 2
17546 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17547 IPROC = 3
17548 ELSE
17549 IPROC = 1
17550 ENDIF
17551
17552 DO 9 K=1,5
17553 PCAS1(K) = PCAS(ICAS,K)
17554 PNUC(K) = PHKK(K,IDXSPE(1))
17555 9 CONTINUE
17556 IF (IPROC.EQ.3) THEN
17557* 2-nucleon absorption of pion
17558 NSPE = 2
17559 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17560 IF (IREJ1.NE.0) GOTO 9999
17561 IF (NSPE.GE.1) LABSOR = .TRUE.
17562 ELSE
17563* sample secondary interaction
17564 IDNUC = IDBAM(IDXSPE(1))
17565 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17566 IF (IREJ1.EQ.1) GOTO 9999
17567 IF (IREJ1.GT.1) GOTO 9998
17568 ENDIF
17569 ENDIF
17570
17571* update arrays to include Pauli-principle
17572 DO 10 I=1,NSPE
17573 IF (NWOUND(ICAS).LE.299) THEN
17574 NWOUND(ICAS) = NWOUND(ICAS)+1
17575 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17576 ENDIF
17577 10 CONTINUE
17578
17579* dump initial hadron for energy-momentum conservation check
17580 IF (LEMCCK)
17581 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17582 & PCAS(ICAS,4),1,IDUM,IDUM)
17583
17584* dump final state particles into DTEVT1
17585
17586* check if Pauli-principle is fulfilled
17587 NPAULI = 0
17588 NWTMP(1) = NWOUND(1)
17589 NWTMP(2) = NWOUND(2)
17590 DO 111 I=1,NFSP
17591 NPAULI = 0
17592 J1 = 2
17593 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17594 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17595 DO 117 J=1,J1
17596 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17597 IF (J.EQ.1) THEN
17598 IDX = ICAS
17599 PE = PFSP(4,I)
17600 ELSE
17601 IDX = I2
17602 MODE = 1
17603 IF (IDX.EQ.1) MODE = -1
17604 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17605 ENDIF
17606* first check if cascade step is forbidden due to Pauli-principle
17607* (in case of absorpion this step is forced)
17608 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17609 & (IDFSP(I).EQ.8))) THEN
17610* get nuclear potential barrier
17611 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17612 IF (IDFSP(I).EQ.1) THEN
17613 POTLOW = POT-EBINDP(IDX)
17614 ELSE
17615 POTLOW = POT-EBINDN(IDX)
17616 ENDIF
17617* final state particle not able to escape nucleus
17618 IF (PE.LE.POTLOW) THEN
17619* check if there are wounded nucleons
17620 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17621 & EWOUND(IDX,NWOUND(IDX)))) THEN
17622 NPAULI = NPAULI+1
17623 NWOUND(IDX) = NWOUND(IDX)-1
17624 ELSE
17625* interaction prohibited by Pauli-principle
17626 NWOUND(1) = NWTMP(1)
17627 NWOUND(2) = NWTMP(2)
17628 GOTO 9997
17629 ENDIF
17630 ENDIF
17631 ENDIF
17632 117 CONTINUE
17633 111 CONTINUE
17634
17635 NPAULI = 0
17636 NWOUND(1) = NWTMP(1)
17637 NWOUND(2) = NWTMP(2)
17638
17639 DO 11 I=1,NFSP
17640
17641 IST = ISTHKK(IDXCAS)
17642
17643 NPAULI = 0
17644 J1 = 2
17645 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17646 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17647 DO 17 J=1,J1
17648 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17649 IDX = ICAS
17650 PE = PFSP(4,I)
17651 IF (J.EQ.2) THEN
17652 IDX = I2
17653 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17654 ENDIF
17655* first check if cascade step is forbidden due to Pauli-principle
17656* (in case of absorpion this step is forced)
17657 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17658 & (IDFSP(I).EQ.8))) THEN
17659* get nuclear potential barrier
17660 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17661 IF (IDFSP(I).EQ.1) THEN
17662 POTLOW = POT-EBINDP(IDX)
17663 ELSE
17664 POTLOW = POT-EBINDN(IDX)
17665 ENDIF
17666* final state particle not able to escape nucleus
17667 IF (PE.LE.POTLOW) THEN
17668* check if there are wounded nucleons
17669 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17670 & EWOUND(IDX,NWOUND(IDX)))) THEN
17671 NWOUND(IDX) = NWOUND(IDX)-1
17672 NPAULI = NPAULI+1
17673 IST = 14+IDX
17674 ELSE
17675* interaction prohibited by Pauli-principle
17676 NWOUND(1) = NWTMP(1)
17677 NWOUND(2) = NWTMP(2)
17678 GOTO 9997
17679 ENDIF
17680**sr
17681c ELSEIF (PE.LE.POT) THEN
17682cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17683cC NWOUND(IDX) = NWOUND(IDX)-1
17684c**
17685c NPAULI = NPAULI+1
17686c IST = 14+IDX
17687 ENDIF
17688 ENDIF
17689 17 CONTINUE
17690
17691* dump final state particles for energy-momentum conservation check
17692 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17693 & -PFSP(4,I),2,IDUM,IDUM)
17694
17695 PX = PFSP(1,I)
17696 PY = PFSP(2,I)
17697 PZ = PFSP(3,I)
17698 PE = PFSP(4,I)
17699 IF (ABS(IST).EQ.1) THEN
17700* transform particles back into n-n cms
17701* LEPTO: leave final state particles in target rest frame
17702C IF (MCGENE.EQ.3) THEN
17703C PFSP(1,I) = PX
17704C PFSP(2,I) = PY
17705C PFSP(3,I) = PZ
17706C PFSP(4,I) = PE
17707C ELSE
17708 IMODE = ICAS+1
17709 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17710 & PFSP(4,I),IDFSP(I),IMODE)
17711C ENDIF
17712 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17713* target cascade but fsp got stuck in proj. --> transform it into
17714* proj. rest system
17715 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17716 & PFSP(4,I),IDFSP(I),-1)
17717 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17718* proj. cascade but fsp got stuck in target --> transform it into
17719* target rest system
17720 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17721 & PFSP(4,I),IDFSP(I),1)
17722 ENDIF
17723
17724* dump final state particles into DTEVT1
17725 IGEN = IDCH(IDXCAS)+1
17726 ID = IDT_IPDGHA(IDFSP(I))
17727 IXR = 0
17728 IF (LABSOR) IXR = 99
17729 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17730 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17731
17732* update the counter for particles which got stuck inside the nucleus
17733 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17734 NOINC = NOINC+1
17735 IDXINC(NOINC) = NHKK
17736 ENDIF
17737 IF (LABSOR) THEN
17738* in case of absorption the spatial treatment is an approximate
17739* solution anyway (the positions of the nucleons which "absorb" the
17740* cascade particle are not taken into consideration) therefore the
17741* particles are produced at the position of the cascade particle
17742 DO 12 K=1,4
17743 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17744 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17745 12 CONTINUE
17746 ELSE
17747* DDISTL - distance the cascade particle moves to the intera. point
17748* (the position where impact-parameter = distance to the interacting
17749* nucleon), DIST - distance to the interacting nucleon at the time of
17750* formation of the cascade particle, BINT - impact-parameter of this
17751* cascade-interaction
17752 DDISTL = SQRT(DIST**2-BINT**2)
17753 DTIME = DDISTL/BECAS(ICAS)
17754 DTIMEL = DDISTL/BGCAS(ICAS)
17755 RDISTL = DTIMEL*BGCAS(I2)
17756 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17757 RTIME = RDISTL/BECAS(I2)
17758 ELSE
17759 RTIME = ZERO
17760 ENDIF
17761* RDISTL, RTIME are this step and time in the rest system of the other
17762* nucleus
17763 DO 13 K=1,3
17764 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17765 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17766 13 CONTINUE
17767 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17768 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17769* position of particle production is half the impact-parameter to
17770* the interacting nucleon
17771 DO 14 K=1,3
17772 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17773 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17774 14 CONTINUE
17775* time of production of secondary = time of interaction
17776 WHKK(4,NHKK) = VTXCA1(1,4)
17777 VHKK(4,NHKK) = VTXCA1(2,4)
17778 ENDIF
17779
17780 11 CONTINUE
17781
17782* modify status and position of cascade particle (the latter for
17783* statistics reasons only)
17784 ISTHKK(IDXCAS) = 2
17785 IF (LABSOR) ISTHKK(IDXCAS) = 19
17786 IF (.NOT.LABSOR) THEN
17787 DO 15 K=1,4
17788 WHKK(K,IDXCAS) = VTXCA1(1,K)
17789 VHKK(K,IDXCAS) = VTXCA1(2,K)
17790 15 CONTINUE
17791 ENDIF
17792
17793 DO 16 I=1,NSPE
17794 IS = IDXSPE(I)
17795* dump interacting nucleons for energy-momentum conservation check
17796 IF (LEMCCK)
17797 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17798 & 2,IDUM,IDUM)
17799* modify entry for interacting nucleons
17800 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17801 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17802 IF (I.GE.2) THEN
17803 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17804 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17805 ENDIF
17806 16 CONTINUE
17807
17808* check energy-momentum conservation
17809 IF (LEMCCK) THEN
17810 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17811 IF (IREJ1.NE.0) GOTO 9999
17812 ENDIF
17813
17814* update counter
17815 IF (LABSOR) THEN
17816 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17817 ELSE
17818 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17819 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17820 ENDIF
17821
17822 RETURN
17823
17824 9997 CONTINUE
17825 9998 CONTINUE
17826* transport-step but no cascade step due to configuration (i.e. there
17827* is no nucleon for interaction etc.)
17828 IF (LCAS) THEN
17829 DO 100 K=1,4
17830C WHKK(K,IDXCAS) = VTXCAS(1,K)
17831C VHKK(K,IDXCAS) = VTXCAS(2,K)
17832 WHKK(K,IDXCAS) = VTXCA1(1,K)
17833 VHKK(K,IDXCAS) = VTXCA1(2,K)
17834 100 CONTINUE
17835 ENDIF
17836
17837C9998 CONTINUE
17838* no cascade-step because of configuration
17839* (i.e. hadron outside nucleus etc.)
17840 LCAS = .TRUE.
17841 RETURN
17842
17843 9999 CONTINUE
17844* rejection
17845 IREJ = 1
17846 RETURN
17847 END
17848
17849*$ CREATE DT_ABSORP.FOR
17850*COPY DT_ABSORP
17851*
17852*===absorp=============================================================*
17853*
17854 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17855
17856************************************************************************
17857* Two-nucleon absorption of antiprotons, pi-, and K-. *
17858* Antiproton absorption is handled by HADRIN. *
17859* The following channels for meson-absorption are considered: *
17860* pi- + p + p ---> n + p *
17861* pi- + p + n ---> n + n *
17862* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17863* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17864* K- + p + p ---> sigma- + n *
17865* IDCAS, PCAS identity, momentum of particle to be absorbed *
17866* NCAS = 1 intranuclear cascade in projectile *
17867* = -1 intranuclear cascade in target *
17868* NSPE number of spectator nucleons involved *
17869* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17870* Revised version of the original STOPIK written by HJM and J. Ranft. *
17871* This version dated 24.02.95 is written by S. Roesler *
17872************************************************************************
17873
17874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17875 SAVE
17876
17877 PARAMETER ( LINP = 10 ,
17878 & LOUT = 6 ,
17879 & LDAT = 9 )
17880
17881 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17882 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17883
17884* event history
17885
17886 PARAMETER (NMXHKK=200000)
17887
17888 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17889 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17890 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17891
17892* extended event history
17893 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17894 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17895 & IHIST(2,NMXHKK)
17896
17897* flags for input different options
17898 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17899 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17900 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17901
17902* final state after inc step
17903 PARAMETER (MAXFSP=10)
17904 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17905
17906* particle properties (BAMJET index convention)
17907 CHARACTER*8 ANAME
17908 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17909 & IICH(210),IIBAR(210),K1(210),K2(210)
17910
17911 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17912 & PTOT3P(4),BG3P(4),
17913 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17914
17915 IREJ = 0
17916 NFSP = 0
17917
17918* skip particles others than ap, pi-, K- for mode=0
17919 IF ((MODE.EQ.0).AND.
17920 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17921* skip particles others than pions for mode=1
17922* (2-nucleon absorption in intranuclear cascade)
17923 IF ((MODE.EQ.1).AND.
17924 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17925
17926 NUCAS = NCAS
17927 IF (NUCAS.EQ.-1) NUCAS = 2
17928
17929 IF (MODE.EQ.0) THEN
17930* scan spectator nucleons for nucleons being able to "absorb"
17931 NSPE = 0
17932 IDXSPE(1) = 0
17933 IDXSPE(2) = 0
17934 DO 1 I=1,NHKK
17935 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17936 NSPE = NSPE+1
17937 IDXSPE(NSPE) = I
17938 IDSPE(NSPE) = IDBAM(I)
17939 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17940 IF (NSPE.EQ.2) THEN
17941 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17942 & (IDSPE(2).EQ.8)) THEN
17943* there is no pi-+n+n channel
17944 NSPE = 1
17945 GOTO 1
17946 ELSE
17947 GOTO 2
17948 ENDIF
17949 ENDIF
17950 ENDIF
17951 1 CONTINUE
17952
17953 2 CONTINUE
17954 ENDIF
17955* transform excited projectile nucleons (status=15) into proj. rest s.
17956 DO 3 I=1,NSPE
17957 DO 4 K=1,5
17958 PSPE(I,K) = PHKK(K,IDXSPE(I))
17959 4 CONTINUE
17960 3 CONTINUE
17961
17962* antiproton absorption
17963 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17964 DO 5 K=1,5
17965 PSPE1(K) = PSPE(1,K)
17966 5 CONTINUE
17967 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17968 IF (IREJ1.NE.0) GOTO 9999
17969
17970* meson absorption
17971 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17972 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17973 IF (IDCAS.EQ.14) THEN
17974* pi- absorption
17975 IDFSP(1) = 8
17976 IDFSP(2) = 8
17977 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17978 ELSEIF (IDCAS.EQ.13) THEN
17979* pi+ absorption
17980 IDFSP(1) = 1
17981 IDFSP(2) = 1
17982 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17983 ELSEIF (IDCAS.EQ.23) THEN
17984* pi0 absorption
17985 IDFSP(1) = IDSPE(1)
17986 IDFSP(2) = IDSPE(2)
17987 ELSEIF (IDCAS.EQ.16) THEN
17988* K- absorption
17989 R = DT_RNDM(PCAS)
17990 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17991 IF (R.LT.ONETHI) THEN
17992 IDFSP(1) = 21
17993 IDFSP(2) = 8
17994 ELSEIF (R.LT.TWOTHI) THEN
17995 IDFSP(1) = 17
17996 IDFSP(2) = 1
17997 ELSE
17998 IDFSP(1) = 22
17999 IDFSP(2) = 1
18000 ENDIF
18001 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
18002 IDFSP(1) = 20
18003 IDFSP(2) = 8
18004 ELSE
18005 IF (R.LT.ONETHI) THEN
18006 IDFSP(1) = 20
18007 IDFSP(2) = 1
18008 ELSEIF (R.LT.TWOTHI) THEN
18009 IDFSP(1) = 17
18010 IDFSP(2) = 8
18011 ELSE
18012 IDFSP(1) = 22
18013 IDFSP(2) = 8
18014 ENDIF
18015 ENDIF
18016 ENDIF
18017* dump initial particles for energy-momentum cons. check
18018 IF (LEMCCK) THEN
18019 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18020 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18021 & IDUM,IDUM)
18022 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18023 & IDUM,IDUM)
18024 ENDIF
18025* get Lorentz-parameter of 3 particle initial state
18026 DO 6 K=1,4
18027 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18028 6 CONTINUE
18029 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18030 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18031 DO 7 K=1,4
18032 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18033 7 CONTINUE
18034* 2-particle decay of the 3-particle compound system
18035 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18036 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18037 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18038 DO 8 I=1,2
18039 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18040 PX = PCMF(I)*COFF(I)*SDF
18041 PY = PCMF(I)*SIFF(I)*SDF
18042 PZ = PCMF(I)*CODF(I)
18043 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18044 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18045 & PFSP(4,I))
18046 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18047* check consistency of kinematics
18048 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18049 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18050 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18051 & ' tree-particle kinematics',/,20X,'id: ',I3,
18052 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18053 ENDIF
18054* dump final state particles for energy-momentum cons. check
18055 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18056 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18057 8 CONTINUE
18058 NFSP = 2
18059 IF (LEMCCK) THEN
18060 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18061 IF (IREJ1.NE.0) THEN
18062 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18063 & AM3P
18064 GOTO 9999
18065 ENDIF
18066 ENDIF
18067 ELSE
18068 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18069 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18070 & ' impossible',/,20X,'too few spectators (',I2,')')
18071 NSPE = 0
18072 ENDIF
18073
18074 RETURN
18075
18076 9999 CONTINUE
18077 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18078 IREJ = 1
18079 RETURN
18080 END
18081
18082*$ CREATE DT_HADRIN.FOR
18083*COPY DT_HADRIN
18084*
18085*===hadrin=============================================================*
18086*
18087 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18088
18089************************************************************************
18090* Interface to the HADRIN-routines for inelastic and elastic *
18091* scattering. *
18092* IDPR,PPR(5) identity, momentum of projectile *
18093* IDTA,PTA(5) identity, momentum of target *
18094* MODE = 1 inelastic interaction *
18095* = 2 elastic interaction *
18096* Revised version of the original FHAD. *
18097* This version dated 27.10.95 is written by S. Roesler *
18098************************************************************************
18099
18100 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18101 SAVE
18102
18103 PARAMETER ( LINP = 10 ,
18104 & LOUT = 6 ,
18105 & LDAT = 9 )
18106
18107 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18108 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18109
18110 LOGICAL LCORR,LMSSG
18111
18112* flags for input different options
18113 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18114 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18115 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18116
18117* final state after inc step
18118 PARAMETER (MAXFSP=10)
18119 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18120
18121* particle properties (BAMJET index convention)
18122 CHARACTER*8 ANAME
18123 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18124 & IICH(210),IIBAR(210),K1(210),K2(210)
18125* output-common for DHADRI/ELHAIN
18126
18127* final state from HADRIN interaction
18128 PARAMETER (MAXFIN=10)
18129 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18130 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18131
18132 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18133 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18134
18135 DATA LMSSG /.TRUE./
18136
18137 IREJ = 0
18138 NFSP = 0
18139 KCORR = 0
18140 IMCORR(1) = 0
18141 IMCORR(2) = 0
18142 LCORR = .FALSE.
18143
18144* dump initial particles for energy-momentum cons. check
18145 IF (LEMCCK) THEN
18146 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18147 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18148 ENDIF
18149
18150 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18151 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18152 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18153 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18154 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18155 IF (LMSSG.AND.(IOULEV(3).GT.0))
18156 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18157 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18158 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18159 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18160 LMSSG = .FALSE.
18161 LCORR = .TRUE.
18162 ENDIF
18163
18164* convert initial state particles into particles which can be
18165* handled by HADRIN
18166 IDHPR = IDPR
18167 IDHTA = IDTA
18168 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18169 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18170 DO 1 K=1,4
18171 P1IN(K) = PPR(K)
18172 P2IN(K) = PTA(K)
18173 1 CONTINUE
18174 XM1 = AAM(IDHPR)
18175 XM2 = AAM(IDHTA)
18176 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18177 IF (IREJ1.GT.0) THEN
18178 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18179 GOTO 9999
18180 ENDIF
18181 DO 2 K=1,4
18182 PPR(K) = P1OUT(K)
18183 PTA(K) = P2OUT(K)
18184 2 CONTINUE
18185 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18186 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18187 ENDIF
18188
18189* Lorentz-parameter for trafo into rest-system of target
18190 DO 3 K=1,4
18191 BGTA(K) = PTA(K)/PTA(5)
18192 3 CONTINUE
18193* transformation of projectile into rest-system of target
18194 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18195 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18196 & PPR1(4))
18197
18198* direction cosines of projectile in target rest system
18199 CX = PPR1(1)/PPRTO1
18200 CY = PPR1(2)/PPRTO1
18201 CZ = PPR1(3)/PPRTO1
18202
18203* sample inelastic interaction
18204 IF (MODE.EQ.1) THEN
18205 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18206 IF (IRH.EQ.1) GOTO 9998
18207* sample elastic interaction
18208 ELSEIF (MODE.EQ.2) THEN
18209 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18210 IF (IREJ1.NE.0) THEN
18211 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18212 GOTO 9999
18213 ENDIF
18214 IF (IRH.EQ.1) GOTO 9998
18215 ELSE
18216 WRITE(LOUT,1001) MODE,INTHAD
18217 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18218 & I4,' (INTHAD =',I4,')')
18219 GOTO 9999
18220 ENDIF
18221
18222* transform final state particles back into Lab.
18223 DO 4 I=1,IRH
18224 NFSP = NFSP+1
18225 PX = CXRH(I)*PLRH(I)
18226 PY = CYRH(I)*PLRH(I)
18227 PZ = CZRH(I)*PLRH(I)
18228 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18229 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18230 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18231 IDFSP(NFSP) = ITRH(I)
18232 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18233 & PFSP(3,NFSP)**2
18234 IF (AMFSP2.LT.-TINY3) THEN
18235 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18236 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18237 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18238 & I2,') with negative mass^2',/,1X,5E12.4)
18239 GOTO 9999
18240 ELSE
18241 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18242 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18243 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18244 & PFSP(5,NFSP)
18245 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18246 & ' (id = ',I2,') with inconsistent mass',/,1X,
18247 & 2E12.4)
18248 KCORR = KCORR+1
18249 IF (KCORR.GT.2) GOTO 9999
18250 IMCORR(KCORR) = NFSP
18251 ENDIF
18252 ENDIF
18253* dump final state particles for energy-momentum cons. check
18254 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18255 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18256 4 CONTINUE
18257
18258* transform momenta on mass shell in case of inconsistencies in
18259* HADRIN
18260 IF (KCORR.GT.0) THEN
18261 IF (KCORR.EQ.2) THEN
18262 I1 = IMCORR(1)
18263 I2 = IMCORR(2)
18264 ELSE
18265 IF (IMCORR(1).EQ.1) THEN
18266 I1 = 1
18267 I2 = 2
18268 ELSE
18269 I1 = 1
18270 I2 = IMCORR(1)
18271 ENDIF
18272 ENDIF
18273 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18274 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18275 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18276 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18277 DO 5 K=1,4
18278 P1IN(K) = PFSP(K,I1)
18279 P2IN(K) = PFSP(K,I2)
18280 5 CONTINUE
18281 XM1 = AAM(IDFSP(I1))
18282 XM2 = AAM(IDFSP(I2))
18283 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18284 IF (IREJ1.GT.0) THEN
18285 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18286C GOTO 9999
18287 ENDIF
18288 DO 6 K=1,4
18289 PFSP(K,I1) = P1OUT(K)
18290 PFSP(K,I2) = P2OUT(K)
18291 6 CONTINUE
18292 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18293 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18294 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18295 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18296* dump final state particles for energy-momentum cons. check
18297 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18298 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18299 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18300 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18301 ENDIF
18302
18303* check energy-momentum conservation
18304 IF (LEMCCK) THEN
18305 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18306 IF (IREJ1.NE.0) GOTO 9999
18307 ENDIF
18308
18309 RETURN
18310
18311 9998 CONTINUE
18312 IREJ = 2
18313 RETURN
18314
18315 9999 CONTINUE
18316 IREJ = 1
18317 RETURN
18318 END
18319
18320*$ CREATE DT_HADCOL.FOR
18321*COPY DT_HADCOL
18322*
18323*===hadcol=============================================================*
18324*
18325 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18326
18327************************************************************************
18328* Interface to the HADRIN-routines for inelastic and elastic *
18329* scattering. This subroutine samples hadron-nucleus interactions *
18330* below DPM-threshold. *
18331* IDPROJ BAMJET-index of projectile hadron *
18332* PPN projectile momentum in target rest frame *
18333* IDXTAR DTEVT1-index of target nucleon undergoing *
18334* interaction with projectile hadron *
18335* This subroutine replaces HADHAD. *
18336* This version dated 5.5.95 is written by S. Roesler *
18337************************************************************************
18338
18339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18340 SAVE
18341
18342 PARAMETER ( LINP = 10 ,
18343 & LOUT = 6 ,
18344 & LDAT = 9 )
18345
18346 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18347
18348 LOGICAL LSTART
18349
18350* event history
18351
18352 PARAMETER (NMXHKK=200000)
18353
18354 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18355 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18356 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18357
18358* extended event history
18359 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18360 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18361 & IHIST(2,NMXHKK)
18362
18363* nuclear potential
18364 LOGICAL LFERMI
18365 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18366 & EBINDP(2),EBINDN(2),EPOT(2,210),
18367 & ETACOU(2),ICOUL,LFERMI
18368
18369* interface HADRIN-DPM
18370 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18371
18372* parameter for intranuclear cascade
18373 LOGICAL LPAULI
18374 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18375
18376* final state after inc step
18377 PARAMETER (MAXFSP=10)
18378 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18379
18380* particle properties (BAMJET index convention)
18381 CHARACTER*8 ANAME
18382 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18383 & IICH(210),IIBAR(210),K1(210),K2(210)
18384
18385 DIMENSION PPROJ(5),PNUC(5)
18386
18387 DATA LSTART /.TRUE./
18388
18389 IREJ = 0
18390
18391 NPOINT(1) = NHKK+1
18392
18393 TAUSAV = TAUFOR
18394**sr 6/9/01 commented
18395C TAUFOR = TAUFOR/2.0D0
18396**
18397 IF (LSTART) THEN
18398 WRITE(LOUT,1000)
18399 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18400 WRITE(LOUT,1001) TAUFOR
18401 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18402 & F5.1,' fm/c')
18403 LSTART = .FALSE.
18404 ENDIF
18405
18406 IDNUC = IDBAM(IDXTAR)
18407 IDNUC1 = IDT_MCHAD(IDNUC)
18408 IDPRO1 = IDT_MCHAD(IDPROJ)
18409
18410 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18411 IPROC = INTHAD
18412 ELSE
18413**
18414C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18415C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18416 DUMZER = ZERO
18417 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18418 SIGIN = SIGTOT-SIGEL
18419C SIGTOT = SIGIN+SIGEL
18420**
18421 IPROC = 1
18422 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18423 ENDIF
18424
18425 PPROJ(1) = ZERO
18426 PPROJ(2) = ZERO
18427 PPROJ(3) = PPN
18428 PPROJ(5) = AAM(IDPROJ)
18429 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18430 DO 1 K=1,5
18431 PNUC(K) = PHKK(K,IDXTAR)
18432 1 CONTINUE
18433
18434 ILOOP = 0
18435 2 CONTINUE
18436 ILOOP = ILOOP+1
18437 IF (ILOOP.GT.100) GOTO 9999
18438
18439 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18440 IF (IREJ1.EQ.1) GOTO 9999
18441
18442 IF (IREJ1.GT.1) THEN
18443* no interaction possible
18444* require Pauli blocking
18445 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18446 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18447 IF ((IIBAR(IDPROJ).NE.1).AND.
18448 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18449* store incoming particle as final state particle
18450 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18451 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18452 NPOINT(4) = NHKK
18453 ELSE
18454* require Pauli blocking for final state nucleons
18455 DO 4 I=1,NFSP
18456 IF ((IDFSP(I).EQ.1).AND.
18457 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18458 IF ((IDFSP(I).EQ.8).AND.
18459 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18460 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18461 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18462 4 CONTINUE
18463* store final state particles
18464 DO 5 I=1,NFSP
18465 IST = 1
18466 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18467 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18468 IDHAD = IDT_IPDGHA(IDFSP(I))
18469 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18470 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18471 & PCMS,ECMS,0,0,0)
18472 IF (I.EQ.1) NPOINT(4) = NHKK
18473 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18474 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18475 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18476 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18477 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18478 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18479 WHKK(3,NHKK) = WHKK(3,1)
18480 WHKK(4,NHKK) = WHKK(4,1)
18481 5 CONTINUE
18482 ENDIF
18483 TAUFOR = TAUSAV
18484 RETURN
18485
18486 9999 CONTINUE
18487 IREJ = 1
18488 TAUFOR = TAUSAV
18489 RETURN
18490 END
18491*$ CREATE DT_GETEMU.FOR
18492*COPY DT_GETEMU
18493*
18494*===getemu=============================================================*
18495*
18496 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18497
18498************************************************************************
18499* Sampling of emulsion component to be considered as target-nucleus. *
18500* This version dated 6.5.95 is written by S. Roesler. *
18501************************************************************************
18502
18503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18504 SAVE
18505
18506 PARAMETER ( LINP = 10 ,
18507 & LOUT = 6 ,
18508 & LDAT = 9 )
18509
18510 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18511
18512 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18513
18514* emulsion treatment
18515 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18516 & NCOMPO,IEMUL
18517
18518* Glauber formalism: flags and parameters for statistics
18519 LOGICAL LPROD
18520 CHARACTER*8 CGLB
18521 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18522
18523 IF (MODE.EQ.0) THEN
18524 SUMFRA = ZERO
18525 RR = DT_RNDM(SUMFRA)
18526 IT = 0
18527 ITZ = 0
18528 DO 1 ICOMP=1,NCOMPO
18529 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18530 IF (SUMFRA.GT.RR) THEN
18531 IT = IEMUMA(ICOMP)
18532 ITZ = IEMUCH(ICOMP)
18533 KKMAT = ICOMP
18534 GOTO 2
18535 ENDIF
18536 1 CONTINUE
18537 2 CONTINUE
18538 IF (IT.LE.0) THEN
18539 WRITE(LOUT,'(1X,A,E12.3)')
18540 & 'Warning! norm. failure within emulsion fractions',
18541 & SUMFRA
18542 STOP
18543 ENDIF
18544 ELSEIF (MODE.EQ.1) THEN
18545 NDIFF = 10000
18546 DO 3 I=1,NCOMPO
18547 IDIFF = ABS(IT-IEMUMA(I))
18548 IF (IDIFF.LT.NDIFF) THEN
18549 KKMAT = I
18550 NDIFF = IDIFF
18551 ENDIF
18552 3 CONTINUE
18553 ELSE
18554 STOP 'DT_GETEMU'
18555 ENDIF
18556
18557* bypass for variable projectile/target/energy runs: the correct
18558* Glauber data will be always loaded on kkmat=1
18559 IF (IOGLB.EQ.100) THEN
18560 KKMAT = 1
18561 ENDIF
18562
18563 RETURN
18564 END
18565
18566*$ CREATE DT_NCLPOT.FOR
18567*COPY DT_NCLPOT
18568*
18569*===nclpot=============================================================*
18570*
18571 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18572
18573************************************************************************
18574* Calculation of Coulomb and nuclear potential for a given configurat. *
18575* IPZ, IP charge/mass number of proj. *
18576* ITZ, IT charge/mass number of targ. *
18577* AFERP,AFERT factors modifying proj./target pot. *
18578* if =0, FERMOD is used *
18579* MODE = 0 calculation of binding energy *
18580* = 1 pre-calculated binding energy is used *
18581* This version dated 16.11.95 is written by S. Roesler. *
18582* *
18583* Last change 28.12.2006 by S. Roesler. *
18584************************************************************************
18585
18586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18587 SAVE
18588
18589 PARAMETER ( LINP = 10 ,
18590 & LOUT = 6 ,
18591 & LDAT = 9 )
18592
18593 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18594 & TINY10=1.0D-10)
18595
18596 LOGICAL LSTART
18597
18598* particle properties (BAMJET index convention)
18599 CHARACTER*8 ANAME
18600 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18601 & IICH(210),IIBAR(210),K1(210),K2(210)
18602
18603* nuclear potential
18604 LOGICAL LFERMI
18605 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18606 & EBINDP(2),EBINDN(2),EPOT(2,210),
18607 & ETACOU(2),ICOUL,LFERMI
18608
18609 DIMENSION IDXPOT(14)
18610* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18611 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18612* asig0 asig+ atet0 atet+
18613 & 100, 101, 102, 103/
18614
18615 DATA AN /0.4D0/
18616 DATA LSTART /.TRUE./
18617
18618 IF (MODE.EQ.0) THEN
18619 EBINDP(1) = ZERO
18620 EBINDN(1) = ZERO
18621 EBINDP(2) = ZERO
18622 EBINDN(2) = ZERO
18623 ENDIF
18624 AIP = DBLE(IP)
18625 AIPZ = DBLE(IPZ)
18626 AIT = DBLE(IT)
18627 AITZ = DBLE(ITZ)
18628
18629 FERMIP = AFERP
18630 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18631 FERMIT = AFERT
18632 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18633
18634* Fermi momenta and binding energy for projectile
18635 IF ((IP.GT.1).AND.LFERMI) THEN
18636 IF (MODE.EQ.0) THEN
18637C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18638C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18639 BIP = AIP -ONE
18640 BIPZ = AIPZ-ONE
18641
18642C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18643C & -ENERGY(AIP,AIPZ))
18644 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18645 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18646 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18647
18648 IF (AIP.LE.AIPZ) THEN
18649 EBINDN(1) = EBINDP(1)
18650 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18651 ELSE
18652
18653C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18654C & -ENERGY(AIP,AIPZ))
18655 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18656 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18657 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18658
18659 ENDIF
18660 ENDIF
18661 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18662 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18663 ELSE
18664 PFERMP(1) = ZERO
18665 PFERMN(1) = ZERO
18666 ENDIF
18667* effective nuclear potential for projectile
18668C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18669C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18670 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18671 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18672
18673* Fermi momenta and binding energy for target
18674 IF ((IT.GT.1).AND.LFERMI) THEN
18675 IF (MODE.EQ.0) THEN
18676C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18677C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18678 BIT = AIT -ONE
18679 BITZ = AITZ-ONE
18680
18681C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18682C & -ENERGY(AIT,AITZ))
18683 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18684 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18685 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18686
18687 IF (AIT.LE.AITZ) THEN
18688 EBINDN(2) = EBINDP(2)
18689 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18690 ELSE
18691
18692C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18693C & -ENERGY(AIT,AITZ))
18694 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18695 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18696 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18697
18698 ENDIF
18699 ENDIF
18700 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18701 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18702 ELSE
18703 PFERMP(2) = ZERO
18704 PFERMN(2) = ZERO
18705 ENDIF
18706* effective nuclear potential for target
18707C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18708C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18709 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18710 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18711
18712 DO 2 I=1,14
18713 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18714 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18715 2 CONTINUE
18716
18717* Coulomb energy
18718 ETACOU(1) = ZERO
18719 ETACOU(2) = ZERO
18720 IF (ICOUL.EQ.1) THEN
18721 IF (IP.GT.1)
18722 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18723 IF (IT.GT.1)
18724 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18725 ENDIF
18726
18727 IF (LSTART) THEN
18728 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18729 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18730 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18731 & FERMOD,ETACOU
18732 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18733 & ,' effects',/,12X,'---------------------------',
18734 & '----------------',/,/,38X,'projectile',
18735 & ' target',/,/,1X,'Mass number / charge',
18736 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18737 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18738 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18739 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18740 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18741 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18742 LSTART = .FALSE.
18743 ENDIF
18744
18745 RETURN
18746 END
18747
18748*$ CREATE DT_RESNCL.FOR
18749*COPY DT_RESNCL
18750*
18751*===resncl=============================================================*
18752*
18753 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18754
18755************************************************************************
18756* Treatment of residual nuclei and nuclear effects. *
18757* MODE = 1 initializations *
18758* = 2 treatment of final state *
18759* This version dated 16.11.95 is written by S. Roesler. *
18760* *
18761* Last change 05.01.2007 by S. Roesler. *
18762************************************************************************
18763
18764 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18765 SAVE
18766
18767 PARAMETER ( LINP = 10 ,
18768 & LOUT = 6 ,
18769 & LDAT = 9 )
18770
18771 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18772 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18773 & ONETHI=ONE/THREE)
18774 PARAMETER (AMUAMU = 0.93149432D0,
18775 & FM2MM = 1.0D-12,
18776 & RNUCLE = 1.12D0)
18777 PARAMETER ( EMVGEV = 1.0 D-03 )
18778 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18779 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18780 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18781 PARAMETER ( AMELCT = 0.51099906 D-03 )
18782 PARAMETER ( HLFHLF = 0.5D+00 )
18783 PARAMETER ( FERTHO = 14.33 D-09 )
18784 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18785 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18786 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18787
18788* event history
18789
18790 PARAMETER (NMXHKK=200000)
18791
18792 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18793 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18794 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18795
18796* extended event history
18797 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18798 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18799 & IHIST(2,NMXHKK)
18800
18801* particle properties (BAMJET index convention)
18802 CHARACTER*8 ANAME
18803 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18804 & IICH(210),IIBAR(210),K1(210),K2(210)
18805
18806* flags for input different options
18807 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18808 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18809 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18810
18811* nuclear potential
18812 LOGICAL LFERMI
18813 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18814 & EBINDP(2),EBINDN(2),EPOT(2,210),
18815 & ETACOU(2),ICOUL,LFERMI
18816
18817* properties of interacting particles
18818 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18819
18820* properties of photon/lepton projectiles
18821 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18822
18823* Lorentz-parameters of the current interaction
18824 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18825 & UMO,PPCM,EPROJ,PPROJ
18826
18827* treatment of residual nuclei: wounded nucleons
18828 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18829
18830* treatment of residual nuclei: 4-momenta
18831 LOGICAL LRCLPR,LRCLTA
18832 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18833 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18834
18835 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18836 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18837 & IDXCOR(15000),IDXOTH(NMXHKK)
18838
18839 GOTO (1,2) MODE
18840
18841*------- initializations
18842 1 CONTINUE
18843
18844* initialize arrays for residual nuclei
18845 DO 10 K=1,5
18846 IF (K.LE.4) THEN
18847 PFSP(K) = ZERO
18848 ENDIF
18849 PINIPR(K) = ZERO
18850 PINITA(K) = ZERO
18851 PRCLPR(K) = ZERO
18852 PRCLTA(K) = ZERO
18853 TRCLPR(K) = ZERO
18854 TRCLTA(K) = ZERO
18855 10 CONTINUE
18856 SCPOT = ONE
18857 NLOOP = 0
18858
18859* correction of projectile 4-momentum for effective target pot.
18860* and Coulomb-energy (in case of hadron-nucleus interaction only)
1a043008
AM		 18861* IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18862* EPNI = EPN
7b076c76 18863* Coulomb-energy:
18864* positively charged hadron - check energy for Coloumb pot.
1a043008
AM		 18865* IF (IICH(IJPROJ).EQ.1) THEN
18866* THRESH = ETACOU(2)+AAM(IJPROJ)
18867* IF (EPNI.LE.THRESH) THEN
18868* WRITE(LOUT,1000)
18869* 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18870* & ' below Coulomb threshold - event rejected',/)
18871* ISTHKK(1) = 1
18872* RETURN
18873* ENDIF
7b076c76 18874* negatively charged hadron - increase energy by Coulomb energy
1a043008
AM		 18875* ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18876* EPNI = EPNI+ETACOU(2)
18877* ENDIF
18878* IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
7b076c76 18879* Effective target potential
18880*sr 6.6. binding energy only (to avoid negative exc. energies)
18881C EPNI = EPNI+EPOT(2,IJPROJ)
1a043008
AM		 18882* EBIPOT = EBINDP(2)
18883* IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18884* & EBIPOT = EBINDN(2)
18885* EPNI = EPNI+ABS(EBIPOT)
7b076c76 18886* re-initialization of DTLTRA
1a043008
AM		 18887* DUM1 = ZERO
18888* DUM2 = ZERO
18889* CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18890* ENDIF
18891* ENDIF
7b076c76 18892
18893* projectile in n-n cms
18894 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18895 PMASS1 = AAM(IJPROJ)
18896C* VDM assumption
18897C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18898 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18899 PMASS2 = AAM(1)
18900 PM1 = SIGN(PMASS1**2,PMASS1)
18901 PM2 = SIGN(PMASS2**2,PMASS2)
18902 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18903 PINIPR(5) = PMASS1
18904 IF (PMASS1.GT.ZERO) THEN
18905 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18906 & *(PINIPR(4)+PINIPR(5)))
18907 ELSE
18908 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18909 ENDIF
18910 AIT = DBLE(IT)
18911 AITZ = DBLE(ITZ)
18912
18913C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18914 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18915
18916 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18917 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18918 PMASS1 = AAM(1)
18919 PMASS2 = AAM(IJTARG)
18920 PM1 = SIGN(PMASS1**2,PMASS1)
18921 PM2 = SIGN(PMASS2**2,PMASS2)
18922 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18923 PINITA(5) = PMASS2
18924 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18925 & *(PINITA(4)+PINITA(5)))
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 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18934 AIP = DBLE(IP)
18935 AIPZ = DBLE(IPZ)
18936
18937C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18938 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18939
18940 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18941 AIT = DBLE(IT)
18942 AITZ = DBLE(ITZ)
18943
18944C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18945 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18946
18947 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18948 ENDIF
18949
18950 RETURN
18951
18952*------- treatment of final state
18953 2 CONTINUE
18954
18955 NLOOP = NLOOP+1
18956 IF (NLOOP.GT.1) SCPOT = 0.10D0
18957C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18958
18959 JPW = NPW
18960 JPCW = NPCW
18961 JTW = NTW
18962 JTCW = NTCW
18963 DO 40 K=1,4
18964 PFSP(K) = ZERO
18965 40 CONTINUE
18966
18967 NOB = 0
18968 NOM = 0
18969 DO 900 I=NPOINT(4),NHKK
18970 IDXOTH(I) = -1
18971 IF (ISTHKK(I).EQ.1) THEN
18972 IF (IDBAM(I).EQ.7) GOTO 900
18973 IPOT = 0
18974 IOTHER = 0
18975* particle moving into forward direction
18976 IF (PHKK(3,I).GE.ZERO) THEN
18977* most likely to be effected by projectile potential
18978 IPOT = 1
18979* there is no projectile nucleus, try target
18980 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18981 IPOT = 2
18982 IF (IP.GT.1) IOTHER = 1
18983* there is no target nucleus --> skip
18984 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18985 ENDIF
18986* particle moving into backward direction
18987 ELSE
18988* most likely to be effected by target potential
18989 IPOT = 2
18990* there is no target nucleus, try projectile
18991 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18992 IPOT = 1
18993 IF (IT.GT.1) IOTHER = 1
18994* there is no projectile nucleus --> skip
18995 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18996 ENDIF
18997 ENDIF
18998 IFLG = -IPOT
18999* nobam=3: particle is in overlap-region or neither inside proj. nor target
19000* =1: particle is not in overlap-region AND is inside target (2)
19001* =2: particle is not in overlap-region AND is inside projectile (1)
19002* flag particles which are inside the nucleus ipot but not in its
19003* overlap region
19004 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19005 IF (IDBAM(I).NE.0) THEN
19006* baryons: keep all nucleons and all others where flag is set
19007 IF (IIBAR(IDBAM(I)).NE.0) THEN
19008 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19009 & THEN
19010 NOB = NOB+1
19011 PMOMB(NOB) = PHKK(3,I)
19012 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
19013 & +1000000*IOTHER+I,IFLG)
19014 ENDIF
19015* mesons: keep only those mesons where flag is set
19016 ELSE
19017 IF (IFLG.GT.0) THEN
19018 NOM = NOM+1
19019 PMOMM(NOM) = PHKK(3,I)
19020 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19021 ENDIF
19022 ENDIF
19023 ENDIF
19024 ENDIF
19025 900 CONTINUE
19026*
19027* sort particles in the arrays according to increasing long. momentum
19028 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19029 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19030*
19031* shuffle indices into one and the same array according to the later
19032* sequence of correction
19033 NCOR = 0
19034 IF (IT.GT.1) THEN
19035 DO 910 I=1,NOB
19036 IF (PMOMB(I).GT.ZERO) GOTO 911
19037 NCOR = NCOR+1
19038 IDXCOR(NCOR) = IDXB(I)
19039 910 CONTINUE
19040 911 CONTINUE
19041 IF (IP.GT.1) THEN
19042 DO 912 J=1,NOB
19043 I = NOB+1-J
19044 IF (PMOMB(I).LT.ZERO) GOTO 913
19045 NCOR = NCOR+1
19046 IDXCOR(NCOR) = IDXB(I)
19047 912 CONTINUE
19048 913 CONTINUE
19049 ELSE
19050 DO 914 I=1,NOB
19051 IF (PMOMB(I).GT.ZERO) THEN
19052 NCOR = NCOR+1
19053 IDXCOR(NCOR) = IDXB(I)
19054 ENDIF
19055 914 CONTINUE
19056 ENDIF
19057 ELSE
19058 DO 915 J=1,NOB
19059 I = NOB+1-J
19060 NCOR = NCOR+1
19061 IDXCOR(NCOR) = IDXB(I)
19062 915 CONTINUE
19063 ENDIF
19064 DO 925 I=1,NOM
19065 IF (PMOMM(I).GT.ZERO) GOTO 926
19066 NCOR = NCOR+1
19067 IDXCOR(NCOR) = IDXM(I)
19068 925 CONTINUE
19069 926 CONTINUE
19070 DO 927 J=1,NOM
19071 I = NOM+1-J
19072 IF (PMOMM(I).LT.ZERO) GOTO 928
19073 NCOR = NCOR+1
19074 IDXCOR(NCOR) = IDXM(I)
19075 927 CONTINUE
19076 928 CONTINUE
19077*
19078C IF (NEVHKK.EQ.484) THEN
19079C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19080C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19081C WRITE(LOUT,9001) NOB,NOM,NCOR
19082C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19083C WRITE(LOUT,'(/,A)') ' baryons '
19084C DO 950 I=1,NOB
19085CC J = IABS(IDXB(I))
19086CC INDEX = J-IABS(J/10000000)*10000000
19087C IPOT = IABS(IDXB(I))/10000000
19088C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19089C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19090C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19091C 950 CONTINUE
19092C WRITE(LOUT,'(/,A)') ' mesons '
19093C DO 951 I=1,NOM
19094CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19095C IPOT = IABS(IDXM(I))/10000000
19096C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19097C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19098C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19099C 951 CONTINUE
19100C 9002 FORMAT(1X,4I14,E14.5)
19101C WRITE(LOUT,'(/,A)') ' all '
19102C DO 952 I=1,NCOR
19103CC J = IABS(IDXCOR(I))
19104CC INDEX = J-IABS(J/10000000)*10000000
19105CC IPOT = IABS(IDXCOR(I))/10000000
19106C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19107C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19108C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19109C 952 CONTINUE
19110C 9003 FORMAT(1X,4I14)
19111C ENDIF
19112*
19113 DO 20 ICOR=1,NCOR
19114 IPOT = IABS(IDXCOR(ICOR))/10000000
19115 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19116 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19117 IDXOTH(I) = 1
19118
19119 IDSEC = IDBAM(I)
19120
19121* reduction of particle momentum by corresponding nuclear potential
19122* (this applies only if Fermi-momenta are requested)
19123
19124 IF (LFERMI) THEN
19125
19126* Lorentz-transformation into the rest system of the selected nucleus
19127 IMODE = -IPOT-1
19128 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19129 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19130 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19131 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19132 JPMOD = 0
19133
19134 CHKLEV = TINY3
19135 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19136 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19137 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19138 IF (IOULEV(3).GT.0)
19139 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19140 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19141 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19142 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19143 GOTO 23
19144 ENDIF
19145
19146 DO 21 K=1,4
19147 PSEC0(K) = PSEC(K)
19148 21 CONTINUE
19149
19150* the correction for nuclear potential effects is applied to as many
19151* p/n as many nucleons were wounded; the momenta of other final state
19152* particles are corrected only if they materialize inside the corresp.
19153* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19154* = 3 part. outside proj. and targ., >=10 in overlapping region)
19155 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19156 IF (IPOT.EQ.1) THEN
19157 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19158* this is most likely a wounded nucleon
19159**test
19160C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19161C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19162C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19163C RAD = RNUCLE*DBLE(IP)**ONETHI
19164C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19165C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19166**
19167 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19168 JPW = JPW-1
19169 JPMOD = 1
19170 ELSE
19171* correct only if part. was materialized inside nucleus
19172* and if it is ouside the overlapping region
19173 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19174 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19175 JPMOD = 1
19176 ENDIF
19177 ENDIF
19178 ELSEIF (IPOT.EQ.2) THEN
19179 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19180* this is most likely a wounded nucleon
19181**test
19182C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19183C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19184C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19185C RAD = RNUCLE*DBLE(IT)**ONETHI
19186C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19187C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19188**
19189 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19190 JTW = JTW-1
19191 JPMOD = 1
19192 ELSE
19193* correct only if part. was materialized inside nucleus
19194 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19195 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19196 JPMOD = 1
19197 ENDIF
19198 ENDIF
19199 ENDIF
19200 ELSE
19201 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19202 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19203 JPMOD = 1
19204 ENDIF
19205 ENDIF
19206
19207 IF (NLOOP.EQ.1) THEN
19208* Coulomb energy correction:
19209* the treatment of Coulomb potential correction is similar to the
19210* one for nuclear potential
19211 IF (IDSEC.EQ.1) THEN
19212 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19213 JPCW = JPCW-1
19214 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19215 JTCW = JTCW-1
19216 ELSE
19217 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19218 ENDIF
19219 ELSE
19220 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19221 ENDIF
19222 IF (IICH(IDSEC).EQ.1) THEN
19223* pos. particles: check if they are able to escape Coulomb potential
19224 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19225 ISTHKK(I) = 14+IPOT
19226 IF (ISTHKK(I).EQ.15) THEN
19227 DO 26 K=1,4
19228 PHKK(K,I) = PSEC0(K)
19229 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19230 26 CONTINUE
19231 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19232 IF (IDSEC.EQ.1) NPCW = NPCW-1
19233 ELSEIF (ISTHKK(I).EQ.16) THEN
19234 DO 27 K=1,4
19235 PHKK(K,I) = PSEC0(K)
19236 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19237 27 CONTINUE
19238 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19239 IF (IDSEC.EQ.1) NTCW = NTCW-1
19240 ENDIF
19241 GOTO 20
19242 ENDIF
19243 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19244* neg. particles: decrease energy by Coulomb-potential
19245 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19246 JPMOD = 1
19247 ENDIF
19248 ENDIF
19249
19250 25 CONTINUE
19251
19252 IF (PSEC(4).LT.AMSEC) THEN
19253 IF (IOULEV(6).GT.0)
19254 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19255 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19256 & ' is not allowed to escape nucleus',/,
19257 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19258 & ' mass: ',E12.3)
19259 ISTHKK(I) = 14+IPOT
19260 IF (ISTHKK(I).EQ.15) THEN
19261 DO 28 K=1,4
19262 PHKK(K,I) = PSEC0(K)
19263 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19264 28 CONTINUE
19265 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19266 IF (IDSEC.EQ.1) NPCW = NPCW-1
19267 ELSEIF (ISTHKK(I).EQ.16) THEN
19268 DO 29 K=1,4
19269 PHKK(K,I) = PSEC0(K)
19270 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19271 29 CONTINUE
19272 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19273 IF (IDSEC.EQ.1) NTCW = NTCW-1
19274 ENDIF
19275 GOTO 20
19276 ENDIF
19277
19278 IF (JPMOD.EQ.1) THEN
19279 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19280* 4-momentum after correction for nuclear potential
19281 DO 22 K=1,3
19282 PSEC(K) = PSEC(K)*PSECN/PSECO
19283 22 CONTINUE
19284
19285* store recoil momentum from particles escaping the nuclear potentials
19286 DO 30 K=1,4
19287 IF (IPOT.EQ.1) THEN
19288 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19289 ELSEIF (IPOT.EQ.2) THEN
19290 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19291 ENDIF
19292 30 CONTINUE
19293
19294* transform momentum back into n-n cms
19295 IMODE = IPOT+1
19296 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19297 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19298 & IDSEC,IMODE)
19299 ENDIF
19300
19301 ENDIF
19302
19303 23 CONTINUE
19304 DO 31 K=1,4
19305 PFSP(K) = PFSP(K)+PHKK(K,I)
19306 31 CONTINUE
19307
19308 20 CONTINUE
19309
19310 DO 33 I=NPOINT(4),NHKK
19311 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19312 PFSP(1) = PFSP(1)+PHKK(1,I)
19313 PFSP(2) = PFSP(2)+PHKK(2,I)
19314 PFSP(3) = PFSP(3)+PHKK(3,I)
19315 PFSP(4) = PFSP(4)+PHKK(4,I)
19316 ENDIF
19317 33 CONTINUE
19318
19319 DO 34 K=1,5
19320 PRCLPR(K) = TRCLPR(K)
19321 PRCLTA(K) = TRCLTA(K)
19322 34 CONTINUE
19323
19324 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19325* hadron-nucleus interactions: get residual momentum from energy-
19326* momentum conservation
19327 DO 32 K=1,4
19328 PRCLPR(K) = ZERO
19329 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19330 32 CONTINUE
19331 ELSE
19332* nucleus-hadron, nucleus-nucleus: get residual momentum from
19333* accumulated recoil momenta of particles leaving the spectators
19334* transform accumulated recoil momenta of residual nuclei into
19335* n-n cms
19336 PZI = PRCLPR(3)
19337 PEI = PRCLPR(4)
19338 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19339 PZI = PRCLTA(3)
19340 PEI = PRCLTA(4)
19341 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19342C IF (IP.GT.1) THEN
19343 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19344 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19345C ENDIF
19346 IF (IT.GT.1) THEN
19347 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19348 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19349 ENDIF
19350 ENDIF
19351
19352* check momenta of residual nuclei
19353 IF (LEMCCK) THEN
19354 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19355 & 1,IDUM,IDUM)
19356 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19357 & 2,IDUM,IDUM)
19358 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19359 & 2,IDUM,IDUM)
19360 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19361 & 2,IDUM,IDUM)
19362 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19363**sr 19.12. changed to avoid output when used with phojet
19364C CHKLEV = TINY3
19365 CHKLEV = TINY1
19366 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19367C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19368C & CALL DT_EVTOUT(4)
19369 IF (IREJ1.GT.0) RETURN
19370 ENDIF
19371
19372 RETURN
19373 END
19374
19375*$ CREATE DT_SCN4BA.FOR
19376*COPY DT_SCN4BA
19377*
19378*===scn4ba=============================================================*
19379*
19380 SUBROUTINE DT_SCN4BA
19381
19382************************************************************************
19383* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19384* This version dated 12.12.95 is written by S. Roesler. *
19385************************************************************************
19386
19387 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19388 SAVE
19389
19390 PARAMETER ( LINP = 10 ,
19391 & LOUT = 6 ,
19392 & LDAT = 9 )
19393
19394 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19395 & TINY10=1.0D-10)
19396
19397* event history
19398
19399 PARAMETER (NMXHKK=200000)
19400
19401 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19402 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19403 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19404
19405* extended event history
19406 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19407 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19408 & IHIST(2,NMXHKK)
19409
19410* particle properties (BAMJET index convention)
19411 CHARACTER*8 ANAME
19412 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19413 & IICH(210),IIBAR(210),K1(210),K2(210)
19414
19415* properties of interacting particles
19416 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19417
19418* nuclear potential
19419 LOGICAL LFERMI
19420 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19421 & EBINDP(2),EBINDN(2),EPOT(2,210),
19422 & ETACOU(2),ICOUL,LFERMI
19423
19424* treatment of residual nuclei: wounded nucleons
19425 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19426
19427* treatment of residual nuclei: 4-momenta
19428 LOGICAL LRCLPR,LRCLTA
19429 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19430 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19431
19432 DIMENSION PLAB(2,5),PCMS(4)
19433
19434 IREJ = 0
19435
19436* get number of wounded nucleons
19437 NPW = 0
19438 NPW0 = 0
19439 NPCW = 0
19440 NPSTCK = 0
19441 NTW = 0
19442 NTW0 = 0
19443 NTCW = 0
19444 NTSTCK = 0
19445
19446 ISGLPR = 0
19447 ISGLTA = 0
19448 LRCLPR = .FALSE.
19449 LRCLTA = .FALSE.
19450
19451C DO 2 I=1,NHKK
19452 DO 2 I=1,NPOINT(1)
19453* projectile nucleons wounded in primary interaction and in fzc
19454 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19455 NPW = NPW+1
19456 IPW(NPW) = I
19457 NPSTCK = NPSTCK+1
19458 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19459 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19460C IF (IP.GT.1) THEN
19461 DO 5 K=1,4
19462 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19463 5 CONTINUE
19464C ENDIF
19465* target nucleons wounded in primary interaction and in fzc
19466 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19467 NTW = NTW+1
19468 ITW(NTW) = I
19469 NTSTCK = NTSTCK+1
19470 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19471 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19472 IF (IT.GT.1) THEN
19473 DO 6 K=1,4
19474 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19475 6 CONTINUE
19476 ENDIF
19477 ELSEIF (ISTHKK(I).EQ.13) THEN
19478 ISGLPR = I
19479 ELSEIF (ISTHKK(I).EQ.14) THEN
19480 ISGLTA = I
19481 ENDIF
19482 2 CONTINUE
19483
19484 DO 11 I=NPOINT(4),NHKK
19485* baryons which are unable to escape the nuclear potential of proj.
19486 IF (ISTHKK(I).EQ.15) THEN
19487 ISGLPR = I
19488 NPSTCK = NPSTCK-1
19489 IF (IIBAR(IDBAM(I)).NE.0) THEN
19490 NPW = NPW-1
19491 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19492 ENDIF
19493 DO 7 K=1,4
19494 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19495 7 CONTINUE
19496* baryons which are unable to escape the nuclear potential of targ.
19497 ELSEIF (ISTHKK(I).EQ.16) THEN
19498 ISGLTA = I
19499 NTSTCK = NTSTCK-1
19500 IF (IIBAR(IDBAM(I)).NE.0) THEN
19501 NTW = NTW-1
19502 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19503 ENDIF
19504 DO 8 K=1,4
19505 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19506 8 CONTINUE
19507 ENDIF
19508 11 CONTINUE
19509
19510* residual nuclei so far
19511 IRESP = IP-NPSTCK
19512 IREST = IT-NTSTCK
19513
19514* ckeck for "residual nuclei" consisting of one nucleon only
19515* treat it as final state particle
19516 IF (IRESP.EQ.1) THEN
19517 ID = IDBAM(ISGLPR)
19518 IST = ISTHKK(ISGLPR)
19519 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19520 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19521 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19522 IF (IST.EQ.13) THEN
19523 ISTHKK(ISGLPR) = 11
19524 ELSE
19525 ISTHKK(ISGLPR) = 2
19526 ENDIF
19527 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19528 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19529 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19530 NOBAM(NHKK) = NOBAM(ISGLPR)
19531 JDAHKK(1,ISGLPR) = NHKK
19532 DO 21 K=1,4
19533 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19534 21 CONTINUE
19535 ENDIF
19536 IF (IREST.EQ.1) THEN
19537 ID = IDBAM(ISGLTA)
19538 IST = ISTHKK(ISGLTA)
19539 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19540 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19541 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19542 IF (IST.EQ.14) THEN
19543 ISTHKK(ISGLTA) = 12
19544 ELSE
19545 ISTHKK(ISGLTA) = 2
19546 ENDIF
19547 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19548 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19549 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19550 NOBAM(NHKK) = NOBAM(ISGLTA)
19551 JDAHKK(1,ISGLTA) = NHKK
19552 DO 22 K=1,4
19553 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19554 22 CONTINUE
19555 ENDIF
19556
19557* get nuclear potential corresp. to the residual nucleus
19558 IPRCL = IP -NPW
19559 IPZRCL = IPZ-NPCW
19560 ITRCL = IT -NTW
19561 ITZRCL = ITZ-NTCW
19562 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19563
19564* baryons unable to escape the nuclear potential are treated as
19565* excited nucleons (ISTHKK=15,16)
19566 DO 3 I=NPOINT(4),NHKK
19567 IF (ISTHKK(I).EQ.1) THEN
19568 ID = IDBAM(I)
19569 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19570* final state n and p not being outside of both nuclei are considered
19571 NPOTP = 1
19572 NPOTT = 1
19573 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19574 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19575* Lorentz-trsf. into proj. rest sys. for those being inside proj.
19576 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19577 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19578 & PLAB(1,4),ID,-2)
19579 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19580 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19581 & (PLAB(1,4)+PLABT) ))
19582 EKIN = PLAB(1,4)-PLAB(1,5)
19583 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19584 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19585 ENDIF
19586 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19587 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19588* Lorentz-trsf. into targ. rest sys. for those being inside targ.
19589 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19590 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19591 & PLAB(2,4),ID,-3)
19592 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19593 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19594 & (PLAB(2,4)+PLABT) ))
19595 EKIN = PLAB(2,4)-PLAB(2,5)
19596 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19597 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19598 ENDIF
19599 IF (PHKK(3,I).GE.ZERO) THEN
19600 ISTHKK(I) = NPOTT
19601 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19602 ELSE
19603 ISTHKK(I) = NPOTP
19604 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19605 ENDIF
19606 IF (ISTHKK(I).NE.1) THEN
19607 J = ISTHKK(I)-14
19608 DO 4 K=1,5
19609 PHKK(K,I) = PLAB(J,K)
19610 4 CONTINUE
19611 IF (ISTHKK(I).EQ.15) THEN
19612 NPW = NPW-1
19613 IF (ID.EQ.1) NPCW = NPCW-1
19614 DO 9 K=1,4
19615 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19616 9 CONTINUE
19617 ELSEIF (ISTHKK(I).EQ.16) THEN
19618 NTW = NTW-1
19619 IF (ID.EQ.1) NTCW = NTCW-1
19620 DO 10 K=1,4
19621 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19622 10 CONTINUE
19623 ENDIF
19624 ENDIF
19625 ENDIF
19626 ENDIF
19627 3 CONTINUE
19628
19629* again: get nuclear potential corresp. to the residual nucleus
19630 IPRCL = IP -NPW
19631 IPZRCL = IPZ-NPCW
19632 ITRCL = IT -NTW
19633 ITZRCL = ITZ-NTCW
19634c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19635cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19636c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19637C AFERP = 0.0D0
19638c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19639cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19640c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19641C AFERT = 0.0D0
19642C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19643C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19644C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19645C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19646 AFERP = FERMOD+0.1D0
19647 AFERT = FERMOD+0.1D0
19648
19649 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19650
19651 RETURN
19652 END
19653
19654*$ CREATE DT_FICONF.FOR
19655*COPY DT_FICONF
19656*
19657*===ficonf=============================================================*
19658*
19659 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19660
19661************************************************************************
19662* Treatment of FInal CONFiguration including evaporation, fission and *
19663* Fermi-break-up (for light nuclei only). *
19664* Adopted from the original routine FINALE and extended to residual *
19665* projectile nuclei. *
19666* This version dated 12.12.95 is written by S. Roesler. *
19667* *
19668* Last change 27.12.2006 by S. Roesler. *
19669************************************************************************
19670
19671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19672 SAVE
19673
19674 PARAMETER ( LINP = 10 ,
19675 & LOUT = 6 ,
19676 & LDAT = 9 )
19677
19678 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19679 PARAMETER (ANGLGB=5.0D-16)
19680
19681* event history
19682
19683 PARAMETER (NMXHKK=200000)
19684
19685 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19686 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19687 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19688
19689* extended event history
19690 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19691 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19692 & IHIST(2,NMXHKK)
19693
19694* rejection counter
19695 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19696 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19697 & IREXCI(3),IRDIFF(2),IRINC
19698
19699* central particle production, impact parameter biasing
19700 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19701
19702* particle properties (BAMJET index convention)
19703 CHARACTER*8 ANAME
19704 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19705 & IICH(210),IIBAR(210),K1(210),K2(210)
19706
19707* treatment of residual nuclei: 4-momenta
19708 LOGICAL LRCLPR,LRCLTA
19709 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19710 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19711
19712* treatment of residual nuclei: properties of residual nuclei
19713 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19714 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19715 & NTOTFI(2),NPROFI(2)
19716
19717* statistics: residual nuclei
19718 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19719 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19720 & NINCST(2,4),NINCEV(2),
19721 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19722 & NRESPB(2),NRESCH(2),NRESEV(4),
19723 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19724 & NEVAFI(2,2)
19725
19726* flags for input different options
19727 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19728 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19729 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19730
19731* INCLUDE '(DIMPAR)'
19732* DIMPAR taken from FLUKA
19733 PARAMETER ( MXXRGN =20000 )
19734 PARAMETER ( MXXMDF = 710 )
19735 PARAMETER ( MXXMDE = 702 )
19736 PARAMETER ( MFSTCK =40000 )
19737 PARAMETER ( MESTCK = 100 )
19738 PARAMETER ( MOSTCK = 2000 )
19739 PARAMETER ( MXPRSN = 100 )
19740 PARAMETER ( MXPDPM = 800 )
19741 PARAMETER ( MXPSCS =30000 )
19742 PARAMETER ( MXGLWN = 300 )
19743 PARAMETER ( MXOUTU = 50 )
19744 PARAMETER ( NALLWP = 64 )
19745 PARAMETER ( NELEMX = 80 )
19746 PARAMETER ( MPDPDX = 18 )
19747 PARAMETER ( MXHTTR = 260 )
19748 PARAMETER ( MXSEAX = 20 )
19749 PARAMETER ( MXHTNC = MXSEAX + 1 )
19750 PARAMETER ( ICOMAX = 2400 )
19751 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19752 PARAMETER ( NSTBIS = 304 )
19753 PARAMETER ( NQSTIS = 46 )
19754 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19755 PARAMETER ( MXPABL = 120 )
19756 PARAMETER ( IDMAXP = 450 )
19757 PARAMETER ( IDMXDC = 2000 )
19758 PARAMETER ( MXMCIN = 410 )
19759 PARAMETER ( IHYPMX = 4 )
19760 PARAMETER ( MKBMX1 = 11 )
19761 PARAMETER ( MKBMX2 = 11 )
19762 PARAMETER ( MXIRRD = 2500 )
19763 PARAMETER ( MXTRDC = 1500 )
19764 PARAMETER ( NKTL = 17 )
19765 PARAMETER ( NBLNMX = 40000000 )
19766
19767* INCLUDE '(GENSTK)'
19768* GENSTK taken from FLUKA
19769 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19770 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19771 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19772 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19773 & TVRECL, TVHEAV, TVBIND,
19774 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19775
19776* INCLUDE '(RESNUC)'
19777* RESNUC from FLUKA
19778 LOGICAL LRNFSS, LFRAGM
19779 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19780 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19781 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19782 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19783 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19784 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19785 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19786 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19787 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19788 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19789 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19790 & LRNFSS, LFRAGM
19791
19792 PARAMETER ( EMVGEV = 1.0 D-03 )
19793 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19794 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19795 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19796 PARAMETER ( AMELCT = 0.51099906 D-03 )
19797 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19798 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19799 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19800 & * 1.D-09 )
19801 PARAMETER ( HLFHLF = 0.5D+00 )
19802 PARAMETER ( FERTHO = 14.33 D-09 )
19803 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19804 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19805 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19806
19807* INCLUDE '(NUCDAT)'
19808* Taken from FLUKA
19809 PARAMETER ( AMUAMU = AMUGEV )
19810 PARAMETER ( AMPROT = AMPRTN )
19811 PARAMETER ( AMNEUT = AMNTRN )
19812 PARAMETER ( AMELEC = AMELCT )
19813 PARAMETER ( R0NUCL = 1.12 D+00 )
19814 PARAMETER ( RCCOUL = 1.7 D+00 )
19815 PARAMETER ( COULPR = COUGFM )
19816 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19817 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19818 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19819 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19820 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19821* Gammin : threshold for deexcitation gammas production, set to 1 keV
19822* (this means that up to 1 keV of energy unbalancing can occur
19823* during an event)
19824 PARAMETER ( GAMMIN = 1.0D-06 )
19825 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19826* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19827 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19828*
19829 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19830 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19831 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19832 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19833 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19834 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19835 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19836 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19837 & ELBNDE (0:110)
19838
19839* INCLUDE '(PAREVT)'
19840* Taken from FLUKA
19841 PARAMETER ( FRDIFF = 0.2D+00 )
19842 PARAMETER ( ETHSEA = 1.0D+00 )
19843*
19844 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19845 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19846 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19847 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19848 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19849 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19850 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19851 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19852 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19853 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19854
19855* INCLUDE '(FHEAVY)'
19856* Taken from FLUKA
19857 PARAMETER ( MXHEAV = 100 )
19858 PARAMETER ( KXHEAV = 30 )
19859 CHARACTER*8 ANHEAV
19860 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19861 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19862 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19863 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19864 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19865 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19866 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19867 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19868 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19869 COMMON / FHEAVC / ANHEAV (KXHEAV)
19870
19871* event flag
19872 COMMON /DTEVNO/ NEVENT,ICASCA
19873
19874 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19875 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19876 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19877
19878 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19879 LOGICAL LLCPOT
19880 DATA EXC,NEXC /520*ZERO,520*0/
19881 DATA EXPNUC /4.0D-3,4.0D-3/
19882
19883 IREJ = 0
19884 LRCLPR = .FALSE.
19885 LRCLTA = .FALSE.
19886
19887* skip residual nucleus treatment if not requested or in case
19888* of central collisions
19889 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19890
19891 DO 1 K=1,2
19892 IDPAR(K) = 0
19893 IDXPAR(K)= 0
19894 NTOT(K) = 0
19895 NTOTFI(K)= 0
19896 NPRO(K) = 0
19897 NPROFI(K)= 0
19898 NN(K) = 0
19899 NH(K) = 0
19900 NHPOS(K) = 0
19901 NQ(K) = 0
19902 EEXC(K) = ZERO
19903 MO1(K) = 0
19904 MO2(K) = 0
19905 DO 2 I=1,4
19906 VRCL(K,I) = ZERO
19907 WRCL(K,I) = ZERO
19908 2 CONTINUE
19909 1 CONTINUE
19910 NFSP = 0
19911 INUC(1) = IP
19912 INUC(2) = IT
19913
19914 DO 3 I=1,NHKK
19915
19916* number of final state particles
19917 IF (ABS(ISTHKK(I)).EQ.1) THEN
19918 NFSP = NFSP+1
19919 IDFSP = IDBAM(I)
19920 ENDIF
19921
19922* properties of remaining nucleon configurations
19923 KF = 0
19924 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19925 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19926 IF (KF.GT.0) THEN
19927 IF (MO1(KF).EQ.0) MO1(KF) = I
19928 MO2(KF) = I
19929* position of residual nucleus = average position of nucleons
19930 DO 4 K=1,4
19931 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19932 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19933 4 CONTINUE
19934* total number of particles contributing to each residual nucleus
19935 NTOT(KF) = NTOT(KF)+1
19936 IDTMP = IDBAM(I)
19937 IDXTMP = I
19938* total charge of residual nuclei
19939 NQ(KF) = NQ(KF)+IICH(IDTMP)
19940* number of protons
19941 IF (IDHKK(I).EQ.2212) THEN
19942 NPRO(KF) = NPRO(KF)+1
19943* number of neutrons
19944 ELSEIF (IDHKK(I).EQ.2112) THEN
19945 NN(KF) = NN(KF)+1
19946 ELSE
19947* number of baryons other than n, p
19948 IF (IIBAR(IDTMP).EQ.1) THEN
19949 NH(KF) = NH(KF)+1
19950 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19951 ELSE
19952* any other mesons (status set to 1)
19953C WRITE(LOUT,1002) KF,IDTMP
19954C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19955C & ' containing meson ',I4,', status set to 1')
19956 ISTHKK(I) = 1
19957 IDTMP = IDPAR(KF)
19958 IDXTMP = IDXPAR(KF)
19959 NTOT(KF) = NTOT(KF)-1
19960 ENDIF
19961 ENDIF
19962 IDPAR(KF) = IDTMP
19963 IDXPAR(KF) = IDXTMP
19964 ENDIF
19965 3 CONTINUE
19966
19967* reject elastic events (def: one final state particle = projectile)
19968 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19969 IREXCI(3) = IREXCI(3)+1
19970 GOTO 9999
19971C RETURN
19972 ENDIF
19973
19974* check if one nucleus disappeared..
19975C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19976C DO 5 K=1,4
19977C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19978C PRCLPR(K) = ZERO
19979C 5 CONTINUE
19980C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19981C DO 6 K=1,4
19982C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19983C PRCLTA(K) = ZERO
19984C 6 CONTINUE
19985C ENDIF
19986
19987 ICOR = 0
19988 INORCL = 0
19989 DO 7 I=1,2
19990 DO 8 K=1,4
19991* get the average of the nucleon positions
19992 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19993 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19994 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19995 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19996 8 CONTINUE
19997* mass number and charge of residual nuclei
19998 AIF(I) = DBLE(NTOT(I))
19999 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
20000 IF (NTOT(I).GT.1) THEN
20001* masses of residual nuclei in ground state
20002
20003C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20004 AMRCL0(I) = AIF(I)*AMUC12
20005 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20006
20007* masses of residual nuclei
20008 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20009 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20010 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20011*
20012* M_res^2 < 0 : configuration not allowed
20013*
20014* a) re-calculate E_exc with scaled nuclear potential
20015* (conditional jump to label 9998)
20016* b) or reject event if N_loop(max) is exceeded
20017* (conditional jump to label 9999)
20018*
20019 IF (AMRCL(I).LE.ZERO) THEN
20020 IF (IOULEV(3).GT.0)
20021 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20022 & PRCL(I,4),NTOT
20023 1000 FORMAT(1X,'warning! negative excitation energy',/,
20024 & I4,4E15.4,2I4)
20025 AMRCL(I) = ZERO
20026 EEXC(I) = ZERO
20027 IF (NLOOP.LE.500) THEN
20028 GOTO 9998
20029 ELSE
20030 IREXCI(2) = IREXCI(2)+1
20031 GOTO 9999
20032 ENDIF
20033*
20034* 0 < M_res < M_res0 : mass below ground-state mass
20035*
20036* a) we had residual nuclei with mass N_tot and reasonable E_exc
20037* before- assign average E_exc of those configurations to this
20038* one ( Nexc(i,N_tot) > 0 )
20039* b) or (and this applies always if run in transport codes) go up
20040* one mass number and
20041* i) if mass now larger than proj/targ mass or if run in
20042* transport codes assign average E_exc per wounded nucleon
20043* x number of wounded nucleons (Inuc-Ntot)
20044* ii) or assign average E_exc of those configurations to this
20045* one ( Nexc(i,m) > 0 )
20046*
20047 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20048 & THEN
20049 M = MIN(NTOT(I),260)
20050 IF (NEXC(I,M).GT.0) THEN
20051 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20052 ELSE
20053 70 CONTINUE
20054 M = M+1
20055**sr corrected 27.12.06
20056* IF (M.GE.INUC(I)) THEN
20057* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20058 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20059 IF ( INUC (I) .GT. NTOT (I) ) THEN
20060 AMRCL(I) = AMRCL0(I)
20061 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20062 ELSE
20063 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20064 END IF
20065**
20066 ELSE
20067 IF (NEXC(I,M).GT.0) THEN
20068 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20069 ELSE
20070 GOTO 70
20071 ENDIF
20072 ENDIF
20073 ENDIF
20074 EEXC(I) = AMRCL(I)-AMRCL0(I)
20075 ICOR = ICOR+I
20076*
20077* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20078*
20079* a) re-calculate E_exc with scaled nuclear potential
20080* (conditional jump to label 9998)
20081* b) or reject event if N_loop(max) is exceeded
20082* (conditional jump to label 9999)
20083*
20084*
20085 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20086 IF (IOULEV(3).GT.0)
20087 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20088 1004 FORMAT(1X,'warning! too high excitation energy',/,
20089 & I4,1P,2E15.4,3I5)
20090 AMRCL(I) = ZERO
20091 EEXC(I) = ZERO
20092 IF (NLOOP.LE.500) THEN
20093 GOTO 9998
20094 ELSE
20095 IREXCI(2) = IREXCI(2)+1
20096 GOTO 9999
20097 ENDIF
20098*
20099* Otherwise (reasonable E_exc) :
20100* E_exc = M_res - M_res0
20101* in addition: calculate and save E_exc per wounded nucleon as
20102* well as E_exc in <E_exc> counter
20103*
20104 ELSE
20105* excitation energies of residual nuclei
20106 EEXC(I) = AMRCL(I)-AMRCL0(I)
20107**sr 27.12.06 new excitation energy correction by A.F.
20108*
20109* all parts with Ilcopt<3 commented since not used
20110*
20111* still to be done/decided:
20112* Increase Icor and put back both residual nuclei on mass shell
20113* with the exciting correction further below.
20114* For the moment the modification in the excitation energy is simply
20115* corrected by scaling the energy of the residual nucleus.
20116*
20117 LLCPOT = .TRUE.
20118 ILCOPT = 3
20119 IF ( LLCPOT ) THEN
20120 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20121 IF ( ILCOPT .LE. 2 ) THEN
20122C* Patch for Fermi momentum reduction correlated with impact parameter:
20123C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20124C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20125C AKPRHO = ONE - DLKPRH
20126C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20127C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20128C & 0.05D+00 )
20129C* REDORI = 0.75D+00
20130C* REDORI = ONE
20131C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20132 ELSE
20133 DLKPRH = ZERO
20134 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20135* Take out roughly one/half of the skin:
20136 RDCORE = RDCORE - 0.5D+00
20137 FRCFLL = RDCORE**3
20138 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20139 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20140 FRCFLL = ONE - PRSKIN
20141 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20142 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20143 END IF
20144 IF ( NNCHIT .GT. 0 ) THEN
20145C IF ( ILCOPT .EQ. 1 ) THEN
20146C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20147C DO 1220 NCH = 1, 10
20148C ETAETA = ( ONE - SKINRH**INUC(I)
20149C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20150C & * ( ONE - SKINRH ) )
20151C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20152C & * ( ONE - FRCFLL) * SKINRH )
20153C SKINRH = SKINRH * ( ONE + ETAETA )
20154C 1220 CONTINUE
20155C PRSKIN = SKINRH**(NNCHIT-1)
20156C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20157C PRSKIN = ONE - FRCFLL
20158C END IF
20159 REDCTN = ZERO
20160 DO 1230 NCH = 1, NNCHIT
20161 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20162 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20163 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20164 ELSE
20165 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20166 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20167 END IF
20168 REDCTN = REDCTN + PRFRMI**2
20169 1230 CONTINUE
20170 REDCTN = REDCTN / DBLE (NNCHIT)
20171 ELSE
20172 REDCTN = 0.5D+00
20173 END IF
20174 EEXC (I) = EEXC (I) * REDCTN / REDORI
20175 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20176 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20177 END IF
20178**
20179 IF (ICASCA.EQ.0) THEN
20180 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20181 M = MIN(NTOT(I),260)
20182 EXC(I,M) = EXC(I,M)+EEXC(I)
20183 NEXC(I,M) = NEXC(I,M)+1
20184 ENDIF
20185 ENDIF
20186 ELSEIF (NTOT(I).EQ.1) THEN
20187 WRITE(LOUT,1003) I
20188 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20189 GOTO 9999
20190 ELSE
20191 AMRCL0(I) = ZERO
20192 AMRCL(I) = ZERO
20193 EEXC(I) = ZERO
20194 INORCL = INORCL+I
20195 ENDIF
20196 7 CONTINUE
20197
20198 PRCLPR(5) = AMRCL(1)
20199 PRCLTA(5) = AMRCL(2)
20200
20201 IF (ICOR.GT.0) THEN
20202 IF (INORCL.EQ.0) THEN
20203* one or both residual nuclei consist of one nucleon only, transform
20204* this nucleon on mass shell
20205 DO 9 K=1,4
20206 P1IN(K) = PRCL(1,K)
20207 P2IN(K) = PRCL(2,K)
20208 9 CONTINUE
20209 XM1 = AMRCL(1)
20210 XM2 = AMRCL(2)
20211 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20212 IF (IREJ1.GT.0) THEN
20213 WRITE(LOUT,*) 'ficonf-mashel rejection'
20214 GOTO 9999
20215 ENDIF
20216 DO 10 K=1,4
20217 PRCL(1,K) = P1OUT(K)
20218 PRCL(2,K) = P2OUT(K)
20219 PRCLPR(K) = P1OUT(K)
20220 PRCLTA(K) = P2OUT(K)
20221 10 CONTINUE
20222 PRCLPR(5) = AMRCL(1)
20223 PRCLTA(5) = AMRCL(2)
20224 ELSE
20225 IF (IOULEV(3).GT.0)
20226 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20227 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20228 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20229 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20230 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20231 & ' correction',/,11X,'at event',I8,
20232 & ', nucleon config. 1:',2I4,' 2:',2I4,
20233 & 2(/,11X,3E12.3))
20234 IF (NLOOP.LE.500) THEN
20235 GOTO 9998
20236 ELSE
20237 IREXCI(1) = IREXCI(1)+1
20238 ENDIF
20239 ENDIF
20240 ENDIF
20241
20242* update counter
20243C IF (NRESEV(1).NE.NEVHKK) THEN
20244C NRESEV(1) = NEVHKK
20245C NRESEV(2) = NRESEV(2)+1
20246C ENDIF
20247 NRESEV(2) = NRESEV(2)+1
20248 DO 15 I=1,2
20249 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20250 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20251 NRESTO(I) = NRESTO(I)+NTOT(I)
20252 NRESPR(I) = NRESPR(I)+NPRO(I)
20253 NRESNU(I) = NRESNU(I)+NN(I)
20254 NRESBA(I) = NRESBA(I)+NH(I)
20255 NRESPB(I) = NRESPB(I)+NHPOS(I)
20256 NRESCH(I) = NRESCH(I)+NQ(I)
20257 15 CONTINUE
20258
20259* evaporation
20260 IF (LEVPRT) THEN
20261 DO 13 I=1,2
20262* initialize evaporation counter
20263 EEXCFI(I) = ZERO
20264 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20265 & (EEXC(I).GT.ZERO)) THEN
20266* put residual nuclei into DTEVT1
20267 IDRCL = 80000
20268 JMASS = INT( AIF(I))
20269 JCHAR = INT(AIZF(I))
20270* the following patch is required to transmit the correct excitation
20271* energy to Eventd
20272 IF (ITRSPT.EQ.1) THEN
20273 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20274 & (IOULEV(3).GT.0))
20275 & WRITE(LOUT,*)
20276 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20277 & AMRCL(I),AMRCL0(I),EEXC(I)
20278 PRCL0 = PRCL(I,4)
20279 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20280 & +PRCL(I,3)**2)
20281 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20282 WRITE(LOUT,*)
20283 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20284 ENDIF
20285 ENDIF
20286 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20287 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20288**sr 22.6.97
20289 NOBAM(NHKK) = I
20290**
20291 DO 14 J=1,4
20292 VHKK(J,NHKK) = VRCL(I,J)
20293 WHKK(J,NHKK) = WRCL(I,J)
20294 14 CONTINUE
20295* interface to evaporation module - fill final residual nucleus into
20296* common FKRESN
20297* fill resnuc only if code is not used as event generator in Fluka
20298 IF (ITRSPT.NE.1) THEN
20299 PXRES = PRCL(I,1)
20300 PYRES = PRCL(I,2)
20301 PZRES = PRCL(I,3)
20302 IBRES = NPRO(I)+NN(I)+NH(I)
20303 ICRES = NPRO(I)+NHPOS(I)
20304 ANOW = DBLE(IBRES)
20305 ZNOW = DBLE(ICRES)
20306 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20307* ground state mass of the residual nucleus (should be equal to AM0T)
20308
20309 AMNRES = AMRCL0(I)
20310 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20311
20312* common FKFINU
20313 TV = ZERO
20314* kinetic energy of residual nucleus
20315 TVRECL = PRCL(I,4)-AMRCL(I)
20316* excitation energy of residual nucleus
20317 TVCMS = EEXC(I)
20318 PTOLD = PTRES
20319 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20320 & 2.0D0*(AMMRES+TVCMS))))
20321 IF (PTOLD.LT.ANGLGB) THEN
20322 CALL DT_RACO(PXRES,PYRES,PZRES)
20323 PTOLD = ONE
20324 ENDIF
20325 PXRES = PXRES*PTRES/PTOLD
20326 PYRES = PYRES*PTRES/PTOLD
20327 PZRES = PZRES*PTRES/PTOLD
20328* zero counter of secondaries from evaporation
20329 NP = 0
20330* evaporation
20331 WE = ONE
20332
20333 NPHEAV = 0
20334 LRNFSS = .FALSE.
20335 LFRAGM = .FALSE.
20336 CALL EVEVAP(WE)
20337
20338* put evaporated particles and residual nuclei to DTEVT1
20339 MO = NHKK
20340 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20341 ENDIF
20342 EEXCFI(I) = EXCITF
20343 EXCEVA(I) = EXCEVA(I)+EXCITF
20344 ENDIF
20345 13 CONTINUE
20346 ENDIF
20347
20348 RETURN
20349
20350C9998 IREXCI(1) = IREXCI(1)+1
20351 9998 IREJ = IREJ+1
20352 9999 CONTINUE
20353 LRCLPR = .TRUE.
20354 LRCLTA = .TRUE.
20355 IREJ = IREJ+1
20356 RETURN
20357 END
20358
20359*$ CREATE DT_EVA2HE.FOR
20360*COPY DT_EVA2HE
20361* *
20362*====eva2he============================================================*
20363* *
20364 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20365
20366************************************************************************
20367* Interface between common's of evaporation module (FKFINU,FKFHVY) *
20368* and DTEVT1. *
20369* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20370* EEXCF exitation energy of residual nucleus after evaporation *
20371* IRCL = 1 projectile residual nucleus *
20372* = 2 target residual nucleus *
20373* This version dated 19.04.95 is written by S. Roesler. *
20374* *
20375* Last change 27.12.2006 by S. Roesler. *
20376************************************************************************
20377
20378 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20379 SAVE
20380
20381 PARAMETER ( LINP = 10 ,
20382 & LOUT = 6 ,
20383 & LDAT = 9 )
20384
20385 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20386
20387* event history
20388
20389 PARAMETER (NMXHKK=200000)
20390
20391 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20392 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20393 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20394* Note: DTEVT2 - special use for heavy fragments !
20395* (IDRES(I) = mass number, IDXRES(I) = charge)
20396
20397* extended event history
20398 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20399 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20400 & IHIST(2,NMXHKK)
20401
20402* particle properties (BAMJET index convention)
20403 CHARACTER*8 ANAME
20404 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20405 & IICH(210),IIBAR(210),K1(210),K2(210)
20406
20407* flags for input different options
20408 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20409 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20410 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20411
20412* statistics: residual nuclei
20413 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20414 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20415 & NINCST(2,4),NINCEV(2),
20416 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20417 & NRESPB(2),NRESCH(2),NRESEV(4),
20418 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20419 & NEVAFI(2,2)
20420
20421* treatment of residual nuclei: properties of residual nuclei
20422 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20423 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20424 & NTOTFI(2),NPROFI(2)
20425
20426* INCLUDE '(DIMPAR)'
20427* Taken from FLUKA
20428 PARAMETER ( MXXRGN =20000 )
20429 PARAMETER ( MXXMDF = 710 )
20430 PARAMETER ( MXXMDE = 702 )
20431 PARAMETER ( MFSTCK =40000 )
20432 PARAMETER ( MESTCK = 100 )
20433 PARAMETER ( MOSTCK = 2000 )
20434 PARAMETER ( MXPRSN = 100 )
20435 PARAMETER ( MXPDPM = 800 )
20436 PARAMETER ( MXPSCS =30000 )
20437 PARAMETER ( MXGLWN = 300 )
20438 PARAMETER ( MXOUTU = 50 )
20439 PARAMETER ( NALLWP = 64 )
20440 PARAMETER ( NELEMX = 80 )
20441 PARAMETER ( MPDPDX = 18 )
20442 PARAMETER ( MXHTTR = 260 )
20443 PARAMETER ( MXSEAX = 20 )
20444 PARAMETER ( MXHTNC = MXSEAX + 1 )
20445 PARAMETER ( ICOMAX = 2400 )
20446 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20447 PARAMETER ( NSTBIS = 304 )
20448 PARAMETER ( NQSTIS = 46 )
20449 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20450 PARAMETER ( MXPABL = 120 )
20451 PARAMETER ( IDMAXP = 450 )
20452 PARAMETER ( IDMXDC = 2000 )
20453 PARAMETER ( MXMCIN = 410 )
20454 PARAMETER ( IHYPMX = 4 )
20455 PARAMETER ( MKBMX1 = 11 )
20456 PARAMETER ( MKBMX2 = 11 )
20457 PARAMETER ( MXIRRD = 2500 )
20458 PARAMETER ( MXTRDC = 1500 )
20459 PARAMETER ( NKTL = 17 )
20460 PARAMETER ( NBLNMX = 40000000 )
20461
20462* INCLUDE '(GENSTK)'
20463* Taken from FLUKA
20464 PARAMETER ( MXP = MXPSCS )
20465*
20466 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20467 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20468 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20469 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20470 & TVRECL, TVHEAV, TVBIND,
20471 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20472
20473* INCLUDE '(RESNUC)'
20474 LOGICAL LRNFSS, LFRAGM
20475 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20476 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20477 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20478 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20479 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20480 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20481 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20482 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20483 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20484 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20485 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20486 & LRNFSS, LFRAGM
20487* Taken from FLUKA
20488
20489* INCLUDE '(FHEAVY)'
20490* Taken from FLUKA
20491 PARAMETER ( MXHEAV = 100 )
20492 PARAMETER ( KXHEAV = 30 )
20493 CHARACTER*8 ANHEAV
20494 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20495 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20496 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20497 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20498 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20499 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20500 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20501 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20502 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20503 COMMON / FHEAVC / ANHEAV (KXHEAV)
20504
20505 DIMENSION IPTOKP(39)
20506 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20507 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20508 & 100, 101, 97, 102, 98, 103, 109, 115 /
20509
20510 IREJ = 0
20511
20512* skip if evaporation package is not included
20513 IF (.NOT.LEVAPO) RETURN
20514
20515* update counter
20516 IF (NRESEV(3).NE.NEVHKK) THEN
20517 NRESEV(3) = NEVHKK
20518 NRESEV(4) = NRESEV(4)+1
20519 ENDIF
20520
20521 IF (LEMCCK)
20522 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20523 & IDUM,IDUM)
20524* mass number/charge of residual nucleus before evaporation
20525 IBTOT = IDRES(MO)
20526 IZTOT = IDXRES(MO)
20527
20528* protons/neutrons/gammas
20529 DO 1 I=1,NP
20530 PX = CXR(I)*PLR(I)
20531 PY = CYR(I)*PLR(I)
20532 PZ = CZR(I)*PLR(I)
20533 ID = IPTOKP(KPART(I))
20534 IDPDG = IDT_IPDGHA(ID)
20535 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20536 & (2.0D0*MAX(TKI(I),TINY10))
20537 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20538 WRITE(LOUT,1000) ID,AM,AAM(ID)
20539 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20540 & 'particle',I3,2E10.3)
20541 ENDIF
20542 PE = TKI(I)+AM
20543 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20544 NOBAM(NHKK) = IRCL
20545 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20546 IBTOT = IBTOT-IIBAR(ID)
20547 IZTOT = IZTOT-IICH(ID)
20548 1 CONTINUE
20549
20550* heavy fragments
20551 DO 2 I=1,NPHEAV
20552 PX = CXHEAV(I)*PHEAVY(I)
20553 PY = CYHEAV(I)*PHEAVY(I)
20554 PZ = CZHEAV(I)*PHEAVY(I)
20555 IDHEAV = 80000
20556 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20557 & (2.0D0*MAX(TKHEAV(I),TINY10))
20558 PE = TKHEAV(I)+AM
20559 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20560 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20561 NOBAM(NHKK) = IRCL
20562 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20563 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20564 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20565 2 CONTINUE
20566
20567 IF (IBRES.GT.0) THEN
20568* residual nucleus after evaporation
20569 IDNUC = 80000
20570 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20571 & IBRES,ICRES,0)
20572 NOBAM(NHKK) = IRCL
20573 ENDIF
20574 EEXCF = TVCMS
20575 NTOTFI(IRCL) = IBRES
20576 NPROFI(IRCL) = ICRES
20577 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20578 IBTOT = IBTOT-IBRES
20579 IZTOT = IZTOT-ICRES
20580
20581* count events with fission
20582 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20583 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20584
20585* energy-momentum conservation check
20586 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20587C IF (IREJ.GT.0) THEN
20588C CALL DT_EVTOUT(4)
20589C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20590C ENDIF
20591* baryon-number/charge conservation check
20592 IF (IBTOT+IZTOT.NE.0) THEN
20593 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20594 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20595 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20596 ENDIF
20597
20598 RETURN
20599 END
20600
20601*$ CREATE DT_EBIND.FOR
20602*COPY DT_EBIND
20603*
20604*===ebind==============================================================*
20605*
20606 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20607
20608************************************************************************
20609* Binding energy for nuclei. *
20610* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20611* IA mass number *
20612* IZ atomic number *
20613* This version dated 5.5.95 is updated by S. Roesler. *
20614************************************************************************
20615
20616 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20617 SAVE
20618
20619 PARAMETER ( LINP = 10 ,
20620 & LOUT = 6 ,
20621 & LDAT = 9 )
20622
20623 PARAMETER (ZERO=0.0D0)
20624
20625 DATA A1, A2, A3, A4, A5
20626 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20627
20628 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20629 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20630 DT_EBIND = ZERO
20631 RETURN
20632 ENDIF
20633 AA = IA
20634 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20635 & -A4*(IA-2*IZ)**2/AA
20636 IF (MOD(IA,2).EQ.1) THEN
20637 IA5 = 0
20638 ELSEIF (MOD(IZ,2).EQ.1) THEN
20639 IA5 = 1
20640 ELSE
20641 IA5 = -1
20642 ENDIF
20643 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20644
20645 RETURN
20646 END
20647
20648************************************************************************
20649* *
20650* DPMJET 3.0: cross section routines *
20651* *
20652************************************************************************
20653*
20654*
20655* SUBROUTINE DT_SHNDIF
20656* diffractive cross sections (all energies)
20657* SUBROUTINE DT_PHOXS
20658* total and inel. cross sections from PHOJET interpol. tables
20659* SUBROUTINE DT_XSHN
20660* total and el. cross sections for all energies
20661* SUBROUTINE DT_SIHNAB
20662* pion 2-nucleon absorption cross sections
20663* SUBROUTINE DT_SIGEMU
20664* cross section for target "compounds"
20665* SUBROUTINE DT_SIGGA
20666* photon nucleus cross sections
20667* SUBROUTINE DT_SIGGAT
20668* photon nucleus cross sections from tables
20669* SUBROUTINE DT_SANO
20670* anomalous hard photon-nucleon cross sections from tables
20671* SUBROUTINE DT_SIGGP
20672* photon nucleon cross sections
20673* SUBROUTINE DT_SIGVEL
20674* quasi-elastic vector meson prod. cross sections
20675* DOUBLE PRECISION FUNCTION DT_SIGVP
20676* sigma_VN(tilde)
20677* DOUBLE PRECISION FUNCTION DT_RRM2
20678* DOUBLE PRECISION FUNCTION DT_RM2
20679* DOUBLE PRECISION FUNCTION DT_SAM2
20680* SUBROUTINE DT_CKMT
20681* SUBROUTINE DT_CKMTX
20682* SUBROUTINE DT_PDF0
20683* SUBROUTINE DT_CKMTQ0
20684* SUBROUTINE DT_CKMTDE
20685* SUBROUTINE DT_CKMTPR
20686* FUNCTION DT_CKMTFF
20687*
20688* SUBROUTINE DT_FLUINI
20689* total nucleon cross section fluctuation treatment
20690*
20691* SUBROUTINE DT_SIGTBL
20692* pre-tabulation of low-energy elastic x-sec. using SIHNEL
20693* SUBROUTINE DT_XSTABL
20694* service routines
20695*
20696*
20697*$ CREATE DT_SHNDIF.FOR
20698*COPY DT_SHNDIF
20699*
20700*===shndif===============================================================*
20701*
20702 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20703
20704**********************************************************************
20705* Single diffractive hadron-nucleon cross sections *
20706* S.Roesler 14/1/93 *
20707* *
20708* The cross sections are calculated from extrapolated single *
20709* diffractive antiproton-proton cross sections (DTUJET92) using *
20710* scaling relations between total and single diffractive cross *
20711* sections. *
20712**********************************************************************
20713
20714 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20715 SAVE
20716 PARAMETER (ZERO=0.0D0)
20717
20718* particle properties (BAMJET index convention)
20719 CHARACTER*8 ANAME
20720 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20721 & IICH(210),IIBAR(210),K1(210),K2(210)
20722*
20723 CSD1 = 4.201483727D0
20724 CSD4 = -0.4763103556D-02
20725 CSD5 = 0.4324148297D0
20726*
20727 CHMSD1 = 0.8519297242D0
20728 CHMSD4 = -0.1443076599D-01
20729 CHMSD5 = 0.4014954567D0
20730*
20731 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20732 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20733*
20734 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20735 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20736 FRAC = SHMSD/SDIAPP
20737*
20738 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20739 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20740 & 10, 10, 20, 20, 20) KPROJ
20741*
20742 10 CONTINUE
20743*---------------------------- p - p , n - p , sigma0+- - p ,
20744* Lambda - p
20745 CSD1 = 6.004476070D0
20746 CSD4 = -0.1257784606D-03
20747 CSD5 = 0.2447335720D0
20748 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20749 SIGDIH = FRAC*SIGDIF
20750 RETURN
20751*
20752 20 CONTINUE
20753*
20754 KPSCAL = 2
20755 KTSCAL = 1
20756C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20757 DUMZER = ZERO
20758 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20759 F = SDIAPP/SIGTO
20760 KT = 1
20761C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20762 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20763 SIGDIF = SIGTO*F
20764 SIGDIH = FRAC*SIGDIF
20765 RETURN
20766*
20767 999 CONTINUE
20768*-------------------------- leptons..
20769 SIGDIF = 1.D-10
20770 SIGDIH = 1.D-10
20771 RETURN
20772 END
20773
20774*$ CREATE DT_PHOXS.FOR
20775*COPY DT_PHOXS
20776*
20777*===phoxs================================================================*
20778*
20779 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20780
20781************************************************************************
20782* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20783* interpolation tables. *
20784* This version dated 05.11.97 is written by S. Roesler *
20785************************************************************************
20786
20787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20788 SAVE
20789
20790 PARAMETER ( LINP = 10 ,
20791 & LOUT = 6 ,
20792 & LDAT = 9 )
20793
20794 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20795 PARAMETER (TWOPI = 6.283185307179586454D+00,
20796 & PI = TWOPI/TWO,
20797 & GEV2MB = 0.38938D0)
20798
20799 LOGICAL LFIRST
20800 DATA LFIRST /.TRUE./
20801
20802* nucleon-nucleon event-generator
20803 CHARACTER*8 CMODEL
20804 LOGICAL LPHOIN
20805 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20806
20807* particle properties (BAMJET index convention)
20808 CHARACTER*8 ANAME
20809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20810 & IICH(210),IIBAR(210),K1(210),K2(210)
20811
20812**PHOJET105a
20813C PARAMETER (IEETAB=10)
20814C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20815**PHOJET110
20816
20817C energy-interpolation table
20818 INTEGER IEETA2
20819 PARAMETER ( IEETA2 = 20 )
20820 INTEGER ISIMAX
20821 DOUBLE PRECISION SIGTAB,SIGECM
20822 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20823**
20824
20825 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20826 WRITE(LOUT,*) MCGENE
20827 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20828 STOP
20829 ENDIF
20830
20831 IF (ECM.LE.ZERO) THEN
20832 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20833 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20834 ENDIF
20835
20836 IF (MODE.EQ.1) THEN
20837* DL
20838 DELDL = 0.0808D0
20839 EPSDL = -0.4525D0
20840 S = ECM*ECM
20841 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20842 ALPHAP= 0.25D0
20843 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20844 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20845 SINE = STOT-SIGEL
20846 SDIF1 = ZERO
20847 ELSE
20848* Phojet
20849 IP = 1
20850 IF(ECM.LE.SIGECM(IP,1)) THEN
20851 I1 = 1
20852 I2 = 1
20853 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20854 DO 1 I=2,ISIMAX
20855 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20856 1 CONTINUE
20857 2 CONTINUE
20858 I1 = I-1
20859 I2 = I
20860 ELSE
20861 IF (LFIRST) THEN
20862 WRITE(LOUT,'(/1X,A,2E12.3)')
20863 & 'PHOXS: warning! energy above initialization limit (',
20864 & ECM,SIGECM(IP,ISIMAX)
20865 LFIRST = .FALSE.
20866 ENDIF
20867 I1 = ISIMAX
20868 I2 = ISIMAX
20869 ENDIF
20870 FAC2 = ZERO
20871 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20872 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20873 FAC1 = ONE-FAC2
20874 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20875 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20876 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20877 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20878 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20879 ENDIF
20880
20881 RETURN
20882 END
20883
20884*$ CREATE DT_XSHN.FOR
20885*COPY DT_XSHN
20886*
20887*===xshn===============================================================*
20888*
20889 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20890
20891************************************************************************
20892* Total and elastic hadron-nucleon cross section. *
20893* Below 500GeV cross sections are based on the '98 data compilation *
20894* of the PDG. At higher energies PHOJET results are used (patched to *
20895* the low energy data at 500GeV). *
20896* IP projectile index (BAMJET numbering scheme) *
20897* (should be in the range 1..25) *
20898* IT target index (BAMJET numbering scheme) *
20899* (1 = proton, 8 = neutron) *
20900* PL laboratory momentum *
20901* ECM cm. energy (ignored if PL>0) *
20902* STOT total cross section *
20903* SELA elastic cross section *
20904* Last change: 24.4.99 by S. Roesler *
20905************************************************************************
20906
20907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20908 SAVE
20909
20910 PARAMETER ( LINP = 10 ,
20911 & LOUT = 6 ,
20912 & LDAT = 9 )
20913
20914 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20915
20916 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20917 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20918 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20919
20920 LOGICAL LFIRST
20921
20922* particle properties (BAMJET index convention)
20923 CHARACTER*8 ANAME
20924 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20925 & IICH(210),IIBAR(210),K1(210),K2(210)
20926
20927* nucleon-nucleon event-generator
20928 CHARACTER*8 CMODEL
20929 LOGICAL LPHOIN
20930 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20931**PHOJET105a
20932C PARAMETER (IEETAB=10)
20933C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20934**PHOJET110
20935
20936C energy-interpolation table
20937 INTEGER IEETA2
20938 PARAMETER ( IEETA2 = 20 )
20939 INTEGER ISIMAX
20940 DOUBLE PRECISION SIGTAB,SIGECM
20941 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20942
20943 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20944 DIMENSION IDXDAT(25,2)
20945*
20946 DATA APL /
20947 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20948 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20949 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20950 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20951 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20952 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20953 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20954*
20955* total cross sections:
20956* p p
20957 DATA (ASIGTO(1,K),K=1,NPOINT) /
20958 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20959 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20960 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20961 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20962 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20963 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20964 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20965* pbar p
20966 DATA (ASIGTO(2,K),K=1,NPOINT) /
20967 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20968 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20969 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20970 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20971 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20972 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20973 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20974* n p
20975 DATA (ASIGTO(3,K),K=1,NPOINT) /
20976 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20977 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20978 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20979 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20980 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20981 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20982 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20983* pi+ p
20984 DATA (ASIGTO(4,K),K=1,NPOINT) /
20985 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20986 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20987 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20988 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20989 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20990 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20991 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20992* pi- p
20993 DATA (ASIGTO(5,K),K=1,NPOINT) /
20994 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20995 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20996 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20997 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20998 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20999 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21000 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21001* K+ p
21002 DATA (ASIGTO(6,K),K=1,NPOINT) /
21003 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21004 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21005 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21006 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21007 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21008 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21009 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21010* K- p
21011 DATA (ASIGTO(7,K),K=1,NPOINT) /
21012 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21013 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21014 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21015 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21016 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21017 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21018 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21019* K+ n
21020 DATA (ASIGTO(8,K),K=1,NPOINT) /
21021 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21022 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21023 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21024 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21025 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21026 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21027 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21028* K- n
21029 DATA (ASIGTO(9,K),K=1,NPOINT) /
21030 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21031 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21032 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21033 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21034 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21035 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21036 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21037* Lambda p
21038 DATA (ASIGTO(10,K),K=1,NPOINT) /
21039 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21040 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21041 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21042 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21043 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21044 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21045 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21046*
21047* elastic cross sections:
21048* p p
21049 DATA (ASIGEL(1,K),K=1,NPOINT) /
21050 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21051 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21052 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21053 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21054 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21055 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21056 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21057* pbar p
21058 DATA (ASIGEL(2,K),K=1,NPOINT) /
21059 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21060 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21061 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21062 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21063 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21064 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21065 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21066* n p
21067 DATA (ASIGEL(3,K),K=1,NPOINT) /
21068 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21069 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21070 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21071 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21072 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21073 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21074 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21075* pi+ p
21076 DATA (ASIGEL(4,K),K=1,NPOINT) /
21077 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21078 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21079 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21080 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21081 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21082 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21083 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21084* pi- p
21085 DATA (ASIGEL(5,K),K=1,NPOINT) /
21086 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21087 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21088 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21089 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21090 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21091 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21092 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21093* K+ p
21094 DATA (ASIGEL(6,K),K=1,NPOINT) /
21095 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21096 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21097 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21098 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21099 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21100 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21101 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21102* K- p
21103 DATA (ASIGEL(7,K),K=1,NPOINT) /
21104 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21105 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21106 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21107 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21108 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21109 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21110 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21111* K+ n
21112 DATA (ASIGEL(8,K),K=1,NPOINT) /
21113 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21114 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21115 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21116 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21117 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21118 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21119 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21120* K- n
21121 DATA (ASIGEL(9,K),K=1,NPOINT) /
21122 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21123 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21124 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21125 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21126 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21127 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21128 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21129* Lambda p
21130 DATA (ASIGEL(10,K),K=1,NPOINT) /
21131 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21132 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21133 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21134 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21135 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21136 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21137 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21138
21139 DATA (IDXDAT(K,1),K=1,25) /
21140 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21141 & 1, 3,45, 8, 9/
21142 DATA (IDXDAT(K,2),K=1,25) /
21143 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21144 & 3, 1,45, 6, 7/
21145
21146 DATA LFIRST /.TRUE./
21147
21148 IF (LFIRST) THEN
21149 APLABL = LOG10(PLABLO)
21150 APLABH = LOG10(PLABHI)
21151 APTHRE = LOG10(PTHRE)
21152 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21153 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21154 DUM0 = ZERO
21155 PHOPLA = PLABHI
21156 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21157 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21158 IF (MCGENE.EQ.2) THEN
21159 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21160 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21161 ELSE
21162 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21163 ENDIF
21164 ELSE
21165 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21166 ENDIF
21167 PHOSEL = PHOSTO-PHOSIN
21168 APHOST = LOG10(PHOSTO)
21169 APHOSE = LOG10(PHOSEL)
21170 LFIRST = .FALSE.
21171 ENDIF
21172 STOT = ZERO
21173 SELA = ZERO
21174 PLAB = PL
21175 ECMS = ECM
21176 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21177 WRITE(LOUT,1000) IP,IT
21178 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21179 & 'proj/target',2I4)
21180 STOP
21181 ENDIF
21182
21183 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21184 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21185 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21186 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21187 WRITE(LOUT,1001) PLAB,ECMS
21188 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21189 STOP
21190 ENDIF
21191
21192* index of spectrum
21193 IDXP = IP
21194 IF (IP.GT.25) THEN
21195 IF (AAM(IP).GT.ZERO) THEN
21196 IF (ABS(IIBAR(IP)).GT.0) THEN
21197 IDXP = 1
21198 ELSE
21199 IDXP = 13
21200 ENDIF
21201 ELSE
21202 IDXP = 7
21203 ENDIF
21204 ENDIF
21205 IDXT = 1
21206 IF (IT.EQ.8) IDXT = 2
21207 IDXS = IDXDAT(IDXP,IDXT)
21208 IF (IDXS.EQ.0) RETURN
21209
21210* compute momentum bin indices
21211 IF (PLAB.LT.PLABLO) THEN
21212 IDX0 = 1
21213 IDX1 = 1
21214 ELSEIF (PLAB.GE.PLABHI) THEN
21215 IDX0 = NPOINT
21216 IDX1 = NPOINT
21217 ELSE
21218 APLAB = LOG10(PLAB)
21219 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21220 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21221 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21222 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21223 ENDIF
21224 IDX1 = IDX0+1
21225 ENDIF
21226
21227* interpolate cross section
21228 IF (IDXS.GT.10) THEN
21229 IDXS1 = IDXS/10
21230 IDXS2 = IDXS-10*IDXS1
21231 IF (IDX0.EQ.IDX1) THEN
21232 IF (IDX0.EQ.1) THEN
21233 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21234 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21235 ELSE
21236 DUM0 = ZERO
21237 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21238 PHOSEL = PHOSTO-PHOSIN
21239 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21240 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21241 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21242 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21243 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21244 ASELA = 0.5D0*(ASELA1+ASELA2)
21245 ENDIF
21246 ELSE
21247 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21248 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21249 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21250 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21251 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21252 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21253 ASELA1 = ASIGEL(IDXS1,IDX0)+
21254 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21255 ASELA2 = ASIGEL(IDXS2,IDX0)+
21256 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21257 ASELA = 0.5D0*(ASELA1+ASELA2)
21258 ENDIF
21259 ELSE
21260 IF (IDX0.EQ.IDX1) THEN
21261 IF (IDX0.EQ.1) THEN
21262 ASTOT = ASIGTO(IDXS,IDX0)
21263 ASELA = ASIGEL(IDXS,IDX0)
21264 ELSE
21265 DUM0 = ZERO
21266 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21267 PHOSEL = PHOSTO-PHOSIN
21268 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21269 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21270 ENDIF
21271 ELSE
21272 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21273 ASTOT = ASIGTO(IDXS,IDX0)+
21274 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21275 ASELA = ASIGEL(IDXS,IDX0)+
21276 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21277 ENDIF
21278 ENDIF
21279 STOT = 10.0D0**ASTOT
21280 SELA = 10.0D0**ASELA
21281
21282 RETURN
21283 END
21284
21285*$ CREATE DT_SIHNAB.FOR
21286*COPY DT_SIHNAB
21287*
21288*===sihnab===============================================================*
21289*
21290 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21291
21292**********************************************************************
21293* Pion 2-nucleon absorption cross sections. *
21294* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21295* taken from Ritchie PRC 28 (1983) 926 ) *
21296* This version dated 18.05.96 is written by S. Roesler *
21297**********************************************************************
21298
21299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21300 SAVE
21301 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21302 PARAMETER (AMPR = 938.0D0,
21303 & AMPI = 140.0D0,
21304 & AMDE = TWO*AMPR,
21305 & A = -1.2D0,
21306 & B = 3.5D0,
21307 & C = 7.4D0,
21308 & D = 5600.0D0,
21309 & ER = 2136.0D0)
21310
21311 SIGABS = ZERO
21312 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21313 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21314 PTOT = PLAB*1.0D3
21315 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21316 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21317 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21318 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21319* approximate 3N-abs., I=1-abs. etc.
21320 SIGABS = SIGABS/0.40D0
21321* pi0-absorption (rough approximation!!)
21322 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21323
21324 RETURN
21325 END
21326
21327*$ CREATE DT_SIGEMU.FOR
21328*COPY DT_SIGEMU
21329*
21330*===sigemu=============================================================*
21331*
21332 SUBROUTINE DT_SIGEMU
21333
21334************************************************************************
21335* Combined cross section for target compounds. *
21336* This version dated 6.4.98 is written by S. Roesler *
21337************************************************************************
21338
21339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21340 SAVE
21341
21342 PARAMETER ( LINP = 10 ,
21343 & LOUT = 6 ,
21344 & LDAT = 9 )
21345
21346 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21347 & OHALF=0.5D0,ONE=1.0D0)
21348
21349 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21350
21351* Glauber formalism: cross sections
21352 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21353 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21354 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21355 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21356 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21357 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21358 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21359 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21360 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21361 & BSLOPE,NEBINI,NQBINI
21362
21363* emulsion treatment
21364 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21365 & NCOMPO,IEMUL
21366
21367* nucleon-nucleon event-generator
21368 CHARACTER*8 CMODEL
21369 LOGICAL LPHOIN
21370 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21371
21372 IF (MCGENE.NE.4) THEN
21373 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21374 WRITE(LOUT,'(15X,A)') '-----------------------'
21375 ENDIF
21376 DO 1 IE=1,NEBINI
21377 DO 2 IQ=1,NQBINI
21378 SIGTOT = ZERO
21379 SIGELA = ZERO
21380 SIGQEP = ZERO
21381 SIGQET = ZERO
21382 SIGQE2 = ZERO
21383 SIGPRO = ZERO
21384 SIGDEL = ZERO
21385 SIGDQE = ZERO
21386 ERRTOT = ZERO
21387 ERRELA = ZERO
21388 ERRQEP = ZERO
21389 ERRQET = ZERO
21390 ERRQE2 = ZERO
21391 ERRPRO = ZERO
21392 ERRDEL = ZERO
21393 ERRDQE = ZERO
21394 IF (NCOMPO.GT.0) THEN
21395 DO 3 IC=1,NCOMPO
21396 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21397 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21398 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21399 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21400 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21401 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21402 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21403 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21404 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21405 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21406 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21407 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21408 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21409 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21410 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21411 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21412 3 CONTINUE
21413 ERRTOT = SQRT(ERRTOT)
21414 ERRELA = SQRT(ERRELA)
21415 ERRQEP = SQRT(ERRQEP)
21416 ERRQET = SQRT(ERRQET)
21417 ERRQE2 = SQRT(ERRQE2)
21418 ERRPRO = SQRT(ERRPRO)
21419 ERRDEL = SQRT(ERRDEL)
21420 ERRDQE = SQRT(ERRDQE)
21421 ELSE
21422 SIGTOT = XSTOT(IE,IQ,1)
21423 SIGELA = XSELA(IE,IQ,1)
21424 SIGQEP = XSQEP(IE,IQ,1)
21425 SIGQET = XSQET(IE,IQ,1)
21426 SIGQE2 = XSQE2(IE,IQ,1)
21427 SIGPRO = XSPRO(IE,IQ,1)
21428 SIGDEL = XSDEL(IE,IQ,1)
21429 SIGDQE = XSDQE(IE,IQ,1)
21430 ERRTOT = XETOT(IE,IQ,1)
21431 ERRELA = XEELA(IE,IQ,1)
21432 ERRQEP = XEQEP(IE,IQ,1)
21433 ERRQET = XEQET(IE,IQ,1)
21434 ERRQE2 = XEQE2(IE,IQ,1)
21435 ERRPRO = XEPRO(IE,IQ,1)
21436 ERRDEL = XEDEL(IE,IQ,1)
21437 ERRDQE = XEDQE(IE,IQ,1)
21438 ENDIF
21439 IF (MCGENE.NE.4) THEN
21440 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21441 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21442 WRITE(LOUT,1001) SIGTOT,ERRTOT
21443 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21444 WRITE(LOUT,1002) SIGELA,ERRELA
21445 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21446 WRITE(LOUT,1003) SIGQEP,ERRQEP
21447 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21448 & F11.5,' mb')
21449 WRITE(LOUT,1004) SIGQET,ERRQET
21450 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21451 & F11.5,' mb')
21452 WRITE(LOUT,1005) SIGQE2,ERRQE2
21453 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21454 & ' +-',F11.5,' mb')
21455 WRITE(LOUT,1006) SIGPRO,ERRPRO
21456 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21457 WRITE(LOUT,1007) SIGDEL,ERRDEL
21458 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21459 WRITE(LOUT,1008) SIGDQE,ERRDQE
21460 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21461 ENDIF
21462
21463 2 CONTINUE
21464 1 CONTINUE
21465
21466 RETURN
21467 END
21468
21469*$ CREATE DT_SIGGA.FOR
21470*COPY DT_SIGGA
21471*
21472*===sigga==============================================================*
21473*
21474 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21475
21476************************************************************************
21477* Total/inelastic photon-nucleus cross sections. *
21478* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21479* production runs !!!! *
21480* This version dated 27.03.96 is written by S. Roesler *
21481************************************************************************
21482
21483 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21484 SAVE
21485
21486 PARAMETER ( LINP = 10 ,
21487 & LOUT = 6 ,
21488 & LDAT = 9 )
21489
21490 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21491 & OHALF=0.5D0,ONE=1.0D0)
21492 PARAMETER (AMPROT = 0.938D0)
21493
21494 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21495
21496* Glauber formalism: cross sections
21497 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21498 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21499 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21500 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21501 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21502 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21503 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21504 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21505 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21506 & BSLOPE,NEBINI,NQBINI
21507
21508 NT = NTI
21509 X = XI
21510 Q2 = Q2I
21511 ECM = ECMI
21512 XNU = XNUI
21513 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21514 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21515 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21516 STOT = XSTOT(1,1,1)
21517 ETOT = XETOT(1,1,1)
21518 SIN = XSPRO(1,1,1)
21519 EIN = XEPRO(1,1,1)
21520
21521 RETURN
21522 END
21523
21524*$ CREATE DT_SIGGAT.FOR
21525*COPY DT_SIGGAT
21526*
21527*===siggat=============================================================*
21528*
21529 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21530
21531************************************************************************
21532* Total/inelastic photon-nucleus cross sections. *
21533* Uses pre-tabulated cross section. *
21534* This version dated 29.07.96 is written by S. Roesler *
21535************************************************************************
21536
21537 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21538 SAVE
21539
21540 PARAMETER ( LINP = 10 ,
21541 & LOUT = 6 ,
21542 & LDAT = 9 )
21543
21544 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21545 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21546
21547 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21548
21549* Glauber formalism: cross sections
21550 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21551 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21552 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21553 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21554 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21555 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21556 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21557 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21558 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21559 & BSLOPE,NEBINI,NQBINI
21560
21561 NTARG = ABS(NT)
21562 I1 = 1
21563 I2 = 1
21564 RATE = ONE
21565 IF (NEBINI.GT.1) THEN
21566 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21567 I1 = NEBINI
21568 I2 = NEBINI
21569 RATE = ONE
21570 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21571 DO 1 I=2,NEBINI
21572 IF (ECMI.LT.ECMNN(I)) THEN
21573 I1 = I-1
21574 I2 = I
21575 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21576 GOTO 2
21577 ENDIF
21578 1 CONTINUE
21579 2 CONTINUE
21580 ENDIF
21581 ENDIF
21582 J1 = 1
21583 J2 = 1
21584 RATQ = ONE
21585 IF (NQBINI.GT.1) THEN
21586 IF (Q2I.GE.Q2G(NQBINI)) THEN
21587 J1 = NQBINI
21588 J2 = NQBINI
21589 RATQ = ONE
21590 ELSEIF (Q2I.GT.Q2G(1)) THEN
21591 DO 3 I=2,NQBINI
21592 IF (Q2I.LT.Q2G(I)) THEN
21593 J1 = I-1
21594 J2 = I
21595 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21596 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21597C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21598 GOTO 4
21599 ENDIF
21600 3 CONTINUE
21601 4 CONTINUE
21602 ENDIF
21603 ENDIF
21604
21605 STOT = XSTOT(I1,J1,NTARG)+
21606 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21607 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21608 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21609 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21610
21611 RETURN
21612 END
21613
21614*$ CREATE DT_SANO.FOR
21615*COPY DT_SANO
21616*
21617*===sigano=============================================================*
21618*
21619 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21620
21621************************************************************************
21622* This version dated 31.07.96 is written by S. Roesler *
21623************************************************************************
21624
21625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21626 SAVE
21627
21628 PARAMETER ( LINP = 10 ,
21629 & LOUT = 6 ,
21630 & LDAT = 9 )
21631
21632 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21633 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21634 PARAMETER (NE = 8)
21635
21636* VDM parameter for photon-nucleus interactions
21637 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21638
21639* properties of interacting particles
21640 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21641
21642 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21643 DATA ECMANO /
21644 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21645 & 0.100D+04,0.200D+04,0.500D+04
21646 & /
21647* fixed cut (3 GeV/c)
21648 DATA FRAANO /
21649 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21650 & 0.062D+00,0.054D+00,0.042D+00
21651 & /
21652 DATA SIGHRD /
21653 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21654 & 3.3086D-01,7.6255D-01,2.1319D+00
21655 & /
21656* running cut (based on obsolete Phojet-caluclations, bugs..)
21657C DATA FRAANO /
21658C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21659C & 0.167E+00,0.150E+00,0.131E+00
21660C & /
21661C DATA SIGHRD /
21662C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21663C & 2.5736E-01,4.5593E-01,8.2550E-01
21664C & /
21665
21666 DT_SANO = ZERO
21667 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21668 J1 = 0
21669 J2 = 0
21670 RATE = ONE
21671 IF (ECM.GE.ECMANO(NE)) THEN
21672 J1 = NE
21673 J2 = NE
21674 ELSEIF (ECM.GT.ECMANO(1)) THEN
21675 DO 1 IE=2,NE
21676 IF (ECM.LT.ECMANO(IE)) THEN
21677 J1 = IE-1
21678 J2 = IE
21679 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21680 GOTO 2
21681 ENDIF
21682 1 CONTINUE
21683 2 CONTINUE
21684 ENDIF
21685 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21686 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21687 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21688 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21689 ENDIF
21690
21691 RETURN
21692 END
21693
21694*$ CREATE DT_SIGGP.FOR
21695*COPY DT_SIGGP
21696*
21697*===siggp==============================================================*
21698*
21699 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21700
21701************************************************************************
21702* Total/inelastic photon-nucleon cross sections. *
21703* This version dated 30.04.96 is written by S. Roesler *
21704************************************************************************
21705
21706 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21707 SAVE
21708
21709 PARAMETER ( LINP = 10 ,
21710 & LOUT = 6 ,
21711 & LDAT = 9 )
21712
21713 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21714 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21715 & PI = TWOPI/TWO,
21716 & GEV2MB = 0.38938D0,
21717 & ALPHEM = ONE/137.0D0)
21718
21719* particle properties (BAMJET index convention)
21720 CHARACTER*8 ANAME
21721 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21722 & IICH(210),IIBAR(210),K1(210),K2(210)
21723
21724* VDM parameter for photon-nucleus interactions
21725 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21726
21727**PHOJET105a
21728C CHARACTER*8 MDLNA
21729C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21730C PARAMETER (IEETAB=10)
21731C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21732**PHOJET110
21733
21734C model switches and parameters
21735 CHARACTER*8 MDLNA
21736 INTEGER ISWMDL,IPAMDL
21737 DOUBLE PRECISION PARMDL
21738 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21739
21740C energy-interpolation table
21741 INTEGER IEETA2
21742 PARAMETER ( IEETA2 = 20 )
21743 INTEGER ISIMAX
21744 DOUBLE PRECISION SIGTAB,SIGECM
21745 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21746**
21747
21748C PARAMETER (NPOINT=80)
21749 PARAMETER (NPOINT=16)
21750 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21751
21752 STOT = ZERO
21753 SINE = ZERO
21754 SDIR = ZERO
21755
21756 W2 = ECMI**2
21757 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21758 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21759 Q2 = Q2I
21760 X = XI
21761* photoprod.
21762 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21763 Q2 = 0.0001D0
21764 X = Q2/(W2+Q2-AAM(1)**2)
21765* DIS
21766 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21767 X = Q2/(W2+Q2-AAM(1)**2)
21768 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21769 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21770 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21771 W2 = Q2*(ONE-X)/X+AAM(1)**2
21772 ELSE
21773 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21774 STOP
21775 ENDIF
21776 ECM = SQRT(W2)
21777
21778 IF (MODEGA.EQ.1) THEN
21779 SCALE = SQRT(Q2)
21780 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21781 & IDPDF)
21782C W = SQRT(W2)
21783
21784C ALLMF2 = PHO_ALLM97(Q2,W)
21785
21786C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21787 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21788 SINE = ZERO
21789 SDIR = ZERO
21790 ELSEIF (MODEGA.EQ.2) THEN
21791 IF (INTRGE(1).EQ.1) THEN
21792 AMLO2 = (3.0D0*AAM(13))**2
21793 ELSEIF (INTRGE(1).EQ.2) THEN
21794 AMLO2 = AAM(33)**2
21795 ELSE
21796 AMLO2 = AAM(96)**2
21797 ENDIF
21798 IF (INTRGE(2).EQ.1) THEN
21799 AMHI2 = W2/TWO
21800 ELSEIF (INTRGE(2).EQ.2) THEN
21801 AMHI2 = W2/4.0D0
21802 ELSE
21803 AMHI2 = W2
21804 ENDIF
21805 AMHI20 = (ECM-AAM(1))**2
21806 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21807 XAMLO = LOG( AMLO2+Q2 )
21808 XAMHI = LOG( AMHI2+Q2 )
21809**PHOJET105a
21810C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21811**PHOJET112
21812
21813 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21814
21815**
21816 SUM = ZERO
21817 DO 1 J=1,NPOINT
21818 AM2 = EXP(ABSZX(J))-Q2
21819 IF (AM2.LT.16.0D0) THEN
21820 R = TWO
21821 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21822 R = 10.0D0/3.0D0
21823 ELSE
21824 R = 11.0D0/3.0D0
21825 ENDIF
21826C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21827 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21828 & * (ONE+EPSPOL*Q2/AM2)
21829 SUM = SUM+WEIGHT(J)*FAC
21830 1 CONTINUE
21831 SINE = SUM
21832 SDIR = DT_SIGVP(X,Q2)
21833 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21834 SDIR = SDIR/(0.588D0+RL2+Q2)
21835C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21836 ELSEIF (MODEGA.EQ.3) THEN
21837 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21838 ELSEIF (MODEGA.EQ.4) THEN
21839* load cross sections from PHOJET interpolation table
21840 IP = 1
21841 IF(ECM.LE.SIGECM(IP,1)) THEN
21842 I1 = 1
21843 I2 = 1
21844 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21845 DO 2 I=2,ISIMAX
21846 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21847 2 CONTINUE
21848 3 CONTINUE
21849 I1 = I-1
21850 I2 = I
21851 ELSE
21852 WRITE(LOUT,'(/1X,A,2E12.3)')
21853 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21854 I1 = ISIMAX
21855 I2 = ISIMAX
21856 ENDIF
21857 FAC2 = ZERO
21858 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21859 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21860 FAC1 = ONE-FAC2
21861* cross section dependence on photon virtuality
21862 FSUP1 = ZERO
21863 DO 4 I=1,3
21864 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21865 & /(1.D0+Q2/PARMDL(30+I))**2
21866 4 CONTINUE
21867 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21868 FAC1 = FAC1*FSUP1
21869 FAC2 = FAC2*FSUP1
21870 FSUP2 = 1.0D0
21871 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21872 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21873 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21874**re:
21875 STOT = STOT-SDIR
21876**
21877 SDIR = SDIR/(FSUP1*FSUP2)
21878**re:
21879 STOT = STOT+SDIR
21880**
21881 ENDIF
21882
21883 RETURN
21884 END
21885
21886*$ CREATE DT_SIGVEL.FOR
21887*COPY DT_SIGVEL
21888*
21889*===sigvel=============================================================*
21890*
21891 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21892
21893************************************************************************
21894* Cross section for elastic vector meson production *
21895* This version dated 10.05.96 is written by S. Roesler *
21896************************************************************************
21897
21898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21899 SAVE
21900
21901 PARAMETER ( LINP = 10 ,
21902 & LOUT = 6 ,
21903 & LDAT = 9 )
21904
21905 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21906 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21907 & PI = TWOPI/TWO,
21908 & GEV2MB = 0.38938D0,
21909 & ALPHEM = ONE/137.0D0)
21910
21911* particle properties (BAMJET index convention)
21912 CHARACTER*8 ANAME
21913 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21914 & IICH(210),IIBAR(210),K1(210),K2(210)
21915
21916* VDM parameter for photon-nucleus interactions
21917 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21918
21919 W2 = ECMI**2
21920 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21921 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21922 Q2 = Q2I
21923 X = XI
21924* photoprod.
21925 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21926 Q2 = 0.0001D0
21927 X = Q2/(W2+Q2-AAM(1)**2)
21928* DIS
21929 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21930 X = Q2/(W2+Q2-AAM(1)**2)
21931 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21932 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21933 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21934 W2 = Q2*(ONE-X)/X+AAM(1)**2
21935 ELSE
21936 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21937 STOP
21938 ENDIF
21939 ECM = SQRT(W2)
21940
21941 AMV = AAM(IDXV)
21942 AMV2 = AMV**2
21943
21944 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21945 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21946 ROSH = 0.1D0
21947 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21948 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21949
21950 IF (IDXV.EQ.33) THEN
21951 COUPL = 0.00365D0
21952 ELSE
21953 STOP
21954 ENDIF
21955 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21956 SIG2 = SELVP
21957 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21958 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21959
21960 RETURN
21961 END
21962
21963*$ CREATE DT_SIGVP.FOR
21964*COPY DT_SIGVP
21965*
21966*===sigvp==============================================================*
21967*
21968 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21969
21970************************************************************************
21971* sigma_Vp *
21972************************************************************************
21973
21974 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21975 SAVE
21976
21977 PARAMETER ( LINP = 10 ,
21978 & LOUT = 6 ,
21979 & LDAT = 9 )
21980
21981 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21982 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21983 & PI = TWOPI/TWO,
21984 & GEV2MB = 0.38938D0,
21985 & AMPROT = 0.938D0,
21986 & ALPHEM = ONE/137.0D0)
21987
21988* VDM parameter for photon-nucleus interactions
21989 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21990
21991 X = XI
21992 Q2 = Q2I
21993 IF (XI.LE.ZERO) X = 0.0001D0
21994 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21995
21996 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21997
21998 SCALE = SQRT(Q2)
21999 IF (MODEGA.EQ.1) THEN
22000 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22001 & IDPDF)
22002C W = ECM
22003
22004C ALLMF2 = PHO_ALLM97(Q2,W)
22005
22006C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22007C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22008C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22009 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22010 ELSEIF (MODEGA.EQ.4) THEN
22011 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22012C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22013 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22014 ELSE
22015 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22016 ENDIF
22017
22018 RETURN
22019
22020 END
22021
22022*$ CREATE DT_RRM2.FOR
22023*COPY DT_RRM2
22024*
22025*===RRM2===============================================================*
22026*
22027 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22028
22029 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22030 SAVE
22031
22032 PARAMETER ( LINP = 10 ,
22033 & LOUT = 6 ,
22034 & LDAT = 9 )
22035
22036 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22037 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22038 & PI = TWOPI/TWO,
22039 & GEV2MB = 0.38938D0)
22040
22041* particle properties (BAMJET index convention)
22042 CHARACTER*8 ANAME
22043 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22044 & IICH(210),IIBAR(210),K1(210),K2(210)
22045
22046* VDM parameter for photon-nucleus interactions
22047 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22048
22049 S = Q2*(ONE-X)/X+AAM(1)**2
22050 ECM = SQRT(S)
22051
22052 IF (INTRGE(1).EQ.1) THEN
22053 AMLO2 = (3.0D0*AAM(13))**2
22054 ELSEIF (INTRGE(1).EQ.2) THEN
22055 AMLO2 = AAM(33)**2
22056 ELSE
22057 AMLO2 = AAM(96)**2
22058 ENDIF
22059 IF (INTRGE(2).EQ.1) THEN
22060 AMHI2 = S/TWO
22061 ELSEIF (INTRGE(2).EQ.2) THEN
22062 AMHI2 = S/4.0D0
22063 ELSE
22064 AMHI2 = S
22065 ENDIF
22066 AMHI20 = (ECM-AAM(1))**2
22067 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22068
22069 AM1C2 = 16.0D0
22070 AM2C2 = 121.0D0
22071 IF (AMHI2.LE.AM1C2) THEN
22072 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22073 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22074 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22075 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22076 ELSE
22077 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22078 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22079 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22080 ENDIF
22081
22082 RETURN
22083 END
22084
22085*$ CREATE DT_RM2.FOR
22086*COPY DT_RM2
22087*
22088*===RM2================================================================*
22089*
22090 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22091
22092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22093 SAVE
22094
22095 PARAMETER ( LINP = 10 ,
22096 & LOUT = 6 ,
22097 & LDAT = 9 )
22098
22099 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22100 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22101 & PI = TWOPI/TWO,
22102 & GEV2MB = 0.38938D0)
22103
22104* VDM parameter for photon-nucleus interactions
22105 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22106
22107 IF (RL2.LE.ZERO) THEN
22108 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22109 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22110 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22111 ELSE
22112 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22113 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22114 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22115 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22116 & +EPSPOL*(
22117 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22118 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22119 ENDIF
22120
22121 RETURN
22122 END
22123
22124*$ CREATE DT_SAM2.FOR
22125*COPY DT_SAM2
22126*
22127*===SAM2===============================================================*
22128*
22129 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22130
22131 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22132 SAVE
22133
22134 PARAMETER ( LINP = 10 ,
22135 & LOUT = 6 ,
22136 & LDAT = 9 )
22137
22138 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22139 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22140 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22141 & PI = TWOPI/TWO,
22142 & GEV2MB = 0.38938D0)
22143
22144* particle properties (BAMJET index convention)
22145 CHARACTER*8 ANAME
22146 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22147 & IICH(210),IIBAR(210),K1(210),K2(210)
22148
22149* VDM parameter for photon-nucleus interactions
22150 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22151
22152 S = ECM**2
22153 IF (INTRGE(1).EQ.1) THEN
22154 AMLO2 = (3.0D0*AAM(13))**2
22155 ELSEIF (INTRGE(1).EQ.2) THEN
22156 AMLO2 = AAM(33)**2
22157 ELSE
22158 AMLO2 = AAM(96)**2
22159 ENDIF
22160 IF (INTRGE(2).EQ.1) THEN
22161 AMHI2 = S/TWO
22162 ELSEIF (INTRGE(2).EQ.2) THEN
22163 AMHI2 = S/4.0D0
22164 ELSE
22165 AMHI2 = S
22166 ENDIF
22167 AMHI20 = (ECM-AAM(1))**2
22168 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22169
22170 AM1C2 = 16.0D0
22171 AM2C2 = 121.0D0
22172 YLO = LOG(AMLO2+Q2)
22173 YC1 = LOG(AM1C2+Q2)
22174 YC2 = LOG(AM2C2+Q2)
22175 YHI = LOG(AMHI2+Q2)
22176 IF (AMHI2.LE.AM1C2) THEN
22177 FACHI = TWO
22178 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22179 FACHI = TENTRD
22180 ELSE
22181 FACHI = ELVTRD
22182 ENDIF
22183
22184 1 CONTINUE
22185 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22186 IF (YSAM2.LE.YC1) THEN
22187 FAC = TWO
22188 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22189 FAC = TENTRD
22190 ELSE
22191 FAC = ELVTRD
22192 ENDIF
22193 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22194 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22195 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22196
22197 DT_SAM2 = EXP(YSAM2)-Q2
22198
22199 RETURN
22200 END
22201
22202*$ CREATE DT_CKMT.FOR
22203*COPY DT_CKMT
22204*
22205*===ckmt===============================================================*
22206*
22207 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22208 & F2,IPAR)
22209
22210************************************************************************
22211* This version dated 31.01.96 is written by S. Roesler *
22212************************************************************************
22213
22214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22215 SAVE
22216
22217 PARAMETER ( LINP = 10 ,
22218 & LOUT = 6 ,
22219 & LDAT = 9 )
22220
22221 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22222
22223 PARAMETER (Q02 = 2.0D0,
22224 & DQ2 = 10.05D0,
22225 & Q12 = Q02+DQ2)
22226
22227 DIMENSION PD(-6:6),SEA(3),VAL(2)
22228
22229 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22230 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22231 ADQ2 = LOG10(Q12)-LOG10(Q02)
22232 F2P = (F2Q1-F2Q0)/ADQ2
22233 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22234 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22235 F2PP = (F2PQ1-F2PQ0)/ADQ2
22236 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22237
22238 Q2 = MAX(SCALE**2.0D0,TINY10)
22239 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22240 IF (Q2.LT.Q02) THEN
22241 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22242 UPV = VAL(1)
22243 DNV = VAL(2)
22244 USEA = SEA(1)
22245 DSEA = SEA(2)
22246 STR = SEA(3)
22247 CHM = 0.0D0
22248 BOT = 0.0D0
22249 TOP = 0.0D0
22250 GL = GLU
22251 ELSE
22252 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22253 F2 = F2*SMOOTH
22254 UPV = PD(2)-PD(3)
22255 DNV = PD(1)-PD(3)
22256 USEA = PD(3)
22257 DSEA = PD(3)
22258 STR = PD(3)
22259 CHM = PD(4)
22260 BOT = PD(5)
22261 TOP = PD(6)
22262 GL = PD(0)
22263C UPV = UPV*SMOOTH
22264C DNV = DNV*SMOOTH
22265C USEA = USEA*SMOOTH
22266C DSEA = DSEA*SMOOTH
22267C STR = STR*SMOOTH
22268C CHM = CHM*SMOOTH
22269C GL = GL*SMOOTH
22270 ENDIF
22271
22272 RETURN
22273 END
22274C
22275
22276*$ CREATE DT_CKMTX.FOR
22277*COPY DT_CKMTX
22278 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22279C**********************************************************************
22280C
22281C PDF based on Regge theory, evolved with .... by ....
22282C
22283C input: IPAR 2212 proton (not installed)
22284C 45 Pomeron
22285C 100 Deuteron
22286C
22287C output: PD(-6:6) x*f(x) parton distribution functions
22288C (PDFLIB convention: d = PD(1), u = PD(2) )
22289C
22290C**********************************************************************
22291
22292 SAVE
22293 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22294
22295 PARAMETER ( LINP = 10 ,
22296 & LOUT = 6 ,
22297 & LDAT = 9 )
22298
22299 DIMENSION QQ(7)
22300C
22301 Q2=SNGL(SCALE2)
22302 Q1S=Q2
22303 XX=SNGL(X)
22304C QCD lambda for evolution
22305 OWLAM = 0.23D0
22306 OWLAM2=OWLAM**2
22307C Q0**2 for evolution
22308 Q02 = 2.D0
22309C
22310C
22311C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22312C q(6)=x*charm, q(7)=x*gluon
22313C
22314 SB=0.
22315 IF(Q2-Q02) 1,1,2
22316 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22317 1 CONTINUE
22318 IF(IPAR.EQ.2212) THEN
22319 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22320 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22321 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22322 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22323 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22324 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22325 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22326C ELSEIF (IPAR.EQ.45) THEN
22327C CALL CKMTPO(1,0,XX,SB,QQ(1))
22328C CALL CKMTPO(2,0,XX,SB,QQ(2))
22329C CALL CKMTPO(3,0,XX,SB,QQ(3))
22330C CALL CKMTPO(4,0,XX,SB,QQ(4))
22331C CALL CKMTPO(5,0,XX,SB,QQ(5))
22332C CALL CKMTPO(8,0,XX,SB,QQ(6))
22333C CALL CKMTPO(7,0,XX,SB,QQ(7))
22334 ELSEIF (IPAR.EQ.100) THEN
22335 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22336 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22337 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22338 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22339 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22340 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22341 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22342 ELSE
22343 WRITE(LOUT,'(1X,A,I4,A)')
22344 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22345 STOP
22346 ENDIF
22347C
22348 PD(-6) = 0.D0
22349 PD(-5) = 0.D0
22350 PD(-4) = DBLE(QQ(6))
22351 PD(-3) = DBLE(QQ(3))
22352 PD(-2) = DBLE(QQ(4))
22353 PD(-1) = DBLE(QQ(5))
22354 PD(0) = DBLE(QQ(7))
22355 PD(1) = DBLE(QQ(2))
22356 PD(2) = DBLE(QQ(1))
22357 PD(3) = DBLE(QQ(3))
22358 PD(4) = DBLE(QQ(6))
22359 PD(5) = 0.D0
22360 PD(6) = 0.D0
22361 IF(IPAR.EQ.45) THEN
22362 CDN = (PD(1)-PD(-1))/2.D0
22363 CUP = (PD(2)-PD(-2))/2.D0
22364 PD(-1) = PD(-1) + CDN
22365 PD(-2) = PD(-2) + CUP
22366 PD(1) = PD(-1)
22367 PD(2) = PD(-2)
22368 ENDIF
22369 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22370 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22371 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22372 END
22373C
22374
22375*$ CREATE DT_PDF0.FOR
22376*COPY DT_PDF0
22377*
22378*===pdf0===============================================================*
22379*
22380 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22381
22382************************************************************************
22383* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22384* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22385* IPAR = 2212 proton *
22386* = 100 deuteron *
22387* This version dated 31.01.96 is written by S. Roesler *
22388************************************************************************
22389
22390 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22391 SAVE
22392
22393 PARAMETER ( LINP = 10 ,
22394 & LOUT = 6 ,
22395 & LDAT = 9 )
22396
22397 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22398
22399 PARAMETER (
22400 & AA = 0.1502D0,
22401 & BBDEU = 1.2D0,
22402 & BUD = 0.754D0,
22403 & BDD = 0.4495D0,
22404 & BUP = 1.2064D0,
22405 & BDP = 0.1798D0,
22406 & DELTA0 = 0.07684D0,
22407 & D = 1.117D0,
22408 & C = 3.5489D0,
22409 & A = 0.2631D0,
22410 & B = 0.6452D0,
22411 & ALPHAR = 0.415D0,
22412 & E = 0.1D0
22413 & )
22414
22415 PARAMETER (NPOINT=16)
22416C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22417 DIMENSION SEA(3),VAL(2)
22418
22419 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22420 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22421* proton, deuteron
22422 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22423 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22424 SEA(1) = 0.75D0*SEA0
22425 SEA(2) = SEA(1)
22426 SEA(3) = SEA(1)
22427 VAL(1) = 9.0D0/4.0D0*VALU0
22428 VAL(2) = 9.0D0*VALD0
22429 GLU0 = SEA(1)/(1.0D0-X)
22430 F2 = SEA0+VALU0+VALD0
22431 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22432 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22433 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22434 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22435 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22436 STOP
22437 ENDIF
22438**PHOJET105a
22439C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22440**PHOJET112
22441
22442C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22443
22444**
22445C SUMQ = ZERO
22446C SUMG = ZERO
22447C DO 1 J=1,NPOINT
22448C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22449C VALU0 = 9.0D0/4.0D0*VALU0
22450C VALD0 = 9.0D0*VALD0
22451C SEA0 = 0.75D0*SEA0
22452C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22453C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22454C 1 CONTINUE
22455C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22456 ELSE
22457 WRITE(LOUT,'(1X,A,I4,A)')
22458 & 'PDF0: IPAR =',IPAR,' not implemented!'
22459 STOP
22460 ENDIF
22461
22462 RETURN
22463 END
22464
22465*$ CREATE DT_CKMTQ0.FOR
22466*COPY DT_CKMTQ0
22467*
22468*===ckmtq0=============================================================*
22469*
22470 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22471
22472************************************************************************
22473* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22474* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22475* IPAR = 2212 proton *
22476* = 100 deuteron *
22477* This version dated 31.01.96 is written by S. Roesler *
22478************************************************************************
22479
22480 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22481 SAVE
22482
22483 PARAMETER ( LINP = 10 ,
22484 & LOUT = 6 ,
22485 & LDAT = 9 )
22486
22487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22488
22489 PARAMETER (
22490 & AA = 0.1502D0,
22491 & BBDEU = 1.2D0,
22492 & BUD = 0.754D0,
22493 & BDD = 0.4495D0,
22494 & BUP = 1.2064D0,
22495 & BDP = 0.1798D0,
22496 & DELTA0 = 0.07684D0,
22497 & D = 1.117D0,
22498 & C = 3.5489D0,
22499 & A = 0.2631D0,
22500 & B = 0.6452D0,
22501 & ALPHAR = 0.415D0,
22502 & E = 0.1D0
22503 & )
22504
22505 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22506 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22507* proton, deuteron
22508 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22509 IF (IPAR.EQ.2212) THEN
22510 BU = BUP
22511 BD = BDP
22512 ELSE
22513 BU = BUD
22514 BD = BDD
22515 ENDIF
22516 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22517 & (Q2/(Q2+A))**(1.0D0+DELTA)
22518 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22519 & (Q2/(Q2+B))**(ALPHAR)
22520 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22521 & (Q2/(Q2+B))**(ALPHAR)
22522 ELSE
22523 WRITE(LOUT,'(1X,A,I4,A)')
22524 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22525 STOP
22526 ENDIF
22527 RETURN
22528 END
22529C
22530C
22531
22532*$ CREATE DT_CKMTDE.FOR
22533*COPY DT_CKMTDE
22534 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22535C
22536C**********************************************************************
22537C Deuteron - PDFs
22538C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22539C ANS = PDF(I)
22540C This version by S. Roesler, 30.01.96
22541C**********************************************************************
22542
22543 SAVE
22544 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22545 EQUIVALENCE (GF(1,1,1),DL(1))
22546 DATA DELTA/.13/
22547C
22548 DATA (DL(K),K= 1, 85) /
22549 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22550 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22551 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22552 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22553 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22554 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22555 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22556 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22557 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22558 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22559 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22560 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22561 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22562 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22563 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22564 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22565 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22566 DATA (DL(K),K= 86, 170) /
22567 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22568 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22569 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22570 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22571 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22572 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22573 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22574 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22575 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22576 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22577 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22578 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22581 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22582 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22583 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22584 DATA (DL(K),K= 171, 255) /
22585 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22586 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22587 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22588 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22589 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22590 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22591 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22592 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22593 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22594 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22595 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22596 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22597 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22598 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22599 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22600 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22601 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22602 DATA (DL(K),K= 256, 340) /
22603 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22604 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22605 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22606 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22607 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22608 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22609 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22610 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22611 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22612 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22615 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22616 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22617 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22618 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22619 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22620 DATA (DL(K),K= 341, 425) /
22621 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22622 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22623 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22624 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22625 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22626 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22627 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22628 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22629 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22630 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22631 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22632 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22633 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22634 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22635 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22636 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22637 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22638 DATA (DL(K),K= 426, 510) /
22639 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22640 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22641 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22642 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22643 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22644 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22645 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22646 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22647 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22649 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22650 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22651 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22652 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22653 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22654 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22655 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22656 DATA (DL(K),K= 511, 595) /
22657 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22658 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22659 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22660 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22661 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22662 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22663 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22664 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22665 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22666 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22667 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22668 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22669 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22670 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22671 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22672 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22673 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22674 DATA (DL(K),K= 596, 680) /
22675 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22676 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22677 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22678 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22679 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22680 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22681 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22683 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22684 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22685 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22686 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22687 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22688 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22689 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22690 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22691 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22692 DATA (DL(K),K= 681, 765) /
22693 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22694 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22695 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22696 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22697 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22698 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22699 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22700 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22701 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22702 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22703 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22704 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22705 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22706 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22707 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22708 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22709 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22710 DATA (DL(K),K= 766, 850) /
22711 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22712 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22713 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22714 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22715 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22717 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22718 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22719 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22720 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22721 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22722 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22723 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22724 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22725 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22726 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22727 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22728 DATA (DL(K),K= 851, 935) /
22729 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22730 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22731 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22732 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22733 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22734 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22735 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22736 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22737 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22738 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22739 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22740 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22741 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22742 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22743 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22745 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22746 DATA (DL(K),K= 936, 1020) /
22747 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22749 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22751 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22752 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22753 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22754 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22755 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22756 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22757 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22758 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22759 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22760 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22761 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22762 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22763 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22764 DATA (DL(K),K= 1021, 1105) /
22765 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22766 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22767 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22768 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22769 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22770 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22771 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22772 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22773 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22774 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22775 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22776 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22777 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22778 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22779 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22780 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22781 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22782 DATA (DL(K),K= 1106, 1190) /
22783 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22784 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22785 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22786 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22787 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22788 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22789 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22790 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22791 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22792 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22793 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22794 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22795 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22796 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22797 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22798 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22799 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22800 DATA (DL(K),K= 1191, 1275) /
22801 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22802 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22803 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22804 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22805 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22806 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22807 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22808 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22809 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22810 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22811 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22813 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22814 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22815 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22817 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22818 DATA (DL(K),K= 1276, 1360) /
22819 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22820 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22821 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22822 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22823 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22824 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22825 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22826 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22827 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22828 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22829 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22830 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22831 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22832 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22833 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22834 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22835 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22836 DATA (DL(K),K= 1361, 1445) /
22837 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22838 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22839 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22840 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22841 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22842 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22843 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22844 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22845 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22846 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22847 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22848 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22849 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22850 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22851 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22852 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22853 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22854 DATA (DL(K),K= 1446, 1530) /
22855 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22856 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22857 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22858 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22859 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22860 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22861 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22862 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22863 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22864 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22865 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22866 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22867 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22868 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22869 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22870 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22871 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22872 DATA (DL(K),K= 1531, 1615) /
22873 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22874 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22875 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22876 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22877 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22878 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22879 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22886 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22887 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22888 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22889 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22890 DATA (DL(K),K= 1616, 1700) /
22891 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22892 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22893 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22894 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22895 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22896 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22897 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22898 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22899 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22900 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22901 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22902 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22903 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22904 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22905 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22906 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22907 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22908 DATA (DL(K),K= 1701, 1785) /
22909 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22910 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22911 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22912 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22913 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22922 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22923 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22924 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22925 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22926 DATA (DL(K),K= 1786, 1870) /
22927 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22928 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22929 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22930 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22931 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22932 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22933 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22934 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22935 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22936 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22937 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22938 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22939 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22940 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22941 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22942 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22943 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22944 DATA (DL(K),K= 1871, 1955) /
22945 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22946 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22947 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22956 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22957 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22958 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22959 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22960 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22961 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22962 DATA (DL(K),K= 1956, 2040) /
22963 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22964 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22965 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22966 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22967 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22968 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22969 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22970 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22971 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22972 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22973 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22974 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22975 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22976 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22977 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22978 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22979 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22980 DATA (DL(K),K= 2041, 2125) /
22981 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22990 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22991 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22992 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22993 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22994 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22995 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22996 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22997 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22998 DATA (DL(K),K= 2126, 2210) /
22999 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23000 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23001 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23002 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23003 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23004 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23005 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23006 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23007 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23008 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23009 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23010 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23011 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23012 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23013 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23016 DATA (DL(K),K= 2211, 2295) /
23017 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23024 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23025 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23026 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23027 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23028 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23029 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23030 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23031 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23032 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23033 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23034 DATA (DL(K),K= 2296, 2380) /
23035 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23036 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23037 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23038 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23039 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23040 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23041 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23042 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23043 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23044 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23045 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23046 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23047 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23048 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23049 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23052 DATA (DL(K),K= 2381, 2465) /
23053 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23058 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23059 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23060 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23061 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23062 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23063 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23064 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23065 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23066 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23067 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23068 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23069 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23070 DATA (DL(K),K= 2466, 2550) /
23071 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23072 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23073 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23074 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23075 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23076 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23077 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23078 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23079 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23080 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23081 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23084 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23088 DATA (DL(K),K= 2551, 2635) /
23089 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23090 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23092 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23093 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23094 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23095 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23096 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23097 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23098 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23099 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23100 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23101 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23102 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23103 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23104 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23105 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23106 DATA (DL(K),K= 2636, 2720) /
23107 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23108 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23109 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23110 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23111 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23112 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23113 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23114 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23115 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23116 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23124 DATA (DL(K),K= 2721, 2805) /
23125 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23126 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23127 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23128 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23129 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23130 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23131 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23132 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23133 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23134 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23135 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23136 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23137 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23138 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23139 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23140 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23141 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23142 DATA (DL(K),K= 2806, 2890) /
23143 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23144 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23145 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23146 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23147 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23148 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23149 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23150 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23159 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23160 DATA (DL(K),K= 2891, 2975) /
23161 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23162 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23163 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23164 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23165 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23166 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23167 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23168 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23169 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23170 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23171 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23172 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23173 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23174 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23175 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23176 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23177 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23178 DATA (DL(K),K= 2976, 3060) /
23179 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23180 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23181 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23182 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23183 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23184 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23193 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23194 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23195 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23196 DATA (DL(K),K= 3061, 3145) /
23197 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23198 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23199 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23200 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23201 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23202 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23203 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23204 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23205 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23206 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23207 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23208 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23209 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23210 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23211 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23212 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23213 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23214 DATA (DL(K),K= 3146, 3230) /
23215 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23216 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23217 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23218 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23227 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23228 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23229 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23230 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23231 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23232 DATA (DL(K),K= 3231, 3315) /
23233 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23234 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23235 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23236 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23237 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23238 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23239 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23240 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23241 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23242 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23243 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23244 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23245 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23246 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23247 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23248 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23249 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23250 DATA (DL(K),K= 3316, 3400) /
23251 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23252 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23261 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23262 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23263 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23264 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23265 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23266 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23267 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23268 DATA (DL(K),K= 3401, 3485) /
23269 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23270 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23271 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23272 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23273 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23274 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23275 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23276 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23277 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23278 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23279 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23280 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23281 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23282 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23283 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23284 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23286 DATA (DL(K),K= 3486, 3570) /
23287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23295 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23296 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23297 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23298 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23299 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23300 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23301 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23302 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23303 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23304 DATA (DL(K),K= 3571, 3655) /
23305 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23306 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23307 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23308 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23309 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23310 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23311 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23312 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23313 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23314 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23315 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23316 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23317 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23318 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23322 DATA (DL(K),K= 3656, 3740) /
23323 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23329 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23330 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23331 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23332 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23333 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23334 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23335 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23336 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23337 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23338 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23339 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23340 DATA (DL(K),K= 3741, 3825) /
23341 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23342 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23343 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23344 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23345 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23346 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23347 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23348 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23349 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23350 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23351 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23352 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23355 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23358 DATA (DL(K),K= 3826, 3910) /
23359 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23363 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23364 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23365 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23366 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23367 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23368 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23369 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23370 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23371 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23372 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23373 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23374 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23375 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23376 DATA (DL(K),K= 3911, 3995) /
23377 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23378 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23379 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23380 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23381 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23382 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23383 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23384 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23385 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23386 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23390 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23394 DATA (DL(K),K= 3996, 4000) /
23395 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23396C
23397 ANS = 0.
23398 IF (X.GT.0.9985) RETURN
23399 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23400C
23401 IS = S/DELTA+1
23402 IS1 = IS+1
23403 DO 1 L=1,25
23404 KL = L+NDRV*25
23405 F1(L) = GF(I,IS,KL)
23406 F2(L) = GF(I,IS1,KL)
23407 1 CONTINUE
23408 A1 = DT_CKMTFF(X,F1)
23409 A2 = DT_CKMTFF(X,F2)
23410C A1=ALOG(A1)
23411C A2=ALOG(A2)
23412 S1 = (IS-1)*DELTA
23413 S2 = S1+DELTA
23414 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23415C ANS=EXP(ANS)
23416 RETURN
23417 END
23418C
23419C
23420
23421*$ CREATE DT_CKMTPR.FOR
23422*COPY DT_CKMTPR
23423 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23424C
23425C**********************************************************************
23426C Proton - PDFs
23427C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23428C ANS = PDF(I)
23429C This version by S. Roesler, 31.01.96
23430C**********************************************************************
23431
23432 SAVE
23433 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23434 EQUIVALENCE (GF(1,1,1),DL(1))
23435 DATA DELTA/.10/
23436C
23437 DATA (DL(K),K= 1, 85) /
23438 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23439 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23440 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23441 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23442 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23443 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23444 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23445 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23446 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23447 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23448 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23449 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23450 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23451 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23452 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23453 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23454 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23455 DATA (DL(K),K= 86, 170) /
23456 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23457 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23458 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23459 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23460 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23461 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23462 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23463 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23464 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23465 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23466 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23467 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23468 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23469 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23470 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23471 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23472 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23473 DATA (DL(K),K= 171, 255) /
23474 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23475 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23476 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23477 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23478 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23479 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23480 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23481 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23482 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23483 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23484 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23485 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23486 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23487 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23488 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23489 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23490 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23491 DATA (DL(K),K= 256, 340) /
23492 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23493 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23494 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23495 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23496 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23497 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23498 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23499 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23500 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23501 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23502 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23503 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23504 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23505 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23506 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23507 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23508 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23509 DATA (DL(K),K= 341, 425) /
23510 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23511 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23512 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23513 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23514 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23515 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23516 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23517 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23518 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23519 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23520 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23521 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23522 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23523 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23524 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23525 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23526 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23527 DATA (DL(K),K= 426, 510) /
23528 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23529 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23530 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23531 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23532 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23533 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23534 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23535 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23536 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23537 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23538 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23539 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23540 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23541 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23542 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23543 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23544 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23545 DATA (DL(K),K= 511, 595) /
23546 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23547 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23548 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23549 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23550 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23551 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23552 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23553 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23554 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23555 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23556 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23557 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23558 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23559 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23560 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23561 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23562 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23563 DATA (DL(K),K= 596, 680) /
23564 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23565 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23566 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23567 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23568 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23569 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23570 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23571 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23572 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23573 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23574 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23575 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23576 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23577 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23578 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23579 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23580 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23581 DATA (DL(K),K= 681, 765) /
23582 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23583 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23584 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23585 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23586 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23587 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23588 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23589 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23590 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23591 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23592 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23593 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23594 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23595 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23596 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23597 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23598 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23599 DATA (DL(K),K= 766, 850) /
23600 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23601 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23602 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23603 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23604 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23605 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23606 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23607 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23608 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23609 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23610 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23611 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23612 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23613 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23614 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23615 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23616 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23617 DATA (DL(K),K= 851, 935) /
23618 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23619 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23620 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23621 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23622 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23623 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23624 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23625 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23626 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23627 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23628 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23629 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23630 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23631 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23632 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23633 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23634 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23635 DATA (DL(K),K= 936, 1020) /
23636 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23637 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23638 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23639 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23640 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23641 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23642 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23643 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23644 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23645 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23646 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23647 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23648 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23649 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23650 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23651 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23652 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23653 DATA (DL(K),K= 1021, 1105) /
23654 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23655 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23656 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23657 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23658 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23659 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23660 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23661 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23662 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23663 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23664 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23665 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23666 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23667 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23668 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23669 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23670 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23671 DATA (DL(K),K= 1106, 1190) /
23672 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23673 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23674 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23675 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23676 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23677 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23678 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23679 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23680 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23681 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23682 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23683 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23684 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23685 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23686 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23687 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23688 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23689 DATA (DL(K),K= 1191, 1275) /
23690 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23691 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23692 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23693 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23694 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23695 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23696 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23697 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23698 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23699 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23700 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23701 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23702 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23703 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23704 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23705 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23706 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23707 DATA (DL(K),K= 1276, 1360) /
23708 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23709 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23710 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23711 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23712 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23713 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23714 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23715 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23716 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23717 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23718 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23719 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23720 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23721 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23722 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23723 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23724 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23725 DATA (DL(K),K= 1361, 1445) /
23726 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23727 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23728 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23729 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23730 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23731 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23732 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23733 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23734 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23735 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23736 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23737 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23738 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23739 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23740 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23741 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23742 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23743 DATA (DL(K),K= 1446, 1530) /
23744 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23745 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23746 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23747 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23748 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23749 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23750 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23751 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23752 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23753 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23754 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23755 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23756 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23757 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23758 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23759 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23760 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23761 DATA (DL(K),K= 1531, 1615) /
23762 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23763 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23764 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23765 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23766 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23767 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23768 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23769 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23770 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23771 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23772 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23773 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23774 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23775 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23776 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23777 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23778 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23779 DATA (DL(K),K= 1616, 1700) /
23780 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23781 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23782 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23783 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23784 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23785 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23786 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23787 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23788 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23789 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23790 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23791 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23792 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23793 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23794 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23795 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23796 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23797 DATA (DL(K),K= 1701, 1785) /
23798 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23799 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23800 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23801 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23802 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23803 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23804 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23805 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23806 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23807 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23808 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23809 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23810 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23811 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23812 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23813 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23814 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23815 DATA (DL(K),K= 1786, 1870) /
23816 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23817 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23818 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23819 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23820 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23821 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23822 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23823 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23824 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23825 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23826 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23827 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23828 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23829 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23830 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23831 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23832 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23833 DATA (DL(K),K= 1871, 1955) /
23834 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23835 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23836 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23837 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23838 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23839 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23840 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23841 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23842 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23843 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23844 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23845 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23846 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23847 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23848 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23849 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23850 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23851 DATA (DL(K),K= 1956, 2040) /
23852 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23853 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23854 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23855 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23856 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23857 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23858 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23859 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23860 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23861 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23862 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23863 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23864 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23865 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23866 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23867 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23868 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23869 DATA (DL(K),K= 2041, 2125) /
23870 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23871 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23872 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23873 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23874 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23875 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23876 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23878 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23879 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23880 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23881 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23882 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23883 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23884 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23885 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23886 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23887 DATA (DL(K),K= 2126, 2210) /
23888 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23889 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23890 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23891 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23892 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23893 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23894 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23895 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23896 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23897 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23898 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23899 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23900 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23901 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23902 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23903 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23904 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23905 DATA (DL(K),K= 2211, 2295) /
23906 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23907 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23908 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23909 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23910 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23912 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23913 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23914 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23915 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23916 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23917 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23918 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23919 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23920 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23921 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23922 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23923 DATA (DL(K),K= 2296, 2380) /
23924 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23925 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23926 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23927 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23928 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23929 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23930 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23931 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23932 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23933 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23934 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23935 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23936 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23937 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23938 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23939 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23940 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23941 DATA (DL(K),K= 2381, 2465) /
23942 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23943 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23944 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23946 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23947 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23948 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23949 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23950 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23951 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23952 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23953 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23954 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23955 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23956 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23957 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23958 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23959 DATA (DL(K),K= 2466, 2550) /
23960 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23961 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23962 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23963 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23964 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23965 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23966 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23967 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23968 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23969 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23970 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23971 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23972 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23973 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23974 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23975 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23976 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23977 DATA (DL(K),K= 2551, 2635) /
23978 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23980 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23981 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23982 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23983 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23984 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23985 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23986 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23987 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23988 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23989 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23990 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23991 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23992 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23993 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23994 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23995 DATA (DL(K),K= 2636, 2720) /
23996 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23997 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23998 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23999 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24000 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24001 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24002 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24003 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24004 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24005 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24006 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24007 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24008 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24009 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24010 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24011 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24012 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24013 DATA (DL(K),K= 2721, 2805) /
24014 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24015 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24016 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24017 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24018 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24019 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24020 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24021 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24022 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24023 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24024 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24025 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24026 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24027 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24028 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24029 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24030 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24031 DATA (DL(K),K= 2806, 2890) /
24032 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24033 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24034 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24035 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24036 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24037 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24038 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24039 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24040 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24041 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24042 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24043 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24044 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24045 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24047 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24048 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24049 DATA (DL(K),K= 2891, 2975) /
24050 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24051 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24052 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24053 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24054 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24055 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24056 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24057 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24058 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24059 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24060 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24061 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24062 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24063 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24064 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24065 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24066 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24067 DATA (DL(K),K= 2976, 3060) /
24068 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24069 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24070 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24071 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24072 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24073 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24074 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24075 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24076 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24077 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24078 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24079 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24080 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24081 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24082 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24083 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24084 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24085 DATA (DL(K),K= 3061, 3145) /
24086 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24087 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24088 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24089 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24090 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24091 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24092 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24093 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24094 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24095 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24096 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24097 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24098 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24099 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24100 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24101 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24102 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24103 DATA (DL(K),K= 3146, 3230) /
24104 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24105 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24106 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24107 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24108 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24109 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24110 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24111 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24112 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24113 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24115 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24116 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24117 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24118 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24119 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24120 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24121 DATA (DL(K),K= 3231, 3315) /
24122 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24123 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24124 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24125 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24126 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24127 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24128 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24129 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24130 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24131 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24132 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24133 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24134 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24135 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24136 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24137 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24138 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24139 DATA (DL(K),K= 3316, 3400) /
24140 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24141 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24142 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24143 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24144 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24145 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24146 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24147 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24149 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24150 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24151 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24152 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24153 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24154 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24155 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24156 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24157 DATA (DL(K),K= 3401, 3485) /
24158 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24159 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24160 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24161 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24162 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24163 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24164 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24165 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24166 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24167 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24168 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24169 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24170 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24171 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24172 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24173 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24174 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24175 DATA (DL(K),K= 3486, 3570) /
24176 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24177 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24178 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24179 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24180 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24181 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24183 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24184 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24185 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24186 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24187 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24188 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24189 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24190 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24191 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24192 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24193 DATA (DL(K),K= 3571, 3655) /
24194 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24195 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24196 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24197 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24198 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24199 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24200 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24201 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24202 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24203 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24204 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24205 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24206 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24207 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24208 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24209 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24210 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24211 DATA (DL(K),K= 3656, 3740) /
24212 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24213 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24214 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24215 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24217 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24218 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24219 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24220 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24221 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24222 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24223 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24224 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24225 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24226 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24227 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24228 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24229 DATA (DL(K),K= 3741, 3825) /
24230 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24231 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24232 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24233 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24234 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24235 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24236 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24237 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24238 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24239 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24240 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24241 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24242 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24243 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24244 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24245 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24246 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24247 DATA (DL(K),K= 3826, 3910) /
24248 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24249 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24251 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24252 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24253 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24254 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24255 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24256 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24257 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24258 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24259 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24260 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24261 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24262 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24263 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24264 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24265 DATA (DL(K),K= 3911, 3995) /
24266 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24267 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24268 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24269 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24270 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24271 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24272 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24273 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24274 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24275 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24276 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24277 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24278 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24279 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24280 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24281 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24282 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24283 DATA (DL(K),K= 3996, 4000) /
24284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24285C
24286 ANS = 0.
24287 IF (X.GT.0.9985) RETURN
24288 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24289C
24290 IS = S/DELTA+1
24291 IS1 = IS+1
24292 DO 1 L=1,25
24293 KL = L+NDRV*25
24294 F1(L) = GF(I,IS,KL)
24295 F2(L) = GF(I,IS1,KL)
24296 1 CONTINUE
24297 A1 = DT_CKMTFF(X,F1)
24298 A2 = DT_CKMTFF(X,F2)
24299C A1=ALOG(A1)
24300C A2=ALOG(A2)
24301 S1 = (IS-1)*DELTA
24302 S2 = S1+DELTA
24303 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24304C ANS=EXP(ANS)
24305 RETURN
24306 END
24307C
24308
24309*$ CREATE DT_CKMTFF.FOR
24310*COPY DT_CKMTFF
24311 FUNCTION DT_CKMTFF(X,FVL)
24312C**********************************************************************
24313C
24314C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24315C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24316C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24317C IN MAIN ROUTINE.
24318C
24319C**********************************************************************
24320
24321 SAVE
24322 DIMENSION FVL(25),XGRID(25)
24323 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24324 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24325C
24326 DT_CKMTFF=0.
24327 DO 1 I=1,NX
24328 IF(X.LT.XGRID(I)) GO TO 2
24329 1 CONTINUE
24330 2 I=I-1
24331 IF(I.EQ.0) THEN
24332 I=I+1
24333 ELSE IF(I.GT.23) THEN
24334 I=23
24335 ENDIF
24336 J=I+1
24337 K=J+1
24338 AXI=LOG(XGRID(I))
24339 BXI=LOG(1.-XGRID(I))
24340 AXJ=LOG(XGRID(J))
24341 BXJ=LOG(1.-XGRID(J))
24342 AXK=LOG(XGRID(K))
24343 BXK=LOG(1.-XGRID(K))
24344 FI=LOG(ABS(FVL(I)) +1.E-15)
24345 FJ=LOG(ABS(FVL(J)) +1.E-16)
24346 FK=LOG(ABS(FVL(K)) +1.E-17)
24347 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24348 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24349 $ BXI))/DET
24350 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24351 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24352 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24353 1RETURN
24354C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24355C WRITE(6,2001) X,FVL
24356C 2001 FORMAT(8E12.4)
24357C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24358C ENDIF
24359 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24360 RETURN
24361 END
24362
24363*$ CREATE DT_FLUINI.FOR
24364*COPY DT_FLUINI
24365*
24366*===fluini=============================================================*
24367*
24368 SUBROUTINE DT_FLUINI
24369
24370************************************************************************
24371* Initialisation of the nucleon-nucleon cross section fluctuation *
24372* treatment. The original version by J. Ranft. *
24373* This version dated 21.04.95 is revised by S. Roesler. *
24374************************************************************************
24375
24376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24377 SAVE
24378
24379 PARAMETER ( LINP = 10 ,
24380 & LOUT = 6 ,
24381 & LDAT = 9 )
24382
24383 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24384
24385 PARAMETER ( A = 0.1D0,
24386 & B = 0.893D0,
24387 & OM = 1.1D0,
24388 & N = 6,
24389 & DX = 0.003D0)
24390
24391* n-n cross section fluctuations
24392 PARAMETER (NBINS = 1000)
24393 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24394 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24395
24396 WRITE(LOUT,1000)
24397 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24398 & 'treated')
24399
24400 FLUSU = ZERO
24401 FLUSUU = ZERO
24402
24403 DO 1 I=1,NBINS
24404 X = DBLE(I)*DX
24405 FLUIX(I) = X
24406 FLUS = ((X-B)/(OM*B))**N
24407 IF (FLUS.LE.20.0D0) THEN
24408 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24409 ELSE
24410 FLUSI(I) = ZERO
24411 ENDIF
24412 FLUSU = FLUSU+FLUSI(I)
24413 1 CONTINUE
24414 DO 2 I=1,NBINS
24415 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24416 FLUSI(I) = FLUSUU
24417 2 CONTINUE
24418
24419C WRITE(LOUT,1001)
24420C1001 FORMAT(1X,'FLUCTUATIONS')
24421C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24422
24423 DO 3 I=1,NBINS
24424 AF = DBLE(I)*0.001D0
24425 DO 4 J=1,NBINS
24426 IF (AF.LE.FLUSI(J)) THEN
24427 FLUIXX(I) = FLUIX(J)
24428 GOTO 5
24429 ENDIF
24430 4 CONTINUE
24431 5 CONTINUE
24432 3 CONTINUE
24433 FLUIXX(1) = FLUIX(1)
24434 FLUIXX(NBINS) = FLUIX(NBINS)
24435
24436 RETURN
24437 END
24438
24439*$ CREATE DT_SIGTBL.FOR
24440*COPY DT_SIGTBL
24441*
24442*===sigtab=============================================================*
24443*
24444 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24445
24446************************************************************************
24447* This version dated 18.11.95 is written by S. Roesler *
24448************************************************************************
24449
24450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24451 SAVE
24452
24453 PARAMETER ( LINP = 10 ,
24454 & LOUT = 6 ,
24455 & LDAT = 9 )
24456
24457 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24458 & OHALF=0.5D0,ONE=1.0D0)
24459 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24460
24461 LOGICAL LINIT
24462
24463* particle properties (BAMJET index convention)
24464 CHARACTER*8 ANAME
24465 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24466 & IICH(210),IIBAR(210),K1(210),K2(210)
24467
24468 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24469 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24470 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24471 & 0, 0, 5/
24472 DATA LINIT /.FALSE./
24473
24474* precalculation and tabulation of elastic cross sections
24475 IF (ABS(MODE).EQ.1) THEN
24476 IF (MODE.EQ.1)
24477 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24478 PLABLX = LOG10(PLO)
24479 PLABHX = LOG10(PHI)
24480 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24481 DO 1 I=1,NBINS+1
24482 PLAB = PLABLX+DBLE(I-1)*DPLAB
24483 PLAB = 10**PLAB
24484 DO 2 IPROJ=1,23
24485 IDX = IDSIG(IPROJ)
24486 IF (IDX.GT.0) THEN
24487C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24488C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24489 DUMZER = ZERO
24490 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24491 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24492 ENDIF
24493 2 CONTINUE
24494 IF (MODE.EQ.1) THEN
24495 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24496 & (SIGEN(IDX,I),IDX=1,5)
24497 1000 FORMAT(F5.1,10F7.2)
24498 ENDIF
24499 1 CONTINUE
24500 IF (MODE.EQ.1) CLOSE(LDAT)
24501 LINIT = .TRUE.
24502 ELSE
24503 SIGE = -ONE
24504 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24505 & .AND.(PTOT.LE.PHI) ) THEN
24506 IDX = IDSIG(JP)
24507 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24508 PLABX = LOG10(PTOT)
24509 IF (PLABX.LE.PLABLX) THEN
24510 I1 = 1
24511 I2 = 1
24512 ELSEIF (PLABX.GE.PLABHX) THEN
24513 I1 = NBINS+1
24514 I2 = NBINS+1
24515 ELSE
24516 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24517 I2 = I1+1
24518 ENDIF
24519 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24520 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24521 PBIN = PLAB2X-PLAB1X
24522 IF (PBIN.GT.TINY10) THEN
24523 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24524 ELSE
24525 RATX = ZERO
24526 ENDIF
24527 IF (JT.EQ.1) THEN
24528 SIG1 = SIGEP(IDX,I1)
24529 SIG2 = SIGEP(IDX,I2)
24530 ELSE
24531 SIG1 = SIGEN(IDX,I1)
24532 SIG2 = SIGEN(IDX,I2)
24533 ENDIF
24534 SIGE = SIG1+RATX*(SIG2-SIG1)
24535 ENDIF
24536 ENDIF
24537 ENDIF
24538
24539 RETURN
24540 END
24541
24542*$ CREATE DT_XSTABL.FOR
24543*COPY DT_XSTABL
24544*
24545*===xstabl=============================================================*
24546*
24547 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24548
24549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24550 SAVE
24551
24552 PARAMETER ( LINP = 10 ,
24553 & LOUT = 6 ,
24554 & LDAT = 9 )
24555
24556 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24557 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24558 LOGICAL LLAB,LELOG,LQLOG
24559
24560* particle properties (BAMJET index convention)
24561 CHARACTER*8 ANAME
24562 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24563 & IICH(210),IIBAR(210),K1(210),K2(210)
24564
24565* properties of interacting particles
24566 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24567
24568 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24569
24570* Glauber formalism: cross sections
24571 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24572 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24573 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24574 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24575 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24576 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24577 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24578 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24579 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24580 & BSLOPE,NEBINI,NQBINI
24581
24582* emulsion treatment
24583 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24584 & NCOMPO,IEMUL
24585
24586 DIMENSION WHAT(6)
24587
24588 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24589 ELO = ABS(WHAT(1))
24590 EHI = ABS(WHAT(2))
24591 IF (ELO.GT.EHI) ELO = EHI
24592 LELOG = WHAT(3).LT.ZERO
24593 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24594 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24595 IF (LELOG) THEN
24596 AELO = LOG10(ELO)
24597 AEHI = LOG10(EHI)
24598 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24599 ENDIF
24600 Q2LO = WHAT(4)
24601 Q2HI = WHAT(5)
24602 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24603 LQLOG = WHAT(6).LT.ZERO
24604 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24605 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24606 IF (LQLOG) THEN
24607 AQ2LO = LOG10(Q2LO)
24608 AQ2HI = LOG10(Q2HI)
24609 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24610 ENDIF
24611
24612 IF ( ELO.EQ. EHI) NEBINS = 0
24613 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24614
24615 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24616 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24617 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24618 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24619 & ' A_p = ',I3,' A_t = ',I3,/)
24620
24621C IF (IJPROJ.NE.7) THEN
24622 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24623* normalize fractions of emulsion components
24624 IF (NCOMPO.GT.0) THEN
24625 SUMFRA = ZERO
24626 DO 10 I=1,NCOMPO
24627 SUMFRA = SUMFRA+EMUFRA(I)
24628 10 CONTINUE
24629 IF (SUMFRA.GT.ZERO) THEN
24630 DO 11 I=1,NCOMPO
24631 EMUFRA(I) = EMUFRA(I)/SUMFRA
24632 11 CONTINUE
24633 ENDIF
24634 ENDIF
24635C ELSE
24636C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24637C ENDIF
24638 DO 1 I=1,NEBINS+1
24639 IF (LELOG) THEN
24640 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24641 ELSE
24642 E = ELO+DBLE(I-1)*DEBINS
24643 ENDIF
24644 DO 2 J=1,NQBINS+1
24645 IF (LQLOG) THEN
24646 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24647 ELSE
24648 Q2 = Q2LO+DBLE(J-1)*DQBINS
24649 ENDIF
24650c IF (IJPROJ.NE.7) THEN
24651 IF (LLAB) THEN
24652 PLAB = ZERO
24653 ECM = ZERO
24654 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24655 ELSE
24656 ECM = E
24657 ENDIF
24658 XI = ZERO
24659 Q2I = ZERO
24660 IF (IJPROJ.EQ.7) Q2I = Q2
24661 IF (NCOMPO.GT.0) THEN
24662 DO 20 IC=1,NCOMPO
24663 IIT = IEMUMA(IC)
24664 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24665 20 CONTINUE
24666 ELSE
24667 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24668C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24669 ENDIF
24670 IF (NCOMPO.GT.0) THEN
24671 XTOT = ZERO
24672 ETOT = ZERO
24673 XELA = ZERO
24674 EELA = ZERO
24675 XQEP = ZERO
24676 EQEP = ZERO
24677 XQET = ZERO
24678 EQET = ZERO
24679 XQE2 = ZERO
24680 EQE2 = ZERO
24681 XPRO = ZERO
24682 EPRO = ZERO
24683 XPRO1= ZERO
24684 XDEL = ZERO
24685 EDEL = ZERO
24686 XDQE = ZERO
24687 EDQE = ZERO
24688 DO 21 IC=1,NCOMPO
24689 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24690 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24691 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24692 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24693 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24694 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24695 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24696 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24697 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24698 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24699 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24700 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24701 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24702 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24703 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24704 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24705 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24706 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24707 & -XSQE2(1,1,IC)
24708 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24709 21 CONTINUE
24710 ETOT = SQRT(ETOT)
24711 EELA = SQRT(EELA)
24712 EQEP = SQRT(EQEP)
24713 EQET = SQRT(EQET)
24714 EQE2 = SQRT(EQE2)
24715 EPRO = SQRT(EPRO)
24716 EDEL = SQRT(EDEL)
24717 EDQE = SQRT(EDQE)
24718 WRITE(LOUT,'(8E9.3)')
24719 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24720C WRITE(LOUT,'(4E9.3)')
24721C & E,XDEL,XDQE,XDEL+XDQE
24722 ELSE
24723 WRITE(LOUT,'(11E10.3)')
24724 & E,
24725 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24726 & XSQE2(1,1,1),XSPRO(1,1,1),
24727 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24728 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24729 & XSDEL(1,1,1)+XSDQE(1,1,1)
24730C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24731C & XSDEL(1,1,1)+XSDQE(1,1,1)
24732 ENDIF
24733c ELSE
24734c IF (LLAB) THEN
24735c IF (IT.GT.1) THEN
24736c IF (IXSQEL.EQ.0) THEN
24737cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24738cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24739c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24740c & STOT,ETOT,SIN,EIN,STOT0)
24741c IF (IRATIO.EQ.1) THEN
24742c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24743cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24744cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24745c*!! save cross sections
24746c STOTA = STOT
24747c ETOTA = ETOT
24748c STOTP = STGP
24749c*!!
24750c STOT = STOT/(DBLE(IT)*STGP)
24751c SIN = SIN/(DBLE(IT)*SIGP)
24752c STOT0 = STGP
24753c ETOT = ZERO
24754c EIN = ZERO
24755c ENDIF
24756c ELSE
24757c WRITE(LOUT,*)
24758c & ' XSTABL: qel. xs. not implemented for nuclei'
24759c STOP
24760c ENDIF
24761c ELSE
24762c ETOT = ZERO
24763c EIN = ZERO
24764c STOT0= ZERO
24765c IF (IXSQEL.EQ.0) THEN
24766c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24767c ELSE
24768c SIN = ZERO
24769c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24770c ENDIF
24771c ENDIF
24772c ELSE
24773c IF (IT.GT.1) THEN
24774c IF (IXSQEL.EQ.0) THEN
24775c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24776c & STOT,ETOT,SIN,EIN,STOT0)
24777c IF (IRATIO.EQ.1) THEN
24778c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24779c*!! save cross sections
24780c STOTA = STOT
24781c ETOTA = ETOT
24782c STOTP = STGP
24783c*!!
24784c STOT = STOT/(DBLE(IT)*STGP)
24785c SIN = SIN/(DBLE(IT)*SIGP)
24786c STOT0 = STGP
24787c ETOT = ZERO
24788c EIN = ZERO
24789c ENDIF
24790c ELSE
24791c WRITE(LOUT,*)
24792c & ' XSTABL: qel. xs. not implemented for nuclei'
24793c STOP
24794c ENDIF
24795c ELSE
24796c ETOT = ZERO
24797c EIN = ZERO
24798c STOT0= ZERO
24799c IF (IXSQEL.EQ.0) THEN
24800c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24801c ELSE
24802c SIN = ZERO
24803c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24804c ENDIF
24805c ENDIF
24806c ENDIF
24807cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24808cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24809cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24810c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24811c ENDIF
24812 2 CONTINUE
24813 1 CONTINUE
24814
24815 RETURN
24816 END
24817
24818*$ CREATE DT_TESTXS.FOR
24819*COPY DT_TESTXS
24820*
24821*===testxs=============================================================*
24822*
24823 SUBROUTINE DT_TESTXS
24824
24825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24826 SAVE
24827
24828 DIMENSION XSTOT(26,2),XSELA(26,2)
24829
24830 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24831 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24832 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24833 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24834 DUMECM = 0.0D0
24835 PLABL = 0.01D0
24836 PLABH = 10000.0D0
24837 NBINS = 120
24838 APLABL = LOG10(PLABL)
24839 APLABH = LOG10(PLABH)
24840 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24841 DO 1 I=1,NBINS+1
24842 ADP = APLABL+DBLE(I-1)*ADPLAB
24843 P = 10.0D0**ADP
24844 DO 2 J=1,26
24845 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24846 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24847 2 CONTINUE
24848 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24849 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24850 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24851 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24852 1 CONTINUE
24853 1000 FORMAT(F8.3,26F9.3)
24854
24855 RETURN
24856 END
24857************************************************************************
24858* *
24859* DTUNUC 2.0: library routines *
24860* processed by S. Roesler, 6.5.95 *
24861* *
24862************************************************************************
24863*
24864* 1) Handling of parton momenta
24865* SUBROUTINE MASHEL
24866* SUBROUTINE DFERMI
24867*
24868* 2) Handling of parton flavors and particle indices
24869* INTEGER FUNCTION IPDG2B
24870* INTEGER FUNCTION IB2PDG
24871* INTEGER FUNCTION IQUARK
24872* INTEGER FUNCTION IBJQUA
24873* INTEGER FUNCTION ICIHAD
24874* INTEGER FUNCTION IPDGHA
24875* INTEGER FUNCTION MCHAD
24876* SUBROUTINE FLAHAD
24877*
24878* 3) Energy-momentum and quantum number conservation check routines
24879* SUBROUTINE EMC1
24880* SUBROUTINE EMC2
24881* SUBROUTINE EVTEMC
24882* SUBROUTINE EVTFLC
24883* SUBROUTINE EVTCHG
24884*
24885* 4) Transformations
24886* SUBROUTINE LTINI
24887* SUBROUTINE LTRANS
24888* SUBROUTINE LTNUC
24889* SUBROUTINE DALTRA
24890* SUBROUTINE DTRAFO
24891* SUBROUTINE STTRAN
24892* SUBROUTINE MYTRAN
24893* SUBROUTINE LT2LAO
24894* SUBROUTINE LT2LAB
24895*
24896* 5) Sampling from distributions
24897* INTEGER FUNCTION NPOISS
24898* DOUBLE PRECISION FUNCTION SAMPXB
24899* DOUBLE PRECISION FUNCTION SAMPEX
24900* DOUBLE PRECISION FUNCTION SAMSQX
24901* DOUBLE PRECISION FUNCTION BETREJ
24902* DOUBLE PRECISION FUNCTION DGAMRN
24903* DOUBLE PRECISION FUNCTION DBETAR
24904* SUBROUTINE RANNOR
24905* SUBROUTINE DPOLI
24906* SUBROUTINE DSFECF
24907* SUBROUTINE RACO
24908*
24909* 6) Special functions, algorithms and service routines
24910* DOUBLE PRECISION FUNCTION YLAMB
24911* SUBROUTINE SORT
24912* SUBROUTINE SORT1
24913* SUBROUTINE DT_XTIME
24914*
24915* 7) Random number generator package
24916* DOUBLE PRECISION FUNCTION DT_RNDM
24917* SUBROUTINE DT_RNDMST
24918* SUBROUTINE DT_RNDMIN
24919* SUBROUTINE DT_RNDMOU
24920* SUBROUTINE DT_RNDMTE
24921*
24922************************************************************************
24923* *
24924* 1) Handling of parton momenta *
24925* *
24926************************************************************************
24927*$ CREATE DT_MASHEL.FOR
24928*COPY DT_MASHEL
24929*
24930*===mashel=============================================================*
24931*
24932 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24933
24934************************************************************************
24935* *
24936* rescaling of momenta of two partons to put both *
24937* on mass shell *
24938* *
24939* input: PA1,PA2 input momentum vectors *
24940* XM1,2 desired masses of particles afterwards *
24941* P1,P2 changed momentum vectors *
24942* *
24943* The original version is written by R. Engel. *
24944* This version dated 12.12.94 is modified by S. Roesler. *
24945************************************************************************
24946
24947 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24948 SAVE
24949
24950 PARAMETER ( LINP = 10 ,
24951 & LOUT = 6 ,
24952 & LDAT = 9 )
24953
24954 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24955
24956 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24957
24958 IREJ = 0
24959
24960* Lorentz transformation into system CMS
24961 PX = PA1(1)+PA2(1)
24962 PY = PA1(2)+PA2(2)
24963 PZ = PA1(3)+PA2(3)
24964 EE = PA1(4)+PA2(4)
24965 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24966 XMS = (EE-XPTOT)*(EE+XPTOT)
24967 IF(XMS.LT.(XM1+XM2)**2) THEN
24968C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24969 GOTO 9999
24970 ENDIF
24971 XMS = SQRT(XMS)
24972 BGX = PX/XMS
24973 BGY = PY/XMS
24974 BGZ = PZ/XMS
24975 GAM = EE/XMS
24976 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24977 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24978* rotation angles
24979 COD = P1(3)/PTOT1
24980C SID = SQRT((ONE-COD)*(ONE+COD))
24981 PPT = SQRT(P1(1)**2+P1(2)**2)
24982 SID = PPT/PTOT1
24983 COF = ONE
24984 SIF = ZERO
24985 IF(PTOT1*SID.GT.TINY10) THEN
24986 COF = P1(1)/(SID*PTOT1)
24987 SIF = P1(2)/(SID*PTOT1)
24988 ANORF = SQRT(COF*COF+SIF*SIF)
24989 COF = COF/ANORF
24990 SIF = SIF/ANORF
24991 ENDIF
24992* new CM momentum and energies (for masses XM1,XM2)
24993 XM12 = SIGN(XM1**2,XM1)
24994 XM22 = SIGN(XM2**2,XM2)
24995 SS = XMS**2
24996 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24997 EE1 = SQRT(XM12+PCMP**2)
24998 EE2 = XMS-EE1
24999* back rotation
25000 MODE = 1
25001 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25002 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25003 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25004 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25005 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25006* check consistency
25007 DEL = XMS*0.0001D0
25008 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25009 IDEV = 1
25010 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25011 IDEV = 2
25012 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25013 IDEV = 3
25014 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25015 IDEV = 4
25016 ELSE
25017 IDEV = 0
25018 ENDIF
25019 IF (IDEV.NE.0) THEN
25020 WRITE(LOUT,'(/1X,A,I3)')
25021 & 'MASHEL: inconsistent transformation',IDEV
25022 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25023 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25024 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25025 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25026 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25027 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25028 ENDIF
25029 RETURN
25030
25031 9999 CONTINUE
25032 IREJ = 1
25033 RETURN
25034 END
25035
25036*$ CREATE DT_DFERMI.FOR
25037*COPY DT_DFERMI
25038*
25039*===dfermi=============================================================*
25040*
25041 SUBROUTINE DT_DFERMI(GPART)
25042
25043************************************************************************
25044* Find largest of three random numbers. *
25045************************************************************************
25046
25047 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25048 SAVE
25049
25050 DIMENSION G(3)
25051
25052 DO 10 I=1,3
25053 G(I)=DT_RNDM(GPART)
25054 10 CONTINUE
25055 IF (G(3).LT.G(2)) GOTO 40
25056 IF (G(3).LT.G(1)) GOTO 30
25057 GPART = G(3)
25058 20 RETURN
25059 30 GPART = G(1)
25060 GOTO 20
25061 40 IF (G(2).LT.G(1)) GOTO 30
25062 GPART = G(2)
25063 GOTO 20
25064
25065 END
25066
25067************************************************************************
25068* *
25069* 2) Handling of parton flavors and particle indices *
25070* *
25071************************************************************************
25072*$ CREATE IDT_IPDG2B.FOR
25073*COPY IDT_IPDG2B
25074*
25075*===ipdg2b=============================================================*
25076*
25077 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25078
25079************************************************************************
25080* *
25081* conversion of quark numbering scheme *
25082* *
25083* input: PDG parton numbering *
25084* for diquarks: NN number of the constituent quark *
25085* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25086* *
25087* output: BAMJET particle codes *
25088* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25089* 2 d 8 a-d -2 a-d *
25090* 3 s 9 a-s -3 a-s *
25091* 4 c 10 a-c -4 a-c *
25092* *
25093* This is a modified version of ICONV2 written by R. Engel. *
25094* This version dated 13.12.94 is written by S. Roesler. *
25095************************************************************************
25096
25097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25098 SAVE
25099
25100 PARAMETER ( LINP = 10 ,
25101 & LOUT = 6 ,
25102 & LDAT = 9 )
25103
25104 IDA = ABS(ID)
25105* diquarks
25106 IF (IDA.GT.6) THEN
25107 KF = 3
25108 IF (IDA.GE.1000) KF = 4
25109 IDA = IDA/(10**(KF-NN))
25110 IDA = MOD(IDA,10)
25111 ENDIF
25112* exchange up and dn quarks
25113 IF (IDA.EQ.1) THEN
25114 IDA = 2
25115 ELSEIF (IDA.EQ.2) THEN
25116 IDA = 1
25117 ENDIF
25118* antiquarks
25119 IF (ID.LT.0) THEN
25120 IF (MODE.EQ.1) THEN
25121 IDA = IDA+6
25122 ELSE
25123 IDA = -IDA
25124 ENDIF
25125 ENDIF
25126 IDT_IPDG2B = IDA
25127
25128 RETURN
25129 END
25130
25131*$ CREATE IDT_IB2PDG.FOR
25132*COPY IDT_IB2PDG
25133*
25134*===ib2pdg=============================================================*
25135*
25136 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25137
25138************************************************************************
25139* *
25140* conversion of quark numbering scheme *
25141* *
25142* input: BAMJET particle codes *
25143* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25144* 2 d 8 a-d -2 a-d *
25145* 3 s 9 a-s -3 a-s *
25146* 4 c 10 a-c -4 a-c *
25147* *
25148* output: PDG parton numbering *
25149* *
25150* This version dated 13.12.94 is written by S. Roesler. *
25151************************************************************************
25152
25153 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25154 SAVE
25155
25156 PARAMETER ( LINP = 10 ,
25157 & LOUT = 6 ,
25158 & LDAT = 9 )
25159
25160 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25161 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25162 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25163 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25164 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25165
25166 IDA = ID1
25167 IDB = ID2
25168 IF (MODE.EQ.1) THEN
25169 IF (ID1.GT.6) IDA = -(ID1-6)
25170 IF (ID2.GT.6) IDB = -(ID2-6)
25171 ENDIF
25172 IF (ID2.EQ.0) THEN
25173 IDT_IB2PDG = IHKKQ(IDA)
25174 ELSE
25175 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25176 ENDIF
25177
25178 RETURN
25179 END
25180
25181*$ CREATE IDT_IQUARK.FOR
25182*COPY IDT_IQUARK
25183*
25184*===ipdgqu=============================================================*
25185*
25186 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25187
25188************************************************************************
25189* *
25190* quark contents according to PDG conventions *
25191* (random selection in case of quark mixing) *
25192* *
25193* input: IDBAMJ BAMJET particle code *
25194* K 1..3 quark number *
25195* *
25196* output: 1 d (anti --> neg.) *
25197* 2 u *
25198* 3 s *
25199* 4 c *
25200* *
25201* This version written by R. Engel. *
25202************************************************************************
25203
25204 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25205 SAVE
25206
25207 IQ = IDT_IBJQUA(K,IDBAMJ)
25208* quark-antiquark
25209 IF (IQ.GT.6) THEN
25210 IQ = 6-IQ
25211 ENDIF
25212* exchange of up and down
25213 IF (ABS(IQ).EQ.1) THEN
25214 IQ = SIGN(2,IQ)
25215 ELSEIF (ABS(IQ).EQ.2) THEN
25216 IQ = SIGN(1,IQ)
25217 ENDIF
25218 IDT_IQUARK = IQ
25219
25220 RETURN
25221 END
25222
25223*$ CREATE IDT_IBJQUA.FOR
25224*COPY IDT_IBJQUA
25225*
25226*===ibamq==============================================================*
25227*
25228 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25229
25230************************************************************************
25231* *
25232* quark contents according to BAMJET conventions *
25233* (random selection in case of quark mixing) *
25234* *
25235* input: IDBAMJ BAMJET particle code *
25236* K 1..3 quark number *
25237* *
25238* output: 1 u 7 u bar *
25239* 2 d 8 d bar *
25240* 3 s 9 s bar *
25241* 4 c 10 c bar *
25242* *
25243* This version written by R. Engel. *
25244************************************************************************
25245
25246 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25247 SAVE
25248
25249 DIMENSION ITAB(3,210)
25250 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25251 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25252 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25253 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25254*sr 10.1.94
25255C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25256 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25257*
25258 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25259*sr 10.1.94
25260C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25261 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25262*sr 10.1.94
25263C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25264 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25265*
25266 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25267 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25268 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25269 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25270 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25271 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25272 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25274 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25275 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25276 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25277 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25278 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25279 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25280 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25281 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25282 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25283 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25284 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25285 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25286 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25287 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25288 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25289 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25290 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25291 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25292 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25293 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25294 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25295 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25296 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25297 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25298 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25299 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25300 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25301 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25302 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25303 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25304 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25305 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25306 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25307 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25308 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25309 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25310 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25311 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25312 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25313 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25314 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25315 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25316 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25317 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25318 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25319 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25320 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25321 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25322 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25323 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25324 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25325 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25326 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25327 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25328 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25329 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25330 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25331 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25332 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25333 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25334 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25335 DATA IDOLD /0/
25336
25337 ONE = 1.0D0
25338 IF (ITAB(1,IDBAMJ).LE.200) THEN
25339 ID = ITAB(K,IDBAMJ)
25340 ELSE
25341 IF(IDOLD.NE.IDBAMJ) THEN
25342 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25343 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25344 ELSE
25345 IDOLD = 0
25346 ENDIF
25347 ID = ITAB(K,IT)
25348 ENDIF
25349 IDOLD = IDBAMJ
25350 IDT_IBJQUA = ID
25351
25352 RETURN
25353 END
25354
25355*$ CREATE IDT_ICIHAD.FOR
25356*COPY IDT_ICIHAD
25357*
25358*===icihad=============================================================*
25359*
25360 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25361
25362************************************************************************
25363* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25364* This is a completely new version dated 25.10.95. *
25365* Renamed to be not in conflict with the modified PHOJET-version *
25366************************************************************************
25367
25368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25369 SAVE
25370
25371* hadron index conversion (BAMJET <--> PDG)
25372 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25373 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25374 & IAMCIN(210)
25375
25376 IDT_ICIHAD = 0
25377 KPDG = ABS(MCIND)
25378 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25379 IF (MCIND.LT.0) THEN
25380 JSIGN = 1
25381 ELSE
25382 JSIGN = 2
25383 ENDIF
25384 IF (KPDG.GE.10000) THEN
25385 DO 1 I=1,19
25386 IDT_ICIHAD = IBAM5(JSIGN,I)
25387 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25388 IDT_ICIHAD = 0
25389 1 CONTINUE
25390 ELSEIF (KPDG.GE.1000) THEN
25391 DO 2 I=1,29
25392 IDT_ICIHAD = IBAM4(JSIGN,I)
25393 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25394 IDT_ICIHAD = 0
25395 2 CONTINUE
25396 ELSEIF (KPDG.GE.100) THEN
25397 DO 3 I=1,22
25398 IDT_ICIHAD = IBAM3(JSIGN,I)
25399 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25400 IDT_ICIHAD = 0
25401 3 CONTINUE
25402 ELSEIF (KPDG.GE.10) THEN
25403 DO 4 I=1,7
25404 IDT_ICIHAD = IBAM2(JSIGN,I)
25405 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25406 IDT_ICIHAD = 0
25407 4 CONTINUE
25408 ENDIF
25409 5 CONTINUE
25410
25411 RETURN
25412 END
25413
25414*$ CREATE IDT_IPDGHA.FOR
25415*COPY IDT_IPDGHA
25416*
25417*===ipdgha=============================================================*
25418*
25419 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25420
25421************************************************************************
25422* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25423* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25424* Renamed to be not in conflict with the modified PHOJET-version *
25425************************************************************************
25426
25427 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25428 SAVE
25429
25430* hadron index conversion (BAMJET <--> PDG)
25431 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25432 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25433 & IAMCIN(210)
25434
25435 IDT_IPDGHA = IAMCIN(MCIND)
25436
25437 RETURN
25438 END
25439
25440*$ CREATE DT_FLAHAD.FOR
25441*COPY DT_FLAHAD
25442*
25443*===flahad=============================================================*
25444*
25445 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25446
25447************************************************************************
25448* sampling of FLAvor composition for HADrons/photons *
25449* ID BAMJET-id of hadron *
25450* IF1,2,3 flavor content *
25451* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25452* Note: - u,d numbering as in BAMJET *
25453* - ID .le. 30 !! *
25454* This version dated 12.03.96 is written by S. Roesler *
25455************************************************************************
25456
25457 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25458 SAVE
25459
25460* auxiliary common for reggeon exchange (DTUNUC 1.x)
25461 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25462 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25463 & IQTCHR(-6:6),MQUARK(3,39)
25464
25465 DIMENSION JSEL(3,6)
25466 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25467
25468 ONE = 1.0D0
25469 IF (ID.EQ.7) THEN
25470* photon (charge dependent flavour sampling)
25471 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25472 IF (K.LE.4) THEN
25473 IF1 = 2
25474 IF2 = -2
25475 ELSE IF(K.EQ.5) THEN
25476 IF1 = 1
25477 IF2 = -1
25478 ELSE
25479 IF1 = 3
25480 IF2 = -3
25481 ENDIF
25482 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25483 K = IF1
25484 IF1 = IF2
25485 IF2 = K
25486 ENDIF
25487 IF3 = 0
25488 ELSE
25489* hadron
25490 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25491 IF1 = MQUARK(JSEL(1,IX),ID)
25492 IF2 = MQUARK(JSEL(2,IX),ID)
25493 IF3 = MQUARK(JSEL(3,IX),ID)
25494 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25495 IF1 = IF3
25496 IF3 = 0
25497 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25498 IF2 = IF3
25499 IF3 = 0
25500 ENDIF
25501 ENDIF
25502
25503 RETURN
25504 END
25505
25506*$ CREATE IDT_MCHAD.FOR
25507*COPY IDT_MCHAD
25508*
25509*===mchad==============================================================*
25510*
25511 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25512
25513************************************************************************
25514* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25515* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25516* *
25517* Last change 28.12.2006 by S. Roesler. *
25518************************************************************************
25519
25520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25521 SAVE
25522
25523 DIMENSION ITRANS(210)
25524 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25525 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25526 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25527 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25528 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25529 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25530 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25531
25532 IF ( ITDTU .GT. 0 ) THEN
25533 IDT_MCHAD = ITRANS(ITDTU)
25534 ELSE
25535 IDT_MCHAD = -1
25536 END IF
25537
25538 RETURN
25539 END
25540
25541************************************************************************
25542* *
25543* 3) Energy-momentum and quantum number conservation check routines *
25544* *
25545************************************************************************
25546*$ CREATE DT_EMC1.FOR
25547*COPY DT_EMC1
25548*
25549*===emc1===============================================================*
25550*
25551 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25552
25553************************************************************************
25554* This version dated 15.12.94 is written by S. Roesler *
25555************************************************************************
25556
25557 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25558 SAVE
25559
25560 PARAMETER ( LINP = 10 ,
25561 & LOUT = 6 ,
25562 & LDAT = 9 )
25563
25564 PARAMETER (TINY10=1.0D-10)
25565
25566 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25567
25568 IREJ = 0
25569
25570 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25571 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25572
25573 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25574 IF (MODE.EQ.1) THEN
25575 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25576 ELSEIF (MODE.EQ.2) THEN
25577 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25578 ENDIF
25579 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25580 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25581 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25582 ELSEIF (MODE.LT.0) THEN
25583 IF (MODE.EQ.-1) THEN
25584 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25585 ELSEIF (MODE.EQ.-2) THEN
25586 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25587 ENDIF
25588 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25589 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25590 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25591 ENDIF
25592
25593 IF (ABS(MODE).EQ.3) THEN
25594 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25595 IF (IREJ1.NE.0) GOTO 9999
25596 ENDIF
25597 RETURN
25598
25599 9999 CONTINUE
25600 IREJ = 1
25601 RETURN
25602 END
25603
25604*$ CREATE DT_EMC2.FOR
25605*COPY DT_EMC2
25606*
25607*===emc2===============================================================*
25608*
25609 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25610 & MODE,IPOS,IREJ)
25611
25612************************************************************************
25613* MODE = 1 energy-momentum cons. check *
25614* = 2 flavor-cons. check *
25615* = 3 energy-momentum & flavor cons. check *
25616* = 4 energy-momentum & charge cons. check *
25617* = 5 energy-momentum & flavor & charge cons. check *
25618* This version dated 16.01.95 is written by S. Roesler *
25619************************************************************************
25620
25621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25622 SAVE
25623
25624 PARAMETER ( LINP = 10 ,
25625 & LOUT = 6 ,
25626 & LDAT = 9 )
25627
25628 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25629
25630* event history
25631
25632 PARAMETER (NMXHKK=200000)
25633
25634 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25635 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25636 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25637
25638* extended event history
25639 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25640 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25641 & IHIST(2,NMXHKK)
25642
25643 IREJ = 0
25644 IREJ1 = 0
25645 IREJ2 = 0
25646 IREJ3 = 0
25647
25648 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25649 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25650 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25651 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25652 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25653 DO 1 I=1,NHKK
25654 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25655 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25656 & (ISTHKK(I).EQ.IP5)) THEN
25657 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25658 & .OR.(MODE.EQ.5))
25659 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25660 & 2,IDUM,IDUM)
25661 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25662 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25663 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25664 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25665 ENDIF
25666 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25667 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25668 & (ISTHKK(I).EQ.IN5)) THEN
25669 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25670 & .OR.(MODE.EQ.5))
25671 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25672 & 2,IDUM,IDUM)
25673 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25674 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25675 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25676 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25677 ENDIF
25678 1 CONTINUE
25679 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25680 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25681 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25682 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25683 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25684 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25685
25686 RETURN
25687
25688 9999 CONTINUE
25689 IREJ = 1
25690 RETURN
25691 END
25692
25693*$ CREATE DT_EVTEMC.FOR
25694*COPY DT_EVTEMC
25695*
25696*===evtemc=============================================================*
25697*
25698 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25699
25700************************************************************************
25701* This version dated 13.12.94 is written by S. Roesler *
25702************************************************************************
25703
25704 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25705 SAVE
25706
25707 PARAMETER ( LINP = 10 ,
25708 & LOUT = 6 ,
25709 & LDAT = 9 )
25710
25711 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25712 & ZERO=0.0D0)
25713
25714* event history
25715
25716 PARAMETER (NMXHKK=200000)
25717
25718 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25719 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25720 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25721
25722* flags for input different options
25723 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25724 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25725 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25726
25727 IREJ = 0
25728
25729 MODE = IMODE
25730 CHKLEV = TINY10
25731 IF (MODE.EQ.4) THEN
25732 CHKLEV = TINY2
25733 MODE = 3
25734 ELSEIF (MODE.EQ.5) THEN
25735 CHKLEV = TINY1
25736 MODE = 3
25737 ELSEIF (MODE.EQ.-1) THEN
25738 CHKLEV = EIO
25739 MODE = 3
25740 ENDIF
25741
25742 IF (ABS(MODE).EQ.3) THEN
25743 PXDEV = PX
25744 PYDEV = PY
25745 PZDEV = PZ
25746 EDEV = E
25747 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25748 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25749 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25750 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25751 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25752 & ' event ',NEVHKK,
25753 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25754 PX = 0.0D0
25755 PY = 0.0D0
25756 PZ = 0.0D0
25757 E = 0.0D0
25758 GOTO 9999
25759 ENDIF
25760 PX = 0.0D0
25761 PY = 0.0D0
25762 PZ = 0.0D0
25763 E = 0.0D0
25764 RETURN
25765 ENDIF
25766
25767 IF (MODE.EQ.1) THEN
25768 PX = 0.0D0
25769 PY = 0.0D0
25770 PZ = 0.0D0
25771 E = 0.0D0
25772 ENDIF
25773
25774 PX = PX+PXIO
25775 PY = PY+PYIO
25776 PZ = PZ+PZIO
25777 E = E+EIO
25778
25779 RETURN
25780
25781 9999 CONTINUE
25782 IREJ = 1
25783 RETURN
25784 END
25785
25786*$ CREATE DT_EVTFLC.FOR
25787*COPY DT_EVTFLC
25788*
25789*===evtflc=============================================================*
25790*
25791 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25792
25793************************************************************************
25794* Flavor conservation check. *
25795* ID identity of particle *
25796* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25797* = 2 ID for particle/resonance in BAMJET numbering scheme *
25798* = 3 ID for particle/resonance in PDG numbering scheme *
25799* MODE = 1 initialization and add ID *
25800* =-1 initialization and subtract ID *
25801* = 2 add ID *
25802* =-2 subtract ID *
25803* = 3 check flavor cons. *
25804* IPOS flag to give position of call of EVTFLC to output *
25805* unit in case of violation *
25806* This version dated 10.01.95 is written by S. Roesler *
25807************************************************************************
25808
25809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25810 SAVE
25811
25812 PARAMETER ( LINP = 10 ,
25813 & LOUT = 6 ,
25814 & LDAT = 9 )
25815
25816 PARAMETER (TINY10=1.0D-10)
25817
25818 IREJ = 0
25819
25820 IF (MODE.EQ.3) THEN
25821 IF (IFL.NE.0) THEN
25822 WRITE(LOUT,'(1X,A,I3,A,I3)')
25823 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25824 & ' ! IFL = ',IFL
25825 IFL = 0
25826 GOTO 9999
25827 ENDIF
25828 IFL = 0
25829 RETURN
25830 ENDIF
25831
25832 IF (MODE.EQ.1) IFL = 0
25833 IF (ID.EQ.0) RETURN
25834
25835 IF (ID1.EQ.1) THEN
25836 IDD = ABS(ID)
25837 NQ = 1
25838 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25839 IF (IDD.GE.1000) NQ = 3
25840 DO 1 I=1,NQ
25841 IFBAM = IDT_IPDG2B(ID,I,2)
25842 IF (ABS(IFBAM).EQ.1) THEN
25843 IFBAM = SIGN(2,IFBAM)
25844 ELSEIF (ABS(IFBAM).EQ.2) THEN
25845 IFBAM = SIGN(1,IFBAM)
25846 ENDIF
25847 IF (MODE.GT.0) THEN
25848 IFL = IFL+IFBAM
25849 ELSE
25850 IFL = IFL-IFBAM
25851 ENDIF
25852 1 CONTINUE
25853 RETURN
25854 ENDIF
25855
25856 IDD = ID
25857 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25858 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25859 DO 2 I=1,3
25860 IF (MODE.GT.0) THEN
25861 IFL = IFL+IDT_IQUARK(I,IDD)
25862 ELSE
25863 IFL = IFL-IDT_IQUARK(I,IDD)
25864 ENDIF
25865 2 CONTINUE
25866 ENDIF
25867 RETURN
25868
25869 9999 CONTINUE
25870 IREJ = 1
25871 RETURN
25872 END
25873
25874*$ CREATE DT_EVTCHG.FOR
25875*COPY DT_EVTCHG
25876*
25877*===evtchg=============================================================*
25878*
25879 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25880
25881************************************************************************
25882* Charge conservation check. *
25883* ID identity of particle (PDG-numbering scheme) *
25884* MODE = 1 initialization *
25885* =-2 subtract ID-charge *
25886* = 2 add ID-charge *
25887* = 3 check charge cons. *
25888* IPOS flag to give position of call of EVTCHG to output *
25889* unit in case of violation *
25890* This version dated 10.01.95 is written by S. Roesler *
25891* Last change: s.r. 21.01.01 *
25892************************************************************************
25893
25894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25895 SAVE
25896
25897 PARAMETER ( LINP = 10 ,
25898 & LOUT = 6 ,
25899 & LDAT = 9 )
25900
25901* event history
25902
25903 PARAMETER (NMXHKK=200000)
25904
25905 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25906 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25907 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25908
25909* particle properties (BAMJET index convention)
25910 CHARACTER*8 ANAME
25911 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25912 & IICH(210),IIBAR(210),K1(210),K2(210)
25913
25914 IREJ = 0
25915
25916 IF (MODE.EQ.1) THEN
25917 ICH = 0
25918 IBAR = 0
25919 RETURN
25920 ENDIF
25921
25922 IF (MODE.EQ.3) THEN
25923 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25924 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25925 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25926 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25927 ICH = 0
25928 IBAR = 0
25929 GOTO 9999
25930 ENDIF
25931 ICH = 0
25932 IBAR = 0
25933 RETURN
25934 ENDIF
25935
25936 IF (ID.EQ.0) RETURN
25937
25938 IDD = IDT_ICIHAD(ID)
25939* modification 21.1.01: use intrinsic phojet-functions to determine charge
25940* and baryon number
25941C IF (IDD.GT.0) THEN
25942C IF (MODE.EQ.2) THEN
25943C ICH = ICH+IICH(IDD)
25944C IBAR = IBAR+IIBAR(IDD)
25945C ELSEIF (MODE.EQ.-2) THEN
25946C ICH = ICH-IICH(IDD)
25947C IBAR = IBAR-IIBAR(IDD)
25948C ENDIF
25949C ELSE
25950C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25951C CALL DT_EVTOUT(4)
25952C STOP
25953C ENDIF
25954 IF (MODE.EQ.2) THEN
25955 ICH = ICH+IPHO_CHR3(ID,1)/3
25956 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25957 ELSEIF (MODE.EQ.-2) THEN
25958 ICH = ICH-IPHO_CHR3(ID,1)/3
25959 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25960 ENDIF
25961
25962 RETURN
25963
25964 9999 CONTINUE
25965 IREJ = 1
25966 RETURN
25967 END
25968
25969************************************************************************
25970* *
25971* 4) Transformations *
25972* *
25973************************************************************************
25974*$ CREATE DT_LTINI.FOR
25975*COPY DT_LTINI
25976*
25977*===ltini==============================================================*
25978*
25979 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25980
25981************************************************************************
25982* Initializations of Lorentz-transformations, calculation of Lorentz- *
25983* parameters. *
25984* This version dated 13.11.95 is written by S. Roesler. *
25985************************************************************************
25986
25987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25988 SAVE
25989
25990 PARAMETER ( LINP = 10 ,
25991 & LOUT = 6 ,
25992 & LDAT = 9 )
25993
25994 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25995 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25996
25997* Lorentz-parameters of the current interaction
25998 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25999 & UMO,PPCM,EPROJ,PPROJ
26000
26001* properties of photon/lepton projectiles
26002 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26003
26004* particle properties (BAMJET index convention)
26005 CHARACTER*8 ANAME
26006 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26007 & IICH(210),IIBAR(210),K1(210),K2(210)
26008
26009* nucleon-nucleon event-generator
26010 CHARACTER*8 CMODEL
26011 LOGICAL LPHOIN
26012 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26013
26014 Q2 = VIRT
26015 IDP = IDPR
26016 IF (MCGENE.NE.3) THEN
26017* lepton-projectiles and PHOJET: initialize real photon instead
26018 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26019 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26020 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26021 IDP = 7
26022 Q2 = ZERO
26023 ENDIF
26024 ENDIF
26025 IDT = IDTA
26026 EPN = EPN0
26027 PPN = PPN0
26028 ECM = ECM0
26029 AMP = AAM(IDP)-SQRT(ABS(Q2))
26030 AMT = AAM(IDT)
26031 AMP2 = SIGN(AMP**2,AMP)
26032 AMT2 = AMT**2
26033 IF (ECM0.GT.ZERO) THEN
26034 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26035 IF (AMP2.GT.ZERO) THEN
26036 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26037 ELSE
26038 PPN = SQRT(EPN**2-AMP2)
26039 ENDIF
26040 ELSE
26041 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26042 IF (IDP.EQ.7) EPN = ABS(EPN)
26043 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26044 IF (AMP2.GT.ZERO) THEN
26045 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26046 ELSE
26047 PPN = SQRT(EPN**2-AMP2)
26048 ENDIF
26049 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26050 IF (AMP2.GT.ZERO) THEN
26051 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26052 ELSE
26053 EPN = SQRT(PPN**2+AMP2)
26054 ENDIF
26055 ENDIF
26056 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26057 ENDIF
26058 UMO = ECM
26059 EPROJ = EPN
26060 PPROJ = PPN
26061 IF (AMP2.GT.ZERO) THEN
26062 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26063 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26064 ELSE
26065 ETARG = TINY10
26066 PTARG = TINY10
26067 ENDIF
26068* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26069 IF (IDP.EQ.7) THEN
26070 PGAMM(1) = ZERO
26071 PGAMM(2) = ZERO
26072 AMGAM = AMP
26073 AMGAM2 = AMP2
26074 IF (ECM0.GT.ZERO) THEN
26075 S = ECM0**2
26076 ELSE
26077 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26078 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26079 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26080 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26081 ENDIF
26082 ENDIF
26083 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26084 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26085 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26086 IF (MODE.EQ.1) THEN
26087 PNUCL(1) = ZERO
26088 PNUCL(2) = ZERO
26089 PNUCL(3) = -PGAMM(3)
26090 PNUCL(4) = SQRT(S)-PGAMM(4)
26091 ENDIF
26092 ENDIF
26093 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26094 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26095 PLEPT0(1) = ZERO
26096 PLEPT0(2) = ZERO
26097* neglect lepton masses
26098C AMLPT2 = AAM(IDPR)**2
26099 AMLPT2 = ZERO
26100*
26101 IF (ECM0.GT.ZERO) THEN
26102 S = ECM0**2
26103 ELSE
26104 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26105 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26106 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26107 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26108 ENDIF
26109 ENDIF
26110 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26111 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26112 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26113 PNUCL(1) = ZERO
26114 PNUCL(2) = ZERO
26115 PNUCL(3) = -PLEPT0(3)
26116 PNUCL(4) = SQRT(S)-PLEPT0(4)
26117 ENDIF
26118* Lorentz-parameter for transformation Lab. - projectile rest system
26119 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26120 GALAB = TINY10
26121 BGLAB = TINY10
26122 BLAB = TINY10
26123 ELSE
26124 GALAB = EPROJ/AMP
26125 BGLAB = PPROJ/AMP
26126 BLAB = BGLAB/GALAB
26127 ENDIF
26128* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26129 IF (IDP.EQ.7) THEN
26130 GACMS(1) = TINY10
26131 BGCMS(1) = TINY10
26132 ELSE
26133 GACMS(1) = (ETARG+AMP)/UMO
26134 BGCMS(1) = PTARG/UMO
26135 ENDIF
26136* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26137 GACMS(2) = (EPROJ+AMT)/UMO
26138 BGCMS(2) = PPROJ/UMO
26139 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26140
26141 EPN0 = EPN
26142 PPN0 = PPN
26143 ECM0 = ECM
26144
26145 RETURN
26146 END
26147
26148*$ CREATE DT_LTRANS.FOR
26149*COPY DT_LTRANS
26150*
26151*===ltrans=============================================================*
26152*
26153 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26154
26155************************************************************************
26156* Lorentz-transformations. *
26157* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26158* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26159* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26160* This version dated 01.11.95 is written by S. Roesler. *
26161************************************************************************
26162
26163 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26164 SAVE
26165
26166 PARAMETER ( LINP = 10 ,
26167 & LOUT = 6 ,
26168 & LDAT = 9 )
26169
26170 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26171
26172 PARAMETER (SQTINF=1.0D+15)
26173
26174* particle properties (BAMJET index convention)
26175 CHARACTER*8 ANAME
26176 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26177 & IICH(210),IIBAR(210),K1(210),K2(210)
26178
26179 PXO = PXI
26180 PYO = PYI
26181 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26182
26183* check particle mass for consistency (numerical rounding errors)
26184 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26185 AMO2 = (PEO-PO)*(PEO+PO)
26186 AMORQ2 = AAM(ID)**2
26187 AMDIF2 = ABS(AMO2-AMORQ2)
26188 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26189 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26190 PEO = PEO+DELTA
26191 PO1 = PO -DELTA
26192 PXO = PXO*PO1/PO
26193 PYO = PYO*PO1/PO
26194 PZO = PZO*PO1/PO
26195C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26196 ENDIF
26197
26198 RETURN
26199 END
26200
26201*$ CREATE DT_LTNUC.FOR
26202*COPY DT_LTNUC
26203*
26204*===ltnuc==============================================================*
26205*
26206 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26207
26208************************************************************************
26209* Lorentz-transformations. *
26210* PIN longitudnal momentum (input) *
26211* EIN energy (input) *
26212* POUT transformed long. momentum (output) *
26213* EOUT transformed energy (output) *
26214* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26215* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26216* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26217* This version dated 01.11.95 is written by S. Roesler. *
26218************************************************************************
26219
26220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26221 SAVE
26222
26223 PARAMETER ( LINP = 10 ,
26224 & LOUT = 6 ,
26225 & LDAT = 9 )
26226
26227 PARAMETER (ZERO=0.0D0)
26228
26229* Lorentz-parameters of the current interaction
26230 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26231 & UMO,PPCM,EPROJ,PPROJ
26232
26233 BDUM1 = ZERO
26234 BDUM2 = ZERO
26235 PDUM1 = ZERO
26236 PDUM2 = ZERO
26237 IF (ABS(MODE).EQ.1) THEN
26238 BG = -SIGN(BGLAB,DBLE(MODE))
26239 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26240 & DUM1,DUM2,DUM3,POUT,EOUT)
26241 ELSEIF (ABS(MODE).EQ.2) THEN
26242 BG = SIGN(BGCMS(1),DBLE(MODE))
26243 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26244 & DUM1,DUM2,DUM3,POUT,EOUT)
26245 ELSEIF (ABS(MODE).EQ.3) THEN
26246 BG = -SIGN(BGCMS(2),DBLE(MODE))
26247 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26248 & DUM1,DUM2,DUM3,POUT,EOUT)
26249 ELSE
26250 WRITE(LOUT,1000) MODE
26251 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26252 EOUT = EIN
26253 POUT = PIN
26254 ENDIF
26255
26256 RETURN
26257 END
26258
26259*$ CREATE DT_DALTRA.FOR
26260*COPY DT_DALTRA
26261*
26262*===daltra=============================================================*
26263*
26264 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26265
26266************************************************************************
26267* Arbitrary Lorentz-transformation. *
26268* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26269************************************************************************
26270
26271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26272 SAVE
26273 PARAMETER (ONE=1.0D0)
26274
26275 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26276 PE = EP/(GA+ONE)+EC
26277 PX = PCX+BGX*PE
26278 PY = PCY+BGY*PE
26279 PZ = PCZ+BGZ*PE
26280 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26281 E = GA*EC+EP
26282
26283 RETURN
26284 END
26285
26286*$ CREATE DT_DTRAFO.FOR
26287*COPY DT_DTRAFO
26288*
26289*====dtrafo============================================================*
26290*
26291 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26292 & PL,CXL,CYL,CZL,EL)
26293
26294C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26295
26296 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26297 SAVE
26298
26299 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26300 SID = SQRT(1.D0-COD*COD)
26301 PLX = P*SID*COF
26302 PLY = P*SID*SIF
26303 PCMZ = P*COD
26304 PLZ = GAM*PCMZ+BGAM*ECM
26305 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26306 EL = GAM*ECM+BGAM*PCMZ
26307C ROTATION INTO THE ORIGINAL DIRECTION
26308 COZ = PLZ/PL
26309 SIZ = SQRT(1.D0-COZ**2)
26310 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26311
26312 RETURN
26313 END
26314
26315*$ CREATE DT_STTRAN.FOR
26316*COPY DT_STTRAN
26317*
26318*====sttran============================================================*
26319*
26320 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26321
26322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26323 SAVE
26324 DATA ANGLSQ/1.D-30/
26325************************************************************************
26326* VERSION BY J. RANFT *
26327* LEIPZIG *
26328* *
26329* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26330* *
26331* INPUT VARIABLES: *
26332* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26333* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26334* ANGLE OF "SCATTERING" *
26335* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26336* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26337* OF "SCATTERING" *
26338* *
26339* OUTPUT VARIABLES: *
26340* X,Y,Z = NEW DIRECTION COSINES *
26341* *
26342* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26343************************************************************************
26344*
26345*
26346* Changed by A. Ferrari
26347*
26348* IF (ABS(XO)-0.0001D0) 1,1,2
26349* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26350* 3 CONTINUE
26351 A = XO**2 + YO**2
26352 IF ( A .LT. ANGLSQ ) THEN
26353 X=SDE*CFE
26354 Y=SDE*SFE
26355 Z=CDE*ZO
26356 ELSE
26357 XI=SDE*CFE
26358 YI=SDE*SFE
26359 ZI=CDE
26360 A=SQRT(A)
26361 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26362 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26363 Z=A*YI+ZO*ZI
26364 ENDIF
26365
26366 RETURN
26367 END
26368
26369*$ CREATE DT_MYTRAN.FOR
26370*COPY DT_MYTRAN
26371*
26372*===mytran=============================================================*
26373*
26374 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26375
26376************************************************************************
26377* This subroutine rotates the coordinate frame *
26378* a) theta around y *
26379* b) phi around z if IMODE = 1 *
26380* *
26381* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26382* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26383* z' 0 0 1 -sin(th) 0 cos(th) z *
26384* *
26385* and vice versa if IMODE = 0. *
26386* This version dated 5.4.94 is based on the original version DTRAN *
26387* by J. Ranft and is written by S. Roesler. *
26388************************************************************************
26389
26390 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26391 SAVE
26392
26393 PARAMETER ( LINP = 10 ,
26394 & LOUT = 6 ,
26395 & LDAT = 9 )
26396
26397 IF (IMODE.EQ.1) THEN
26398 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26399 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26400 Z=-SDE *XO +CDE *ZO
26401 ELSE
26402 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26403 Y= -SFE*XO+CFE*YO
26404 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26405 ENDIF
26406 RETURN
26407 END
26408
26409*$ CREATE DT_LT2LAO.FOR
26410*COPY DT_LT2LAO
26411*
26412*===lt2lab=============================================================*
26413*
26414 SUBROUTINE DT_LT2LAO
26415
26416************************************************************************
26417* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26418* for final state particles/fragments defined in nucleon-nucleon-cms *
26419* and transforms them back to the lab. *
26420* This version dated 16.11.95 is written by S. Roesler *
26421************************************************************************
26422
26423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26424 SAVE
26425
26426 PARAMETER ( LINP = 10 ,
26427 & LOUT = 6 ,
26428 & LDAT = 9 )
26429
26430* event history
26431
26432 PARAMETER (NMXHKK=200000)
26433
26434 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26435 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26436 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26437
26438* extended event history
26439 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26440 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26441 & IHIST(2,NMXHKK)
26442
26443 NEND = NHKK
26444 NPOINT(5) = NHKK+1
26445 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26446 DO 1 I=NPOINT(4),NEND
26447C DO 1 I=1,NEND
26448 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26449 & (ISTHKK(I).EQ.1001)) THEN
26450 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26451 NOB = NOBAM(I)
26452 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26453 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26454 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26455 ISTHKK(I) = 3*ISTHKK(I)
26456 NOBAM(NHKK) = NOB
26457 ELSE
26458 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26459 ISTHKK(I) = SIGN(3,ISTHKK(I))
26460 ENDIF
26461 JDAHKK(1,I) = NHKK
26462 ENDIF
26463 1 CONTINUE
26464
26465 RETURN
26466 END
26467
26468*$ CREATE DT_LT2LAB.FOR
26469*COPY DT_LT2LAB
26470*
26471*===lt2lab=============================================================*
26472*
26473 SUBROUTINE DT_LT2LAB
26474
26475************************************************************************
26476* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26477* for final state particles/fragments defined in nucleon-nucleon-cms *
26478* and transforms them to the lab. *
26479* This version dated 07.01.96 is written by S. Roesler *
26480************************************************************************
26481
26482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26483 SAVE
26484
26485 PARAMETER ( LINP = 10 ,
26486 & LOUT = 6 ,
26487 & LDAT = 9 )
26488
26489* event history
26490
26491 PARAMETER (NMXHKK=200000)
26492
26493 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26494 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26495 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26496
26497* extended event history
26498 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26499 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26500 & IHIST(2,NMXHKK)
26501
26502 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26503 DO 1 I=NPOINT(4),NHKK
26504 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26505 & (ISTHKK(I).EQ.1001)) THEN
26506 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26507 PHKK(3,I) = PZ
26508 PHKK(4,I) = PE
26509 ENDIF
26510 1 CONTINUE
26511
26512 RETURN
26513 END
26514
26515************************************************************************
26516* *
26517* 5) Sampling from distributions *
26518* *
26519************************************************************************
26520*$ CREATE IDT_NPOISS.FOR
26521*COPY IDT_NPOISS
26522*
26523*===npoiss=============================================================*
26524*
26525 INTEGER FUNCTION IDT_NPOISS(AVN)
26526
26527************************************************************************
26528* Sample according to Poisson distribution with Poisson parameter AVN. *
26529* The original version written by J. Ranft. *
26530* This version dated 11.1.95 is written by S. Roesler. *
26531************************************************************************
26532
26533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26534 SAVE
26535
26536 PARAMETER ( LINP = 10 ,
26537 & LOUT = 6 ,
26538 & LDAT = 9 )
26539
26540 EXPAVN = EXP(-AVN)
26541 K = 1
26542 A = 1.0D0
26543
26544 10 CONTINUE
26545 A = DT_RNDM(A)*A
26546 IF (A.GE.EXPAVN) THEN
26547 K = K+1
26548 GOTO 10
26549 ENDIF
26550 IDT_NPOISS = K-1
26551
26552 RETURN
26553 END
26554
26555*$ CREATE DT_SAMPXB.FOR
26556*COPY DT_SAMPXB
26557*
26558*===sampxb=============================================================*
26559*
26560 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26561
26562************************************************************************
26563* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26564* Processed by S. Roesler, 6.5.95 *
26565************************************************************************
26566
26567 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26568 SAVE
26569 PARAMETER (TWO=2.0D0)
26570
26571 A1 = LOG(X1+SQRT(X1**2+B**2))
26572 A2 = LOG(X2+SQRT(X2**2+B**2))
26573 AN = A2-A1
26574 A = AN*DT_RNDM(A1)+A1
26575 BB = EXP(A)
26576 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26577
26578 RETURN
26579 END
26580
26581*$ CREATE DT_SAMPEX.FOR
26582*COPY DT_SAMPEX
26583*
26584*===sampex=============================================================*
26585*
26586 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26587
26588************************************************************************
26589* Sampling from f(x)=1./x between x1 and x2. *
26590* Processed by S. Roesler, 6.5.95 *
26591************************************************************************
26592
26593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26594 SAVE
26595 PARAMETER (ONE=1.0D0)
26596
26597 R = DT_RNDM(X1)
26598 AL1 = LOG(X1)
26599 AL2 = LOG(X2)
26600 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26601
26602 RETURN
26603 END
26604
26605*$ CREATE DT_SAMSQX.FOR
26606*COPY DT_SAMSQX
26607*
26608*===samsqx=============================================================*
26609*
26610 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26611
26612************************************************************************
26613* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26614* Processed by S. Roesler, 6.5.95 *
26615************************************************************************
26616
26617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26618 SAVE
26619 PARAMETER (ONE=1.0D0)
26620
26621 R = DT_RNDM(X1)
26622 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26623
26624 RETURN
26625 END
26626
26627*$ CREATE DT_SAMPLW.FOR
26628*COPY DT_SAMPLW
26629*
26630*===samplw=============================================================*
26631*
26632 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26633
26634************************************************************************
26635* Sampling from f(x)=1/x^b between x_min and x_max. *
26636* S. Roesler, 18.4.98 *
26637************************************************************************
26638
26639 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26640 SAVE
26641 PARAMETER (ONE=1.0D0)
26642
26643 R = DT_RNDM(B)
26644 IF (B.EQ.ONE) THEN
26645 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26646 ELSE
26647 ONEMB = ONE-B
26648 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26649 ENDIF
26650
26651 RETURN
26652 END
26653
26654*$ CREATE DT_BETREJ.FOR
26655*COPY DT_BETREJ
26656*
26657*===betrej=============================================================*
26658*
26659 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26660
26661 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26662 SAVE
26663
26664 PARAMETER ( LINP = 10 ,
26665 & LOUT = 6 ,
26666 & LDAT = 9 )
26667
26668 PARAMETER (ONE=1.0D0)
26669
26670 IF (XMIN.GE.XMAX)THEN
26671 WRITE (LOUT,500) XMIN,XMAX
26672 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26673 STOP
26674 ENDIF
26675
26676 10 CONTINUE
26677 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26678 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26679 YY = BETMAX*DT_RNDM(XX)
26680 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26681 IF (YY.GT.BETXX) GOTO 10
26682 DT_BETREJ = XX
26683
26684 RETURN
26685 END
26686
26687*$ CREATE DT_DGAMRN.FOR
26688*COPY DT_DGAMRN
26689*
26690*===dgamrn=============================================================*
26691*
26692 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26693
26694************************************************************************
26695* Sampling from Gamma-distribution. *
26696* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26697* Processed by S. Roesler, 6.5.95 *
26698************************************************************************
26699
26700 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26701 SAVE
26702 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26703
26704 NCOU = 0
26705 N = INT(ETA)
26706 F = ETA-DBLE(N)
26707 IF (F.EQ.ZERO) GOTO 20
26708 10 R = DT_RNDM(F)
26709 NCOU = NCOU+1
26710 IF (NCOU.GE.11) GOTO 20
26711 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26712 YYY = LOG(DT_RNDM(R)+TINY9)/F
26713 IF (ABS(YYY).GT.50.0D0) GOTO 20
26714 Y = EXP(YYY)
26715 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26716 GOTO 40
26717 20 Y = 0.0D0
26718 GOTO 50
26719 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26720 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26721 40 IF (N.EQ.0) GOTO 70
26722 50 Z = 1.0D0
26723 DO 60 I = 1,N
26724 60 Z = Z*DT_RNDM(Z)
26725 Y = Y-LOG(Z+TINY9)
26726 70 DT_DGAMRN = Y/ALAM
26727
26728 RETURN
26729 END
26730
26731*$ CREATE DT_DBETAR.FOR
26732*COPY DT_DBETAR
26733*
26734*===dbetar=============================================================*
26735*
26736 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26737
26738************************************************************************
26739* Sampling from Beta -distribution between 0.0 and 1.0 *
26740* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26741* Processed by S. Roesler, 6.5.95 *
26742************************************************************************
26743
26744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26745 SAVE
26746
26747 Y = DT_DGAMRN(1.0D0,GAM)
26748 Z = DT_DGAMRN(1.0D0,ETA)
26749 DT_DBETAR = Y/(Y+Z)
26750
26751 RETURN
26752 END
26753
26754*$ CREATE DT_RANNOR.FOR
26755*COPY DT_RANNOR
26756*
26757*===rannor=============================================================*
26758*
26759 SUBROUTINE DT_RANNOR(X,Y)
26760
26761************************************************************************
26762* Sampling from Gaussian distribution. *
26763* Processed by S. Roesler, 6.5.95 *
26764************************************************************************
26765
26766 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26767 SAVE
26768 PARAMETER (TINY10=1.0D-10)
26769
26770 CALL DT_DSFECF(SFE,CFE)
26771 V = MAX(TINY10,DT_RNDM(X))
26772 A = SQRT(-2.D0*LOG(V))
26773 X = A*SFE
26774 Y = A*CFE
26775
26776 RETURN
26777 END
26778
26779*$ CREATE DT_DPOLI.FOR
26780*COPY DT_DPOLI
26781*
26782*===dpoli==============================================================*
26783*
26784 SUBROUTINE DT_DPOLI(CS,SI)
26785
26786 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26787 SAVE
26788
26789 U = DT_RNDM(CS)
26790 CS = DT_RNDM(U)
26791 IF (U.LT.0.5D0) CS=-CS
26792 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26793
26794 RETURN
26795 END
26796
26797*$ CREATE DT_DSFECF.FOR
26798*COPY DT_DSFECF
26799*
26800*===dsfecf=============================================================*
26801*
26802 SUBROUTINE DT_DSFECF(SFE,CFE)
26803
26804 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26805 SAVE
26806 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26807
26808 1 CONTINUE
26809 X = DT_RNDM(SFE)
26810 Y = DT_RNDM(X)
26811 XX = X*X
26812 YY = Y*Y
26813 XY = XX+YY
26814 IF (XY.GT.ONE) GOTO 1
26815 CFE = (XX-YY)/XY
26816 SFE = TWO*X*Y/XY
26817 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26818 RETURN
26819 END
26820
26821*$ CREATE DT_RACO.FOR
26822*COPY DT_RACO
26823*
26824*===raco===============================================================*
26825*
26826 SUBROUTINE DT_RACO(WX,WY,WZ)
26827
26828************************************************************************
26829* Direction cosines of random uniform (isotropic) direction in three *
26830* dimensional space *
26831* Processed by S. Roesler, 20.11.95 *
26832************************************************************************
26833
26834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26835 SAVE
26836 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26837
26838 10 CONTINUE
26839 X = TWO*DT_RNDM(WX)-ONE
26840 Y = DT_RNDM(X)
26841 X2 = X*X
26842 Y2 = Y*Y
26843 IF (X2+Y2.GT.ONE) GOTO 10
26844
26845 CFE = (X2-Y2)/(X2+Y2)
26846 SFE = TWO*X*Y/(X2+Y2)
26847* z = 1/2 [ 1 + cos (theta) ]
26848 Z = DT_RNDM(X)
26849* 1/2 sin (theta)
26850 WZ = SQRT(Z*(ONE-Z))
26851 WX = TWO*WZ*CFE
26852 WY = TWO*WZ*SFE
26853 WZ = TWO*Z-ONE
26854
26855 RETURN
26856 END
26857
26858************************************************************************
26859* *
26860* 6) Special functions, algorithms and service routines *
26861* *
26862************************************************************************
26863*$ CREATE DT_YLAMB.FOR
26864*COPY DT_YLAMB
26865*
26866*===ylamb==============================================================*
26867*
26868 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26869
26870************************************************************************
26871* *
26872* auxiliary function for three particle decay mode *
26873* (standard LAMBDA**(1/2) function) *
26874* *
26875* Adopted from an original version written by R. Engel. *
26876* This version dated 12.12.94 is written by S. Roesler. *
26877************************************************************************
26878
26879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26880 SAVE
26881
26882 YZ = Y-Z
26883 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26884 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26885 DT_YLAMB = SQRT(XLAM)
26886
26887 RETURN
26888 END
26889
26890*$ CREATE DT_SORT.FOR
26891*COPY DT_SORT
26892*
26893*===sort1==============================================================*
26894*
26895 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26896
26897************************************************************************
26898* This subroutine sorts entries in A in increasing/decreasing order *
26899* of A(3,i). *
26900* MODE = 1 increasing in A(3,i=1..N) *
26901* = 2 decreasing in A(3,i=1..N) *
26902* This version dated 21.04.95 is revised by S. Roesler *
26903************************************************************************
26904
26905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26906 SAVE
26907
26908 DIMENSION A(3,N)
26909
26910 M = I1
26911 10 CONTINUE
26912 M = I1-1
26913 IF (M.LE.0) RETURN
26914 L = 0
26915 DO 20 I=I0,M
26916 J = I+1
26917 IF (MODE.EQ.1) THEN
26918 IF (A(3,I).LE.A(3,J)) GOTO 20
26919 ELSE
26920 IF (A(3,I).GE.A(3,J)) GOTO 20
26921 ENDIF
26922 B = A(3,I)
26923 C = A(1,I)
26924 D = A(2,I)
26925 A(3,I) = A(3,J)
26926 A(2,I) = A(2,J)
26927 A(1,I) = A(1,J)
26928 A(3,J) = B
26929 A(1,J) = C
26930 A(2,J) = D
26931 L = 1
26932 20 CONTINUE
26933 IF (L.EQ.1) GOTO 10
26934
26935 RETURN
26936 END
26937
26938*$ CREATE DT_SORT1.FOR
26939*COPY DT_SORT1
26940*
26941*===sort1==============================================================*
26942*
26943 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26944
26945************************************************************************
26946* This subroutine sorts entries in A in increasing/decreasing order *
26947* of A(i). *
26948* MODE = 1 increasing in A(i=1..N) *
26949* = 2 decreasing in A(i=1..N) *
26950* This version dated 21.04.95 is revised by S. Roesler *
26951************************************************************************
26952
26953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26954 SAVE
26955
26956 DIMENSION A(N),IDX(N)
26957
26958 M = I1
26959 10 CONTINUE
26960 M = I1-1
26961 IF (M.LE.0) RETURN
26962 L = 0
26963 DO 20 I=I0,M
26964 J = I+1
26965 IF (MODE.EQ.1) THEN
26966 IF (A(I).LE.A(J)) GOTO 20
26967 ELSE
26968 IF (A(I).GE.A(J)) GOTO 20
26969 ENDIF
26970 B = A(I)
26971 A(I) = A(J)
26972 A(J) = B
26973 IX = IDX(I)
26974 IDX(I) = IDX(J)
26975 IDX(J) = IX
26976 L = 1
26977 20 CONTINUE
26978 IF (L.EQ.1) GOTO 10
26979
26980 RETURN
26981 END
26982
26983*$ CREATE DT_XTIME.FOR
26984*COPY DT_XTIME
26985*
26986*===xtime==============================================================*
26987*
26988 SUBROUTINE DT_XTIME
26989
26990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26991 SAVE
26992
26993 PARAMETER ( LINP = 10 ,
26994 & LOUT = 6 ,
26995 & LDAT = 9 )
26996
26997 CHARACTER DAT*9,TIM*11
26998
26999 DAT = ' '
27000 TIM = ' '
27001C CALL GETDAT(IYEAR,IMONTH,IDAY)
27002C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27003
27004C CALL DATE(DAT)
27005C CALL TIME(TIM)
27006C WRITE(LOUT,1000) DAT,TIM
27007 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27008
27009 RETURN
27010 END
27011
27012************************************************************************
27013* *
27014* 7) Random number generator package *
27015* *
27016* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27017* SERVICE ROUTINES. *
27018* THE ALGORITHM IS FROM *
27019* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27020* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27021* IMPLEMENTATION BY K. HAHN DEC. 88, *
27022* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27023* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27024* THE PERIOD IS ABOUT 2**144, *
27025* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27026* THE PACKAGE CONTAINS *
27027* FUNCTION DT_RNDM(I) : GENERATOR *
27028* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27029* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27030* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27031* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27032*--- *
27033* FUNCTION DT_RNDM(I) *
27034* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27035* I - DUMMY VARIABLE, NOT USED *
27036* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27037* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27038* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27039* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27040* 12,34,56 ARE THE STANDARD VALUES *
27041* NB1 MUST BE IN 1..168 *
27042* 78 IS THE STANDARD VALUE *
27043* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27044* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27045* AS AFTER THE LAST DT_RNDMOU CALL ) *
27046* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27047* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27048* TAKES SEED FROM GENERATOR *
27049* U(97),C,CD,CM,I,J - SEED VALUES *
27050* SUBROUTINE DT_RNDMTE(IO) *
27051* TEST OF THE GENERATOR *
27052* IO - DEFINES OUTPUT *
27053* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27054* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27055* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27056* SAME STATUS *
27057* AS BEFORE CALL OF DT_RNDMTE *
27058************************************************************************
27059*$ CREATE DT_RNDM.FOR
27060*COPY DT_RNDM
27061*
27062*===rndm===============================================================*
27063*
27064c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27065c$$$
27066c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27067c$$$ SAVE
27068c$$$
27069c$$$* counter of calls to random number generator
27070c$$$* uncomment if needed
27071c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27072c$$$C LOGICAL LFIRST
27073c$$$C DATA LFIRST /.TRUE./
27074c$$$
27075c$$$* counter of calls to random number generator
27076c$$$* uncomment if needed
27077c$$$C IF (LFIRST) THEN
27078c$$$C IRNCT0 = 0
27079c$$$C IRNCT1 = 0
27080c$$$C LFIRST = .FALSE.
27081c$$$C ENDIF
27082c$$$
27083c$$$ DT_RNDM = FLRNDM(VDUMMY)
27084c$$$* counter of calls to random number generator
27085c$$$* uncomment if needed
27086c$$$C IRNCT1 = IRNCT1+1
27087c$$$
27088c$$$ RETURN
27089c$$$ END
27090c$$$
27091c$$$*$ CREATE DT_RNDMST.FOR
27092c$$$*COPY DT_RNDMST
27093c$$$*
27094c$$$*===rndmst=============================================================*
27095c$$$*
27096c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27097c$$$
27098c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27099c$$$ SAVE
27100c$$$
27101c$$$* random number generator
27102c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27103c$$$
27104c$$$ MA1 = NA1
27105c$$$ MA2 = NA2
27106c$$$ MA3 = NA3
27107c$$$ MB1 = NB1
27108c$$$ I = 97
27109c$$$ J = 33
27110c$$$ DO 20 II2 = 1,97
27111c$$$ S = 0
27112c$$$ T = 0.5D0
27113c$$$ DO 10 II1 = 1,24
27114c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27115c$$$ MA1 = MA2
27116c$$$ MA2 = MA3
27117c$$$ MA3 = MAT
27118c$$$ MB1 = MOD(53*MB1+1,169)
27119c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27120c$$$ 10 T = 0.5D0*T
27121c$$$ 20 U(II2) = S
27122c$$$ C = 362436.0D0/16777216.0D0
27123c$$$ CD = 7654321.0D0/16777216.0D0
27124c$$$ CM = 16777213.0D0/16777216.0D0
27125c$$$ RETURN
27126c$$$ END
27127c$$$
27128c$$$*$ CREATE DT_RNDMIN.FOR
27129c$$$*COPY DT_RNDMIN
27130c$$$*
27131c$$$*===rndmin=============================================================*
27132c$$$*
27133c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27134c$$$
27135c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27136c$$$ SAVE
27137c$$$
27138c$$$* random number generator
27139c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27140c$$$
27141c$$$ DIMENSION UIN(97)
27142c$$$
27143c$$$ DO 10 KKK = 1,97
27144c$$$ 10 U(KKK) = UIN(KKK)
27145c$$$ C = CIN
27146c$$$ CD = CDIN
27147c$$$ CM = CMIN
27148c$$$ I = IIN
27149c$$$ J = JIN
27150c$$$
27151c$$$ RETURN
27152c$$$ END
27153c$$$
27154c$$$*$ CREATE DT_RNDMOU.FOR
27155c$$$*COPY DT_RNDMOU
27156c$$$*
27157c$$$*===rndmou=============================================================*
27158c$$$*
27159c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27160c$$$
27161c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27162c$$$ SAVE
27163c$$$
27164c$$$* random number generator
27165c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27166c$$$
27167c$$$ DIMENSION UOUT(97)
27168c$$$
27169c$$$ DO 10 KKK = 1,97
27170c$$$ 10 UOUT(KKK) = U(KKK)
27171c$$$ COUT = C
27172c$$$ CDOUT = CD
27173c$$$ CMOUT = CM
27174c$$$ IOUT = I
27175c$$$ JOUT = J
27176c$$$
27177c$$$ RETURN
27178c$$$ END
27179c$$$
27180c$$$*$ CREATE DT_RNDMTE.FOR
27181c$$$*COPY DT_RNDMTE
27182c$$$*
27183c$$$*===rndmte=============================================================*
27184c$$$*
27185c$$$ SUBROUTINE DT_RNDMTE(IO)
27186c$$$
27187c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27188c$$$ SAVE
27189c$$$
27190c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27191c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27192c$$$ +8354498.D0, 10633180.D0/
27193c$$$
27194c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27195c$$$ CALL DT_RNDMST(12,34,56,78)
27196c$$$ DO 10 II1 = 1,20000
27197c$$$ 10 XX = DT_RNDM(XX)
27198c$$$ SD = 0.0D0
27199c$$$ DO 20 II2 = 1,6
27200c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27201c$$$ D(II2) = X(II2)-U(II2)
27202c$$$ 20 SD = SD+D(II2)
27203c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27204c$$$**sr 24.01.95
27205c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27206c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27207c$$$C WRITE(6,1000)
27208c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27209c$$$ & ' passed')
27210c$$$ ENDIF
27211c$$$**
27212c$$$ RETURN
27213c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27214c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27215c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27216c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27217c$$$ END
27218*
27219*$ CREATE PHO_RNDM.FOR
27220*COPY PHO_RNDM
27221*
27222*===pho_rndm===========================================================*
27223*
27224 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27225
27226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27227 SAVE
27228
27229 PHO_RNDM = DT_RNDM(DUMMY)
27230
27231 RETURN
27232 END
27233
27234*$ CREATE PYR.FOR
27235*COPY PYR
27236*
27237*===pyr================================================================*
27238*
27239 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27240
27241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27242 SAVE
27243
27244 DUMMY = DBLE(IDUMMY)
27245 PYR = DT_RNDM(DUMMY)
27246
27247 RETURN
27248 END
27249*$ CREATE DT_TITLE.FOR
27250*COPY DT_TITLE
27251*
27252*===title==============================================================*
27253*
27254 SUBROUTINE DT_TITLE
27255
27256 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27257 SAVE
27258
27259 PARAMETER ( LINP = 10 ,
27260 & LOUT = 6 ,
27261 & LDAT = 9 )
27262
27263 CHARACTER*6 CVERSI
27264 CHARACTER*11 CCHANG
27265 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27266
27267 CALL DT_XTIME
27268 WRITE(LOUT,1000) CVERSI,CCHANG
27269 1000 FORMAT(1X,'+-------------------------------------------------',
27270 & '----------------------+',/,
27271 & 1X,'|',71X,'|',/,
27272 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27273 & 1X,'|',71X,'|',/,
27274 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27275 & 1X,'|',71X,'|',/,
27276 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27277 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27278 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27279C & 1X,'|',71X,'|',/,
27280C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27281C & 17X,'|',/,
27282 & 1X,'|',71X,'|',/,
27283 & 1X,'+-------------------------------------------------',
27284 & '----------------------+',/,
27285 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27286 & 'Stefan.Roesler@cern.ch |',/,
27287 & 1X,'+-------------------------------------------------',
27288 & '----------------------+',/)
27289
27290 RETURN
27291 END
27292
27293*$ CREATE DT_EVTINI.FOR
27294*COPY DT_EVTINI
27295*
27296*===evtini=============================================================*
27297*
27298 SUBROUTINE DT_EVTINI
27299
27300************************************************************************
27301* Initialization of DTEVT1. *
27302* This version dated 15.01.94 is written by S. Roesler *
27303************************************************************************
27304
27305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27306 SAVE
27307
27308 PARAMETER ( LINP = 10 ,
27309 & LOUT = 6 ,
27310 & LDAT = 9 )
27311
27312* event history
27313
27314 PARAMETER (NMXHKK=200000)
27315
27316 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27317 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27318 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27319
27320* extended event history
27321 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27322 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27323 & IHIST(2,NMXHKK)
27324
27325* event flag
27326 COMMON /DTEVNO/ NEVENT,ICASCA
27327
27328 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27329
27330* emulsion treatment
27331 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27332 & NCOMPO,IEMUL
27333
27334* initialization of DTEVT1/DTEVT2
27335 NEND = NHKK
27336 IF (NEVENT.EQ.1) NEND = NMXHKK
27337 NHKK = 0
27338 NEVHKK = NEVENT
27339 DO 1 I=1,NEND
27340 ISTHKK(I) = 0
27341 IDHKK(I) = 0
27342 JMOHKK(1,I) = 0
27343 JMOHKK(2,I) = 0
27344 JDAHKK(1,I) = 0
27345 JDAHKK(2,I) = 0
27346 IDRES(I) = 0
27347 IDXRES(I) = 0
27348 NOBAM(I) = 0
27349 IDCH(I) = 0
27350 IHIST(1,I) = 0
27351 IHIST(2,I) = 0
27352 DO 2 J=1,4
27353 PHKK(J,I) = 0.0D0
27354 VHKK(J,I) = 0.0D0
27355 WHKK(J,I) = 0.0D0
27356 2 CONTINUE
27357 PHKK(5,I) = 0.0D0
27358 1 CONTINUE
27359 DO 3 I=1,10
27360 NPOINT(I) = 0
27361 3 CONTINUE
27362 CALL DT_CHASTA(-1)
27363
27364C* initialization of DTLTRA
27365C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27366
27367 RETURN
27368 END
27369
27370*$ CREATE DT_STATIS.FOR
27371*COPY DT_STATIS
27372*
27373*===statis=============================================================*
27374*
27375 SUBROUTINE DT_STATIS(MODE)
27376
27377************************************************************************
27378* Initialization and output of run-statistics. *
27379* MODE = 1 initialization *
27380* = 2 output *
27381* This version dated 23.01.94 is written by S. Roesler *
27382************************************************************************
27383
27384 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27385 SAVE
27386
27387 PARAMETER ( LINP = 10 ,
27388 & LOUT = 6 ,
27389 & LDAT = 9 )
27390
27391 PARAMETER (TINY3=1.0D-3)
27392
27393* statistics
27394 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27395 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27396 & ICEVTG(8,0:30)
27397
27398* rejection counter
27399 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27400 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27401 & IREXCI(3),IRDIFF(2),IRINC
27402
27403* central particle production, impact parameter biasing
27404 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27405
27406* various options for treatment of partons (DTUNUC 1.x)
27407* (chain recombination, Cronin,..)
27408 LOGICAL LCO2CR,LINTPT
27409 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27410 & LCO2CR,LINTPT
27411
27412* nucleon-nucleon event-generator
27413 CHARACTER*8 CMODEL
27414 LOGICAL LPHOIN
27415 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27416
27417* flags for particle decays
27418 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27419 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27420 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27421
27422* diquark-breaking mechanism
27423 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27424
27425 DIMENSION PP(4),PT(4)
27426
27427 GOTO (1,2) MODE
27428
27429* initialization
27430 1 CONTINUE
27431
27432* initialize statistics counter
27433 ICREQU = 0
27434 ICSAMP = 0
27435 ICCPRO = 0
27436 ICDPR = 0
27437 ICDTA = 0
27438 ICRJSS = 0
27439 ICVV2S = 0
27440 DO 10 I=1,9
27441 ICRES(I) = 0
27442 ICCHAI(1,I) = 0
27443 ICCHAI(2,I) = 0
27444 10 CONTINUE
27445* initialize rejection counter
27446 IRPT = 0
27447 IRHHA = 0
27448 LOMRES = 0
27449 LOBRES = 0
27450 IRFRAG = 0
27451 IREVT = 0
27452 IRRES(1) = 0
27453 IRRES(2) = 0
27454 IRCHKI(1) = 0
27455 IRCHKI(2) = 0
27456 IRCRON(1) = 0
27457 IRCRON(2) = 0
27458 IRCRON(3) = 0
27459 IRDIFF(1) = 0
27460 IRDIFF(2) = 0
27461 IRINC = 0
27462 DO 11 I=1,5
27463 ICDIFF(I) = 0
27464 11 CONTINUE
27465 DO 12 I=1,8
27466 DO 13 J=0,30
27467 ICEVTG(I,J) = 0
27468 13 CONTINUE
27469 12 CONTINUE
27470
27471 RETURN
27472
27473* output
27474 2 CONTINUE
27475
27476* statistics counter
27477 WRITE(LOUT,1000)
27478 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27479 & 28X,'---------------------')
004932dd 27480 IF (ICREQU.GT.0) THEN
7b076c76 27481 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27482 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27483 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27484 & 'event',11X,F9.1)
004932dd 27485 ENDIF
7b076c76 27486 IF (ICDIFF(1).NE.0) THEN
27487 WRITE(LOUT,1009) ICDIFF
27488 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27489 & 'low mass high mass',/,24X,'single diffraction',
27490 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27491 ENDIF
004932dd 27492 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
7b076c76 27493 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27494 & DBLE(ICSAMP)/DBLE(ICCPRO)
27495 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27496 & ' of sampled Glauber-events per event',9X,F9.1,/,
27497 & 2X,'fraction of production cross section',21X,F10.6)
27498 ENDIF
004932dd 27499 IF (ICSAMP.GT.0) THEN
7b076c76 27500 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27501 & DBLE(ICDTA)/DBLE(ICSAMP)
27502 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27503 & ' nucleons after x-sampling',2(4X,F6.2))
004932dd 27504 ENDIF
7b076c76 27505
27506 IF (MCGENE.EQ.1) THEN
004932dd 27507 IF (ICSAMP.GT.0) THEN
7b076c76 27508 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27509 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27510 & ' event',3X,F9.1)
27511 IF (ISICHA.EQ.1) THEN
27512 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27513 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27514 & 'of single chains per event',13X,F9.1)
27515 ENDIF
004932dd 27516 ENDIF
27517 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
7b076c76 27518 WRITE(LOUT,1006)
27519 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27520 & 23X,'mean number of chains mean number of chains',/,
27521 & 23X,'sampled hadronized having mass of a reso.')
27522 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27523 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27524 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27525 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27526 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27527 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27531 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27532 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27533 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27534 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27535 WRITE(LOUT,1008)
27536 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27537 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27538 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27539 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27540 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27541 & DBLE(IRHHA)/DBLE(ICREQU),
27542 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27543 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27544 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27545 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27546 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27547 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27548 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27549 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27550 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27551 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27552 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27553 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27554 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27555 & F7.2,/,1X,'Total no. of rej.',
27556 & ' in chain-systems treatment (GETCSY)',/,43X,
27557 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27558 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27559 & 1X,'Total no. of rej. in DPM-treatment of one event',
27560 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27561 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27562 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27563 & 'IREXCI(3) = ',I5,/)
004932dd 27564 ENDIF
7b076c76 27565 ELSEIF (MCGENE.EQ.2) THEN
27566 WRITE(LOUT,1010) ELOJET
27567 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27568 & F4.1,' GeV')
27569 WRITE(LOUT,1011)
27570 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27571 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27572 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27573 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27574 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27575 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27576 & ((ICEVTG(I,J),I=1,8),J=3,7),
27577 & ((ICEVTG(I,J),I=1,8),J=19,21),
27578 & (ICEVTG(I,8),I=1,8),
27579 & ((ICEVTG(I,J),I=1,8),J=22,24),
27580 & (ICEVTG(I,9),I=1,8),
27581 & ((ICEVTG(I,J),I=1,8),J=25,28),
27582 & ((ICEVTG(I,J),I=1,8),J=10,18)
27583 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27584 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27585 & ' no-dif.',8I8,/,
27586 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27587 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27588 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27589 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27590 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27591 & ' hi-lo ',8I8,/,
27592 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27593 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27594 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27595 WRITE(LOUT,1013)
27596 1013 FORMAT(/,1X,'2. chain system statistics -',
27597 & ' mean numbers per evt:',/,30X,'---------------------',
27598 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
004932dd 27599 IF (ICSAMP.GT.0) THEN
7b076c76 27600 WRITE(LOUT,1014)
27601 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27602 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27603 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27604 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27605 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27606 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27607 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27608 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27609 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27610 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27611 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27612 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27613 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
004932dd 27614 ENDIF
7b076c76 27615 WRITE(LOUT,1015)
27616 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
004932dd 27617 IF (ICSAMP.GT.0) THEN
7b076c76 27618 WRITE(LOUT,1016)
27619 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27620 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27621 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27622 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27623 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27624 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27625 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27626 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27627 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27628 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27629 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27630 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27631 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
004932dd 27632 ENDIF
7b076c76 27633
27634 ENDIF
27635 CALL DT_CHASTA(1)
27636
27637 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27638 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27639 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27640 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27641 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27642 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27643 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27644 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27645 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27646 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27647 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27648 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27649 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27650 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27651 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27652 & DBRKA(3,1),DBRKA(3,2),
27653 & DBRKA(3,3),DBRKA(3,4)
27654 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27655 & DBRKR(3,1),DBRKR(3,2),
27656 & DBRKR(3,3),DBRKR(3,4)
27657 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27658 & DBRKA(3,5),DBRKA(3,6),
27659 & DBRKA(3,7),DBRKA(3,8)
27660 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27661 & DBRKR(3,5),DBRKR(3,6),
27662 & DBRKR(3,7),DBRKR(3,8)
27663 ENDIF
27664
27665 FAC = 1.0D0
27666 IF (MCGENE.EQ.2) THEN
27667
27668C CALL PHO_PHIST(-2,SIGMAX)
27669 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27670
27671 ENDIF
27672
27673 CALL DT_XTIME
27674
27675 RETURN
27676 END
27677
27678*$ CREATE DT_EVTOUT.FOR
27679*COPY DT_EVTOUT
27680*
27681*===evtout=============================================================*
27682*
27683 SUBROUTINE DT_EVTOUT(MODE)
27684
27685************************************************************************
27686* MODE = 1 plot content of complete DTEVT1 to out. unit *
27687* 3 plot entries of extended DTEVT1 (DTEVT2) *
27688* 4 plot entries of DTEVT1 and DTEVT2 *
27689* This version dated 11.12.94 is written by S. Roesler *
27690************************************************************************
27691
27692 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27693 SAVE
27694
27695 PARAMETER ( LINP = 10 ,
27696 & LOUT = 6 ,
27697 & LDAT = 9 )
27698
27699* event history
27700
27701 PARAMETER (NMXHKK=200000)
27702
27703 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27704 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27705 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27706
27707 DIMENSION IRANGE(NMXHKK)
27708
27709 IF (MODE.EQ.2) RETURN
27710
27711 CALL DT_EVTPLO(IRANGE,MODE)
27712
27713 RETURN
27714 END
27715
27716*$ CREATE DT_EVTPLO.FOR
27717*COPY DT_EVTPLO
27718*
27719*===evtplo=============================================================*
27720*
27721 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27722
27723************************************************************************
27724* MODE = 1 plot content of complete DTEVT1 to out. unit *
27725* 2 plot entries of DTEVT1 given by IRANGE *
27726* 3 plot entries of extended DTEVT1 (DTEVT2) *
27727* 4 plot entries of DTEVT1 and DTEVT2 *
27728* 5 plot rejection counter *
27729* This version dated 11.12.94 is written by S. Roesler *
27730************************************************************************
27731
27732 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27733 SAVE
27734
27735 PARAMETER ( LINP = 10 ,
27736 & LOUT = 6 ,
27737 & LDAT = 9 )
27738
27739 CHARACTER*16 CHAU
27740
27741* event history
27742
27743 PARAMETER (NMXHKK=200000)
27744
27745 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27746 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27747 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27748
27749* extended event history
27750 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27751 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27752 & IHIST(2,NMXHKK)
27753
27754* rejection counter
27755 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27756 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27757 & IREXCI(3),IRDIFF(2),IRINC
27758
27759 DIMENSION IRANGE(NMXHKK)
27760
27761 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27762 WRITE(LOUT,1000)
27763 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27764 & 15X,' --------------------------',/,/,
27765 & ' ST ID M1 M2 D1 D2 PX PY',
27766 & ' PZ E M',/)
27767 DO 1 I=1,NHKK
27768 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27769 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27770 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27771 & PHKK(5,I)
27772C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27773C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27774C & PHKK(3,I),PHKK(4,I)
27775C WRITE(LOUT,'(4E15.4)')
27776C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27777 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27778 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27779 1 CONTINUE
27780 WRITE(LOUT,*)
27781C DO 4 I=1,NHKK
27782C WRITE(LOUT,1006) I,ISTHKK(I),
27783C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27784C & WHKK(2,I),WHKK(3,I)
27785C1006 FORMAT(1X,I4,I6,6E10.3)
27786C 4 CONTINUE
27787 ENDIF
27788
27789 IF (MODE.EQ.2) THEN
27790 WRITE(LOUT,1000)
27791 NC = 0
27792 2 CONTINUE
27793 NC = NC+1
27794 IF (IRANGE(NC).EQ.-100) GOTO 9999
27795 I = IRANGE(NC)
27796 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27797 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27798 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27799 & PHKK(5,I)
27800 GOTO 2
27801 ENDIF
27802
27803 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27804 WRITE(LOUT,1002)
27805 1002 FORMAT(/,1X,'EVTPLO:',14X,
27806 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27807 & 15X,' -----------------------------------',/,/,
27808 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27809 & ' NOBAM IDCH M',/)
27810 DO 3 I=1,NHKK
27811C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27812 KF = IDHKK(I)
27813 IDCHK = KF/10000
27814 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27815 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27816
27817 CALL PYNAME(KF,CHAU)
27818
27819 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27820 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27821 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27822 & PHKK(5,I),CHAU
27823 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27824C ENDIF
27825 3 CONTINUE
27826 ENDIF
27827
27828 IF (MODE.EQ.5) THEN
27829 WRITE(LOUT,1004)
27830 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27831 & 15X,' --------------------------',/)
27832 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27833 & IRSEA,IRCRON
27834 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27835 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27836 & 1X,'IREMC = ',10I5,/,
27837 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27838 ENDIF
27839
27840 9999 RETURN
27841 END
27842
27843*$ CREATE DT_EVTPUT.FOR
27844*COPY DT_EVTPUT
27845*
27846*===evtput=============================================================*
27847*
27848 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27849
27850 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27851 SAVE
27852
27853 PARAMETER ( LINP = 10 ,
27854 & LOUT = 6 ,
27855 & LDAT = 9 )
27856
27857 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27858 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27859
27860* event history
27861
27862 PARAMETER (NMXHKK=200000)
27863
27864 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27865 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27866 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27867
27868* extended event history
27869 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27870 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27871 & IHIST(2,NMXHKK)
27872
27873* Lorentz-parameters of the current interaction
27874 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27875 & UMO,PPCM,EPROJ,PPROJ
27876
27877* particle properties (BAMJET index convention)
27878 CHARACTER*8 ANAME
27879 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27880 & IICH(210),IIBAR(210),K1(210),K2(210)
27881
27882C IF (MODE.GT.100) THEN
27883C WRITE(LOUT,'(1X,A,I5,A,I5)')
27884C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27885C NHKK = NHKK-MODE+100
27886C RETURN
27887C ENDIF
27888 MO1 = M1
27889 MO2 = M2
27890 NHKK = NHKK+1
27891
27892 IF (NHKK.GT.NMXHKK) THEN
27893 WRITE(LOUT,1000) NHKK
27894 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27895 & '! program execution stopped..')
27896 STOP
27897 ENDIF
27898 IF (M1.LT.0) MO1 = NHKK+M1
27899 IF (M2.LT.0) MO2 = NHKK+M2
27900 ISTHKK(NHKK) = IST
27901 IDHKK(NHKK) = ID
27902 JMOHKK(1,NHKK) = MO1
27903 JMOHKK(2,NHKK) = MO2
27904 JDAHKK(1,NHKK) = 0
27905 JDAHKK(2,NHKK) = 0
27906 IDRES(NHKK) = IDR
27907 IDXRES(NHKK) = IDXR
27908 IDCH(NHKK) = IDC
27909** here we need to do something..
27910 IF (ID.EQ.88888) THEN
27911 IDMO1 = ABS(IDHKK(MO1))
27912 IDMO2 = ABS(IDHKK(MO2))
27913 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27914 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27915 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27916 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27917 ELSE
27918 NOBAM(NHKK) = 0
27919 ENDIF
27920 IDBAM(NHKK) = IDT_ICIHAD(ID)
27921 IF (MO1.GT.0) THEN
27922 IF (JDAHKK(1,MO1).NE.0) THEN
27923 JDAHKK(2,MO1) = NHKK
27924 ELSE
27925 JDAHKK(1,MO1) = NHKK
27926 ENDIF
27927 ENDIF
27928 IF (MO2.GT.0) THEN
27929 IF (JDAHKK(1,MO2).NE.0) THEN
27930 JDAHKK(2,MO2) = NHKK
27931 ELSE
27932 JDAHKK(1,MO2) = NHKK
27933 ENDIF
27934 ENDIF
27935C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27936C PTOT = SQRT(PX**2+PY**2+PZ**2)
27937C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27938C AMRQ = AAM(IDBAM(NHKK))
27939C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27940C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27941C & (PTOT.GT.ZERO)) THEN
27942C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27943CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27944C E = E+DELTA
27945C PTOT1 = PTOT-DELTA
27946C PX = PX*PTOT1/PTOT
27947C PY = PY*PTOT1/PTOT
27948C PZ = PZ*PTOT1/PTOT
27949C ENDIF
27950C ENDIF
27951 PHKK(1,NHKK) = PX
27952 PHKK(2,NHKK) = PY
27953 PHKK(3,NHKK) = PZ
27954 PHKK(4,NHKK) = E
27955 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27956 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27957 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27958 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27959 ELSE
27960 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27961C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27962C & WRITE(LOUT,'(1X,A,G10.3)')
27963C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27964 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27965 ENDIF
27966 IDCHK = ID/10000
27967 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27968* special treatment for chains:
27969* z coordinate of chain in Lab = pos. of target nucleon
27970* time of chain-creation in Lab = time of passage of projectile
27971* nucleus at pos. of taget nucleus
27972C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27973C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27974 VHKK(1,NHKK) = VHKK(1,MO2)
27975 VHKK(2,NHKK) = VHKK(2,MO2)
27976 VHKK(3,NHKK) = VHKK(3,MO2)
27977 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27978C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27979C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27980 WHKK(1,NHKK) = WHKK(1,MO1)
27981 WHKK(2,NHKK) = WHKK(2,MO1)
27982 WHKK(3,NHKK) = WHKK(3,MO1)
27983 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27984 ELSE
27985 IF (MO1.GT.0) THEN
27986 DO 1 I=1,4
27987 VHKK(I,NHKK) = VHKK(I,MO1)
27988 WHKK(I,NHKK) = WHKK(I,MO1)
27989 1 CONTINUE
27990 ELSE
27991 DO 2 I=1,4
27992 VHKK(I,NHKK) = ZERO
27993 WHKK(I,NHKK) = ZERO
27994 2 CONTINUE
27995 ENDIF
27996 ENDIF
27997
27998 RETURN
27999 END
28000
28001*$ CREATE DT_CHASTA.FOR
28002*COPY DT_CHASTA
28003*
28004*===chasta=============================================================*
28005*
28006 SUBROUTINE DT_CHASTA(MODE)
28007
28008************************************************************************
28009* This subroutine performs CHAin STAtistics and checks sequence of *
28010* partons in dtevt1 and sorts them with projectile partons coming *
28011* first if necessary. *
28012* *
28013* This version dated 8.5.00 is written by S. Roesler. *
28014************************************************************************
28015
28016 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28017 SAVE
28018
28019 PARAMETER ( LINP = 10 ,
28020 & LOUT = 6 ,
28021 & LDAT = 9 )
28022
28023 CHARACTER*5 CCHTYP
28024
28025* event history
28026
28027 PARAMETER (NMXHKK=200000)
28028
28029 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28030 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28031 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28032
28033* extended event history
28034 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28035 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28036 & IHIST(2,NMXHKK)
28037
28038* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28039 PARAMETER (MAXCHN=10000)
28040 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28041
28042 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28043 & CCHTYP(9),ICHSTA(10),ITOT(10)
28044 DATA ICHCFG /1800*0/
28045 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28046 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28047 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28048 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28049 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28050 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28051 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28052 & 'ad aq',' d ad','ad d ',' g g '/
28053*
28054* initialization
28055*
28056 IF (MODE.EQ.-1) THEN
28057 NCHAIN = 0
28058*
28059* loop over DTEVT1 and analyse chain configurations
28060*
28061 ELSEIF (MODE.EQ.0) THEN
28062 DO 21 IDX=NPOINT(3),NHKK
28063 IDCHK = IDHKK(IDX)/10000
28064 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28065 & (IDHKK(IDX).NE.80000).AND.
28066 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28067 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28068 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28069 & ' at entry ',IDX
28070 GOTO 21
28071 ENDIF
28072*
28073 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28074 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28075 IMO1 = IST1/10
28076 IMO1 = IST1-10*IMO1
28077 IMO2 = IST2/10
28078 IMO2 = IST2-10*IMO2
28079* swop parton entries if necessary since we need projectile partons
28080* to come first in the common
28081 IF (IMO1.GT.IMO2) THEN
28082 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28083 DO 22 K=1,NPTN/2
28084 I0 = JMOHKK(1,IDX)-1+K
28085 I1 = JMOHKK(2,IDX)+1-K
28086 ITMP = ISTHKK(I0)
28087 ISTHKK(I0) = ISTHKK(I1)
28088 ISTHKK(I1) = ITMP
28089 ITMP = IDHKK(I0)
28090 IDHKK(I0) = IDHKK(I1)
28091 IDHKK(I1) = ITMP
28092 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28093 & JDAHKK(1,JMOHKK(1,I0)) = I1
28094 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28095 & JDAHKK(2,JMOHKK(1,I0)) = I1
28096 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28097 & JDAHKK(1,JMOHKK(2,I0)) = I1
28098 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28099 & JDAHKK(2,JMOHKK(2,I0)) = I1
28100 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28101 & JDAHKK(1,JMOHKK(1,I1)) = I0
28102 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28103 & JDAHKK(2,JMOHKK(1,I1)) = I0
28104 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28105 & JDAHKK(1,JMOHKK(2,I1)) = I0
28106 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28107 & JDAHKK(2,JMOHKK(2,I1)) = I0
28108 ITMP = JMOHKK(1,I0)
28109 JMOHKK(1,I0) = JMOHKK(1,I1)
28110 JMOHKK(1,I1) = ITMP
28111 ITMP = JMOHKK(2,I0)
28112 JMOHKK(2,I0) = JMOHKK(2,I1)
28113 JMOHKK(2,I1) = ITMP
28114 ITMP = JDAHKK(1,I0)
28115 JDAHKK(1,I0) = JDAHKK(1,I1)
28116 JDAHKK(1,I1) = ITMP
28117 ITMP = JDAHKK(2,I0)
28118 JDAHKK(2,I0) = JDAHKK(2,I1)
28119 JDAHKK(2,I1) = ITMP
28120 DO 23 J=1,4
28121 RTMP1 = PHKK(J,I0)
28122 RTMP2 = VHKK(J,I0)
28123 RTMP3 = WHKK(J,I0)
28124 PHKK(J,I0) = PHKK(J,I1)
28125 VHKK(J,I0) = VHKK(J,I1)
28126 WHKK(J,I0) = WHKK(J,I1)
28127 PHKK(J,I1) = RTMP1
28128 VHKK(J,I1) = RTMP2
28129 WHKK(J,I1) = RTMP3
28130 23 CONTINUE
28131 RTMP1 = PHKK(5,I0)
28132 PHKK(5,I0) = PHKK(5,I1)
28133 PHKK(5,I1) = RTMP1
28134 ITMP = IDRES(I0)
28135 IDRES(I0) = IDRES(I1)
28136 IDRES(I1) = ITMP
28137 ITMP = IDXRES(I0)
28138 IDXRES(I0) = IDXRES(I1)
28139 IDXRES(I1) = ITMP
28140 ITMP = NOBAM(I0)
28141 NOBAM(I0) = NOBAM(I1)
28142 NOBAM(I1) = ITMP
28143 ITMP = IDBAM(I0)
28144 IDBAM(I0) = IDBAM(I1)
28145 IDBAM(I1) = ITMP
28146 ITMP = IDCH(I0)
28147 IDCH(I0) = IDCH(I1)
28148 IDCH(I1) = ITMP
28149 ITMP = IHIST(1,I0)
28150 IHIST(1,I0) = IHIST(1,I1)
28151 IHIST(1,I1) = ITMP
28152 ITMP = IHIST(2,I0)
28153 IHIST(2,I0) = IHIST(2,I1)
28154 IHIST(2,I1) = ITMP
28155 22 CONTINUE
28156 ENDIF
28157 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28158 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28159*
28160* parton 1 (projectile side)
28161 IF (IST1.EQ.21) THEN
28162 IDX1 = 1
28163 ELSEIF (IST1.EQ.22) THEN
28164 IDX1 = 2
28165 ELSEIF (IST1.EQ.31) THEN
28166 IDX1 = 3
28167 ELSEIF (IST1.EQ.32) THEN
28168 IDX1 = 4
28169 ELSEIF (IST1.EQ.41) THEN
28170 IDX1 = 5
28171 ELSEIF (IST1.EQ.42) THEN
28172 IDX1 = 6
28173 ELSEIF (IST1.EQ.51) THEN
28174 IDX1 = 7
28175 ELSEIF (IST1.EQ.52) THEN
28176 IDX1 = 8
28177 ELSEIF (IST1.EQ.61) THEN
28178 IDX1 = 9
28179 ELSEIF (IST1.EQ.62) THEN
28180 IDX1 = 10
28181 ELSE
28182c WRITE(LOUT,*)
28183c & ' CHASTA: unknown parton status flag (',
28184c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28185 GOTO 21
28186 ENDIF
28187 ID = IDHKK(JMOHKK(1,IDX))
28188 IF (ABS(ID).LE.4) THEN
28189 IF (ID.GT.0) THEN
28190 ITYP1 = 1
28191 ELSE
28192 ITYP1 = 2
28193 ENDIF
28194 ELSEIF (ABS(ID).GE.1000) THEN
28195 IF (ID.GT.0) THEN
28196 ITYP1 = 3
28197 ELSE
28198 ITYP1 = 4
28199 ENDIF
28200 ELSEIF (ID.EQ.21) THEN
28201 ITYP1 = 5
28202 ELSE
28203 WRITE(LOUT,*)
28204 & ' CHASTA: inconsistent parton identity (',
28205 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28206 GOTO 21
28207 ENDIF
28208*
28209* parton 2 (target side)
28210 IF (IST2.EQ.21) THEN
28211 IDX2 = 1
28212 ELSEIF (IST2.EQ.22) THEN
28213 IDX2 = 2
28214 ELSEIF (IST2.EQ.31) THEN
28215 IDX2 = 3
28216 ELSEIF (IST2.EQ.32) THEN
28217 IDX2 = 4
28218 ELSEIF (IST2.EQ.41) THEN
28219 IDX2 = 5
28220 ELSEIF (IST2.EQ.42) THEN
28221 IDX2 = 6
28222 ELSEIF (IST2.EQ.51) THEN
28223 IDX2 = 7
28224 ELSEIF (IST2.EQ.52) THEN
28225 IDX2 = 8
28226 ELSEIF (IST2.EQ.61) THEN
28227 IDX2 = 9
28228 ELSEIF (IST2.EQ.62) THEN
28229 IDX2 = 10
28230 ELSE
28231c WRITE(LOUT,*)
28232c & ' CHASTA: unknown parton status flag (',
28233c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28234 GOTO 21
28235 ENDIF
28236 ID = IDHKK(JMOHKK(2,IDX))
28237 IF (ABS(ID).LE.4) THEN
28238 IF (ID.GT.0) THEN
28239 ITYP2 = 1
28240 ELSE
28241 ITYP2 = 2
28242 ENDIF
28243 ELSEIF (ABS(ID).GE.1000) THEN
28244 IF (ID.GT.0) THEN
28245 ITYP2 = 3
28246 ELSE
28247 ITYP2 = 4
28248 ENDIF
28249 ELSEIF (ID.EQ.21) THEN
28250 ITYP2 = 5
28251 ELSE
28252 WRITE(LOUT,*)
28253 & ' CHASTA: inconsistent parton identity (',
28254 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28255 GOTO 21
28256 ENDIF
28257*
28258* fill counter
28259 ITYPE = ICHTYP(ITYP1,ITYP2)
28260 IF (ITYPE.NE.0) THEN
28261 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28262 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28263 ICHCFG(IDX1,IDX2,ITYPE,2) =
28264 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28265
28266 NCHAIN = NCHAIN+1
28267 IF (NCHAIN.GT.MAXCHN) THEN
28268 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28269 & NCHAIN,MAXCHN
28270 STOP
28271 ENDIF
28272 IDXCHN(1,NCHAIN) = IDX
28273 IDXCHN(2,NCHAIN) = ITYPE
28274 ELSE
28275 WRITE(LOUT,*)
28276 & ' CHASTA: inconsistent chain at entry ',IDX
28277 GOTO 21
28278 ENDIF
28279 ENDIF
28280 21 CONTINUE
28281*
28282* write statistics to output unit
28283*
28284 ELSEIF (MODE.EQ.1) THEN
28285 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28286 DO 31 I=1,10
28287 WRITE(LOUT,'(/,2A)')
28288 & ' -----------------------------------------',
28289 & '------------------------------------'
28290 WRITE(LOUT,'(2A)')
28291 & ' p\\t 21 22 31 32 41',
28292 & ' 42 51 52 61 62'
28293 WRITE(LOUT,'(2A)')
28294 & ' -----------------------------------------',
28295 & '------------------------------------'
28296 DO 32 J=1,10
28297 ITOT(J) = 0
28298 DO 33 K=1,9
28299 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28300 33 CONTINUE
28301 32 CONTINUE
28302 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28303 DO 34 K=1,9
28304 ISUM = 0
28305 DO 35 J=1,10
28306 ISUM = ISUM+ICHCFG(I,J,K,1)
28307 35 CONTINUE
28308 IF (ISUM.GT.0)
28309 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28310 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28311 34 CONTINUE
28312C WRITE(LOUT,'(2A)')
28313C & ' -----------------------------------------',
28314C & '-------------------------------'
28315 31 CONTINUE
28316*
28317 ELSE
28318 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28319 STOP
28320 ENDIF
28321
28322 RETURN
28323 END
28324*$ CREATE PHO_PHIST.FOR
28325*COPY PHO_PHIST
28326*
28327*===pohist=============================================================*
28328*
28329 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28330
28331 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28332 SAVE
28333
28334 PARAMETER ( LINP = 10 ,
28335 & LOUT = 6 ,
28336 & LDAT = 9 )
28337
28338 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28339
28340* Glauber formalism: cross sections
28341 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28342 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28343 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28344 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28345 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28346 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28347 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28348 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28349 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28350 & BSLOPE,NEBINI,NQBINI
28351
28352 ILAB = 0
28353 IF (IMODE.EQ.10) THEN
28354 IMODE = 1
28355 ILAB = 1
28356 ENDIF
28357 IF (ABS(IMODE).LT.1000) THEN
28358* PHOJET-statistics
28359C CALL POHISX(IMODE,WEIGHT)
28360 IF (IMODE.EQ.-1) THEN
28361 MODE = 1
28362 XSTOT(1,1,1) = WEIGHT
28363 ENDIF
28364 IF (IMODE.EQ. 1) MODE = 2
28365 IF (IMODE.EQ.-2) MODE = 3
28366 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28367C IF (MODE.EQ.3) WRITE(LOUT,*)
28368C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28369 CALL DT_HISTOG(MODE)
28370 CALL DT_USRHIS(MODE)
28371 ELSE
28372* DTUNUC-statistics
28373 MODE = IMODE/1000
28374C IF (MODE.EQ.3) WRITE(LOUT,*)
28375C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28376 CALL DT_HISTOG(MODE)
28377 CALL DT_USRHIS(MODE)
28378 ENDIF
28379
28380 RETURN
28381 END
28382
28383*$ CREATE DT_SWPPHO.FOR
28384*COPY DT_SWPPHO
28385*
28386*===swppho=============================================================*
28387*
28388 SUBROUTINE DT_SWPPHO(ILAB)
28389
28390 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28391 SAVE
28392
28393 PARAMETER ( LINP = 10 ,
28394 & LOUT = 6 ,
28395 & LDAT = 9 )
28396
28397 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28398
28399 LOGICAL LSTART
28400
28401* event history
28402
28403 PARAMETER (NMXHKK=200000)
28404
28405 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28406 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28407 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28408
28409* extended event history
28410 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28411 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28412 & IHIST(2,NMXHKK)
28413
28414* flags for input different options
28415 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28416 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28417 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28418
28419* properties of photon/lepton projectiles
28420 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28421
28422**PHOJET105a
28423C PARAMETER (NMXHEP=2000)
28424C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28425C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28426C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28427C COMMON /PLASAV/ PLAB
28428**PHOJET110
28429C standard particle data interface
28430 INTEGER NMXHEP
28431
28432 PARAMETER (NMXHEP=4000)
28433
28434 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28435 DOUBLE PRECISION PHEP,VHEP
28436 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28437 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28438 & VHEP(4,NMXHEP)
28439C extension to standard particle data interface (PHOJET specific)
28440 INTEGER IMPART,IPHIST,ICOLOR
28441 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28442
28443C global event kinematics and particle IDs
28444 INTEGER IFPAP,IFPAB
28445 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28446 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28447**
28448 DATA ICOUNT/0/
28449
28450 DATA LSTART /.TRUE./
28451
28452C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28453 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28454 UMO = ECM
28455 ELA = ZERO
28456 PLA = ZERO
28457 IDP = IDT_ICIHAD(IFPAP(1))
28458 IDT = IDT_ICIHAD(IFPAP(2))
28459 VIRT = PVIRT(1)
28460 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28461 PLAB = PLA
28462 LSTART = .FALSE.
28463 ENDIF
28464
28465 NHKK = 0
28466 ICOUNT = ICOUNT+1
28467C NEVHKK = NEVHEP
28468 NEVHKK = ICOUNT
28469 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28470 DO 1 I=3,NHEP
28471 IF (ISTHEP(I).EQ.1) THEN
28472 NHKK = NHKK+1
28473 ISTHKK(NHKK) = 1
28474 IDHKK(NHKK) = IDHEP(I)
28475 JMOHKK(1,NHKK) = 0
28476 JMOHKK(2,NHKK) = 0
28477 JDAHKK(1,NHKK) = 0
28478 JDAHKK(2,NHKK) = 0
28479 DO 2 K=1,4
28480 PHKK(K,NHKK) = PHEP(K,I)
28481 VHKK(K,NHKK) = ZERO
28482 WHKK(K,NHKK) = ZERO
28483 2 CONTINUE
28484 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28485 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28486 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28487 PHKK(5,NHKK) = PHEP(5,I)
28488 IDRES(NHKK) = 0
28489 IDXRES(NHKK) = 0
28490 NOBAM(NHKK) = 0
28491 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28492 IDCH(NHKK) = 0
28493 ENDIF
28494 1 CONTINUE
28495
28496 RETURN
28497 END
28498
28499*$ CREATE DT_HISTOG.FOR
28500*COPY DT_HISTOG
28501*
28502*===histog=============================================================*
28503*
28504 SUBROUTINE DT_HISTOG(MODE)
28505
28506************************************************************************
28507* This version dated 25.03.96 is written by S. Roesler *
28508************************************************************************
28509
28510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28511 SAVE
28512
28513 PARAMETER ( LINP = 10 ,
28514 & LOUT = 6 ,
28515 & LDAT = 9 )
28516
28517 LOGICAL LFSP,LRNL
28518
28519* event history
28520
28521 PARAMETER (NMXHKK=200000)
28522
28523 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28524 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28525 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28526
28527* extended event history
28528 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28529 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28530 & IHIST(2,NMXHKK)
28531
28532* event flag used for histograms
28533 COMMON /DTNORM/ ICEVT,IEVHKK
28534
28535* flags for activated histograms
28536 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28537
28538 IEVHKK = NEVHKK
28539 GOTO (1,2,3) MODE
28540
28541*------------------------------------------------------------------
28542* initialization
28543 1 CONTINUE
28544 ICEVT = 0
28545 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28546 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28547
28548 RETURN
28549*------------------------------------------------------------------
28550* filling of histogram with event-record
28551 2 CONTINUE
28552 ICEVT = ICEVT+1
28553
28554 DO 20 I=1,NHKK
28555 CALL DT_SWPFSP(I,LFSP,LRNL)
28556 IF (LFSP) THEN
28557 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28558 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28559 ENDIF
28560 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28561 20 CONTINUE
28562 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28563
28564 RETURN
28565*------------------------------------------------------------------
28566* output
28567 3 CONTINUE
28568 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28569 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28570
28571 RETURN
28572 END
28573
28574*$ CREATE DT_SWPFSP.FOR
28575*COPY DT_SWPFSP
28576*
28577*===swpfsp=============================================================*
28578*
28579 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28580
28581 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28582 SAVE
28583 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28584 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28585 & PI =TWOPI/TWO,
28586 & BOG =TWOPI/360.0D0)
28587
28588* event history
28589
28590 PARAMETER (NMXHKK=200000)
28591
28592 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28593 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28594 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28595
28596* extended event history
28597 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28598 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28599 & IHIST(2,NMXHKK)
28600
28601* particle properties (BAMJET index convention)
28602 CHARACTER*8 ANAME
28603 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28604 & IICH(210),IIBAR(210),K1(210),K2(210)
28605
28606* Lorentz-parameters of the current interaction
28607 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28608 & UMO,PPCM,EPROJ,PPROJ
28609
28610* flags for input different options
28611 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28612 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28613 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28614
28615* INCLUDE '(DIMPAR)'
28616* Taken from FLUKA
28617 PARAMETER ( MXXRGN =20000 )
28618 PARAMETER ( MXXMDF = 710 )
28619 PARAMETER ( MXXMDE = 702 )
28620 PARAMETER ( MFSTCK =40000 )
28621 PARAMETER ( MESTCK = 100 )
28622 PARAMETER ( MOSTCK = 2000 )
28623 PARAMETER ( MXPRSN = 100 )
28624 PARAMETER ( MXPDPM = 800 )
28625 PARAMETER ( MXPSCS =30000 )
28626 PARAMETER ( MXGLWN = 300 )
28627 PARAMETER ( MXOUTU = 50 )
28628 PARAMETER ( NALLWP = 64 )
28629 PARAMETER ( NELEMX = 80 )
28630 PARAMETER ( MPDPDX = 18 )
28631 PARAMETER ( MXHTTR = 260 )
28632 PARAMETER ( MXSEAX = 20 )
28633 PARAMETER ( MXHTNC = MXSEAX + 1 )
28634 PARAMETER ( ICOMAX = 2400 )
28635 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28636 PARAMETER ( NSTBIS = 304 )
28637 PARAMETER ( NQSTIS = 46 )
28638 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28639 PARAMETER ( MXPABL = 120 )
28640 PARAMETER ( IDMAXP = 450 )
28641 PARAMETER ( IDMXDC = 2000 )
28642 PARAMETER ( MXMCIN = 410 )
28643 PARAMETER ( IHYPMX = 4 )
28644 PARAMETER ( MKBMX1 = 11 )
28645 PARAMETER ( MKBMX2 = 11 )
28646 PARAMETER ( MXIRRD = 2500 )
28647 PARAMETER ( MXTRDC = 1500 )
28648 PARAMETER ( NKTL = 17 )
28649 PARAMETER ( NBLNMX = 40000000 )
28650
28651* INCLUDE '(PAREVT)'
28652* Taken from FLUKA
28653 PARAMETER ( FRDIFF = 0.2D+00 )
28654 PARAMETER ( ETHSEA = 1.0D+00 )
28655*
28656 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28657 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28658 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28659 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28660 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28661 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28662 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28663 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28664 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28665 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28666
28667* temporary storage for one final state particle
28668 LOGICAL LFRAG,LGREY,LBLACK
28669 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28670 & SINTHE,COSTHE,THETA,THECMS,
28671 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28672 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28673 & LFRAG,LGREY,LBLACK
28674
28675 LOGICAL LFSP,LRNL
28676
28677 LFSP = .FALSE.
28678 LRNL = .FALSE.
28679 ISTRNL = 1000
28680 MULDEF = 1
28681 IF (LEVPRT) ISTRNL = 1001
28682
28683 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28684 IST = ISTHKK(IDX)
28685 IDPDG = IDHKK(IDX)
28686 LFRAG = .FALSE.
28687 IF (IDHKK(IDX).LT.80000) THEN
28688 IDBJT = IDBAM(IDX)
28689 IBARY = IIBAR(IDBJT)
28690 ICHAR = IICH(IDBJT)
28691 AMASS = AAM(IDBJT)
28692 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28693 IDBJT = 0
28694 IBARY = IDRES(IDX)
28695 ICHAR = IDXRES(IDX)
28696 AMASS = PHKK(5,IDX)
28697 INUT = IBARY-ICHAR
28698 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28699 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28700 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28701 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28702 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28703 ELSE
28704 GOTO 9999
28705 ENDIF
28706 PE = PHKK(4,IDX)
28707 PX = PHKK(1,IDX)
28708 PY = PHKK(2,IDX)
28709 PZ = PHKK(3,IDX)
28710 PT2 = PX**2+PY**2
28711 PT = SQRT(PT2)
28712 PTOT = SQRT(PT2+PZ**2)
28713 SINTHE = PT/MAX(PTOT,TINY14)
28714 COSTHE = PZ/MAX(PTOT,TINY14)
28715 IF (COSTHE.GT.ONE) THEN
28716 THETA = ZERO
28717 ELSEIF (COSTHE.LT.-ONE) THEN
28718 THETA = TWOPI/2.0D0
28719 ELSE
28720 THETA = ACOS(COSTHE)
28721 ENDIF
28722 EKIN = PE-AMASS
28723**sr 15.4.96 new E_t-definition
28724 IF (IBARY.GT.0) THEN
28725 ET = EKIN*SINTHE
28726 ELSEIF (IBARY.LT.0) THEN
28727 ET = (EKIN+TWO*AMASS)*SINTHE
28728 ELSE
28729 ET = PE*SINTHE
28730 ENDIF
28731**
28732 XLAB = PZ/MAX(PPROJ,TINY14)
28733C XLAB = PE/MAX(EPROJ,TINY14)
28734 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28735 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28736 PPLUS = PE+PZ
28737 PMINUS = PE-PZ
28738 IF (PMINUS.GT.TINY14) THEN
28739 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28740 ELSE
28741 YY = 100.0D0
28742 ENDIF
28743 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28744 ETA = -LOG(TAN(THETA/TWO))
28745 ELSE
28746 ETA = 100.0D0
28747 ENDIF
28748 IF (IFRAME.EQ.1) THEN
28749 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28750 PPLUS = EECMS+PZCMS
28751 PMINUS = EECMS-PZCMS
28752 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28753 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28754 ELSE
28755 YYCMS = 100.0D0
28756 ENDIF
28757 PTOTCM = SQRT(PT2+PZCMS**2)
28758 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28759 IF (COSTH.GT.ONE) THEN
28760 THECMS = ZERO
28761 ELSEIF (COSTH.LT.-ONE) THEN
28762 THECMS = TWOPI/2.0D0
28763 ELSE
28764 THECMS = ACOS(COSTH)
28765 ENDIF
28766 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28767 ETACMS = -LOG(TAN(THECMS/TWO))
28768 ELSE
28769 ETACMS = 100.0D0
28770 ENDIF
28771 XF = PZCMS/MAX(PPCM,TINY14)
28772 THECMS = THECMS/BOG
28773 ELSE
28774 PZCMS = PZ
28775 EECMS = PE
28776 YYCMS = YY
28777 ETACMS = ETA
28778 XF = XLAB
28779 THECMS = THETA/BOG
28780 ENDIF
28781 THETA = THETA/BOG
28782
28783* set flag for "grey/black"
28784 LGREY = .FALSE.
28785 LBLACK = .FALSE.
28786 EK = EKIN
28787 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28788 IF (MULDEF.EQ.1) THEN
28789* EMU01-Def.
28790 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28791 & (EK.LE.375.0D-3) ).OR.
28792 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28793 & (EK.LE. 56.0D-3) ).OR.
28794 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28795 & (EK.LE. 56.0D-3) ).OR.
28796 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28797 & (EK.LE.198.0D-3) ).OR.
28798 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28799 & (EK.LE.198.0D-3) ).OR.
28800 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28801 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28802 & (IDBJT.NE.16).AND.
28803 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28804 & LGREY = .TRUE.
28805 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28806 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28807 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28808 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28809 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28810 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28811 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28812 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28813 & LBLACK = .TRUE.
28814 ELSE
28815* common Def.
28816 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28817 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28818 ENDIF
28819 LFSP = .TRUE.
28820 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28821 IST = ISTHKK(IDX)
28822 IDPDG = IDHKK(IDX)
28823 LFRAG = .TRUE.
28824 IDBJT = 0
28825 IBARY = IDRES(IDX)
28826 ICHAR = IDXRES(IDX)
28827 AMASS = PHKK(5,IDX)
28828 PE = PHKK(4,IDX)
28829 PX = PHKK(1,IDX)
28830 PY = PHKK(2,IDX)
28831 PZ = PHKK(3,IDX)
28832 PT2 = PX**2+PY**2
28833 PT = SQRT(PT2)
28834 PTOT = SQRT(PT2+PZ**2)
28835 SINTHE = PT/MAX(PTOT,TINY14)
28836 COSTHE = PZ/MAX(PTOT,TINY14)
28837 IF (COSTHE.GT.ONE) THEN
28838 THETA = ZERO
28839 ELSEIF (COSTHE.LT.-ONE) THEN
28840 THETA = TWOPI/2.0D0
28841 ELSE
28842 THETA = ACOS(COSTHE)
28843 ENDIF
28844 EKIN = PE-AMASS
28845**sr 15.4.96 new E_t-definition
28846C ET = PE*SINTHE
28847 ET = EKIN*SINTHE
28848**
28849 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28850 ETA = -LOG(TAN(THETA/TWO))
28851 ELSE
28852 ETA = 100.0D0
28853 ENDIF
28854 THETA = THETA/BOG
28855 LRNL = .TRUE.
28856 ENDIF
28857
28858 9999 CONTINUE
28859 RETURN
28860 END
28861
28862*$ CREATE DT_HIMULT.FOR
28863*COPY DT_HIMULT
28864*
28865*===himult=============================================================*
28866*
28867 SUBROUTINE DT_HIMULT(MODE)
28868
28869************************************************************************
28870* Tables of average energies/multiplicities. *
28871* This version dated 30.08.2000 is written by S. Roesler *
28872************************************************************************
28873
28874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28875 SAVE
28876
28877 PARAMETER ( LINP = 10 ,
28878 & LOUT = 6 ,
28879 & LDAT = 9 )
28880
28881 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28882
28883 PARAMETER (SWMEXP=1.7D0)
28884
28885 CHARACTER*8 ANAMEH(4)
28886
28887* particle properties (BAMJET index convention)
28888 CHARACTER*8 ANAME
28889 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28890 & IICH(210),IIBAR(210),K1(210),K2(210)
28891
28892* temporary storage for one final state particle
28893 LOGICAL LFRAG,LGREY,LBLACK
28894 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28895 & SINTHE,COSTHE,THETA,THECMS,
28896 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28897 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28898 & LFRAG,LGREY,LBLACK
28899
28900* event flag used for histograms
28901 COMMON /DTNORM/ ICEVT,IEVHKK
28902
28903* Lorentz-parameters of the current interaction
28904 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28905 & UMO,PPCM,EPROJ,PPROJ
28906
28907 PARAMETER (NOPART=210)
28908 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28909 & AVPT(4,NOPART),IAVPT(4,NOPART)
28910 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28911
28912 GOTO (1,2,3) MODE
28913
28914*------------------------------------------------------------------
28915* initialization
28916 1 CONTINUE
28917 DO 10 I=1,NOPART
28918 DO 11 J=1,4
28919 AVMULT(J,I) = ZERO
28920 AVE(J,I) = ZERO
28921 AVSWM(J,I) = ZERO
28922 AVPT(J,I) = ZERO
28923 IAVPT(J,I) = 0
28924 11 CONTINUE
28925 10 CONTINUE
28926
28927 RETURN
28928
28929*------------------------------------------------------------------
28930* filling of histogram with event-record
28931 2 CONTINUE
28932 IF (PE.LT.0.0D0) THEN
28933 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28934 RETURN
28935 ENDIF
28936 IF (.NOT.LFRAG) THEN
28937 IVEL = 2
28938 IF (LGREY) IVEL = 3
28939 IF (LBLACK) IVEL = 4
28940 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28941 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28942 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28943 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28944 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28945 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28946 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28947 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28948 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28949 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28950 IF (IDBJT.LT.116) THEN
28951* total energy, multiplicity
28952 AVE(1,30) = AVE(1,30) +PE
28953 AVE(IVEL,30) = AVE(IVEL,30)+PE
28954 AVPT(1,30) = AVPT(1,30) +PT
28955 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28956 IAVPT(1,30) = IAVPT(1,30) +1
28957 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28958 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28959 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28960 AVMULT(1,30) = AVMULT(1,30) +ONE
28961 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28962* charged energy, multiplicity
28963 IF (ICHAR.LT.0) THEN
28964 AVE(1,26) = AVE(1,26) +PE
28965 AVE(IVEL,26) = AVE(IVEL,26)+PE
28966 AVPT(1,26) = AVPT(1,26) +PT
28967 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28968 IAVPT(1,26) = IAVPT(1,26) +1
28969 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28970 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28971 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28972 AVMULT(1,26) = AVMULT(1,26) +ONE
28973 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28974 ENDIF
28975 IF (ICHAR.NE.0) THEN
28976 AVE(1,27) = AVE(1,27) +PE
28977 AVE(IVEL,27) = AVE(IVEL,27)+PE
28978 AVPT(1,27) = AVPT(1,27) +PT
28979 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28980 IAVPT(1,27) = IAVPT(1,27) +1
28981 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28982 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28983 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28984 AVMULT(1,27) = AVMULT(1,27) +ONE
28985 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28986 ENDIF
28987 ENDIF
28988 ENDIF
28989
28990 RETURN
28991
28992*------------------------------------------------------------------
28993* output
28994 3 CONTINUE
28995 WRITE(LOUT,3000)
28996 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28997 & 29X,'---------------------',/)
28998 IF (MULDEF.EQ.1) THEN
28999 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29000 ELSE
29001 BETGRE = 0.7D0
29002 BETBLC = 0.23D0
29003 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29004 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29005 & ,F4.2,' black: beta < ',F4.2,/)
29006 ENDIF
29007 WRITE(LOUT,3003) SWMEXP
29008 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29009 & 13X,'| total fast',
29010C & ' grey black K f(',F3.1,')',/,1X,
29011 & ' grey black <pt> f(',F3.1,')',/,1X,
29012 & '------------+--------------',
29013 & '-------------------------------------------------')
29014 DO 30 I=1,NOPART
29015 DO 31 J=1,4
29016 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29017 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29018 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29019 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29020 31 CONTINUE
29021 IF (I.LE.115) THEN
29022 WRITE(LOUT,3004) ANAME(I),I,
29023 & AVMULT(1,I),AVMULT(2,I),
29024 & AVMULT(3,I),AVMULT(4,I),
29025C & AVE(1,I),AVSWM(1,I)
29026 & AVPT(1,I),AVSWM(1,I)
29027 ELSEIF (I.LE.119) THEN
29028 WRITE(LOUT,3004) ANAMEH(I-115),I,
29029 & AVMULT(1,I),AVMULT(2,I),
29030 & AVMULT(3,I),AVMULT(4,I),
29031C & AVE(1,I),AVSWM(1,I)
29032 & AVPT(1,I),AVSWM(1,I)
29033 ENDIF
29034 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29035 30 CONTINUE
29036**temporary
29037C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29038C & AVMULT(3,27)+AVMULT(4,27)
29039**
29040
29041 RETURN
29042 END
29043
29044*$ CREATE DT_HISTAT.FOR
29045*COPY DT_HISTAT
29046*
29047*===histat=============================================================*
29048*
29049 SUBROUTINE DT_HISTAT(IDX,MODE)
29050
29051************************************************************************
29052* This version dated 26.02.96 is written by S. Roesler *
29053* *
29054* Last change 27.12.2006 by S. Roesler. *
29055************************************************************************
29056
29057 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29058 SAVE
29059
29060 PARAMETER ( LINP = 10 ,
29061 & LOUT = 6 ,
29062 & LDAT = 9 )
29063
29064 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29065 PARAMETER (NDIM=199)
29066
29067* event history
29068
29069 PARAMETER (NMXHKK=200000)
29070
29071 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29072 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29073 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29074
29075* extended event history
29076 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29077 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29078 & IHIST(2,NMXHKK)
29079
29080* particle properties (BAMJET index convention)
29081 CHARACTER*8 ANAME
29082 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29083 & IICH(210),IIBAR(210),K1(210),K2(210)
29084
29085 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29086
29087* Glauber formalism: cross sections
29088 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29089 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29090 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29091 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29092 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29093 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29094 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29095 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29096 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29097 & BSLOPE,NEBINI,NQBINI
29098
29099* emulsion treatment
29100 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29101 & NCOMPO,IEMUL
29102
29103* properties of interacting particles
29104 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29105
29106* rejection counter
29107 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29108 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29109 & IREXCI(3),IRDIFF(2),IRINC
29110
29111* statistics: residual nuclei
29112 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29113 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29114 & NINCST(2,4),NINCEV(2),
29115 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29116 & NRESPB(2),NRESCH(2),NRESEV(4),
29117 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29118 & NEVAFI(2,2)
29119
29120* parameter for intranuclear cascade
29121 LOGICAL LPAULI
29122 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29123
29124* INCLUDE '(DIMPAR)'
29125* Taken from FLUKA
29126 PARAMETER ( MXXRGN =20000 )
29127 PARAMETER ( MXXMDF = 710 )
29128 PARAMETER ( MXXMDE = 702 )
29129 PARAMETER ( MFSTCK =40000 )
29130 PARAMETER ( MESTCK = 100 )
29131 PARAMETER ( MOSTCK = 2000 )
29132 PARAMETER ( MXPRSN = 100 )
29133 PARAMETER ( MXPDPM = 800 )
29134 PARAMETER ( MXPSCS =30000 )
29135 PARAMETER ( MXGLWN = 300 )
29136 PARAMETER ( MXOUTU = 50 )
29137 PARAMETER ( NALLWP = 64 )
29138 PARAMETER ( NELEMX = 80 )
29139 PARAMETER ( MPDPDX = 18 )
29140 PARAMETER ( MXHTTR = 260 )
29141 PARAMETER ( MXSEAX = 20 )
29142 PARAMETER ( MXHTNC = MXSEAX + 1 )
29143 PARAMETER ( ICOMAX = 2400 )
29144 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29145 PARAMETER ( NSTBIS = 304 )
29146 PARAMETER ( NQSTIS = 46 )
29147 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29148 PARAMETER ( MXPABL = 120 )
29149 PARAMETER ( IDMAXP = 450 )
29150 PARAMETER ( IDMXDC = 2000 )
29151 PARAMETER ( MXMCIN = 410 )
29152 PARAMETER ( IHYPMX = 4 )
29153 PARAMETER ( MKBMX1 = 11 )
29154 PARAMETER ( MKBMX2 = 11 )
29155 PARAMETER ( MXIRRD = 2500 )
29156 PARAMETER ( MXTRDC = 1500 )
29157 PARAMETER ( NKTL = 17 )
29158 PARAMETER ( NBLNMX = 40000000 )
29159
29160* INCLUDE '(PAREVT)'
29161* Taken from FLUKA
29162 PARAMETER ( FRDIFF = 0.2D+00 )
29163 PARAMETER ( ETHSEA = 1.0D+00 )
29164*
29165 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29166 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29167 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29168 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29169 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29170 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29171 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29172 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29173 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29174 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29175
29176* INCLUDE '(FRBKCM)'
29177* Taken from FLUKA
29178* Maximum number of fragments to be emitted:
29179 PARAMETER ( MXFFBK = 6 )
29180 PARAMETER ( MXZFBK = 10 )
29181 PARAMETER ( MXNFBK = 12 )
29182 PARAMETER ( MXAFBK = 16 )
29183 PARAMETER ( MXASST = 25 )
29184 PARAMETER ( NXAFBK = MXAFBK + 1 )
29185 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29186 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29187 PARAMETER ( MXPSST = 700 )
29188* Maximum number of pre-computed break-up combinations
29189 PARAMETER ( MXPPFB = 42500 )
29190* Maximum number of break-up combinations, including special
29191* run-time ones:
29192 PARAMETER ( MXPSFB = 43000 )
29193* Base for J multiplicity encoding:
29194 PARAMETER ( IBFRBK = 73 )
29195* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29196* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29197* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29198* --> Ibfrbk^(Jpwfbx+1) < 2100000000
29199 PARAMETER ( JPWFBX = 4 )
29200 LOGICAL LFRMBK, LNCMSS
29201 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29202 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29203 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29204 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29205 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29206 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29207 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29208 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29209 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29210 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29211
29212* INCLUDE '(EVAFLG)'
29213* Taken from FLUKA
29214 LOGICAL 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 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29219 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29220 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29221 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29222 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29223 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29224 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29225 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29226
29227* temporary storage for one final state particle
29228 LOGICAL LFRAG,LGREY,LBLACK
29229 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29230 & SINTHE,COSTHE,THETA,THECMS,
29231 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29232 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29233 & LFRAG,LGREY,LBLACK
29234
29235* event flag used for histograms
29236 COMMON /DTNORM/ ICEVT,IEVHKK
29237
29238* statistics: double-Pomeron exchange
29239 COMMON /DTFLG2/ INTFLG,IPOPO
29240
29241 DIMENSION EMUSAM(NCOMPX)
29242
29243 CHARACTER*13 CMSG(3)
29244 DATA CMSG /'not requested','not requested','not requested'/
29245
29246 GOTO (1,2,3,4,5) MODE
29247
29248*------------------------------------------------------------------
29249* initialization
29250 1 CONTINUE
29251* emulsion treatment
29252 IF (NCOMPO.GT.0) THEN
29253 DO 10 I=1,NCOMPX
29254 EMUSAM(I) = ZERO
29255 10 CONTINUE
29256 ENDIF
29257* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29258 NINCGE = 0
29259 DO 11 I=1,2
29260 EXCDPM(I) = ZERO
29261 EXCDPM(I+2) = ZERO
29262 EXCEVA(I) = ZERO
29263 NINCWO(I) = 0
29264 NINCEV(I) = 0
29265 NRESTO(I) = 0
29266 NRESPR(I) = 0
29267 NRESNU(I) = 0
29268 NRESBA(I) = 0
29269 NRESPB(I) = 0
29270 NRESCH(I) = 0
29271 NRESEV(I) = 0
29272 NRESEV(I+2) = 0
29273 NEVAGA(I) = 0
29274 NEVAHT(I) = 0
29275 NEVAFI(1,I) = 0
29276 NEVAFI(2,I) = 0
29277 DO 12 J=1,6
29278 IF (J.LE.2) NINCHR(I,J) = 0
29279 IF (J.LE.3) NINCCO(I,J) = 0
29280 IF (J.LE.4) NINCST(I,J) = 0
29281 NEVA(I,J) = 0
29282 12 CONTINUE
29283 DO 13 J=1,210
29284 NEVAHY(1,I,J) = 0
29285 NEVAHY(2,I,J) = 0
29286 13 CONTINUE
29287 11 CONTINUE
29288 MAXGEN = 0
29289**dble Po statistics.
29290 KPOPO = 0
29291
29292 RETURN
29293*------------------------------------------------------------------
29294* filling of histogram with event-record
29295 2 CONTINUE
29296 IF (IST.EQ.-1) THEN
29297 IF (.NOT.LFRAG) THEN
29298 IF (IDPDG.EQ.2212) THEN
29299 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29300 ELSEIF (IDPDG.EQ.2112) THEN
29301 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29302 ELSEIF (IDPDG.EQ.22) THEN
29303 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29304 ELSEIF (IDPDG.EQ.80000) THEN
29305 IF (IDBJT.EQ.116) THEN
29306 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29307 ELSEIF (IDBJT.EQ.117) THEN
29308 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29309 ELSEIF (IDBJT.EQ.118) THEN
29310 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29311 ELSEIF (IDBJT.EQ.119) THEN
29312 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29313 ENDIF
29314 ENDIF
29315 ELSE
29316* heavy fragments (here: fission products only)
29317 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29318 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29319 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29320 ENDIF
29321 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29322 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29323 ENDIF
29324
29325 RETURN
29326*------------------------------------------------------------------
29327* output
29328 3 CONTINUE
29329
29330**dble Po statistics.
29331C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29332C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29333C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29334
29335* emulsion treatment
29336 IF (NCOMPO.GT.0) THEN
29337 WRITE(LOUT,3000)
29338 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29339 & 22X,'----------------------------',/,/,19X,
29340 & 'mass charge fraction',/,39X,
29341 & 'input treated',/)
29342 DO 30 I=1,NCOMPO
29343 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29344 & EMUSAM(I)/DBLE(ICEVT)
29345 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29346 30 CONTINUE
29347 ENDIF
29348
29349* i.n.c. statistics: output
29350 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29351 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29352 & 22X,'---------------------------------',/,/,1X,
29353 & 'no. of events for normalization: (accepted final events,',
29354 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29355 & /,1X,'no. of rejected events due to intranuclear',
29356 & ' cascade',15X,I6,/)
29357 ICEV = MAX(ICEVT,1)
29358 ICEV1 = ICEV
29359 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29360 WRITE(LOUT,3002)
29361 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29362 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29363 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29364 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29365 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29366 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29367 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29368 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29369 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29370 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29371 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29372 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29373 & /,1X,'maximum no. of generations treated (maximum allowed:'
29374 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29375 & ' interactions in proj./ target (mean per evt1)',
29376 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29377 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29378 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29379 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29380 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29381 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29382 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29383 & 'evaporation',/,22X,'-----------------------------',
29384 & '------------',/,/,1X,'no. of events for normal.: ',
29385 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29386 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29387 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29388
29389 WRITE(LOUT,3004)
29390 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29391 ICEV = MAX(NRESEV(2),1)
29392 WRITE(LOUT,3005)
29393 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29394 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29395 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29396 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29397 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29398 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29399 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29400 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29401 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29402 & 'proj. / target',/,/,8X,'total number of particles',15X,
29403 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29404 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29405 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29406 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29407 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29408
29409* evaporation / fission / fragmentation statistics: output
29410 ICEV = MAX(NRESEV(2),1)
29411 ICEV1 = MAX(NRESEV(4),1)
29412 NTEVA1 =
29413 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29414 NTEVA2 =
29415 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29416 IF (LEVPRT) THEN
29417
29418 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29419
29420 IF (LFRMBK) CMSG(2) = 'requested '
29421 IF (LDEEXG) CMSG(3) = 'requested '
29422 WRITE(LOUT,3006)
29423 & CMSG,
29424 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29425 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29426 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29427 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29428 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29429 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29430 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29431 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29432 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29433 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29434 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29435 & 'deexcitation:',2X,A13,/,/,
29436 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29437 & 'proj. / target',/,/,8X,'total number of evap. particles',
29438 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29439 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29440 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29441 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29442 & 'heavy fragments',25X,2F9.3,/)
29443
29444 IF (IEVFSS.EQ.1) THEN
29445
29446 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29447 & NEVAFI(2,1),NEVAFI(2,2),
29448 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29449 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29450 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29451 & 12X,'out of which fission occured',8X,2I9,/,
29452 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29453 ENDIF
29454
29455C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29456
29457C WRITE(LOUT,3008)
29458C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29459C & ' proj. / target',/)
29460C DO 31 I=1,210
29461C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29462C WRITE(LOUT,3009) I,
29463C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29464C3009 FORMAT(38X,I3,3X,2E12.3)
29465C ENDIF
29466C 31 CONTINUE
29467C WRITE(LOUT,3010)
29468C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29469C & ' proj. / target',/)
29470C DO 32 I=1,210
29471C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29472C WRITE(LOUT,3011) I,
29473C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29474C3011 FORMAT(38X,I3,3X,2E12.3)
29475C ENDIF
29476C 32 CONTINUE
29477C WRITE(LOUT,*)
29478C ENDIF
29479 ELSE
29480 WRITE(LOUT,3012)
29481 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29482 & 'Evaporation: not requested',/)
29483 ENDIF
29484
29485 RETURN
29486*------------------------------------------------------------------
29487* filling of histogram with event-record
29488 4 CONTINUE
29489* emulsion treatment
29490 IF (NCOMPO.GT.0) THEN
29491 DO 40 I=1,NCOMPO
29492 IF (IT.EQ.IEMUMA(I)) THEN
29493 EMUSAM(I) = EMUSAM(I)+ONE
29494 ENDIF
29495 40 CONTINUE
29496 ENDIF
29497 NINCGE = NINCGE+MAXGEN
29498 MAXGEN = 0
29499**dble Po statistics.
29500 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29501
29502 RETURN
29503*------------------------------------------------------------------
29504* filling of histogram with event-record
29505 5 CONTINUE
29506 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29507 IB = IIBAR(IDBAM(IDX))
29508 IC = IICH(IDBAM(IDX))
29509 J = ISTHKK(IDX)-14
29510 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29511 NINCST(J,1) = NINCST(J,1)+1
29512 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29513 NINCST(J,2) = NINCST(J,2)+1
29514 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29515 NINCST(J,3) = NINCST(J,3)+1
29516 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29517 NINCST(J,4) = NINCST(J,4)+1
29518 ENDIF
29519 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29520 NINCWO(1) = NINCWO(1)+1
29521 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29522 NINCWO(2) = NINCWO(2)+1
29523 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29524 IB = IDRES(IDX)
29525 IC = IDXRES(IDX)
29526 IF (IC.GT.0) THEN
29527 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29528 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29529 ENDIF
29530 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29531 ENDIF
29532
29533 RETURN
29534 END
29535*$ CREATE DT_NEWHGR.FOR
29536*COPY DT_NEWHGR
29537*
29538*===newhgr=============================================================*
29539*
29540 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29541
29542************************************************************************
29543* *
29544* Histogram initialization. *
29545* *
29546* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29547* XLIM3 bin size *
29548* IBIN > 0 number of bins in equidistant lin. binning *
29549* = -1 reset histograms *
29550* < -1 |IBIN| number of bins in equidistant log. *
29551* binning or log. binning in user def. struc. *
29552* XLIMB(*) user defined bin structure *
29553* *
29554* The bin structure is sensitive to *
29555* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29556* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29557* XLIMB, IBIN if XLIM3 < 0 *
29558* *
29559* *
29560* output: IREFN histogram index *
29561* (= -1 for inconsistent histogr. request) *
29562* *
29563* This subroutine is based on a original version by R. Engel. *
29564* This version dated 22.4.95 is written by S. Roesler. *
29565************************************************************************
29566
29567 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29568 SAVE
29569
29570 PARAMETER ( LINP = 10 ,
29571 & LOUT = 6 ,
29572 & LDAT = 9 )
29573
29574 LOGICAL LSTART
29575
29576 PARAMETER (ZERO = 0.0D0,
29577 & TINY = 1.0D-10)
29578
29579 DIMENSION XLIMB(*)
29580
29581* histograms
29582
29583 PARAMETER (NHIS=150, NDIM=250)
29584
29585 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29586 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29587
29588* auxiliary common for histograms
29589 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29590
29591 DATA LSTART /.TRUE./
29592
29593* reset histogram counter
29594 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29595 IHISL = 0
29596 IF (IBIN.EQ.-1) RETURN
29597 LSTART = .FALSE.
29598 ENDIF
29599
29600 IHIS = IHISL+1
29601* check for maximum number of allowed histograms
29602 IF (IHIS.GT.NHIS) THEN
29603 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29604 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29605 & I4,') exceeds array size (',I4,')',/,21X,
29606 & 'histogram',I3,' skipped!')
29607 GOTO 9999
29608 ENDIF
29609
29610 IREFN = IHIS
29611 IBINS(IHIS) = ABS(IBIN)
29612* check requested number of bins
29613 IF (IBINS(IHIS).GE.NDIM) THEN
29614 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29615 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29616 & I3,') exceeds array size (',I3,')',/,21X,
29617 & 'and will be reset to ',I3)
29618 IBINS(IHIS) = NDIM
29619 ENDIF
29620 IF (IBINS(IHIS).EQ.0) THEN
29621 WRITE(LOUT,1001) IBIN,IHIS
29622 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29623 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29624 GOTO 9999
29625 ENDIF
29626
29627* initialize arrays
29628 DO 1 I=1,NDIM
29629 DO 2 K=1,3
29630 HIST(K,IHIS,I) = ZERO
29631 HIST(K+3,IHIS,I) = ZERO
29632 TMPHIS(K,IHIS,I) = ZERO
29633 2 CONTINUE
29634 HIST(7,IHIS,I) = ZERO
29635 1 CONTINUE
29636 DENTRY(1,IHIS)= ZERO
29637 DENTRY(2,IHIS)= ZERO
29638 OVERF(IHIS) = ZERO
29639 UNDERF(IHIS) = ZERO
29640 TMPUFL(IHIS) = ZERO
29641 TMPOFL(IHIS) = ZERO
29642
29643* bin str. sensitive to lower edge, bin size, and numb. of bins
29644 IF (XLIM3.GT.ZERO) THEN
29645 DO 3 K=1,IBINS(IHIS)+1
29646 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29647 3 CONTINUE
29648 ISWI(IHIS) = 1
29649* bin str. sensitive to lower/upper edge and numb. of bins
29650 ELSEIF (XLIM3.EQ.ZERO) THEN
29651* linear binning
29652 IF (IBIN.GT.0) THEN
29653 XLOW = XLIM1
29654 XHI = XLIM2
29655 IF (XLIM2.LE.XLIM1) THEN
29656 WRITE(LOUT,1002) XLIM1,XLIM2
29657 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29658 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29659 GOTO 9999
29660 ENDIF
29661 ISWI(IHIS) = 1
29662 ELSEIF (IBIN.LT.-1) THEN
29663* logarithmic binning
29664 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29665 WRITE(LOUT,1004) XLIM1,XLIM2
29666 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29667 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29668 GOTO 9999
29669 ENDIF
29670 IF (XLIM2.LE.XLIM1) THEN
29671 WRITE(LOUT,1005) XLIM1,XLIM2
29672 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29673 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29674 GOTO 9999
29675 ENDIF
29676 XLOW = LOG10(XLIM1)
29677 XHI = LOG10(XLIM2)
29678 ISWI(IHIS) = 3
29679 ENDIF
29680 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29681 DO 4 K=1,IBINS(IHIS)+1
29682 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29683 4 CONTINUE
29684 ELSE
29685* user defined bin structure
29686 DO 5 K=1,IBINS(IHIS)+1
29687 IF (IBIN.GT.0) THEN
29688 HIST(1,IHIS,K) = XLIMB(K)
29689 ISWI(IHIS) = 2
29690 ELSEIF (IBIN.LT.-1) THEN
29691 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29692 ISWI(IHIS) = 4
29693 ENDIF
29694 5 CONTINUE
29695 ENDIF
29696
29697* histogram accepted
29698 IHISL = IHIS
29699
29700 RETURN
29701
29702 9999 CONTINUE
29703 IREFN = -1
29704 RETURN
29705 END
29706
29707*$ CREATE DT_FILHGR.FOR
29708*COPY DT_FILHGR
29709*
29710*===filhgr=============================================================*
29711*
29712 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29713
29714************************************************************************
29715* *
29716* Scoring for histogram IHIS. *
29717* *
29718* This subroutine is based on a original version by R. Engel. *
29719* This version dated 23.4.95 is written by S. Roesler. *
29720************************************************************************
29721
29722 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29723 SAVE
29724
29725 PARAMETER ( LINP = 10 ,
29726 & LOUT = 6 ,
29727 & LDAT = 9 )
29728
29729 PARAMETER (ZERO = 0.0D0,
29730 & ONE = 1.0D0,
29731 & TINY = 1.0D-10)
29732
29733* histograms
29734
29735 PARAMETER (NHIS=150, NDIM=250)
29736
29737 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29738 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29739
29740* auxiliary common for histograms
29741 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29742
29743 DATA NCEVT /1/
29744
29745 X = XI
29746 Y = YI
29747
29748* dump content of temorary arrays into histograms
29749 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29750 CALL DT_EVTHIS(IDUM)
29751 NCEVT = NEVT
29752 ENDIF
29753
29754* check histogram index
29755 IF (IHIS.EQ.-1) RETURN
29756 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29757C WRITE(LOUT,1000) IHIS,IHISL
29758 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29759 & ' out of range (1..',I3,')')
29760 RETURN
29761 ENDIF
29762
29763 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29764* bin structure not explicitly given
29765 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29766 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29767 IF (X.LT.HIST(1,IHIS,1)) THEN
29768 I1 = 0
29769 ELSE
29770 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29771 ENDIF
29772
29773 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29774* user defined bin structure
29775 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29776 IF (X.LT.HIST(1,IHIS,1)) THEN
29777 I1 = 0
29778 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29779 I1 = IBINS(IHIS)+1
29780 ELSE
29781* binary sort algorithm
29782 KMIN = 0
29783 KMAX = IBINS(IHIS)+1
29784 1 CONTINUE
29785 IF ((KMAX-KMIN).EQ.1) GOTO 2
29786 KK = (KMAX+KMIN)/2
29787 IF (X.LE.HIST(1,IHIS,KK)) THEN
29788 KMAX=KK
29789 ELSE
29790 KMIN=KK
29791 ENDIF
29792 GOTO 1
29793 2 CONTINUE
29794 I1 = KMIN
29795 ENDIF
29796
29797 ELSE
29798 WRITE(LOUT,1001)
29799 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29800 RETURN
29801 ENDIF
29802
29803* scoring
29804 IF (I1.LE.0) THEN
29805 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29806 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29807 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29808 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29809 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29810 ELSE
29811 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29812 ENDIF
29813 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29814 ELSE
29815 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29816 ENDIF
29817
29818 RETURN
29819 END
29820
29821*$ CREATE DT_EVTHIS.FOR
29822*COPY DT_EVTHIS
29823*
29824*===evthis=============================================================*
29825*
29826 SUBROUTINE DT_EVTHIS(NEVT)
29827
29828************************************************************************
29829* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29830* is called after each event and for the last event before any call *
29831* to OUTHGR. *
29832* NEVT number of events dumped, this is only needed to *
29833* get the normalization after the last event *
29834* This version dated 23.4.95 is written by S. Roesler. *
29835************************************************************************
29836
29837 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29838 SAVE
29839
29840 PARAMETER ( LINP = 10 ,
29841 & LOUT = 6 ,
29842 & LDAT = 9 )
29843
29844 LOGICAL LNOETY
29845
29846 PARAMETER (ZERO = 0.0D0,
29847 & ONE = 1.0D0,
29848 & TINY = 1.0D-10)
29849
29850* histograms
29851
29852 PARAMETER (NHIS=150, NDIM=250)
29853
29854 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29855 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29856
29857* auxiliary common for histograms
29858 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29859
29860 DATA NCEVT /0/
29861
29862 NCEVT = NCEVT+1
29863 NEVT = NCEVT
29864
29865 DO 1 I=1,IHISL
29866 LNOETY = .TRUE.
29867 DO 2 J=1,IBINS(I)
29868 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29869 LNOETY = .FALSE.
29870 HIST(2,I,J) = HIST(2,I,J)+ONE
29871 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29872 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29873 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29874 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29875 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29876 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29877 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29878 TMPHIS(1,I,J) = ZERO
29879 TMPHIS(2,I,J) = ZERO
29880 TMPHIS(3,I,J) = ZERO
29881 ENDIF
29882 2 CONTINUE
29883 IF (LNOETY) THEN
29884 IF (TMPUFL(I).GT.ZERO) THEN
29885 UNDERF(I) = UNDERF(I)+ONE
29886 TMPUFL(I) = ZERO
29887 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29888 OVERF(I) = OVERF(I)+ONE
29889 TMPOFL(I) = ZERO
29890 ENDIF
29891 ELSE
29892 DENTRY(1,I) = DENTRY(1,I)+ONE
29893 ENDIF
29894 1 CONTINUE
29895
29896 RETURN
29897 END
29898
29899*$ CREATE DT_OUTHGR.FOR
29900*COPY DT_OUTHGR
29901*
29902*===outhgr=============================================================*
29903*
29904 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29905 & ILOGY,INORM,NMODE)
29906
29907************************************************************************
29908* *
29909* Plot histogram(s) to standard output unit *
29910* *
29911* I1..6 indices of histograms to be plotted *
29912* CHEAD,IHEAD header string,integer *
29913* NEVTS number of events *
29914* FAC scaling factor *
29915* ILOGY = 1 logarithmic y-axis *
29916* INORM normalization *
29917* = 0 no further normalization (FAC is obsolete) *
29918* = 1 per event and bin width *
29919* = 2 per entry and bin width *
29920* = 3 per bin entry *
29921* = 4 per event and "bin width" x1^2...x2^2 *
29922* = 5 per event and "log. bin width" ln x1..ln x2 *
29923* = 6 per event *
29924* MODE = 0 no output but normalization applied *
29925* = 1 all valid histograms separately (small frame) *
29926* all valid histograms separately (small frame) *
29927* = -1 and tables as histograms *
29928* = 2 all valid histograms (one plot, wide frame) *
29929* all valid histograms (one plot, wide frame) *
29930* = -2 and tables as histograms *
29931* *
29932* *
29933* Note: All histograms to be plotted with one call to this *
29934* subroutine and |MODE|=2 must have the same bin structure! *
29935* There is no test included ensuring this fact. *
29936* *
29937* This version dated 23.4.95 is written by S. Roesler. *
29938************************************************************************
29939
29940 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29941 SAVE
29942
29943 PARAMETER ( LINP = 10 ,
29944 & LOUT = 6 ,
29945 & LDAT = 9 )
29946
29947 CHARACTER*72 CHEAD
29948
29949 PARAMETER (ZERO = 0.0D0,
29950 & IZERO = 0,
29951 & ONE = 1.0D0,
29952 & TWO = 2.0D0,
29953 & OHALF = 0.5D0,
29954 & EPS = 1.0D-5,
29955 & TINY = 1.0D-8,
29956 & SMALL = -1.0D8,
29957 & RLARGE = 1.0D8 )
29958
29959* histograms
29960
29961 PARAMETER (NHIS=150, NDIM=250)
29962
29963 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29964 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29965
29966 PARAMETER (NDIM2 = 2*NDIM)
29967 DIMENSION XX(NDIM2),YY(NDIM2)
29968
29969 PARAMETER (NHISTO = 6)
29970 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29971 & IDX(NHISTO)
29972
29973 CHARACTER*43 CNORM(0:8)
29974 DATA CNORM /'no further normalization ',
29975 & 'per event and bin width ',
29976 & 'per entry1 and bin width ',
29977 & 'per bin entry ',
29978 & 'per event and "bin width" x1^2...x2^2 ',
29979 & 'per event and "log. bin width" ln x1..ln x2',
29980 & 'per event ',
29981 & 'per bin entry1 ',
29982 & 'per entry2 and bin width '/
29983
29984 IDX1(1) = I1
29985 IDX1(2) = I2
29986 IDX1(3) = I3
29987 IDX1(4) = I4
29988 IDX1(5) = I5
29989 IDX1(6) = I6
29990
29991 MODE = NMODE
29992
29993* initialization if "wide frame" is requested
29994 IF (ABS(MODE).EQ.2) THEN
29995 DO 1 I=1,NHISTO
29996 DO 2 J=1,NDIM
29997 XX1(J,I) = ZERO
29998 YY1(J,I) = ZERO
29999 2 CONTINUE
30000 1 CONTINUE
30001 ENDIF
30002
30003* plot header
30004 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30005
30006* check histogram indices
30007 NHI = 0
30008 DO 3 I=1,NHISTO
30009 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30010 IF (ISWI(IDX1(I)).NE.0) THEN
30011 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30012 WRITE(LOUT,1000)
30013 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30014 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30015 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30016 & ' overflows: ',F10.0)
30017 ELSE
30018 NHI = NHI+1
30019 IDX(NHI) = IDX1(I)
30020 ENDIF
30021 ENDIF
30022 ENDIF
30023 3 CONTINUE
30024 IF (NHI.EQ.0) THEN
30025 WRITE(LOUT,1001)
30026 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30027 RETURN
30028 ENDIF
30029
30030* check normalization request
30031 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30032 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30033 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30034 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30035 WRITE(LOUT,1002) NEVTS,INORM,FAC
30036 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30037 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30038 & 'FAC = ',E11.4)
30039 RETURN
30040 ENDIF
30041
30042 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30043
30044* apply normalization
30045 DO 4 N=1,NHI
30046
30047 I = IDX(N)
30048
30049 IF (ISWI(I).EQ.1) THEN
30050 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30051 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30052 & ' to',2X,E10.4,',',2X,I3,' bins')
30053 ELSEIF (ISWI(I).EQ.2) THEN
30054 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30055 WRITE(LOUT,1007)
30056 1007 FORMAT(1X,'user defined bin structure')
30057 ELSEIF (ISWI(I).EQ.3) THEN
30058 WRITE(LOUT,1004)
30059 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30060 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30061 & ' to',2X,E10.4,',',2X,I3,' bins')
30062 ELSEIF (ISWI(I).EQ.4) THEN
30063 WRITE(LOUT,1004)
30064 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30065 WRITE(LOUT,1007)
30066 ELSE
30067 WRITE(LOUT,1008) ISWI(I)
30068 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30069 ENDIF
30070 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30071 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30072 & ' overfl.:',F8.0)
30073 WRITE(LOUT,1009) CNORM(INORM)
30074 1009 FORMAT(1X,'normalization: ',A,/)
30075
30076 DO 5 K=1,IBINS(I)
30077 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30078 YMEAN = FAC*YMEAN
30079 YERR = FAC*YERR
30080 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30081 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30082 1006 FORMAT(1X,5E11.3)
30083* small frame
30084 II = 2*K
30085 XX(II-1) = HIST(1,I,K)
30086 XX(II) = HIST(1,I,K+1)
30087 YY(II-1) = YMEAN
30088 YY(II) = YMEAN
30089* wide frame
30090 XX1(K,N) = XMEAN
30091 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30092 & XX1(K,N) = LOG10(XMEAN)
30093 YY1(K,N) = YMEAN
30094 5 CONTINUE
30095
30096* plot small frame
30097 IF (ABS(MODE).EQ.1) THEN
30098 IBIN2 = 2*IBINS(I)
30099 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30100 IF(ILOGY.EQ.1) THEN
30101 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30102 ELSE
30103 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30104 ENDIF
30105 ENDIF
30106
30107 4 CONTINUE
30108
30109* plot wide frame
30110 IF (ABS(MODE).EQ.2) THEN
30111 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30112 NSIZE = NDIM*NHISTO
30113 DXLOW = HIST(1,IDX(1),1)
30114 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30115 YLOW = RLARGE
30116 YHI = SMALL
30117 DO 6 I=1,NHISTO
30118 DO 7 J=1,NDIM
30119 IF (YY1(J,I).LT.YLOW) THEN
30120 IF (ILOGY.EQ.1) THEN
30121 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30122 ELSE
30123 YLOW = YY1(J,I)
30124 ENDIF
30125 ENDIF
30126 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30127 7 CONTINUE
30128 6 CONTINUE
30129 DY = (YHI-YLOW)/DBLE(NDIM)
30130 IF (DY.LE.ZERO) THEN
30131 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30132 & 'OUTHGR: warning! zero bin width for histograms ',
30133 & IDX,': ',YLOW,YHI
30134 RETURN
30135 ENDIF
30136 IF (ILOGY.EQ.1) THEN
30137 YLOW = LOG10(YLOW)
30138 DY = (LOG10(YHI)-YLOW)/100.0D0
30139 DO 8 I=1,NHISTO
30140 DO 9 J=1,NDIM
30141 IF (YY1(J,I).LE.ZERO) THEN
30142 YY1(J,I) = YLOW
30143 ELSE
30144 YY1(J,I) = LOG10(YY1(J,I))
30145 ENDIF
30146 9 CONTINUE
30147 8 CONTINUE
30148 ENDIF
30149 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30150 ENDIF
30151
30152 RETURN
30153 END
30154
30155*$ CREATE DT_GETBIN.FOR
30156*COPY DT_GETBIN
30157*
30158*===getbin=============================================================*
30159*
30160 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30161 & XMEAN,YMEAN,YERR)
30162
30163************************************************************************
30164* This version dated 23.4.95 is written by S. Roesler. *
30165************************************************************************
30166
30167 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30168 SAVE
30169
30170 PARAMETER ( LINP = 10 ,
30171 & LOUT = 6 ,
30172 & LDAT = 9 )
30173
30174 PARAMETER (ZERO = 0.0D0,
30175 & ONE = 1.0D0,
30176 & TINY35 = 1.0D-35)
30177
30178* histograms
30179
30180 PARAMETER (NHIS=150, NDIM=250)
30181
30182 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30183 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30184
30185 XLOW = HIST(1,IHIS,IBIN)
30186 XHI = HIST(1,IHIS,IBIN+1)
30187 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30188 XLOW = 10**XLOW
30189 XHI = 10**XHI
30190 ENDIF
30191 IF (NORM.EQ.2) THEN
30192 DX = XHI-XLOW
30193 NEVT = INT(DENTRY(1,IHIS))
30194 ELSEIF (NORM.EQ.3) THEN
30195 DX = ONE
30196 NEVT = INT(HIST(2,IHIS,IBIN))
30197 ELSEIF (NORM.EQ.4) THEN
30198 DX = XHI**2-XLOW**2
30199 NEVT = KEVT
30200 ELSEIF (NORM.EQ.5) THEN
30201 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30202 NEVT = KEVT
30203 ELSEIF (NORM.EQ.6) THEN
30204 DX = ONE
30205 NEVT = KEVT
30206 ELSEIF (NORM.EQ.7) THEN
30207 DX = ONE
30208 NEVT = INT(HIST(7,IHIS,IBIN))
30209 ELSEIF (NORM.EQ.8) THEN
30210 DX = XHI-XLOW
30211 NEVT = INT(DENTRY(2,IHIS))
30212 ELSE
30213 DX = ABS(XHI-XLOW)
30214 NEVT = KEVT
30215 ENDIF
30216 IF (ABS(DX).LT.TINY35) DX = ONE
30217 NEVT = MAX(NEVT,1)
30218 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30219 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30220 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30221 YSUM = HIST(5,IHIS,IBIN)
30222 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30223C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30224 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30225 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30226
30227 RETURN
30228 END
30229
30230*$ CREATE DT_JOIHIS.FOR
30231*COPY DT_JOIHIS
30232*
30233*===joihis=============================================================*
30234*
30235 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30236
30237************************************************************************
30238* *
30239* Operation on histograms. *
30240* *
30241* input: IH1,IH2 histogram indices to be joined *
30242* COPER character defining the requested operation, *
30243* i.e. '+', '-', '*', '/' *
30244* FAC1,FAC2 factors for joining, i.e. *
30245* FAC1*histo1 COPER FAC2*histo2 *
30246* *
30247* This version dated 23.4.95 is written by S. Roesler. *
30248************************************************************************
30249
30250 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30251 SAVE
30252
30253 PARAMETER ( LINP = 10 ,
30254 & LOUT = 6 ,
30255 & LDAT = 9 )
30256
30257 CHARACTER COPER*1
30258
30259 PARAMETER (ZERO = 0.0D0,
30260 & ONE = 1.0D0,
30261 & OHALF = 0.5D0,
30262 & TINY8 = 1.0D-8,
30263 & SMALL = -1.0D8,
30264 & RLARGE = 1.0D8 )
30265
30266* histograms
30267
30268 PARAMETER (NHIS=150, NDIM=250)
30269
30270 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30271 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30272
30273 PARAMETER (NDIM2 = 2*NDIM)
30274 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30275
30276 CHARACTER*43 CNORM(0:6)
30277 DATA CNORM /'no further normalization ',
30278 & 'per event and bin width ',
30279 & 'per entry and bin width ',
30280 & 'per bin entry ',
30281 & 'per event and "bin width" x1^2...x2^2 ',
30282 & 'per event and "log. bin width" ln x1..ln x2',
30283 & 'per event '/
30284
30285* check histogram indices
30286 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30287 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30288 WRITE(LOUT,1000) IH1,IH2,IHISL
30289 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30290 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30291 GOTO 9999
30292 ENDIF
30293
30294* check bin structure of histograms to be joined
30295 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30296 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30297 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30298 & ' and ',I3,' failed',/,21X,
30299 & 'due to different numbers of bins (',I3,',',I3,')')
30300 GOTO 9999
30301 ENDIF
30302 DO 1 K=1,IBINS(IH1)+1
30303 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30304 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30305 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30306 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30307 & 'X1,X2 = ',2E11.4)
30308 GOTO 9999
30309 ENDIF
30310 1 CONTINUE
30311
30312 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30313 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30314 & 'operation ',A,/,11X,'and factors ',2E11.4)
30315 WRITE(LOUT,1004) CNORM(NORM)
30316 1004 FORMAT(1X,'normalization: ',A,/)
30317
30318 DO 2 K=1,IBINS(IH1)
30319 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30320 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30321 XLOW = XLOW1
30322 XHI = XHI1
30323 XMEAN = OHALF*(XMEAN1+XMEAN2)
30324 IF (COPER.EQ.'+') THEN
30325 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30326 ELSEIF (COPER.EQ.'*') THEN
30327 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30328 ELSEIF (COPER.EQ.'/') THEN
30329 IF (YMEAN2.EQ.ZERO) THEN
30330 YMEAN = ZERO
30331 ELSE
30332 IF (FAC2.EQ.ZERO) FAC2 = ONE
30333 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30334 ENDIF
30335 ELSE
30336 GOTO 9998
30337 ENDIF
30338 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30339 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30340 1006 FORMAT(1X,5E11.3)
30341* small frame
30342 II = 2*K
30343 XX(II-1) = HIST(1,IH1,K)
30344 XX(II) = HIST(1,IH1,K+1)
30345 YY(II-1) = YMEAN
30346 YY(II) = YMEAN
30347* wide frame
30348 XX1(K) = XMEAN
30349 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30350 YY1(K) = YMEAN
30351 2 CONTINUE
30352
30353* plot small frame
30354 IF (ABS(MODE).EQ.1) THEN
30355 IBIN2 = 2*IBINS(IH1)
30356 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30357 IF(ILOGY.EQ.1) THEN
30358 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30359 ELSE
30360 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30361 ENDIF
30362 ENDIF
30363
30364* plot wide frame
30365 IF (ABS(MODE).EQ.2) THEN
30366 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30367 NSIZE = NDIM
30368 DXLOW = HIST(1,IH1,1)
30369 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30370 YLOW = RLARGE
30371 YHI = SMALL
30372 DO 3 I=1,NDIM
30373 IF (YY1(I).LT.YLOW) THEN
30374 IF (ILOGY.EQ.1) THEN
30375 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30376 ELSE
30377 YLOW = YY1(I)
30378 ENDIF
30379 ENDIF
30380 IF (YY1(I).GT.YHI) YHI = YY1(I)
30381 3 CONTINUE
30382 DY = (YHI-YLOW)/DBLE(NDIM)
30383 IF (DY.LE.ZERO) THEN
30384 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30385 & 'JOIHIS: warning! zero bin width for histograms ',
30386 & IH1,IH2,': ',YLOW,YHI
30387 RETURN
30388 ENDIF
30389 IF (ILOGY.EQ.1) THEN
30390 YLOW = LOG10(YLOW)
30391 DY = (LOG10(YHI)-YLOW)/100.0D0
30392 DO 4 I=1,NDIM
30393 IF (YY1(I).LE.ZERO) THEN
30394 YY1(I) = YLOW
30395 ELSE
30396 YY1(I) = LOG10(YY1(I))
30397 ENDIF
30398 4 CONTINUE
30399 ENDIF
30400 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30401 ENDIF
30402
30403 RETURN
30404
30405 9998 CONTINUE
30406 WRITE(LOUT,1005) COPER
30407 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30408
30409 9999 CONTINUE
30410 RETURN
30411 END
30412
30413*$ CREATE DT_XGRAPH.FOR
30414*COPY DT_XGRAPH
30415*
30416*===qgraph=============================================================*
30417*
30418 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30419C***********************************************************************
30420C
30421C calculate quasi graphic picture with 25 lines and 79 columns
30422C ranges will be chosen automatically
30423C
30424C input N dimension of input fields
30425C IARG number of curves (fields) to plot
30426C X field of X
30427C Y1 field of Y1
30428C Y2 field of Y2
30429C
30430C This subroutine is written by R. Engel.
30431C***********************************************************************
30432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30433 SAVE
30434
30435 PARAMETER ( LINP = 10 ,
30436 & LOUT = 6 ,
30437 & LDAT = 9 )
30438
30439C
30440 DIMENSION X(N),Y1(N),Y2(N)
30441 PARAMETER (EPS=1.D-30)
30442 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30443 CHARACTER SYMB(5)
30444 CHARACTER COL(0:149,0:49)
30445C
30446 DATA SYMB /'0','e','z','#','x'/
30447C
30448 ISPALT=IBREIT-10
30449C
30450C*** automatic range fitting
30451C
30452 XMAX=X(1)
30453 XMIN=X(1)
30454 DO 600 I=1,N
30455 XMAX=MAX(X(I),XMAX)
30456 XMIN=MIN(X(I),XMIN)
30457 600 CONTINUE
30458 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30459C
30460 ITEST=0
30461 DO 1100 K=0,IZEIL-1
30462 ITEST=ITEST+1
30463 IF (ITEST.EQ.IYRAST) THEN
30464 DO 1010 L=1,ISPALT-1
30465 COL(L,K)='-'
304661010 CONTINUE
30467 COL(ISPALT,K)='+'
30468 ITEST=0
30469 DO 1020 L=0,ISPALT-1,IXRAST
30470 COL(L,K)='+'
304711020 CONTINUE
30472 ELSE
30473 DO 1030 L=1,ISPALT-1
30474 COL(L,K)=' '
304751030 CONTINUE
30476 DO 1040 L=0,ISPALT-1,IXRAST
30477 COL(L,K)='|'
304781040 CONTINUE
30479 COL(ISPALT,K)='|'
30480 ENDIF
304811100 CONTINUE
30482C
30483C*** plot curve Y1
30484C
30485 YMAX=Y1(1)
30486 YMIN=Y1(1)
30487 DO 500 I=1,N
30488 YMAX=MAX(Y1(I),YMAX)
30489 YMIN=MIN(Y1(I),YMIN)
30490500 CONTINUE
30491 IF(IARG.GT.1) THEN
30492 DO 550 I=1,N
30493 YMAX=MAX(Y2(I),YMAX)
30494 YMIN=MIN(Y2(I),YMIN)
30495550 CONTINUE
30496 ENDIF
30497 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30498 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30499 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30500 IF(YZOOM.LT.EPS) THEN
30501 WRITE(LOUT,'(1X,A)')
30502 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30503 RETURN
30504 ENDIF
30505C
30506C*** plot curve Y1
30507C
30508 ILAST=-1
30509 LLAST=-1
30510 DO 1200 K=1,N
30511 L=NINT((X(K)-XMIN)/XZOOM)
30512 I=NINT((YMAX-Y1(K))/YZOOM)
30513 IF(ILAST.GE.0) THEN
30514 LD = L-LLAST
30515 ID = I-ILAST
30516 DO 55 II=0,LD,SIGN(1,LD)
30517 DO 66 KK=0,ID,SIGN(1,ID)
30518 COL(II+LLAST,KK+ILAST)=SYMB(1)
30519 66 CONTINUE
30520 55 CONTINUE
30521 ELSE
30522 COL(L,I)=SYMB(1)
30523 ENDIF
30524 ILAST = I
30525 LLAST = L
305261200 CONTINUE
30527C
30528 IF(IARG.GT.1) THEN
30529C
30530C*** plot curve Y2
30531C
30532 DO 1250 K=1,N
30533 L=NINT((X(K)-XMIN)/XZOOM)
30534 I=NINT((YMAX-Y2(K))/YZOOM)
30535 COL(L,I)=SYMB(2)
305361250 CONTINUE
30537 ENDIF
30538C
30539C*** write it
30540C
30541 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30542C
30543C*** write range of X
30544C
30545 XZOOM = (XMAX-XMIN)/DBLE(7)
30546 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30547C
30548 DO 1300 K=0,IZEIL-1
30549 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30550 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30551 110 FORMAT(1X,1PE9.2,70A1)
305521300 CONTINUE
30553C
30554C*** write range of X
30555C
30556 XZOOM = (XMAX-XMIN)/DBLE(7)
30557 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30558 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30559 120 FORMAT(6X,7(1PE10.3))
30560 END
30561
30562*$ CREATE DT_XGLOGY.FOR
30563*COPY DT_XGLOGY
30564*
30565*===qglogy=============================================================*
30566*
30567 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30568C***********************************************************************
30569C
30570C calculate quasi graphic picture with 25 lines and 79 columns
30571C logarithmic y axis
30572C ranges will be chosen automatically
30573C
30574C input N dimension of input fields
30575C IARG number of curves (fields) to plot
30576C X field of X
30577C Y1 field of Y1
30578C Y2 field of Y2
30579C
30580C This subroutine is written by R. Engel.
30581C***********************************************************************
30582C
30583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30584 SAVE
30585
30586 PARAMETER ( LINP = 10 ,
30587 & LOUT = 6 ,
30588 & LDAT = 9 )
30589
30590 DIMENSION X(N),Y1(N),Y2(N)
30591 PARAMETER (EPS=1.D-30)
30592 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30593 CHARACTER SYMB(5)
30594 CHARACTER COL(0:149,0:49)
30595 PARAMETER (DEPS = 1.D-10)
30596C
30597 DATA SYMB /'0','e','z','#','x'/
30598C
30599 ISPALT=IBREIT-10
30600C
30601C*** automatic range fitting
30602C
30603 XMAX=X(1)
30604 XMIN=X(1)
30605 DO 600 I=1,N
30606 XMAX=MAX(X(I),XMAX)
30607 XMIN=MIN(X(I),XMIN)
30608 600 CONTINUE
30609 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30610C
30611 ITEST=0
30612 DO 1100 K=0,IZEIL-1
30613 ITEST=ITEST+1
30614 IF (ITEST.EQ.IYRAST) THEN
30615 DO 1010 L=1,ISPALT-1
30616 COL(L,K)='-'
306171010 CONTINUE
30618 COL(ISPALT,K)='+'
30619 ITEST=0
30620 DO 1020 L=0,ISPALT-1,IXRAST
30621 COL(L,K)='+'
306221020 CONTINUE
30623 ELSE
30624 DO 1030 L=1,ISPALT-1
30625 COL(L,K)=' '
306261030 CONTINUE
30627 DO 1040 L=0,ISPALT-1,IXRAST
30628 COL(L,K)='|'
306291040 CONTINUE
30630 COL(ISPALT,K)='|'
30631 ENDIF
306321100 CONTINUE
30633C
30634C*** plot curve Y1
30635C
30636 YMAX=Y1(1)
30637 YMIN=MAX(Y1(1),EPS)
30638 DO 500 I=1,N
30639 YMAX =MAX(Y1(I),YMAX)
30640 IF(Y1(I).GT.EPS) THEN
30641 IF(YMIN.EQ.EPS) THEN
30642 YMIN = Y1(I)/10.D0
30643 ELSE
30644 YMIN = MIN(Y1(I),YMIN)
30645 ENDIF
30646 ENDIF
30647500 CONTINUE
30648 IF(IARG.GT.1) THEN
30649 DO 550 I=1,N
30650 YMAX=MAX(Y2(I),YMAX)
30651 IF(Y2(I).GT.EPS) THEN
30652 IF(YMIN.EQ.EPS) THEN
30653 YMIN = Y2(I)
30654 ELSE
30655 YMIN = MIN(Y2(I),YMIN)
30656 ENDIF
30657 ENDIF
30658550 CONTINUE
30659 ENDIF
30660C
30661 DO 560 I=1,N
30662 Y1(I) = MAX(Y1(I),YMIN)
30663 560 CONTINUE
30664 IF(IARG.GT.1) THEN
30665 DO 570 I=1,N
30666 Y2(I) = MAX(Y2(I),YMIN)
30667 570 CONTINUE
30668 ENDIF
30669C
30670 IF(YMAX.LE.YMIN) THEN
30671 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30672 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30673 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30674 RETURN
30675 ENDIF
30676C
30677 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30678 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30679 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30680 IF(YZOOM.LT.EPS) THEN
30681 WRITE(LOUT,'(1X,A)')
30682 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30683 RETURN
30684 ENDIF
30685C
30686C*** plot curve Y1
30687C
30688 ILAST=-1
30689 LLAST=-1
30690 DO 1200 K=1,N
30691 L=NINT((X(K)-XMIN)/XZOOM)
30692 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30693 IF(ILAST.GE.0) THEN
30694 LD = L-LLAST
30695 ID = I-ILAST
30696 DO 55 II=0,LD,SIGN(1,LD)
30697 DO 66 KK=0,ID,SIGN(1,ID)
30698 COL(II+LLAST,KK+ILAST)=SYMB(1)
30699 66 CONTINUE
30700 55 CONTINUE
30701 ELSE
30702 COL(L,I)=SYMB(1)
30703 ENDIF
30704 ILAST = I
30705 LLAST = L
307061200 CONTINUE
30707C
30708 IF(IARG.GT.1) THEN
30709C
30710C*** plot curve Y2
30711C
30712 DO 1250 K=1,N
30713 L=NINT((X(K)-XMIN)/XZOOM)
30714 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30715 COL(L,I)=SYMB(2)
307161250 CONTINUE
30717 ENDIF
30718C
30719C*** write it
30720C
30721 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30722 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30723C
30724C*** write range of X
30725C
30726 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30727 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30728C
30729 DO 1300 K=0,IZEIL-1
30730 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30731 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30732 110 FORMAT(1X,1PE9.2,70A1)
307331300 CONTINUE
30734C
30735C*** write range of X
30736C
30737 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30738 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30739 120 FORMAT(6X,7(1PE10.3))
30740C
30741 END
30742
30743*$ CREATE DT_SRPLOT.FOR
30744*COPY DT_SRPLOT
30745*
30746*===plot===============================================================*
30747*
30748 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30749
30750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30751 SAVE
30752
30753 PARAMETER ( LINP = 10 ,
30754 & LOUT = 6 ,
30755 & LDAT = 9 )
30756
30757*
30758* initial version
30759* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30760* This is a subroutine of fluka to plot Y across the page
30761* as a function of X down the page. Up to 37 curves can be
30762* plotted in the same picture with different plotting characters.
30763* Output of first 10 overprinted characters addad by FB 88
30764* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30765*
30766* Input Variables:
30767* X = array containing the values of X
30768* Y = array containing the values of Y
30769* N = number of values in X and in Y
30770* can exceed the fixed number of lines
30771* M = number of different curves X,Y are containing
30772* MM = number of points in each curve i.e. N=M*MM
30773* XO = smallest value of X to be plotted
30774* DX = increment of X between subsequent lines
30775* YO = smallest value of Y to be plotted
30776* DY = increment of Y between subsequent character spaces
30777*
30778* other variables used inside:
30779* XX = numbers along the X-coordinate axis
30780* YY = numbers along the Y-coordinate axis
30781* LL = ten lines temporary storage for the plot
30782* L = character set used to plot different curves
30783* LOV = memorizes overprinted symbols
30784* the first 10 overprinted symbols are printed on
30785* the end of the line to avoid ambiguities
30786* (added by FB as considered quite helpful)
30787*
30788*********************************************************************
30789*
30790 DIMENSION XX(61),YY(61),LL(101,10)
30791 DIMENSION X(N),Y(N),L(40),LOV(40,10)
004932dd 30792 INTEGER*4 LL, L, LOV
7b076c76 30793 DATA L/
30794 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30795 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30796 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30797 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30798*
30799*
30800 MN=51
30801 DO 10 I=1,MN
30802 AI=I-1
30803 10 XX(I)=XO+AI*DX
30804 DO 20 I=1,11
30805 AI=I-1
30806 20 YY(I)=YO+10.0D0*AI*DY
30807 WRITE(LOUT, 500) (YY(I),I=1,11)
30808 MMN=MN-1
30809*
30810*
30811 DO 90 JJ=1,MMN,10
30812 JJJ=JJ-1
30813 DO 30 I=1,101
30814 DO 30 J=1,10
30815 30 LL(I,J)=L(40)
30816 DO 40 I=1,101
30817 40 LL(I,1)=L(39)
30818 DO 50 I=1,101,10
30819 DO 50 J=1,10
30820 50 LL(I,J)=L(38)
30821 DO 60 I=1,40
30822 DO 60 J=1,10
30823 60 LOV(I,J)=L(40)
30824*
30825*
30826 DO 70 I=1,M
30827 DO 70 J=1,MM
30828 II=J+(I-1)*MM
30829 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30830 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30831 AIX=AIX-DBLE(JJJ)
30832* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30833 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30834 + . AIY .LT. 102.D0) THEN
30835 IX=INT(AIX)
30836 IY=INT(AIY)
30837 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30838 + THEN
30839 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30840 + =LL(IY,IX)
30841 LL(IY,IX)=L(I)
30842 ENDIF
30843 ENDIF
30844 70 CONTINUE
30845*
30846*
30847 DO 80 I=1,10
30848 II=I+JJJ
30849 III=II+1
30850 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30851 & (LOV(J,I),J=1,10)
30852 80 CONTINUE
30853 90 CONTINUE
30854*
30855*
30856 WRITE(LOUT, 520)
30857 WRITE(LOUT, 500) (YY(I),I=1,11)
30858 RETURN
30859*
30860 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30861 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30862 520 FORMAT(20X,10('1---------'),'1')
30863 END
30864*$ CREATE DT_DEFSET.FOR
30865*COPY DT_DEFSET
30866*
30867*===defset=============================================================*
30868*
30869 BLOCK DATA DT_DEFSET
30870
30871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30872 SAVE
30873
30874* flags for input different options
30875 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30876 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30877 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30878
30879 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30880
30881* emulsion treatment
30882 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30883 & NCOMPO,IEMUL
30884
30885* / DTFLG1 /
30886 DATA IFRAG / 2, 1 /
30887 DATA IRESCO / 1 /
30888 DATA IMSHL / 1 /
30889 DATA IRESRJ / 0 /
30890 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30891 DATA LEMCCK / .FALSE. /
30892 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30893 & .TRUE.,.TRUE.,.TRUE./
30894 DATA LSEADI / .TRUE. /
30895 DATA LEVAPO / .TRUE. /
30896 DATA IFRAME / 1 /
30897 DATA ITRSPT / 0 /
30898
30899* / DTCOMP /
30900 DATA EMUFRA / NCOMPX*0.0D0 /
30901 DATA IEMUMA / NCOMPX*1 /
30902 DATA IEMUCH / NCOMPX*1 /
30903 DATA NCOMPO / 0 /
30904 DATA IEMUL / 0 /
30905
30906 END
30907
30908*$ CREATE DT_HADPRP.FOR
30909*COPY DT_HADPRP
30910*
30911*===hadprp=============================================================*
30912*
30913 BLOCK DATA DT_HADPRP
30914
30915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30916 SAVE
30917
30918* auxiliary common for reggeon exchange (DTUNUC 1.x)
30919 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30920 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30921 & IQTCHR(-6:6),MQUARK(3,39)
30922
30923* hadron index conversion (BAMJET <--> PDG)
30924 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30925 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30926 & IAMCIN(210)
30927
30928* names of hadrons used in input-cards
30929 CHARACTER*8 BTYPE
30930 COMMON /DTPAIN/ BTYPE(30)
30931
30932* / DTQUAR /
30933*----------------------------------------------------------------------*
30934* *
30935* Quark content of particles: *
30936* index quark el. charge bar. charge isospin isospin3 *
30937* 1 = u 2/3 1/3 1/2 1/2 *
30938* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30939* 2 = d -1/3 1/3 1/2 -1/2 *
30940* -2 = dbar 1/3 -1/3 1/2 1/2 *
30941* 3 = s -1/3 1/3 0 0 *
30942* -3 = sbar 1/3 -1/3 0 0 *
30943* 4 = c 2/3 1/3 0 0 *
30944* -4 = cbar -2/3 -1/3 0 0 *
30945* 5 = b -1/3 1/3 0 0 *
30946* -5 = bbar 1/3 -1/3 0 0 *
30947* 6 = t 2/3 1/3 0 0 *
30948* -6 = tbar -2/3 -1/3 0 0 *
30949* *
30950* Mquark = particle quark composition (Paprop numbering) *
30951* Iqechr = electric charge ( in 1/3 unit ) *
30952* Iqbchr = baryonic charge ( in 1/3 unit ) *
30953* Iqichr = isospin ( in 1/2 unit ), z component *
30954* Iqschr = strangeness *
30955* Iqcchr = charm *
30956* Iquchr = beauty *
30957* Iqtchr = ...... *
30958* *
30959*----------------------------------------------------------------------*
30960 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30961 DATA IQBCHR / 6*-1, 0, 6*1 /
30962 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30963 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30964 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30965 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30966 DATA IQTCHR / -1, 11*0, 1 /
30967 DATA MQUARK /
30968 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30969 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30970 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30971 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30972 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30973 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30974 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30975 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30976
30977* / DTHAIC /
30978* (renamed) (HAdron InDex COnversion)
30979* translation table version filled up by r.e. 25.01.94 *
30980 DATA IAMCIN /
30981 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30982 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30983 &3222,3212,111,311,-311, 0,0,0,0,0,
30984 &221,213,113,-213,223, 323,313,-323,-313,10323,
30985 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30986 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30987 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30988 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30989 &5*99999, 5*99999,
30990 &4*99999,331, 333,3322,3312,-3222,-3212,
30991 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30992 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30993 &-431,441,423,413,-413, -423,433,-433,20443,443,
30994 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30995 &4212,4112,3*99999, 3*99999,-4122,-4232,
30996 &-4132,-4222,-4212,-4112,99999, 5*99999,
30997 &5*99999, 5*99999,
30998 &10*99999,
30999 &5*99999 , 20211,20111,-20211,99999,20321,
31000 &-20321,20311,-20311,7*99999 ,
31001 &7*99999,12212,12112,99999/
31002
31003* / DTHAIC /
31004* (HAdron InDex COnversion)
31005 DATA (IPDG2(1,K),K=1,7)
31006 & / -11, -12, -13, -15, -16, -14, 0/
31007 DATA (IBAM2(1,K),K=1,7)
31008 & / 4, 6, 10, 131, 134, 136, 0/
31009 DATA (IPDG2(2,K),K=1,7)
31010 & / 11, 12, 22, 13, 15, 16, 14/
31011 DATA (IBAM2(2,K),K=1,7)
31012 & / 3, 5, 7, 11, 132, 133, 135/
31013 DATA (IPDG3(1,K),K=1,22)
31014 & / -211, -321, -311, -213, -323, -313, -411, -421,
31015 & -431, -413, -423, -433, 0, 0, 0, 0,
31016 & 0, 0, 0, 0, 0, 0/
31017 DATA (IBAM3(1,K),K=1,22)
31018 & / 14, 16, 25, 34, 38, 39, 118, 119,
31019 & 121, 125, 126, 128, 0, 0, 0, 0,
31020 & 0, 0, 0, 0, 0, 0/
31021 DATA (IPDG3(2,K),K=1,22)
31022 & / 130, 211, 321, 310, 111, 311, 221, 213,
31023 & 113, 223, 323, 313, 331, 333, 421, 411,
31024 & 431, 441, 423, 413, 433, 443/
31025 DATA (IBAM3(2,K),K=1,22)
31026 & / 12, 13, 15, 19, 23, 24, 31, 32,
31027 & 33, 35, 36, 37, 95, 96, 116, 117,
31028 & 120, 122, 123, 124, 127, 130/
31029 DATA (IPDG4(1,K),K=1,29)
31030 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31031 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31032 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31033 & -4212, -4112, 0, 0, 0/
31034 DATA (IBAM4(1,K),K=1,29)
31035 & / 2, 9, 18, 67, 68, 69, 70, 75,
31036 & 76, 99, 100, 101, 102, 103, 110, 111,
31037 & 112, 113, 114, 115, 149, 150, 151, 152,
31038 & 153, 154, 0, 0, 0/
31039 DATA (IPDG4(2,K),K=1,29)
31040 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31041 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31042 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31043 & 4232, 4132, 4222, 4212, 4112/
31044 DATA (IBAM4(2,K),K=1,29)
31045 & / 1, 8, 17, 20, 21, 22, 48, 49,
31046 & 50, 51, 52, 53, 54, 55, 56, 97,
31047 & 98, 104, 105, 106, 107, 108, 109, 137,
31048 & 138, 139, 140, 141, 142/
31049 DATA (IPDG5(1,K),K=1,19)
31050 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31051 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31052 & 0, 0, 0/
31053 DATA (IBAM5(1,K),K=1,19)
31054 & / 42, 43, 46, 47, 71, 72, 73, 74,
31055 & 188, 191, 193, 0, 0, 0, 0, 0,
31056 & 0, 0, 0/
31057 DATA (IPDG5(2,K),K=1,19)
31058 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31059 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31060 & 20311, 12212, 12112/
31061 DATA (IBAM5(2,K),K=1,19)
31062 & / 40, 41, 44, 45, 57, 58, 59, 60,
31063 & 63, 64, 65, 66, 129, 186, 187, 190,
31064 & 192, 208, 209/
31065
31066* / DTPAIN /
31067* internal particle names
31068 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31069 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31070 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31071 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31072 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31073 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31074 &'BLANK ' /
31075
31076 END
31077
31078*$ CREATE DT_BLKD46.FOR
31079*COPY DT_BLKD46
31080*
31081*===blkd46=============================================================*
31082*
31083 BLOCK DATA DT_BLKD46
31084
31085 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31086 SAVE
31087
31088 PARAMETER ( AMELCT = 0.51099906 D-03 )
31089 PARAMETER ( AMMUON = 0.105658389 D+00 )
31090
31091* particle properties (BAMJET index convention)
31092 CHARACTER*8 ANAME
31093 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31094 & IICH(210),IIBAR(210),K1(210),K2(210)
31095
31096* / DTPART /
31097* Particle masses Engel version JETSET compatible
31098C DATA (AAM(K),K=1,85) /
31099C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31100C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31101C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31102C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31103C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31104C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31105C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31106C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31107C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31108C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31109C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31110C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31111C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31112C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31113C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31114C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31115C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31116C DATA (AAM(K),K=86,183) /
31117C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31118C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31119C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31120C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31121C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31122C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31123C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31124C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31125C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31126C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31127C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31128C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31129C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31130C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31131C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31132C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31133C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31134C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31135C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31136C & .1250D+01, .1250D+01, .1250D+01 /
31137C DATA (AAM ( I ), I = 184,210 ) /
31138C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31139C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31140C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31141C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31142C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31143C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31144C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31145C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31146C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31147* sr 25.1.06: particle masses adjusted to Pythia
31148 DATA (AAM(K),K=1,85) /
31149 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31150 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31151 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31152 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31153 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31154 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31155 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31156 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31157 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31158 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31159 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31160 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31161 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31162 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31163 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31164 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31165 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31166 DATA (AAM(K),K=86,183) /
31167 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31168 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31169 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31170 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31171 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31172 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31173 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31174 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31175 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31176 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31177 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31178 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31179 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31180 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31181 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31182 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31183 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31184 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31185 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31186 & .1250D+01, .1250D+01, .1250D+01 /
31187 DATA (AAM ( I ), I = 184,210 ) /
31188 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31189 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31190 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31191 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31192 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31193 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31194 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31195 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31196 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31197* Particle mean lives
31198 DATA (TAU(K),K=1,183) /
31199 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31200 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31201 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31202 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31203 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31204 & 70*.0000D+00,
31205 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31206 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31207 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31208 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31209 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31210 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31211 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31213 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31214 & 40*.0000D+00,
31215 & .0000D+00, .0000D+00, .0000D+00 /
31216 DATA ( TAU ( I ), I = 184,210 ) /
31217 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31218 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31219 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31220 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31221 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31222 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31223 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31224 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31225 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31226* Resonance width Gamma in GeV
31227 DATA (GA(K),K= 1,85) /
31228 & 30*.0000D+00,
31229 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31230 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31231 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31232 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31233 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31234 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31235 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31236 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31237 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31238 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31239 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31240 DATA (GA(K),K= 86,183) /
31241 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31242 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31243 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31244 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31245 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31246 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31247 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31248 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31249 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31250 & 50*.0000D+00,
31251 & .3000D+00, .3000D+00, .3000D+00 /
31252 DATA ( GA ( I ), I = 184,210 ) /
31253 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31254 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31255 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31256 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31257 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31258 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31259 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31260 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31261 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31262* Particle names
31263* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31264* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31265* designation N*@@ means N*@1(@2)
31266 DATA (ANAME(K),K=1,85) /
31267 & 'P ','AP ','E- ','E+ ','NUE ',
31268 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31269 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31270 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31271 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31272 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31273 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31274 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31275 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31276 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31277 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31278 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31279 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31280 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31281 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31282 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31283 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31284 DATA (ANAME(K),K=86,183) /
31285 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31286 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31287 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31288 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31289 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31290 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31291 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31292 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31293 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31294 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31295 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31296 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31297 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31298 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31299 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31300 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31301 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31302 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31303 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31304 & 'RO ','R+ ','R- ' /
31305 DATA ( ANAME ( I ), I = 184,210 ) /
31306 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31307 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31308 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31309 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31310 &'N*+14 ','N*014 ','BLANK '/
31311* Charge of particles and resonances
31312 DATA (IICH ( I ), I = 1,210 ) /
31313 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31314 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31315 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31316 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31317 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31318 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31319 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31320 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31321 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31322 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31323 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31324 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31325 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31326 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31327* Particle baryonic charges
31328 DATA (IIBAR ( I ), I = 1,210 ) /
31329 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31330 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31331 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31332 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31333 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31334 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31335 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31336 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31337 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31338 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31339 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31340 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31341 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31342 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31343* First number of decay channels used for resonances
31344* and decaying particles
31345 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31346 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31347 & 2*330, 46, 51, 52, 54, 55, 58,
31348* 50
31349 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31350 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31351 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31352* 85
31353 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31354 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31355 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31356 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31357 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31358 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31359 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31360 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31361 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31362 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31363 & 590, 596, 602 /
31364* Last number of decay channels used for resonances
31365* and decaying particles
31366 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31367 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31368 & 2* 330, 50, 51, 53, 54, 57,
31369* 50
31370 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31371 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31372 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31373* 85
31374 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31375 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31376 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31377 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31378 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31379 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31380 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31381 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31382 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31383 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31384 & 589, 595, 601, 602 /
31385
31386 END
31387
31388*$ CREATE DT_BLKD47.FOR
31389*COPY DT_BLKD47
31390*
31391*===blkd47=============================================================*
31392*
31393 BLOCK DATA DT_BLKD47
31394
31395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31396 SAVE
31397
31398* HADRIN: decay channel information
31399 PARAMETER (IDMAX9=602)
31400 CHARACTER*8 ZKNAME
31401 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31402
31403* Name of decay channel
31404* Designation N*@ means N*@1(1236)
31405* @1=# means ++, @1 = = means --
31406* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31407 DATA (ZKNAME(K),K= 1, 85) /
31408 & 'P ','AP ','E- ','E+ ','NUE ',
31409 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31410 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31411 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31412 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31413 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31414 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31415 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31416 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31417 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31418 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31419 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31420 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31421 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31422 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31423 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31424 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31425 DATA (ZKNAME(K),K= 86,170) /
31426 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31427 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31428 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31429 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31430 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31431 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31432 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31433 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31434 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31435 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31436 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31437 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31438 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31439 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31440 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31441 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31442 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31443 DATA (ZKNAME(K),K=171,255) /
31444 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31445 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31446 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31447 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31448 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31449 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31450 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31451 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31452 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31453 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31454 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31455 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31456 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31457 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31458 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31459 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31460 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31461 DATA (ZKNAME(K),K=256,340) /
31462 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31463 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31464 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31465 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31466 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31467 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31468 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31469 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31470 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31471 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31472 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31473 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31474 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31475 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31476 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31477 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31478 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31479 DATA (ZKNAME(K),K=341,425) /
31480 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31481 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31482 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31483 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31484 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31485 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31486 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31487 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31488 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31489 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31490 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31491 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31492 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31493 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31494 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31495 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31496 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31497 DATA (ZKNAME(K),K=426,510) /
31498 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31499 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31500 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31501 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31502 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31503 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31504 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31505 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31506 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31507 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31508 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31509 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31510 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31511 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31512 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31513 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31514 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31515 DATA (ZKNAME(K),K=511,540) /
31516 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31517 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31518 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31519 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31520 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31521 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31522 DATA (ZKNAME(I),I=541,602)/
31523 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31524 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31525 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31526 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31527 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31528 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31529 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31530 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31531 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31532* Weight of decay channel
31533 DATA (WT(K),K= 1, 85) /
31534 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31535 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31536 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31537 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31538 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31539 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31540 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31541 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31542 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31543 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31544 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31545 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31546 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31547 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31548 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31549 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31550 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31551 DATA (WT(K),K= 86,170) /
31552 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31553 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31554 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31555 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31556 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31557 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31558 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31559 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31560 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31561 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31562 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31563 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31564 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31565 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31566 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31567 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31568 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31569 DATA (WT(K),K=171,255) /
31570 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31571 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31572 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31573 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31574 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31575 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31576 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31577 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31578 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31579 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31580 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31581 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31582 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31583 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31584 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31585 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31586 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31587 DATA (WT(K),K=256,340) /
31588 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31589 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31590 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31591 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31592 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31593 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31594 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31595 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31596 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31597 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31598 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31599 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31600 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31601 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31602 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31603 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31604 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31605 DATA (WT(K),K=341,425) /
31606 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31607 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31608 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31609 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31610 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31611 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31612 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31613 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31614 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31615 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31616 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31617 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31618 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31619 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31620 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31621 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31622 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31623 DATA (WT(K),K=426,510) /
31624 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31625 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31626 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31627 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31628 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31629 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31630 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31631 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31632 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31633 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31634 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31635 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31636 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31637 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31638 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31639 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31640 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31641 DATA (WT(K),K=511,540) /
31642 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31643 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31644 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31645 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31646 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31647 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31648C
31649 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31650 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31651 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31652 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31653 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31654 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31655 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31656* Particle numbers in decay channel
31657 DATA (NZK(K,1),K= 1,170) /
31658 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31659 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31660 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31661 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31662 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31663 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31664 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31665 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31666 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31667 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31668 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31669 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31670 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31671 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31672 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31673 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31674 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31675 DATA (NZK(K,1),K=171,340) /
31676 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31677 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31678 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31679 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31680 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31681 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31682 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31683 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31684 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31685 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31686 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31687 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31688 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31689 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31690 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31691 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31692 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31693 DATA (NZK(K,1),K=341,510) /
31694 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31695 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31696 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31697 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31698 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31699 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31700 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31701 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31702 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31703 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31704 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31705 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31706 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31707 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31708 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31709 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31710 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31711 DATA (NZK(K,1),K=511,540) /
31712 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31713 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31714 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31715 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31716 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31717 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31718 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31719 & 55, 8, 1, 8, 8, 54, 55, 210/
31720 DATA (NZK(K,2),K= 1,170) /
31721 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31722 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31723 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31724 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31725 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31726 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31727 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31728 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31729 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31730 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31731 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31732 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31733 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31734 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31735 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31736 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31737 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31738 DATA (NZK(K,2),K=171,340) /
31739 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31740 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31741 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31742 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31743 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31744 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31745 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31746 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31747 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31748 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31749 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31750 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31751 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31752 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31753 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31754 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31755 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31756 DATA (NZK(K,2),K=341,510) /
31757 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31758 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31759 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31760 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31761 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31762 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31763 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31764 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31765 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31766 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31767 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31768 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31769 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31770 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31771 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31772 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31773 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31774 DATA (NZK(K,2),K=511,540) /
31775 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31776 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31777 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31778 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31779 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31780 & 14, 14, 23, 14, 16, 25,
31781 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31782 & 23, 13, 14, 23, 0 /
31783 DATA (NZK(K,3),K= 1,170) /
31784 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31785 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31786 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31787 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31788 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31789 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31790 & 110*0 /
31791 DATA (NZK(K,3),K=171,340) /
31792 & 80*0,
31793 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31794 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31795 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31796 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31797 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31798 & 30*0,
31799 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31800 DATA (NZK(K,3),K=341,510) /
31801 & 30*0,
31802 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31803 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31804 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31805 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31806 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31807 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31808 & 80*0 /
31809 DATA (NZK(K,3),K=511,540) /
31810 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31811 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31812 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31813 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31814 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31815
31816 END
31817
31818*$ CREATE DT_XHOINI.FOR
31819*COPY DT_XHOINI
31820*
31821*====phoini============================================================*
31822*
31823 SUBROUTINE DT_XHOINI
31824C SUBROUTINE DT_PHOINI
31825
31826 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31827 SAVE
31828
31829 PARAMETER ( LINP = 10 ,
31830 & LOUT = 6 ,
31831 & LDAT = 9 )
31832
31833 RETURN
31834 END
31835
31836*$ CREATE DT_XVENTB.FOR
31837*COPY DT_XVENTB
31838*
31839*====eventb============================================================*
31840*
31841 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31842C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31843
31844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31845 SAVE
31846
31847 PARAMETER ( LINP = 10 ,
31848 & LOUT = 6 ,
31849 & LDAT = 9 )
31850
31851 WRITE(LOUT,1000)
31852 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31853 STOP
31854
31855 END
31856
31857*$ CREATE DT_XVENT.FOR
31858*COPY DT_XVENT
31859*
31860*===event==============================================================*
31861*
31862 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31863C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31864
31865 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31866 SAVE
31867
31868 DIMENSION PP(4),PT(4)
31869
31870 RETURN
31871 END
31872
31873*$ CREATE DT_XOHISX.FOR
31874*COPY DT_XOHISX
31875*
31876*===pohisx=============================================================*
31877*
31878 SUBROUTINE DT_XOHISX(I,X)
31879C SUBROUTINE POHISX(I,X)
31880
31881 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31882 SAVE
31883
31884 RETURN
31885 END
31886
31887*$ CREATE PHO_LHIST.FOR
31888*COPY PHO_LHIST
31889*
31890*===poluhi=============================================================*
31891*
31892 SUBROUTINE PHO_LHIST(I,X)
31893
31894**
31895
31896 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31897 SAVE
31898
31899 RETURN
31900 END
31901
31902*$ CREATE PDFSET.FOR
31903*COPY PDFSET
31904*
31905C**********************************************************************
31906C
31907C dummy subroutines, remove to link PDFLIB
31908C
31909C**********************************************************************
31910 SUBROUTINE PDFSET(PARAM,VALUE)
31911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31912 DIMENSION PARAM(20),VALUE(20)
31913 CHARACTER*20 PARAM
31914 END
31915
31916*$ CREATE STRUCTM.FOR
31917*COPY STRUCTM
31918*
31919 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31921 END
31922
31923*$ CREATE STRUCTP.FOR
31924*COPY STRUCTP
31925*
31926 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31927 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31928 END
31929
31930*$ CREATE DT_DIQBRK.FOR
31931*COPY DT_DIQBRK
31932*
31933*===diqbrk=============================================================*
31934*
31935 SUBROUTINE DT_XIQBRK
31936C SUBROUTINE DT_DIQBRK
31937
31938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31939 SAVE
31940
31941 STOP 'diquark-breaking not implemeted !'
31942
31943 RETURN
31944 END
31945*$ CREATE DT_ELHAIN.FOR
31946*COPY DT_ELHAIN
31947*
31948*===elhain=============================================================*
31949*
31950 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31951
31952************************************************************************
31953* Elastic hadron-hadron scattering. *
31954* This is a revised version of the original. *
31955* This version dated 03.04.98 is written by S. Roesler *
31956************************************************************************
31957
31958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31959 SAVE
31960
31961 PARAMETER ( LINP = 10 ,
31962 & LOUT = 6 ,
31963 & LDAT = 9 )
31964
31965 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31966 & TINY10=1.0D-10)
31967
31968 PARAMETER (ENNTHR = 3.5D0)
31969 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31970 & BLOWB=0.05D0,BHIB=0.2D0,
31971 & BLOWM=0.1D0, BHIM=2.0D0)
31972
31973* particle properties (BAMJET index convention)
31974 CHARACTER*8 ANAME
31975 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31976 & IICH(210),IIBAR(210),K1(210),K2(210)
31977
31978* final state from HADRIN interaction
31979 PARAMETER (MAXFIN=10)
31980 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31981 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31982
31983C DATA TSLOPE /10.0D0/
31984
31985 IREJ = 0
31986
31987 1 CONTINUE
31988
31989 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31990 EKIN = ELAB-AAM(IP)
31991* kinematical quantities in cms of the hadrons
31992 AMP2 = AAM(IP)**2
31993 AMT2 = AAM(IT)**2
31994 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31995 ECM = SQRT(S)
31996 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31997 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31998
31999* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
32000 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
32001 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
32002* TSAMCS treats pp and np only, therefore change pn into np and
32003* nn into pp
32004 IF (IT.EQ.1) THEN
32005 KPROJ = IP
32006 ELSE
32007 KPROJ = 8
32008 IF (IP.EQ.8) KPROJ = 1
32009 ENDIF
32010 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32011 T = TWO*PCM**2*(CTCMS-ONE)
32012
32013* very crude treatment otherwise: sample t from exponential dist.
32014 ELSE
32015* momentum transfer t
32016 TMAX = TWO*TWO*PCM**2
32017 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32018 IF (IIBAR(IP).NE.0) THEN
32019 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32020 ELSE
32021 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32022 ENDIF
32023 FMAX = EXP(-TSLOPE*TMAX)-ONE
32024 R = DT_RNDM(RR)
32025 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32026 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32027 ENDIF
32028
32029* target hadron in Lab after scattering
32030 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32031 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32032 IF (PLRH(2).LE.TINY10) THEN
32033C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32034 GOTO 1
32035 ENDIF
32036* projectile hadron in Lab after scattering
32037 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32038 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32039* scattering angle of projectile in Lab
32040 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32041 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32042 CALL DT_DSFECF(SPLABP,CPLABP)
32043* direction cosines of projectile in Lab
32044 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32045 & CXRH(1),CYRH(1),CZRH(1))
32046* scattering angle of target in Lab
32047 PLLABT = PLAB-CTLABP*PLRH(1)
32048 CTLABT = PLLABT/PLRH(2)
32049 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32050* direction cosines of target in Lab
32051 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32052 & CXRH(2),CYRH(2),CZRH(2))
32053* fill /HNFSPA/
32054 IRH = 2
32055 ITRH(1) = IP
32056 ITRH(2) = IT
32057
32058 RETURN
32059 END
32060
32061*$ CREATE DT_TSAMCS.FOR
32062*COPY DT_TSAMCS
32063*
32064*===tsamcs=============================================================*
32065*
32066 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32067
32068************************************************************************
32069* Sampling of cos(theta) for nucleon-proton scattering according to *
32070* hetkfa2/bertini parametrization. *
32071* This is a revised version of the original (HJM 24/10/88) *
32072* This version dated 28.10.95 is written by S. Roesler *
32073************************************************************************
32074
32075 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32076 SAVE
32077
32078 PARAMETER ( LINP = 10 ,
32079 & LOUT = 6 ,
32080 & LDAT = 9 )
32081
32082 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32083 & TINY10=1.0D-10)
32084
32085 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32086 DIMENSION PDCI(60),PDCH(55)
32087
32088 DATA (DCLIN(I),I=1,80) /
32089 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32090 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32091 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32092 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32093 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32094 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32095 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32096 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32097 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32098 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32099 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32100 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32101 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32102 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32103 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32104 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32105 DATA (DCLIN(I),I=81,160) /
32106 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32107 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32108 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32109 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32110 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32111 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32112 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32113 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32114 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32115 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32116 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32117 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32118 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32119 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32120 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32121 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32122 DATA (DCLIN(I),I=161,195) /
32123 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32124 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32125 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32126 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32127 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32128 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32129 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32130
32131 DATA PDCI /
32132 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32133 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32134 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32135 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32136 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32137 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32138 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32139 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32140 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32141 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32142 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32143 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32144
32145 DATA PDCH /
32146 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32147 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32148 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32149 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32150 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32151 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32152 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32153 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32154 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32155 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32156 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32157
32158 DATA (DCHN(I),I=1,90) /
32159 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32160 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32161 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32162 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32163 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32164 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32165 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32166 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32167 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32168 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32169 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32170 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32171 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32172 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32173 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32174 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32175 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32176 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32177 DATA (DCHN(I),I=91,143) /
32178 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32179 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32180 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32181 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32182 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32183 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32184 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32185 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32186 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32187 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32188 & 6.488D-02, 6.485D-02, 6.480D-02/
32189
32190 DATA DCHNA /
32191 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32192 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32193 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32194 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32195 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32196 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32197 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32198 & 1.000D+00/
32199
32200 DATA DCHNB /
32201 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32202 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32203 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32204 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32205 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32206 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32207 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32208 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32209 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32210 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32211 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32212 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32213
32214 CST = ONE
32215 IF (EKIN.GT.3.5D0) RETURN
32216C
32217 IF(KPROJ.EQ.8) GOTO 101
32218 IF(KPROJ.EQ.1) GOTO 102
32219C* INVALID REACTION
32220 WRITE(LOUT,'(A,I5/A)')
32221 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32222 & ' COS(THETA) = 1D0 RETURNED'
32223 RETURN
32224C-------------------------------- NP ELASTIC SCATTERING----------
32225101 CONTINUE
32226 IF (EKIN.GT.0.740D0)GOTO 1000
32227 IF (EKIN.LT.0.300D0)THEN
32228C EKIN .LT. 300 MEV
32229 IDAT=1
32230 ELSE
32231C 300 MEV < EKIN < 740 MEV
32232 IDAT=6
32233 END IF
32234C
32235 ENER=EKIN
32236 IE=INT(ABS(ENER/0.020D0))
32237 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32238C FORWARD/BACKWARD DECISION
32239 K=IDAT+5*IE
32240 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32241 IF (DT_RNDM(CST).LT.BWFW)THEN
32242 VALUE2=-1D0
32243 K=K+1
32244 ELSE
32245 VALUE2=1D0
32246 K=K+3
32247 END IF
32248C
32249 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32250 RND=DT_RNDM(COEF)
32251C
32252 IF(RND.LT.COEF)THEN
32253 CST=DT_RNDM(RND)
32254 CST=CST*VALUE2
32255 ELSE
32256 R1=DT_RNDM(CST)
32257 R2=DT_RNDM(R1)
32258 R3=DT_RNDM(R2)
32259 R4=DT_RNDM(R3)
32260C
32261 IF(VALUE2.GT.0.0)THEN
32262 CST=MAX(R1,R2,R3,R4)
32263 GOTO 1500
32264 ELSE
32265 R5=DT_RNDM(R4)
32266C
32267 IF (IDAT.EQ.1)THEN
32268 CST=-MAX(R1,R2,R3,R4,R5)
32269 ELSE
32270 R6=DT_RNDM(R5)
32271 R7=DT_RNDM(R6)
32272 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32273 END IF
32274C
32275 END IF
32276C
32277 END IF
32278C
32279 GOTO 1500
32280C
32281C******** EKIN .GT. 0.74 GEV
32282C
322831000 ENER=EKIN - 0.66D0
32284C IE=ABS(ENER/0.02)
32285 IE=INT(ENER/0.02D0)
32286 EMEV=EKIN*1D3
32287C
32288 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32289 K=IE
32290 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32291 RND=DT_RNDM(BWFW)
32292C FORWARD NEUTRON
32293 IF (RND.GE.BWFW)THEN
32294 DO 1200 K=10,36,9
32295 IF (DCHNA(K).GT.EMEV) THEN
32296 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32297 UNIV=DT_RNDM(UNIVE)
32298 DO 1100 I=1,8
32299 II=K+I
32300 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32301C
32302 IF (P.GT.UNIV)THEN
32303 UNIV=DT_RNDM(UNIVE)
32304 FLTI=DBLE(I)-UNIV
32305 GOTO(290,290,290,290,330,340,350,360) I
32306 END IF
32307 1100 CONTINUE
32308 END IF
32309 1200 CONTINUE
32310C
32311 ELSE
32312C BACKWARD NEUTRON
32313 DO 1400 K=13,60,12
32314 IF (DCHNB(K).GT.EMEV) THEN
32315 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32316 UNIV=DT_RNDM(UNIVE)
32317 DO 1300 I=1,11
32318 II=K+I
32319 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32320C
32321 IF (P.GT.UNIV)THEN
32322 UNIV=DT_RNDM(P)
32323 FLTI=DBLE(I)-UNIV
32324 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32325 END IF
32326 1300 CONTINUE
32327 END IF
32328 1400 CONTINUE
32329 END IF
32330C
32331120 CST=1.0D-2*FLTI-1.0D0
32332 GOTO 1500
32333140 CST=2.0D-2*UNIV-0.98D0
32334 GOTO 1500
32335150 CST=4.0D-2*UNIV-0.96D0
32336 GOTO 1500
32337160 CST=6.0D-2*FLTI-1.16D0
32338 GOTO 1500
32339180 CST=8.0D-2*UNIV-0.80D0
32340 GOTO 1500
32341190 CST=1.0D-1*UNIV-0.72D0
32342 GOTO 1500
32343200 CST=1.2D-1*UNIV-0.62D0
32344 GOTO 1500
32345210 CST=2.0D-1*UNIV-0.50D0
32346 GOTO 1500
32347220 CST=3.0D-1*(UNIV-1.0D0)
32348 GOTO 1500
32349C
32350290 CST=1.0D0-2.5d-2*FLTI
32351 GOTO 1500
32352330 CST=0.85D0+0.5D-1*UNIV
32353 GOTO 1500
32354340 CST=0.70D0+1.5D-1*UNIV
32355 GOTO 1500
32356350 CST=0.50D0+2.0D-1*UNIV
32357 GOTO 1500
32358360 CST=0.50D0*UNIV
32359C
323601500 RETURN
32361C
32362C----------------------------------- PP ELASTIC SCATTERING -------
32363C
32364 102 CONTINUE
32365 EMEV=EKIN*1D3
32366C
32367 IF (EKIN.LE.0.500D0) THEN
32368 RND=DT_RNDM(EMEV)
32369 CST=2.0D0*RND-1.0D0
32370 RETURN
32371C
32372 ELSEIF (EKIN.LT.1.0D0) THEN
32373 DO 2200 K=13,60,12
32374 IF (PDCI(K).GT.EMEV) THEN
32375 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32376 UNIV=DT_RNDM(UNIVE)
32377 SUM=0
32378 DO 2100 I=1,11
32379 II=K+I
32380 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32381C
32382 IF (UNIV.LT.SUM)THEN
32383 UNIV=DT_RNDM(SUM)
32384 FLTI=DBLE(I)-UNIV
32385 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32386 END IF
32387 2100 CONTINUE
32388 END IF
32389 2200 CONTINUE
32390 ELSE
32391 DO 2400 K=12,55,11
32392 IF (PDCH(K).GT.EMEV) THEN
32393 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32394 UNIV=DT_RNDM(UNIVE)
32395 SUM=0.0D0
32396 DO 2300 I=1,10
32397 II=K+I
32398 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32399C
32400 IF (UNIV.LT.SUM)THEN
32401 UNIV=DT_RNDM(SUM)
32402 FLTI=UNIV+DBLE(I)
32403 GOTO(50,55,60,60,65,65,65,65,70,70) I
32404 END IF
32405 2300 CONTINUE
32406 END IF
32407 2400 CONTINUE
32408 END IF
32409C
3241050 CST=0.4D0*UNIV
32411 GOTO 2500
3241255 CST=0.2D0*FLTI
32413 GOTO 2500
3241460 CST=0.3D0+0.1D0*FLTI
32415 GOTO 2500
3241665 CST=0.6D0+0.04D0*FLTI
32417 GOTO 2500
3241870 CST=0.78D0+0.02D0*FLTI
32419C
324202500 CONTINUE
32421 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32422C
32423 RETURN
32424 END
32425
32426*$ CREATE DT_DHADRI.FOR
32427*COPY DT_DHADRI
32428*
32429*===dhadri=============================================================*
32430*
32431 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32432
32433 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32434 SAVE
32435
32436 PARAMETER ( LINP = 10 ,
32437 & LOUT = 6 ,
32438 & LDAT = 9 )
32439
32440C
32441C-----------------------------
32442C*** INPUT VARIABLES LIST:
32443C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32444C*** GEV/C LABORATORY MOMENTUM REGION
32445C*** N - PROJECTILE HADRON INDEX
32446C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32447C*** ELAB - LABORATORY ENERGY OF N (GEV)
32448C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32449C*** ITTA - TARGET NUCLEON INDEX
32450C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32451C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32452C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32453C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32454C*** RESPECT., UNITS (GEV/C AND GEV)
32455C----------------------------
32456
32457 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32458
32459 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32460
32461 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32462 & NRK(2,268),NURE(30,2)
32463
32464* particle properties (BAMJET index convention),
32465* (dublicate of DTPART for HADRIN)
32466 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32467 & K1H(110),K2H(110)
32468
32469 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32470
32471 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32472 & ITS(149),IS
32473
32474 COMMON /HNDRUN/ RUNTES,EFTES
32475
32476* particle properties (BAMJET index convention)
32477 CHARACTER*8 ANAME
32478 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32479 & IICH(210),IIBAR(210),K1(210),K2(210)
32480
32481* final state from HADRIN interaction
32482 PARAMETER (MAXFIN=10)
32483 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32484 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32485
32486 DIMENSION ITPRF(110)
32487 DATA NNN/0/
32488 DATA UMODA/0./
32489 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32490 LOWP=0
32491 IF (N.LE.0.OR.N.GE.111)N=1
32492 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32493 GOTO 280
32494* WRITE (6,1000)
32495* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32496* STOP
32497*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32498* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32499 ENDIF
32500 IATMPT=0
32501 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32502C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32503C STOP
32504 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32505 + ALLOWED REGION, PLAB=',1E15.5)
32506
32507 20 CONTINUE
32508 UMODAT=N*1.11111D0+ITTA*2.19291D0
32509 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32510 UMODA=UMODAT
32511 30 IATMPT=0
32512 LOWP=LOWP+1
32513 40 CONTINUE
32514 IMACH=0
32515 REDU=2.0D0
32516 IF (LOWP.GT.20) THEN
32517C WRITE(LOUT,*) ' jump 1'
32518 GO TO 280
32519 ENDIF
32520 NNN=N
32521 IF (NNN.EQ.N) GO TO 50
32522 RUNTES=0.0D0
32523 EFTES=0.0D0
32524 50 CONTINUE
32525 IS=1
32526 IRH=0
32527 IST=1
32528 NSTAB=23
32529 IRE=NURE(N,1)
32530 IF(ITTA.GT.1) IRE=NURE(N,2)
32531C
32532C-----------------------------
32533C*** IE,AMT,ECM,SI DETERMINATION
32534C----------------------------
32535 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32536 IANTH=-1
32537**sr
32538C IF (AMH(1).NE.0.93828D0) IANTH=1
32539 IF (AMH(1).NE.0.9383D0) IANTH=1
32540**
32541 IF (IANTH.GE.0) SI=1.0D0
32542 ECMMH=ECM
32543C
32544C-----------------------------
32545C ENERGY INDEX
32546C IRE CHARACTERIZES THE REACTION
32547C IE IS THE ENERGY INDEX
32548C----------------------------
32549 IF (SI.LT.1.D-6) THEN
32550C WRITE(LOUT,*) ' jump 2'
32551 GO TO 280
32552 ENDIF
32553 IF (N.LE.NSTAB) GO TO 60
32554 RUNTES=RUNTES+1.0D0
32555 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32556 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32557 IF(IBARH(N).EQ.1) N=8
32558 IF(IBARH(N).EQ.-1) N=9
32559 60 CONTINUE
32560 IMACH=IMACH+1
32561**sr 19.2.97: loop for direct channel suppression
32562C IF (IMACH.GT.10) THEN
32563 IF (IMACH.GT.1000) THEN
32564**
32565C WRITE(LOUT,*) ' jump 3'
32566 GO TO 280
32567 ENDIF
32568 ECM =ECMMH
32569 AMN2=AMN**2
32570 AMT2=AMT**2
32571 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32572 IF(ECMN.LE.AMN) ECMN=AMN
32573 PCMN=SQRT(ECMN**2-AMN2)
32574 GAM=(ELAB+AMT)/ECM
32575 BGAM=PLAB/ECM
32576 IF (IANTH.GE.0) ECM=2.1D0
32577C
32578C-----------------------------
32579C*** RANDOM CHOICE OF REACTION CHANNEL
32580C----------------------------
32581 IST=0
32582 VV=DT_RNDM(AMN2)
32583 VV=VV-1.D-17
32584C
32585C-----------------------------
32586C*** PLACE REDUCED VERSION
32587C----------------------------
32588 IIEI=IEII(IRE)
32589 IDWK=IEII(IRE+1)-IIEI
32590 IIWK=IRII(IRE)
32591 IIKI=IKII(IRE)
32592C
32593C-----------------------------
32594C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32595C----------------------------
32596 HECM=ECM
32597 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32598 IF (HUMO.LT.ECM) ECM=HUMO
32599C
32600C-----------------------------
32601C*** INTERPOLATION PREPARATION
32602C----------------------------
32603 ECMO=UMO(IE)
32604 ECM1=UMO(IE-1)
32605 DECM=ECMO-ECM1
32606 DEC=ECMO-ECM
32607C
32608C-----------------------------
32609C*** RANDOM LOOP
32610C----------------------------
32611 IK=0
32612 WKK=0.0D0
32613 WICOR=0.0D0
32614 70 IK=IK+1
32615 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32616 WOK=WK(IWK)
32617 WDK=WOK-WK(IWK-1)
32618C
32619C-----------------------------
32620C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32621C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32622C CONTRIBUTE
32623C----------------------------
32624 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32625 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32626 IF (WICO.EQ.WICOR) GO TO 70
32627 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32628 WICOR=WICO
32629C
32630C-----------------------------
32631C*** INTERPOLATION IN CHANNEL WEIGHTS
32632C----------------------------
32633 EKLIM=-THRESH(IIKI+IK)
32634 IELIM=IDT_IEFUND(EKLIM,IRE)
32635 DELIM=UMO(IELIM)+EKLIM
32636 *+1.D-16
32637 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32638 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32639 80 DECC=DELIM
32640 GO TO 100
32641 90 DECC=DECM
32642 100 CONTINUE
32643 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32644C
32645C-----------------------------
32646C*** RANDOM CHOICE
32647C----------------------------
32648C
32649 IF (VV.GT.WKK) GO TO 70
32650C
32651C***IK IS THE REACTION CHANNEL
32652C----------------------------
32653 INRK=IKII(IRE)+IK
32654 ECM=HECM
32655 I1001 =0
32656C
32657 110 CONTINUE
32658 IT1=NRK(1,INRK)
32659 AM1=DT_DAMG(IT1)
32660 IT2=NRK(2,INRK)
32661 AM2=DT_DAMG(IT2)
32662 AMS=AM1+AM2
32663 I1001=I1001+1
32664 IF (I1001.GT.50) GO TO 60
32665C
32666 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32667 IT11=IT1
32668 IT22=IT2
32669 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32670 AM11=AM1
32671 AM22=AM2
32672 IF (IT2.GT.0) GO TO 120
32673**sr 19.2.97: supress direct channel for pp-collisions
32674 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32675 RR = DT_RNDM(AM11)
32676 IF (RR.LE.0.75D0) GOTO 60
32677 ENDIF
32678**
32679C
32680C-----------------------------
32681C INCLUSION OF DIRECT RESONANCES
32682C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32683C------------------------
32684 KZ1=K1H(IT1)
32685 IST=IST+1
32686 IECO=0
32687 ECO=ECM
32688 GAM=(ELAB+AMT)/ECO
32689 BGAM=PLAB/ECO
32690 CXS(1)=CX
32691 CYS(1)=CY
32692 CZS(1)=CZ
32693 GO TO 170
32694 120 CONTINUE
32695 WW=DT_RNDM(ECO)
32696 IF(WW.LT. 0.5D0) GO TO 130
32697 IT1=IT22
32698 IT2=IT11
32699 AM1=AM22
32700 AM2=AM11
32701 130 CONTINUE
32702C
32703C-----------------------------
32704C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32705 IBN=IBARH(N)
32706 IB1=IBARH(IT1)
32707 IT11=IT1
32708 IT22=IT2
32709 AM11=AM1
32710 AM22=AM2
32711 IF(IB1.EQ.IBN) GO TO 140
32712 IT1=IT22
32713 IT2=IT11
32714 AM1=AM22
32715 AM2=AM11
32716 140 CONTINUE
32717C-----------------------------
32718C***IT1,IT2 ARE THE CREATED PARTICLES
32719C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32720C------------------------
32721 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32722 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32723 IST=IST+1
32724 ITS(IST)=IT1
32725 AMM(IST)=AM1
32726C
32727C-----------------------------
32728C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32729C----------------------------
32730 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32731 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32732 IST=IST+1
32733 ITS(IST)=IT2
32734 AMM(IST)=AM2
32735 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32736 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32737 150 CONTINUE
32738C
32739C-----------------------------
32740C***TEST STABLE OR UNSTABLE
32741C----------------------------
32742 IF(ITS(IST).GT.NSTAB) GO TO 160
32743 IRH=IRH+1
32744C
32745C-----------------------------
32746C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32747C----------------------------
32748C* IF (REDU.LT.0.D0) GO TO 1009
32749 ITRH(IRH)=ITS(IST)
32750 PLRH(IRH)=PLS(IST)
32751 CXRH(IRH)=CXS(IST)
32752 CYRH(IRH)=CYS(IST)
32753 CZRH(IRH)=CZS(IST)
32754 ELRH(IRH)=ELS(IST)
32755 IST=IST-1
32756 IF(IST.GE.1) GO TO 150
32757 GO TO 260
32758 160 CONTINUE
32759C
32760C RANDOM CHOICE OF DECAY CHANNELS
32761C----------------------------
32762C
32763 IT=ITS(IST)
32764 ECO=AMM(IST)
32765 GAM=ELS(IST)/ECO
32766 BGAM=PLS(IST)/ECO
32767 IECO=0
32768 KZ1=K1H(IT)
32769 170 CONTINUE
32770 IECO=IECO+1
32771 VV=DT_RNDM(GAM)
32772 VV=VV-1.D-17
32773 IIK=KZ1-1
32774 180 IIK=IIK+1
32775 IF (VV.GT.WTI(IIK)) GO TO 180
32776C
32777C IIK IS THE DECAY CHANNEL
32778C----------------------------
32779 IT1=NZKI(IIK,1)
32780 I310=0
32781 190 CONTINUE
32782 I310=I310+1
32783 AM1=DT_DAMG(IT1)
32784 IT2=NZKI(IIK,2)
32785 AM2=DT_DAMG(IT2)
32786 IF (IT2-1.LT.0) GO TO 240
32787 IT3=NZKI(IIK,3)
32788 AM3=DT_DAMG(IT3)
32789 AMS=AM1+AM2+AM3
32790C
32791C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32792C----------------------------
32793 IF (IECO.LE.10) GO TO 200
32794 IATMPT=IATMPT+1
32795 IF(IATMPT.GT.3) THEN
32796C WRITE(LOUT,*) ' jump 4'
32797 GO TO 280
32798 ENDIF
32799 GO TO 40
32800 200 CONTINUE
32801 IF (I310.GT.50) GO TO 170
32802 IF (AMS.GT.ECO) GO TO 190
32803C
32804C FOR THE DECAY CHANNEL
32805C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32806C----------------------------
32807 IF (REDU.LT.0.D0) GO TO 30
32808 ITWTHC=0
32809 REDU=2.0D0
32810 IF(IT3.EQ.0) GO TO 220
32811 210 CONTINUE
32812 ITWTH=1
32813 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32814 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32815 GO TO 230
32816 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32817 &COD2,COF2,SIF2,AM1,AM2)
32818 ITWTH=-1
32819 IT3=0
32820 230 CONTINUE
32821 ITWTHC=ITWTHC+1
32822 IF (REDU.GT.0.D0) GO TO 240
32823 REDU=2.0D0
32824 IF (ITWTHC.GT.100) GO TO 30
32825 IF (ITWTH) 220,220,210
32826 240 CONTINUE
32827 ITS(IST )=IT1
32828 IF (IT2-1.LT.0) GO TO 250
32829 ITS(IST+1) =IT2
32830 ITS(IST+2)=IT3
32831 RX=CXS(IST)
32832 RY=CYS(IST)
32833 RZ=CZS(IST)
32834 AMM(IST)=AM1
32835 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32836 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32837 IST=IST+1
32838 AMM(IST)=AM2
32839 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32840 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32841 IF (IT3.LE.0) GO TO 250
32842 IST=IST+1
32843 AMM(IST)=AM3
32844 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32845 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32846 250 CONTINUE
32847 GO TO 150
32848 260 CONTINUE
32849 270 CONTINUE
32850 RETURN
32851 280 CONTINUE
32852C
32853C----------------------------
32854C
32855C ZERO CROSS SECTION CASE
32856C----------------------------
32857C
32858 IRH=1
32859 ITRH(1)=N
32860 CXRH(1)=CX
32861 CYRH(1)=CY
32862 CZRH(1)=CZ
32863 ELRH(1)=ELAB
32864 PLRH(1)=PLAB
32865 RETURN
32866 END
32867
32868*$ CREATE DT_RUNTT.FOR
32869*COPY DT_RUNTT
32870*
32871*===runtt==============================================================*
32872*
32873 BLOCK DATA DT_RUNTT
32874
32875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32876 SAVE
32877
32878 COMMON /HNDRUN/ RUNTES,EFTES
32879
32880 DATA RUNTES,EFTES /100.D0,100.D0/
32881
32882 END
32883
32884*$ CREATE DT_NONAME.FOR
32885*COPY DT_NONAME
32886*
32887*===noname=============================================================*
32888*
32889 BLOCK DATA DT_NONAME
32890
32891 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32892 SAVE
32893
32894* slope parameters for HADRIN interactions
32895 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32896
32897 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32898
32899C DATAS DATAS DATAS DATAS DATAS
32900C****** *********
32901 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32902 & 207, 224, 241, 252, 268 /
32903 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32904 & 220, 241, 262, 279, 296 /
32905 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32906 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32907
32908C
32909C MASSES FOR THE SLOPE B(M) IN GEV
32910C SLOPE B(M) FOR AN MESONIC SYSTEM
32911C SLOPE B(M) FOR A BARYONIC SYSTEM
32912
32913*
32914 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32915 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32916 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32917 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32918 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32919 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32920 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32921 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32922 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32923 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32924 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32925 & 14.2D0, 13.4D0, 12.6D0,
32926 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32927 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32928*
32929 END
32930
32931*$ CREATE DT_DAMG.FOR
32932*COPY DT_DAMG
32933*
32934*===damg===============================================================*
32935*
32936 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32937
32938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32939 SAVE
32940
32941* particle properties (BAMJET index convention),
32942* (dublicate of DTPART for HADRIN)
32943 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32944 & K1H(110),K2H(110)
32945
32946 DIMENSION GASUNI(14)
32947 DATA GASUNI/
32948 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32949 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32950 DATA GAUNO/2.352D0/
32951 DATA GAUNON/2.4D0/
32952 DATA IO/14/
32953 DATA NSTAB/23/
32954
32955 I=1
32956 IF (IT.LE.0) GO TO 30
32957 IF (IT.LE.NSTAB) GO TO 20
32958 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32959 VV=DT_RNDM(DGAUNI)
32960 VV=VV*2.0D0-1.0D0+1.D-16
32961 10 CONTINUE
32962 VO=GASUNI(I)
32963 I=I+1
32964 V1=GASUNI(I)
32965 IF (VV.GT.V1) GO TO 10
32966 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32967 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32968 DAM=GAH(IT)*UNIGA/GAUNO
32969 AAM=AMH(IT)+DAM
32970 DT_DAMG=AAM
32971 RETURN
32972 20 CONTINUE
32973 DT_DAMG=AMH(IT)
32974 RETURN
32975 30 CONTINUE
32976 DT_DAMG=0.0D0
32977 RETURN
32978 END
32979
32980*$ CREATE DT_DCALUM.FOR
32981*COPY DT_DCALUM
32982*
32983*===dcalum=============================================================*
32984*
32985 SUBROUTINE DT_DCALUM(N,ITTA)
32986
32987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32988 SAVE
32989
32990C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32991
32992* particle properties (BAMJET index convention),
32993* (dublicate of DTPART for HADRIN)
32994 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32995 & K1H(110),K2H(110)
32996
32997 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32998
32999 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33000
33001 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33002 & NRK(2,268),NURE(30,2)
33003
33004 IRE=NURE(N,ITTA/8+1)
33005 IEO=IEII(IRE)+1
33006 IEE=IEII(IRE +1)
33007 AM1=AMH(N )
33008 AM12=AM1**2
33009 AM2=AMH(ITTA)
33010 AM22=AM2**2
33011 DO 10 IE=IEO,IEE
33012 PLAB2=PLABF(IE)**2
33013 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33014 UMO(IE)=ELAB
33015 10 CONTINUE
33016 IKO=IKII(IRE)+1
33017 IKE=IKII(IRE +1)
33018 UMOO=UMO(IEO)
33019 DO 30 IK=IKO,IKE
33020 IF(NRK(2,IK).GT.0) GO TO 30
33021 IKI=NRK(1,IK)
33022 AMSS=5.0D0
33023 K11=K1H(IKI)
33024 K22=K2H(IKI)
33025 DO 20 IK1=K11,K22
33026 IN=NZKI(IK1,1)
33027 AMS=AMH(IN)
33028 IN=NZKI(IK1,2)
33029 IF(IN.GT.0)AMS=AMS+AMH(IN)
33030 IN=NZKI(IK1,3)
33031 IF(IN.GT.0) AMS=AMS+AMH(IN)
33032 IF (AMS.LT.AMSS) AMSS=AMS
33033 20 CONTINUE
33034 IF(UMOO.LT.AMSS) UMOO=AMSS
33035 THRESH(IK)=UMOO
33036 30 CONTINUE
33037 RETURN
33038 END
33039
33040*$ CREATE DT_DCHANH.FOR
33041*COPY DT_DCHANH
33042*
33043*===dchanh=============================================================*
33044*
33045 SUBROUTINE DT_DCHANH
33046
33047 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33048 SAVE
33049
33050 PARAMETER ( LINP = 10 ,
33051 & LOUT = 6 ,
33052 & LDAT = 9 )
33053
33054* particle properties (BAMJET index convention),
33055* (dublicate of DTPART for HADRIN)
33056 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33057 & K1H(110),K2H(110)
33058
33059 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33060
33061 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33062
33063 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33064 & NRK(2,268),NURE(30,2)
33065
33066 DIMENSION HWT(460),HWK(40),SI(5184)
33067 EQUIVALENCE (WK(1),SI(1))
33068C--------------------
33069C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33070C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33071C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33072C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33073C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33074C--------------------------
33075 IREG=16
33076 DO 90 IRE=1,IREG
33077 IWKO=IRII(IRE)
33078 IEE=IEII(IRE+1)-IEII(IRE)
33079 IKE=IKII(IRE+1)-IKII(IRE)
33080 IEO=IEII(IRE)+1
33081 IIKA=IKII(IRE)
33082* modifications to suppress elestic scattering 24/07/91
33083 DO 80 IE=1,IEE
33084 SIS=1.D-14
33085 SINORC=0.0D0
33086 DO 10 IK=1,IKE
33087 IWK=IWKO+IEE*(IK-1)+IE
33088 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33089 SIS=SIS+SI(IWK)*SINORC
33090 10 CONTINUE
33091 SIIN(IEO+IE-1)=SIS
33092 SIO=0.D0
33093 IF (SIS.GE.1.D-12) GO TO 20
33094 SIS=1.D0
33095 SIO=1.D0
33096 20 CONTINUE
33097 SINORC=0.0D0
33098 DO 30 IK=1,IKE
33099 IWK=IWKO+IEE*(IK-1)+IE
33100 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33101 SIO=SIO+SI(IWK)*SINORC/SIS
33102 HWK(IK)=SIO
33103 30 CONTINUE
33104 DO 40 IK=1,IKE
33105 IWK=IWKO+IEE*(IK-1)+IE
33106 40 WK(IWK)=HWK(IK)
33107 IIKI=IKII(IRE)
33108 DO 70 IK=1,IKE
33109 AM111=0.D0
33110 INRK1=NRK(1,IIKI+IK)
33111 IF (INRK1.GT.0) AM111=AMH(INRK1)
33112 AM222=0.D0
33113 INRK2=NRK(2,IIKI+IK)
33114 IF (INRK2.GT.0) AM222=AMH(INRK2)
33115 THRESH(IIKI+IK)=AM111 +AM222
33116 IF (INRK2-1.GE.0) GO TO 60
33117 INRKK=K1H(INRK1)
33118 AMSS=5.D0
33119 INRKO=K2H(INRK1)
33120 DO 50 INRK1=INRKK,INRKO
33121 INZK1=NZKI(INRK1,1)
33122 INZK2=NZKI(INRK1,2)
33123 INZK3=NZKI(INRK1,3)
33124 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33125 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33126 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33127C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33128 1000 FORMAT (4I10)
33129 AMS=AMH(INZK1)+AMH(INZK2)
33130 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33131 IF (AMSS.GT.AMS) AMSS=AMS
33132 50 CONTINUE
33133 AMS=AMSS
33134 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33135 THRESH(IIKI+IK)=AMS
33136 60 CONTINUE
33137 70 CONTINUE
33138 80 CONTINUE
33139 90 CONTINUE
33140 DO 100 J=1,460
33141 100 HWT(J)=0.D0
33142 DO 120 I=1,110
33143 IK1=K1H(I)
33144 IK2=K2H(I)
33145 HV=0.D0
33146 IF (IK2.GT.460)IK2=460
33147 IF (IK1.LE.0)IK1=1
33148 DO 110 J=IK1,IK2
33149 HV=HV+WTI(J)
33150 HWT(J)=HV
33151 JI=J
33152 110 CONTINUE
33153 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33154 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33155 120 CONTINUE
33156 DO 130 J=1,460
33157 130 WTI(J)=HWT(J)
33158 RETURN
33159 END
33160
33161*$ CREATE DT_DHADDE.FOR
33162*COPY DT_DHADDE
33163*
33164*===dhadde=============================================================*
33165*
33166 SUBROUTINE DT_DHADDE
33167
33168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33169 SAVE
33170
33171* particle properties (BAMJET index convention)
33172 CHARACTER*8 ANAME
33173 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33174 & IICH(210),IIBAR(210),K1(210),K2(210)
33175
33176* HADRIN: decay channel information
33177 PARAMETER (IDMAX9=602)
33178 CHARACTER*8 ZKNAME
33179 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33180
33181* particle properties (BAMJET index convention),
33182* (dublicate of DTPART for HADRIN)
33183 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33184 & K1H(110),K2H(110)
33185
33186 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33187
33188* decay channel information for HADRIN
33189 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33190 & K1Z(16),K2Z(16),WTZ(153),II22,
33191 & NZK1(153),NZK2(153),NZK3(153)
33192
33193 DATA IRETUR/0/
33194
33195 IRETUR=IRETUR+1
33196 AMH(31)=0.48D0
33197 IF (IRETUR.GT.1) RETURN
33198 DO 10 I=1,94
33199 AMH(I) = AAM(I)
33200 GAH(I) = GA(I)
33201 TAUH(I) = TAU(I)
33202 ICHH(I) = IICH(I)
33203 IBARH(I) = IIBAR(I)
33204 K1H(I) = K1(I)
33205 K2H(I) = K2(I)
33206 10 CONTINUE
33207**sr
33208C AMH(1)=0.93828D0
33209 AMH(1)=0.9383D0
33210**
33211 AMH(2)=AMH(1)
33212 DO 20 I=26,30
33213 K1H(I)=452
33214 K2H(I)=452
33215 20 CONTINUE
33216 DO 30 I=1,307
33217 WTI(I) = WT(I)
33218 NZKI(I,1) = NZK(I,1)
33219 NZKI(I,2) = NZK(I,2)
33220 NZKI(I,3) = NZK(I,3)
33221 30 CONTINUE
33222 DO 40 I=1,16
33223 L=I+94
33224 AMH(L)=AMZ(I)
33225 GAH( L)=GAZ(I)
33226 TAUH( L)=TAUZ(I)
33227 ICHH( L)=ICHZ(I)
33228 IBARH( L)=IBARZ(I)
33229 K1H( L)=K1Z(I)
33230 K2H( L)=K2Z(I)
33231 40 CONTINUE
33232 DO 50 I=1,153
33233 L=I+307
33234 WTI(L) = WTZ(I)
33235 NZKI(L,3) = NZK3(I)
33236 NZKI(L,2) = NZK2(I)
33237 NZKI(L,1) = NZK1(I)
33238 50 CONTINUE
33239 RETURN
33240 END
33241
33242*$ CREATE IDT_IEFUND.FOR
33243*COPY IDT_IEFUND
33244*
33245*===iefund=============================================================*
33246*
33247 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33248
33249 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33250 SAVE
33251
33252C*****IEFUN CALCULATES A MOMENTUM INDEX
33253
33254 PARAMETER ( LINP = 10 ,
33255 & LOUT = 6 ,
33256 & LDAT = 9 )
33257
33258 COMMON /HNDRUN/ RUNTES,EFTES
33259
33260 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33261
33262 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33263 & NRK(2,268),NURE(30,2)
33264
33265 IPLA=IEII(IRE)+1
33266 *+1
33267 IPLE=IEII(IRE+1)
33268 IF (PL.LT.0.) GO TO 30
33269 DO 10 I=IPLA,IPLE
33270 J=I-IPLA+1
33271 IF (PL.LE.PLABF(I)) GO TO 60
33272 10 CONTINUE
33273 I=IPLE
33274 IF ( EFTES.GT.40.D0) GO TO 20
33275 EFTES=EFTES+1.0D0
33276 WRITE(LOUT,1000)PL,J
33277 20 CONTINUE
33278 GO TO 70
33279 30 CONTINUE
33280 DO 40 I=IPLA,IPLE
33281 J=I-IPLA+1
33282 IF (-PL.LE.UMO(I)) GO TO 60
33283 40 CONTINUE
33284 I=IPLE
33285 IF ( EFTES.GT.40.D0) GO TO 50
33286 EFTES=EFTES+1.0D0
33287 WRITE(LOUT,1000)PL,I
33288 50 CONTINUE
33289 60 CONTINUE
33290 70 CONTINUE
33291 IDT_IEFUND=I
33292 RETURN
33293 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33294 +7H IEFUN=,I5)
33295 END
33296
33297*$ CREATE DT_DSIGIN.FOR
33298*COPY DT_DSIGIN
33299*
33300*===dsigin=============================================================*
33301*
33302 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33303
33304 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33305 SAVE
33306
33307* particle properties (BAMJET index convention),
33308* (dublicate of DTPART for HADRIN)
33309 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33310 & K1H(110),K2H(110)
33311
33312 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33313
33314 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33315 & NRK(2,268),NURE(30,2)
33316
33317 IE=IDT_IEFUND(PLAB,IRE)
33318 IF (IE.LE.IEII(IRE)) IE=IE+1
33319 AMT=AMH(ITAR)
33320 AMN=AMH(N)
33321 AMN2=AMN*AMN
33322 AMT2=AMT*AMT
33323 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33324C*** INTERPOLATION PREPARATION
33325 ECMO=UMO(IE)
33326 ECM1=UMO(IE-1)
33327 DECM=ECMO-ECM1
33328 DEC=ECMO-ECM
33329 IIKI=IKII(IRE)+1
33330 EKLIM=-THRESH(IIKI)
33331 WOK=SIIN(IE)
33332 WDK=WOK-SIIN(IE-1)
33333 IF (ECM.GT.ECMO) WDK=0.0D0
33334C*** INTERPOLATION IN CHANNEL WEIGHTS
33335 IELIM=IDT_IEFUND(EKLIM,IRE)
33336 DELIM=UMO(IELIM)+EKLIM
33337 *+1.D-16
33338 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33339 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33340 10 DECC=DELIM
33341 GO TO 30
33342 20 DECC=DECM
33343 30 CONTINUE
33344 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33345 IF (WKK.LT.0.0D0) WKK=0.0D0
33346 SI=WKK+1.D-12
33347 IF (-EKLIM.GT.ECM) SI=1.D-14
33348 RETURN
33349 END
33350
33351*$ CREATE DT_DTCHOI.FOR
33352*COPY DT_DTCHOI
33353*
33354*===dtchoi=============================================================*
33355*
33356 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33357
33358 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33359 SAVE
33360
33361C ****************************
33362C TCHOIC CALCULATES A RANDOM VALUE
33363C FOR THE FOUR-MOMENTUM-TRANSFER T
33364C ****************************
33365
33366* particle properties (BAMJET index convention),
33367* (dublicate of DTPART for HADRIN)
33368 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33369 & K1H(110),K2H(110)
33370
33371* slope parameters for HADRIN interactions
33372 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33373
33374 AMA=AM1
33375 AMB=AM2
33376 IF (I.GT.30.AND.II.GT.30) GO TO 20
33377 III=II
33378 AM3=AM2
33379 IF (I.LE.30) GO TO 10
33380 III=I
33381 AM3=AM1
33382 10 CONTINUE
33383 GO TO 30
33384 20 CONTINUE
33385 III=II
33386 AM3=AM2
33387 IF (AMA.LE.AMB) GO TO 30
33388 III=I
33389 AM3=AM1
33390 30 CONTINUE
33391 IB=IBARH(III)
33392 AMA=AM3
33393 K=INT((AMA-0.75D0)/0.05D0)
33394 IF (K-2.LT.0) K=1
33395 IF (K-26.GE.0) K=25
33396 IF (IB)50,40,50
33397 40 BM=BBM(K)
33398 GO TO 60
33399 50 BM=BBB(K)
33400 60 CONTINUE
33401C NORMALIZATION
33402 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33403 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33404 VB=DT_RNDM(TMIN)
33405**sr test
33406C IF (VB.LT.0.2D0) BM=BM*0.1
33407C **0.5
33408 BM = BM*5.05D0
33409**
33410 TMI=BM*TMIN
33411 TMA=BM*TMAX
33412 ETMA=0.D0
33413 IF (ABS(TMA).GT.120.D0) GO TO 70
33414 ETMA=EXP(TMA)
33415 70 CONTINUE
33416 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33417C*** RANDOM CHOICE OF THE T - VALUE
33418 R=DT_RNDM(TMI)
33419 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33420 RETURN
33421 END
33422
33423*$ CREATE DT_DTWOPA.FOR
33424*COPY DT_DTWOPA
33425*
33426*===dtwopa=============================================================*
33427*
33428 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33429 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33430
33431 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33432 SAVE
33433
33434C ******************************************************
33435C QUASI TWO PARTICLE PRODUCTION
33436C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33437C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33438C IN THE CM - SYSTEM
33439C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33440C SPHERICAL COORDINATES
33441C ******************************************************
33442
33443* particle properties (BAMJET index convention),
33444* (dublicate of DTPART for HADRIN)
33445 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33446 & K1H(110),K2H(110)
33447
33448 AMA=AM1
33449 AMB=AM2
33450 AMA2=AMA*AMA
33451 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33452 E2=UMOO - E1
33453 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33454 AMTE=(E1-AMA)*(E1+AMA)
33455 AMTE=AMTE+1.D-18
33456 P1=SQRT(AMTE)
33457 P2=P1
33458C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33459C DETERMINATION OF THE ANGLES
33460C COS(THETA1)=COD1 COS(THETA2)=COD2
33461C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33462C COS(PHI1)=COF1 COS(PHI2)=COF2
33463C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33464 CALL DT_DSFECF(COF1,SIF1)
33465 COF2=-COF1
33466 SIF2=-SIF1
33467C CALCULATION OF THETA1
33468 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33469 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33470 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33471 COD2=-COD1
33472 RETURN
33473 END
33474
33475*$ CREATE DT_ZK.FOR
33476*COPY DT_ZK
33477*
33478*===zk=================================================================*
33479*
33480 BLOCK DATA DT_ZK
33481
33482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33483 SAVE
33484
33485* decay channel information for HADRIN
33486 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33487 & K1Z(16),K2Z(16),WTZ(153),II22,
33488 & NZK1(153),NZK2(153),NZK3(153)
33489
33490* decay channel information for HADRIN
33491 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33492 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33493
33494* Particle masses in GeV *
33495 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33496 & 2*1.7D0, 3*0.D0/
33497* Resonance width Gamma in GeV *
33498 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33499* Mean life time in seconds *
33500 DATA TAUZ / 16*0.D0 /
33501* Charge of particles and resonances *
33502 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33503* Baryonic charge *
33504 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33505* First number of decay channels used for resonances *
33506* and decaying particles *
33507 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33508 & 3*460/
33509* Last number of decay channels used for resonances *
33510* and decaying particles *
33511 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33512 & 3*460/
33513* Weight of decay channel *
33514 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33515 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33516 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33517 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33518 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33519 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33520 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33521 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33522 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33523 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33524 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33525 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33526 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33527 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33528 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33529 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33530 & .05D0, .65D0, 9*1.D0 /
33531* Particle numbers in decay channel *
33532 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33533 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33534 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33535 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33536 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33537 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33538 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33539 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33540 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33541 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33542 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33543 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33544 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33545 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33546 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33547 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33548 & 1, 8, 1, 8, 1, 9*0 /
33549 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33550 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33551 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33552 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33553 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33554 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33555* Particle names *
33556 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33557 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33558 & 3*'BLANK' /
33559* Name of decay channel *
33560 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33561 & 'ANNPI0','APPPI0','ANPPI-'/
33562 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33563 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33564 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33565 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33566 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33567 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33568 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33569 & 'OMOMOM',
33570 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33571 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33572 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33573 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33574 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33575 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33576 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33577 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33578 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33579 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33580 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33581 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33582 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33583 & 9*'BLANK'/
33584*= end*block.zk *
33585 END
33586
33587*$ CREATE DT_BLKD43.FOR
33588*COPY DT_BLKD43
33589*
33590*===blkd43=============================================================*
33591*
33592 BLOCK DATA DT_BLKD43
33593
33594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33595 SAVE
33596
33597*
33598*=== reac =============================================================*
33599*
33600*----------------------------------------------------------------------*
33601* *
33602* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33603* Infn - Milan *
33604* *
33605* Last change on 10-dec-91 by Alfredo Ferrari *
33606* *
33607* This is the original common reac of Hadrin *
33608* *
33609*----------------------------------------------------------------------*
33610*
33611
33612 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33613 & NRK(2,268),NURE(30,2)
33614
33615 DIMENSION
33616 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33617 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33618 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33619 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33620 & SPIKP5(187), SPIKP6(289),
33621 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33622 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33623 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33624 & SANPEL(84) , SPIKPF(273),
33625 & SPKP15(187), SPKP16(272),
33626 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33627 & NURELN(60)
33628*
33629 DIMENSION NRKLIN(532)
33630 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33631 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33632 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33633 EQUIVALENCE ( UMO(263), UMOK0(1))
33634 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33635 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33636 EQUIVALENCE ( PLABF(263), PLAK0(1))
33637 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33638 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33639 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33640 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33641 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33642 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33643 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33644 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33645 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33646 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33647 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33648 EQUIVALENCE ( WK(4913), SPKP16(1))
33649 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33650 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33651 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33652 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33653 EQUIVALENCE (NURE(1,1), NURELN(1))
33654*
33655**** pi- p data *
33656**** pi+ n data *
33657 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33658 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33659 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33660 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33661 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33662 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33663 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33664 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33665 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33666 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33667 DATA PLAKC /
33668 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33669 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33670 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33671 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33672 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33673 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33674 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33675 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33676 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33677 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33678 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33679 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33680 DATA PLAK0 /
33681 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33682 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33683 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33684 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33685 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33686 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33687* pp pn np nn *
33688 DATA PLAP /
33689 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33690 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33691 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33692 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33693 & 0.D0, 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* app apn anp ann *
33696 DATA PLAN /
33697 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33698 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33699 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33700 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33701 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33702 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33703 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33704 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33705 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33706 DATA SIIN / 296*0.D0 /
33707 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33708 & 1.557D0,1.615D0,1.6435D0,
33709 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33710 & 2.286D0,2.366D0,2.482D0,2.56D0,
33711 & 2.735D0,2.90D0,
33712 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33713 & 1.496D0,1.527D0,1.557D0,
33714 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33715 & 2.071D0,2.159D0,2.286D0,2.366D0,
33716 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33717 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33718 & 1.496D0,1.527D0,1.557D0,
33719 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33720 & 2.071D0,2.159D0,2.286D0,2.366D0,
33721 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33722 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33723 & 1.557D0,1.615D0,1.6435D0,
33724 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33725 & 2.286D0,2.366D0,2.482D0,2.56D0,
33726 & 2.735D0, 2.90D0/
33727 DATA UMOKC/ 1.44D0,
33728 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33729 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33730 & 3.1D0,1.44D0,
33731 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33732 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33733 & 3.1D0,1.44D0,
33734 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33735 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33736 & 3.1D0,1.44D0,
33737 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33738 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33739 & 3.1D0/
33740 DATA UMOK0/ 1.44D0,
33741 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33742 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33743 & 3.1D0,1.44D0,
33744 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33745 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33746 & 3.1D0/
33747* pp pn np nn *
33748 DATA UMOP/
33749 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33750 & 3.D0,3.1D0,3.2D0,
33751 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33752 & 3.D0,3.1D0,3.2D0,
33753 & 1.88D0,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* app apn anp ann *
33756 DATA UMON /
33757 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33758 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33759 & 3.D0,3.1D0,3.2D0,
33760 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33761 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33762 & 3.D0,3.1D0,3.2D0,
33763 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33764 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33765 & 3.D0,3.1D0,3.2D0/
33766**** reaction channel state particles *
33767 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33768 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33769 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33770 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33771 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33772 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33773 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33774 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33775 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33776 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33777 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33778 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33779 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33780 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33781 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33782 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33783 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33784 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33785* *
33786* k0 p k0 n ak0 p ak/ n *
33787* *
33788 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33789 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33790 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33791 & 53, 47, 1, 103, 0, 93, 0/
33792* pp pn np nn *
33793 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33794 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33795 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33796 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33797* app apn anp ann *
33798 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33799 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33800 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33801 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33802 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33803 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33804 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33805**** channel cross section *
33806 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33807 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33808 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33809 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33810 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33811 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33812 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33813 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33814 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33815 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33816 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33817 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33818 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33819 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33820 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33821 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33822 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33823 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33824 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33825 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33826**** pi+ n data *
33827 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33828 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33829 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33830 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33831 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33832 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33833 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33834 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33835 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33836 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33837 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33838 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33839 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33840 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33841 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33842 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33843 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33844 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33845 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33846 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33847*
33848 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33849 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33850 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33851 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33852 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33853 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33854 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33855 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33856 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33857 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33858 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33859 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33860 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33861 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33862 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33863 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33864 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33865 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33866 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33867 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33868**** pi- p data *
33869 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33870 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33871 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33872 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33873 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33874 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33875 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33876 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33877 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33878 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33879 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33880 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33881 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33882 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33883 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33884 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33885 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33886 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33887 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33888*
33889 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33890 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33891 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33892 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33893 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33894 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33895 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33896 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33897 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33898 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33899 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33900 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33901 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33902 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33903 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33904 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33905 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33906 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33907 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33908 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33909**** pi- n data *
33910 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33911 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33912 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33913 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33914 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33915 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33916 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33917 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33918 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33919 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33920 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33921 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33922 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33923 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33924 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33925 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33926 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33927 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33928 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33929 & 3.3D0, 5.4D0, 7.D0 /
33930**** k+ p data *
33931 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33932 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33933 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33934 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33935 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33936 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33937 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33938 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33939 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33940 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33941 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33942 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33943 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33944**** k+ n data *
33945 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33946 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33947 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33948 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33949 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33950 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33951 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33952 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33953 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33954 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33955 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33956 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33957 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33958 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33959 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33960 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33961 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33962 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33963 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33964**** k- p data *
33965 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33966 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33967 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33968 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33969 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33970 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33971 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33972 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33973 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33974 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33975 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33976 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33977 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33978 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33979 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33980 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33981 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33982 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33983 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33984 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33985 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33986 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33987 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33988 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33989 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33990 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33991 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33992 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33993 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33994 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33995 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33996 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33997 & 10*0.D0/
33998***** k- n data *
33999 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34000 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
34001 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
34002 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
34003 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34004 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34005 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34006 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34007 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34008 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34009 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34010 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34011 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34012 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34013 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34014 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34015 & .39D0, .22D0, .07D0, 0.D0,
34016 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34017 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34018 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34019 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34020 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34021 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34022 & 5.10D0, 5.44D0, 5.3D0,
34023 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34024***** p p data *
34025 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34026 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34027 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34028 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34029 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34030 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34031 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34032 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34033 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34034 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34035 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34036 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34037 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34038 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34039 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34040***** p n data *
34041 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34042 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34043 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34044 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34045 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34046 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34047 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34048 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34049 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34050 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34051 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34052 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34053 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34054 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34055 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34056 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34057 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34058 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34059* nn - data *
34060* *
34061 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34062 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34063 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34064 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34065 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34066 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34067 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34068 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34069 & 11.D0, 5.5D0, 3.5D0,
34070 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34071 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34072 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34073 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34074 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34075 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34076**************** ap - p - data *
34077 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34078 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34079 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34080 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34081 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34082 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34083 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34084 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34085 & 1.55D0, 1.3D0, .95D0, .75D0,
34086 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34087 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34088 & .01D0, .008D0, .006D0, .005D0/
34089 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34090 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34091 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34092 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34093 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34094 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34095 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34096 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34097 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34098 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34099 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34100 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34101 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34102 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34103 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34104 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34105 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34106 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34107 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34108 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34109**************** ap - n - data *
34110 DATA SAPNEL/
34111 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34112 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34113 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34114 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34115 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34116 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34117 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34118 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34119 & .01D0, .008D0, .006D0, .005D0 /
34120 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34121 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34122 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34123 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34124 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34125 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34126 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34127 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34128 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34129 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34130 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34131 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34132 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34133 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34134* *
34135* *
34136**************** an - p - data *
34137* *
34138 DATA SANPEL/
34139 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34140 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34141 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34142 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34143 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34144 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34145 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34146 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34147 & .01D0, .008D0, .006D0, .005D0 /
34148 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34149 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34150 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34151 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34152 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34153 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34154 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34155 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34156 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34157 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34158 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34159 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34160 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34161 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34162**** ko - n - data *
34163 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34164 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34165 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34166 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34167 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34168 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34169 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34170 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34171 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34172 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34173 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34174 & 4.85D0, 4.9D0,
34175 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34176 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34177 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34178 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34179 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34180**** ako - p - data *
34181 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34182 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34183 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34184 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34185 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34186 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34187 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34188 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34189 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34190 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34191 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34192 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34193 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34194 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34195 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34196 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34197 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34198 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34199 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34200 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34201 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34202 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34203 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34204*= end*block.blkdt3 *
34205 END
34206*$ CREATE DT_QEL_POL.FOR
34207*COPY DT_QEL_POL
34208*
34209*===qel_pol============================================================*
34210*
34211 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34212
34213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34214 SAVE
34215
34216 CALL DT_MASS_INI
34217 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34218
34219 RETURN
34220 END
34221
34222*$ CREATE DT_GEN_QEL.FOR
34223*COPY DT_GEN_QEL
34224C==================================================================
34225C Generation of a Quasi-Elastic neutrino scattering
34226C==================================================================
34227*
34228*===gen_qel============================================================*
34229*
34230 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34231
34232C...Generate a quasi-elastic neutrino/antineutrino
34233C. Interaction on a nuclear target
34234C. INPUT : LTYP = neutrino type (1,...,6)
34235C. ENU (GeV) = neutrino energy
34236C----------------------------------------------------
34237
34238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34239 SAVE
34240
34241 PARAMETER ( LINP = 10 ,
34242 & LOUT = 6 ,
34243 & LDAT = 9 )
34244 PARAMETER (MAXLND=4000)
34245 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34246
34247* nuclear potential
34248 LOGICAL LFERMI
34249 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34250 & EBINDP(2),EBINDN(2),EPOT(2,210),
34251 & ETACOU(2),ICOUL,LFERMI
34252
34253* steering flags for qel neutrino scattering modules
34254 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34255**sr - removed (not needed)
34256C COMMON /CBAD/ LBAD, NBAD
34257C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34258**
34259
34260 DIMENSION PI(3),PO(3)
34261CJR+
34262 DATA ININU/0/
34263CJR-
34264C REAL*8 DBETA(3)
34265C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34266 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34267 DATA AMN /0.93827231D0, 0.93956563D0/
34268 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34269 DATA INIPRI/0/
34270
34271C DATA PFERMI/0.22D0/
34272CGB+...Binding Energy
34273 DATA EBIND/0.008D0/
34274CGB-...
34275
34276 ININU=ININU+1
34277 IF(ININU.EQ.1)NDSIG=0
34278 LBAD = 0
34279 enu0=enu
34280c write(*,*) enu0
34281C...Lepton mass
34282 AML = AML0(LTYP) ! massa leptoni
34283 AML2 = AML**2 ! massa leptoni **2
34284C...Particle labels (LUND)
34285 N = 5
34286 K(1,1) = 21
34287 K(2,1) = 21
34288 K(3,1) = 21
34289 K(3,3) = 1
34290 K(4,1) = 1
34291 K(4,3) = 1
34292 K(5,1) = 1
34293 K(5,3) = 2
34294 K0 = (LTYP-1)/2 ! 2
34295 K1 = LTYP/2 ! 2
34296 KA = 12 + 2*K0 ! 16
34297 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34298 K(1,2) = IS*KA
34299 K(4,2) = IS*(KA-1)
34300 K(3,2) = IS*24
34301 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34302 IF (LNU .EQ. 2) THEN
34303 K(2,2) = 2212
34304 K(5,2) = 2112
34305 AMI = AMN(1)
34306 AMF = AMN(2)
34307CJR+
34308 PFERMI=PFERMN(2)
34309CJR-
34310 ELSE
34311 K(2,2) = 2112
34312 K(5,2) = 2212
34313 AMI = AMN(2)
34314 AMF = AMN(1)
34315CJR+
34316 PFERMI=PFERMP(2)
34317CJR-
34318 ENDIF
34319 AMI2 = AMI**2
34320 AMF2 = AMF**2
34321
34322 DO IGB=1,5
34323 P(3,IGB) = 0.
34324 P(4,IGB) = 0.
34325 P(5,IGB) = 0.
34326 END DO
34327
34328 NTRY = 0
34329CGB+...
34330 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34331 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34332CGB-...
34333
34334 100 CONTINUE
34335
34336C...4-momentum initial lepton
34337 P(1,5) = 0. ! massa
34338 P(1,4) = ENU0 ! energia
34339 P(1,1) = 0. ! px
34340 P(1,2) = 0. ! py
34341 P(1,3) = ENU0 ! pz
34342
34343C PF = PFERMI*PYR(0)**(1./3.)
34344c write(23,*) PYR(0)
34345c write(*,*) 'Pfermi=',PF
34346c PF = 0.
34347 NTRY=NTRY+1
34348C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34349 IF (NTRY .GT. 500) THEN
34350 LBAD = 1
34351 WRITE (LOUT,1001) NBAD, ENU
34352 RETURN
34353 ENDIF
34354C CT = -1. + 2.*PYR(0)
34355c CT = -1.
34356C ST = SQRT(1.-CT*CT)
34357C F = 2.*3.1415926*PYR(0)
34358c F = 0.
34359
34360C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34361C P(2,1) = PF*ST*COS(F) ! px
34362C P(2,2) = PF*ST*SIN(F) ! py
34363C P(2,3) = PF*CT ! pz
34364C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34365 P(2,1) = P21
34366 P(2,2) = P22
34367 P(2,3) = P23
34368 P(2,4) = P24
34369 P(2,5) = P25
34370 beta1=-p(2,1)/p(2,4)
34371 beta2=-p(2,2)/p(2,4)
34372 beta3=-p(2,3)/p(2,4)
34373 N=2
34374C WRITE(6,*)' before transforming into target rest frame'
34375
34376 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34377
34378C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34379 N=5
34380
34381 phi11=atan(p(1,2)/p(1,3))
34382 pi(1)=p(1,1)
34383 pi(2)=p(1,2)
34384 pi(3)=p(1,3)
34385
34386 CALL DT_TESTROT(PI,Po,PHI11,1)
34387 DO ll=1,3
34388 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34389 END DO
34390c WRITE(*,*) po
34391 p(1,1)=po(1)
34392 p(1,2)=po(2)
34393 p(1,3)=po(3)
34394 phi12=atan(p(1,1)/p(1,3))
34395
34396 pi(1)=p(1,1)
34397 pi(2)=p(1,2)
34398 pi(3)=p(1,3)
34399 CALL DT_TESTROT(Pi,Po,PHI12,2)
34400 DO ll=1,3
34401 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34402 END DO
34403c WRITE(*,*) po
34404 p(1,1)=po(1)
34405 p(1,2)=po(2)
34406 p(1,3)=po(3)
34407
34408 enu=p(1,4)
34409
34410C...Kinematical limits in Q**2
34411c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34412 S = P(2,5)**2 + 2.*ENU*P(2,5)
34413 SQS = SQRT(S) ! E centro massa
34414 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34415 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34416 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34417 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34418 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34419 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34420 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34421
34422C...Generate Q**2
34423 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34424 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34425 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34426 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34427 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34428 NDSIG=NDSIG+1
34429C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34430C &Q2,Q2min,Q2MAX,DSIGEV
34431
34432C...c.m. frame. Neutrino along z axis
34433 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34434 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34435 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34436 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34437c WRITE(*,*)
34438c WRITE(*,*)
34439C WRITE(*,*) 'Input values laboratory frame'
34440 N=2
34441
34442 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34443
34444 N=5
34445c STHETA = ULANGL(P(1,3),P(1,1))
34446c write(*,*) 'stheta' ,stheta
34447c stheta=0.
34448c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34449c WRITE(*,*)
34450c WRITE(*,*)
34451C WRITE(*,*) 'Output values cm frame'
34452C...Kinematic in c.m. frame
34453 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34454 STSTAR = SQRT(1.-CTSTAR**2)
34455 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34456 P(4,5) = AML ! massa leptone
34457 P(4,4) = ELF ! e leptone
34458 P(4,3) = PLF*CTSTAR ! px
34459 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34460 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34461
34462 P(5,5) = AMF ! barione
34463 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34464 P(5,3) = -P(4,3) ! px
34465 P(5,1) = -P(4,1) ! py
34466 P(5,2) = -P(4,2) ! pz
34467
34468 P(3,5) = -Q2
34469 P(3,1) = P(1,1)-P(4,1)
34470 P(3,2) = P(1,2)-P(4,2)
34471 P(3,3) = P(1,3)-P(4,3)
34472 P(3,4) = P(1,4)-P(4,4)
34473
34474C...Transform back to laboratory frame
34475C WRITE(*,*) 'before going back to nucl rest frame'
34476c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34477 N=5
34478
34479 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34480
34481C WRITE(*,*) 'Now back in nucl rest frame'
34482 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34483
34484c********************************************
34485
34486 DO kw=1,5
34487 pi(1)=p(kw,1)
34488 pi(2)=p(kw,2)
34489 pi(3)=p(kw,3)
34490 CALL DT_TESTROT(Pi,Po,PHI12,3)
34491 DO ll=1,3
34492 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34493 END DO
34494 p(kw,1)=po(1)
34495 p(kw,2)=po(2)
34496 p(kw,3)=po(3)
34497 END DO
34498c********************************************
34499
34500 DO kw=1,5
34501 pi(1)=p(kw,1)
34502 pi(2)=p(kw,2)
34503 pi(3)=p(kw,3)
34504 CALL DT_TESTROT(Pi,Po,PHI11,4)
34505 DO ll=1,3
34506 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34507 END DO
34508 p(kw,1)=po(1)
34509 p(kw,2)=po(2)
34510 p(kw,3)=po(3)
34511 END DO
34512
34513c********************************************
34514
34515C WRITE(*,*) 'Now back in lab frame'
34516
34517 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34518
34519CGB+...
34520C...test (on final momentum of nucleon) if Fermi-blocking
34521C...is operating
34522 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34523 & - P(5,5)
34524 IF (ENUCL.LT. EFMAX) THEN
34525 IF(INIPRI.LT.10)THEN
34526 INIPRI=INIPRI+1
34527C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34528C...the interaction is not possible due to Pauli-Blocking and
34529C...it must be resampled
34530 ENDIF
34531 GOTO 100
34532 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34533 IF(INIPRI.LT.10)THEN
34534 INIPRI=INIPRI+1
34535C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34536 ENDIF
34537C Reject (J:R) here all these events
34538C are otherwise rejected in dpmjet
34539 GOTO 100
34540C...the interaction is possible, but the nucleon remains inside
34541C...the nucleus. The nucleus is therefore left excited.
34542C...We treat this case as a nucleon with 0 kinetic energy.
34543C P(5,5) = AMF
34544C P(5,4) = AMF
34545C P(5,1) = 0.
34546C P(5,2) = 0.
34547C P(5,3) = 0.
34548 ELSE IF (ENUCL.GE.ENWELL) THEN
34549C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34550C...the interaction is possible, the nucleon can exit the nucleus
34551C...but the nuclear well depth must be subtracted. The nucleus could be
34552C...left in an excited state.
34553 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34554C P(5,4) = ENUCL-ENWELL + AMF
34555 Pnucl = SQRT(P(5,4)**2-AMF**2)
34556C...The 3-momentum is scaled assuming that the direction remains
34557C...unaffected
34558 P(5,1) = P(5,1) * Pnucl/Pstart
34559 P(5,2) = P(5,2) * Pnucl/Pstart
34560 P(5,3) = P(5,3) * Pnucl/Pstart
34561C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34562 ENDIF
34563CGB-...
34564 DSIGSU=DSIGSU+DSIGEV
34565
34566 GA=P(4,4)/P(4,5)
34567 BGX=P(4,1)/P(4,5)
34568 BGY=P(4,2)/P(4,5)
34569 BGZ=P(4,3)/P(4,5)
34570*
34571 DBETB(1)=BGX/GA
34572 DBETB(2)=BGY/GA
34573 DBETB(3)=BGZ/GA
34574 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34575
34576 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34577
34578 ENDIF
34579c
34580C PRINT*,' FINE EVENTO '
34581 enu=enu0
34582 RETURN
34583
34584 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34585 END
34586
34587*$ CREATE DT_MASS_INI.FOR
34588*COPY DT_MASS_INI
34589C====================================================================
34590C. Masses
34591C====================================================================
34592*
34593*===mass_ini===========================================================*
34594*
34595 SUBROUTINE DT_MASS_INI
34596C...Initialize the kinematics for the quasi-elastic cross section
34597
34598 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34599 SAVE
34600
34601* particle masses used in qel neutrino scattering modules
34602 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34603 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34604 & EMPROTSQ,EMNEUTSQ,EMNSQ
34605
34606 EML(1) = 0.51100D-03 ! e-
34607 EML(2) = EML(1) ! e+
34608 EML(3) = 0.105659D0 ! mu-
34609 EML(4) = EML(3) ! mu+
34610 EML(5) = 1.7777D0 ! tau-
34611 EML(6) = EML(5) ! tau+
34612 EMPROT = 0.93827231D0 ! p
34613 EMNEUT = 0.93956563D0 ! n
34614 EMPROTSQ = EMPROT**2
34615 EMNEUTSQ = EMNEUT**2
34616 EMN = (EMPROT + EMNEUT)/2.
34617 EMNSQ = EMN**2
34618 DO J=1,3
34619 J0 = 2*(J-1)
34620 EMN1(J0+1) = EMNEUT
34621 EMN1(J0+2) = EMPROT
34622 EMN2(J0+1) = EMPROT
34623 EMN2(J0+2) = EMNEUT
34624 ENDDO
34625 DO J=1,6
34626 EMLSQ(J) = EML(J)**2
34627 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34628 ENDDO
34629 RETURN
34630 END
34631
34632*$ CREATE DT_DSQEL_Q2.FOR
34633*COPY DT_DSQEL_Q2
34634*
34635*===dsqel_q2===========================================================*
34636*
34637 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34638
34639C...differential cross section for Quasi-Elastic scattering
34640C. nu + N -> l + N'
34641C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34642C.
34643C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34644C. ENU (GeV) = Neutrino energy
34645C. Q2 (GeV**2) = (Transfer momentum)**2
34646C.
34647C. OUTPUT : DSQEL_Q2 = differential cross section :
34648C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34649C------------------------------------------------------------------
34650
34651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34652 SAVE
34653
34654* particle masses used in qel neutrino scattering modules
34655 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34656 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34657 & EMPROTSQ,EMNEUTSQ,EMNSQ
34658**sr - removed (not needed)
34659C COMMON /CAXIAL/ FA0, AXIAL2
34660**
34661
34662 DIMENSION SS(6)
34663 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34664 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34665 DATA AXIAL2 /1.03D0/ ! to be checked
34666
34667 FA0=-1.253D0
34668 CSI = 3.71D0 ! ???
34669 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34670 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34671 X = Q2/(EMN*EMN) ! emn=massa barione
34672 XA = X/4.D0
34673 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34674 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34675 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34676 FFA = FA*FA
34677 FFV1 = FV1*FV1
34678 FFV2 = FV2*FV2
34679 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34680 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34681 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34682 AA = (XA+0.25D0*RM)*(A1 + A2)
34683 BB = -X*FA*(FV1 + FV2)
34684 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34685 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34686 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34687 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34688
34689 RETURN
34690 END
34691
34692*$ CREATE DT_PREPOLA.FOR
34693*COPY DT_PREPOLA
34694*
34695*===prepola============================================================*
34696*
34697 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34698
34699 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34700 SAVE
34701c
34702c By G. Battistoni and E. Scapparone (sept. 1997)
34703c According to:
34704c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34705c
34706c
34707 PARAMETER (MAXLND=4000)
34708 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34709
34710 COMMON /QNPOL/ POLARX(4),PMODUL
34711
34712* particle masses used in qel neutrino scattering modules
34713 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34714 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34715 & EMPROTSQ,EMNEUTSQ,EMNSQ
34716
34717* steering flags for qel neutrino scattering modules
34718 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34719**sr - removed (not needed)
34720C COMMON /CAXIAL/ FA0, AXIAL2
34721C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34722C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34723**
34724 REAL*8 POL(4,4),BB2(3)
34725 DIMENSION SS(6)
34726C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34727 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34728**sr uncommented since common block CAXIAL is now commented
34729 DATA AXIAL2 /1.03D0/ ! to be checked
34730**
34731
34732 RML=P(4,5)
34733 RMM=0.93960D+00
34734 FM2 = RMM**2
34735 MPI = 0.135D+00
34736 OLDQ2=Q2
34737 FA0=-1.253D+00
34738 CSI = 3.71D+00 !
34739 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34740 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34741 X = Q2/(EMN*EMN) ! emn=massa barione
34742 XA = X/4.D0
34743 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34744 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34745 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34746 FFA = FA*FA
34747 FFV1 = FV1*FV1
34748 FFV2 = FV2*FV2
34749 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34750 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34751 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34752 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34753 AA = (XA+0.25D+00*RM)*(A1 + A2)
34754 BB = -X*FA*(FV1 + FV2)
34755 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34756 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34757
34758 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34759 OMEGA2=4.D+00*CC
34760 OMEGA3=2.D+00*FA*(FV1+FV2)
34761 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34762 1 (Q2/FM2))*FP**2)
34763 OMEGA5=OMEGA2
34764 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34765 WW1=2.D+00*OMEGA1*EMN**2
34766 WW2=2.D+00*OMEGA2*EMN**2
34767 WW3=2.D+00*OMEGA3*EMN**2
34768 WW4=2.D+00*OMEGA4*EMN**2
34769 WW5=2.D+00*OMEGA5*EMN**2
34770
34771 DO I=1,3
34772 BB2(I)=-P(4,I)/P(4,4)
34773 END DO
34774c WRITE(*,*)
34775c WRITE(*,*)
34776c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34777 N=5
34778
34779 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34780
34781* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34782c WRITE(*,*)
34783c WRITE(*,*)
34784c WRITE(*,*) 'Prepola: now in lepton rest frame'
34785 EE=ENU
34786 QM2=Q2+RML**2
34787 U=Q2/(2.*RMM)
34788 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34789 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34790 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34791
34792 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34793 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34794
34795 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34796
34797 DO I=1,3
34798 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34799 POLARX(I)=POL(4,I)
34800 END DO
34801
34802 PMODUL=0.D0
34803 DO I=1,3
34804 PMODUL=PMODUL+POL(4,I)**2
34805 END DO
34806
34807 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34808 IF(NEUDEC.EQ.1) THEN
34809 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34810 + ETL,PXL,PYL,PZL,
34811 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34812c
34813c Tau has decayed in muon
34814c
34815 ENDIF
34816 IF(NEUDEC.EQ.2) THEN
34817 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34818 + ETL,PXL,PYL,PZL,
34819 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34820c
34821c Tau has decayed in electron
34822c
34823 ENDIF
34824 K(4,1)=15
34825 K(4,4) = 6
34826 K(4,5) = 8
34827 N=N+3
34828c
34829c fill common for muon(electron)
34830c
34831 P(6,1)=PXL
34832 P(6,2)=PYL
34833 P(6,3)=PZL
34834 P(6,4)=ETL
34835 K(6,1)=1
34836 IF(JTYP.EQ.5) THEN
34837 IF(NEUDEC.EQ.1) THEN
34838 P(6,5)=EML(JTYP-2)
34839 K(6,2)=13
34840 ELSEIF(NEUDEC.EQ.2) THEN
34841 P(6,5)=EML(JTYP-4)
34842 K(6,2)=11
34843 ENDIF
34844 ELSEIF(JTYP.EQ.6) THEN
34845 IF(NEUDEC.EQ.1) THEN
34846 K(6,2)=-13
34847 ELSEIF(NEUDEC.EQ.2) THEN
34848 K(6,2)=-11
34849 ENDIF
34850 END IF
34851 K(6,3)=4
34852 K(6,4)=0
34853 K(6,5)=0
34854c
34855c fill common for tau_(anti)neutrino
34856c
34857 P(7,1)=PXB
34858 P(7,2)=PYB
34859 P(7,3)=PZB
34860 P(7,4)=ETB
34861 P(7,5)=0.
34862 K(7,1)=1
34863 IF(JTYP.EQ.5) THEN
34864 K(7,2)=16
34865 ELSEIF(JTYP.EQ.6) THEN
34866 K(7,2)=-16
34867 END IF
34868 K(7,3)=4
34869 K(7,4)=0
34870 K(7,5)=0
34871c
34872c Fill common for muon(electron)_(anti)neutrino
34873c
34874 P(8,1)=PXN
34875 P(8,2)=PYN
34876 P(8,3)=PZN
34877 P(8,4)=ETN
34878 P(8,5)=0.
34879 K(8,1)=1
34880 IF(JTYP.EQ.5) THEN
34881 IF(NEUDEC.EQ.1) THEN
34882 K(8,2)=-14
34883 ELSEIF(NEUDEC.EQ.2) THEN
34884 K(8,2)=-12
34885 ENDIF
34886 ELSEIF(JTYP.EQ.6) THEN
34887 IF(NEUDEC.EQ.1) THEN
34888 K(8,2)=14
34889 ELSEIF(NEUDEC.EQ.2) THEN
34890 K(8,2)=12
34891 ENDIF
34892 END IF
34893 K(8,3)=4
34894 K(8,4)=0
34895 K(8,5)=0
34896 ENDIF
34897c WRITE(*,*)
34898c WRITE(*,*)
34899
34900c IF(PMODUL.GE.1.D+00) THEN
34901c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34902c write(*,*) pmodul
34903c DO I=1,3
34904c POL(4,I)=POL(4,I)/PMODUL
34905c POLARX(I)=POL(4,I)
34906c END DO
34907c PMODUL=0.
34908c DO I=1,3
34909c PMODUL=PMODUL+POL(4,I)**2
34910c END DO
34911c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34912c
34913c ENDIF
34914
34915c WRITE(*,*) 'PMODUL = ',PMODUL
34916
34917c WRITE(*,*)
34918c WRITE(*,*)
34919c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34920
34921 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34922
34923 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34924 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34925 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34926 DO NDC =6,8
34927 V(NDC,1) = XDC
34928 V(NDC,2) = YDC
34929 V(NDC,3) = ZDC
34930 END DO
34931
34932 RETURN
34933 END
34934
34935*$ CREATE DT_TESTROT.FOR
34936*COPY DT_TESTROT
34937*
34938*===testrot============================================================*
34939*
34940 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34941
34942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34943 SAVE
34944
34945 DIMENSION ROT(3,3),PI(3),PO(3)
34946
34947 IF (MODE.EQ.1) THEN
34948 ROT(1,1) = 1.D0
34949 ROT(1,2) = 0.D0
34950 ROT(1,3) = 0.D0
34951 ROT(2,1) = 0.D0
34952 ROT(2,2) = COS(PHI)
34953 ROT(2,3) = -SIN(PHI)
34954 ROT(3,1) = 0.D0
34955 ROT(3,2) = SIN(PHI)
34956 ROT(3,3) = COS(PHI)
34957 ELSEIF (MODE.EQ.2) THEN
34958 ROT(1,1) = 0.D0
34959 ROT(1,2) = 1.D0
34960 ROT(1,3) = 0.D0
34961 ROT(2,1) = COS(PHI)
34962 ROT(2,2) = 0.D0
34963 ROT(2,3) = -SIN(PHI)
34964 ROT(3,1) = SIN(PHI)
34965 ROT(3,2) = 0.D0
34966 ROT(3,3) = COS(PHI)
34967 ELSEIF (MODE.EQ.3) THEN
34968 ROT(1,1) = 0.D0
34969 ROT(2,1) = 1.D0
34970 ROT(3,1) = 0.D0
34971 ROT(1,2) = COS(PHI)
34972 ROT(2,2) = 0.D0
34973 ROT(3,2) = -SIN(PHI)
34974 ROT(1,3) = SIN(PHI)
34975 ROT(2,3) = 0.D0
34976 ROT(3,3) = COS(PHI)
34977 ELSEIF (MODE.EQ.4) THEN
34978 ROT(1,1) = 1.D0
34979 ROT(2,1) = 0.D0
34980 ROT(3,1) = 0.D0
34981 ROT(1,2) = 0.D0
34982 ROT(2,2) = COS(PHI)
34983 ROT(3,2) = -SIN(PHI)
34984 ROT(1,3) = 0.D0
34985 ROT(2,3) = SIN(PHI)
34986 ROT(3,3) = COS(PHI)
34987 ELSE
34988 STOP ' TESTROT: mode not supported!'
34989 ENDIF
34990 DO 1 J=1,3
34991 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34992 1 CONTINUE
34993
34994 RETURN
34995 END
34996
34997*$ CREATE DT_LEPDCYP.FOR
34998*COPY DT_LEPDCYP
34999*
35000*===lepdcyp============================================================*
35001*
35002 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
35003 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35004C
35005C-----------------------------------------------------------------
35006C
35007C Author :- G. Battistoni 10-NOV-1995
35008C
35009C=================================================================
35010C
35011C Purpose : performs decay of polarized lepton in
35012C its rest frame: a => b + l + anti-nu
35013C (Example: mu- => nu-mu + e- + anti-nu-e)
35014C Polarization is assumed along Z-axis
35015C WARNING:
35016C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35017C OF NEGLIGIBLE MASS
35018C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35019C IN THIS VERSION
35020C
35021C Method : modifies phase space distribution obtained
35022C by routine EXPLOD using a rejection against the
35023C matrix element for unpolarized lepton decay
35024C
35025C Inputs : Mass of a : AMA
35026C Mass of l : AML
35027C Polar. of a: POL
35028C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35029C POL = -1)
35030C
35031C Outputs : kinematic variables in the rest frame of decaying lepton
35032C ETL,PXL,PYL,PZL 4-moment of l
35033C ETB,PXB,PYB,PZB 4-moment of b
35034C ETN,PXN,PYN,PZN 4-moment of anti-nu
35035C
35036C============================================================
35037C +
35038C Declarations.
35039C -
35040 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35041 SAVE
35042
35043 PARAMETER ( LINP = 10 ,
35044 & LOUT = 6 ,
35045 & LDAT = 9 )
35046
35047 PARAMETER ( KALGNM = 2 )
35048 PARAMETER ( ANGLGB = 5.0D-16 )
35049 PARAMETER ( ANGLSQ = 2.5D-31 )
35050 PARAMETER ( AXCSSV = 0.2D+16 )
35051 PARAMETER ( ANDRFL = 1.0D-38 )
35052 PARAMETER ( AVRFLW = 1.0D+38 )
35053 PARAMETER ( AINFNT = 1.0D+30 )
35054 PARAMETER ( AZRZRZ = 1.0D-30 )
35055 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35056 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35057 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35058 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35059 PARAMETER ( CSNNRM = 2.0D-15 )
35060 PARAMETER ( DMXTRN = 1.0D+08 )
35061 PARAMETER ( ZERZER = 0.D+00 )
35062 PARAMETER ( ONEONE = 1.D+00 )
35063 PARAMETER ( TWOTWO = 2.D+00 )
35064 PARAMETER ( THRTHR = 3.D+00 )
35065 PARAMETER ( FOUFOU = 4.D+00 )
35066 PARAMETER ( FIVFIV = 5.D+00 )
35067 PARAMETER ( SIXSIX = 6.D+00 )
35068 PARAMETER ( SEVSEV = 7.D+00 )
35069 PARAMETER ( EIGEIG = 8.D+00 )
35070 PARAMETER ( ANINEN = 9.D+00 )
35071 PARAMETER ( TENTEN = 10.D+00 )
35072 PARAMETER ( HLFHLF = 0.5D+00 )
35073 PARAMETER ( ONETHI = ONEONE / THRTHR )
35074 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35075 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35076 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35077 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35078 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35079 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35080 PARAMETER ( AMELGR = 9.1093897 D-28 )
35081 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35082 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35083 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35084 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35085 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35086 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35087 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35088 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35089 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35090 PARAMETER ( PLABRC = 0.197327053 D+00 )
35091 PARAMETER ( AMELCT = 0.51099906 D-03 )
35092 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35093 PARAMETER ( AMMUON = 0.105658389 D+00 )
35094 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35095 PARAMETER ( GEVMEV = 1.0 D+03 )
35096 PARAMETER ( EMVGEV = 1.0 D-03 )
35097 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35098 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35099 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35100C +
35101C variables for EXPLOD
35102C -
35103 PARAMETER ( KPMX = 10 )
35104 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35105 & PZEXPL (KPMX), ETEXPL (KPMX)
35106C +
35107C test variables
35108C -
35109**sr - removed (not needed)
35110C COMMON /GBATNU/ ELERAT,NTRY
35111**
35112C +
35113C Initializes test variables
35114C -
35115 NTRY = 0
35116 ELERAT = 0.D+00
35117C +
35118C Maximum value for matrix element
35119C -
35120 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35121 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35122C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35123C Inputs for EXPLOD
35124C part. no. 1 is l (e- in mu- decay)
35125C part. no. 2 is b (nu-mu in mu- decay)
35126C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35127C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35128 NPEXPL = 3
35129 ETOTEX = AMA
35130 AMEXPL(1) = AML
35131 AMEXPL(2) = 0.D+00
35132 AMEXPL(3) = 0.D+00
35133C +
35134C phase space distribution
35135C -
35136 100 CONTINUE
35137 NTRY = NTRY + 1
35138
35139 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35140 & PYEXPL, PZEXPL )
35141
35142C +
35143C Calculates matrix element:
35144C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35145C Here CTH is the cosine of the angle between anti-nu and Z axis
35146C -
35147 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35148 & PZEXPL(3)**2 )
35149 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35150 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35151 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35152 ELEMAT = 16.D+00 * PROD1 * PROD2
35153 IF(ELEMAT.GT.ELEMAX) THEN
35154 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35155 STOP
35156 ENDIF
35157C +
35158C Here performs the rejection
35159C -
35160 TEST = DT_RNDM(ETOTEX) * ELEMAX
35161 IF ( TEST .GT. ELEMAT ) GO TO 100
35162C +
35163C final assignment of variables
35164C -
35165 ELERAT = ELEMAT/ELEMAX
35166 ETL = ETEXPL(1)
35167 PXL = PXEXPL(1)
35168 PYL = PYEXPL(1)
35169 PZL = PZEXPL(1)
35170 ETB = ETEXPL(2)
35171 PXB = PXEXPL(2)
35172 PYB = PYEXPL(2)
35173 PZB = PZEXPL(2)
35174 ETN = ETEXPL(3)
35175 PXN = PXEXPL(3)
35176 PYN = PYEXPL(3)
35177 PZN = PZEXPL(3)
35178 999 RETURN
35179 END
35180
35181*$ CREATE DT_GEN_DELTA.FOR
35182*COPY DT_GEN_DELTA
35183C==================================================================
35184C. Generation of Delta resonance events
35185C==================================================================
35186*
35187*===gen_delta==========================================================*
35188*
35189 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35190
35191 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35192 SAVE
35193
35194 PARAMETER ( LINP = 10 ,
35195 & LOUT = 6 ,
35196 & LDAT = 9 )
35197
35198C...Generate a Delta-production neutrino/antineutrino
35199C. CC-interaction on a nucleon
35200C
35201C. INPUT ENU (GeV) = Neutrino Energy
35202C. LLEP = neutrino type
35203C. LTARG = nucleon target type 1=p, 2=n.
35204C. JINT = 1:CC, 2::NC
35205C.
35206C. OUTPUT PPL(4) 4-monentum of final lepton
35207C----------------------------------------------------
35208 PARAMETER (MAXLND=4000)
35209 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35210
35211**sr - removed (not needed)
35212C COMMON /CBAD/ LBAD, NBAD
35213**
35214
35215 DIMENSION PI(3),PO(3)
35216C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35217 DIMENSION AML0(6),AMN(2)
35218 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35219 DATA AMN /0.93827231, 0.93956563/
35220 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35221
35222c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35223 LBAD = 0
35224C...Final lepton mass
35225 IF (JINT.EQ.1) THEN
35226 AML = AML0(LLEP)
35227 ELSE
35228 AML = 0.
35229 ENDIF
35230 AML2 = AML**2
35231
35232C...Particle labels (LUND)
35233 N = 5
35234 K(1,1) = 21
35235 K(2,1) = 21
35236 K(3,1) = 21
35237 K(4,1) = 1
35238 K(3,3) = 1
35239 K(4,3) = 1
35240 IF (LTARG .EQ. 1) THEN
35241 K(2,2) = 2212
35242 ELSE
35243 K(2,2) = 2112
35244 ENDIF
35245 K0 = (LLEP-1)/2
35246 K1 = LLEP/2
35247 KA = 12 + 2*K0
35248 IS = -1 + 2*LLEP - 4*K1
35249 LNU = 2 - LLEP + 2*K1
35250 K(1,2) = IS*KA
35251 K(5,1) = 1
35252 K(5,3) = 2
35253 IF (JINT .EQ. 1) THEN ! CC interactions
35254 K(3,2) = IS*24
35255 K(4,2) = IS*(KA-1)
35256 IF(LNU.EQ.1) THEN
35257 IF (LTARG .EQ. 1) THEN
35258 K(5,2) = 2224
35259 ELSE
35260 K(5,2) = 2214
35261 ENDIF
35262 ELSE
35263 IF (LTARG .EQ. 1) THEN
35264 K(5,2) = 2114
35265 ELSE
35266 K(5,2) = 1114
35267 ENDIF
35268 ENDIF
35269 ELSE
35270 K(3,2) = 23 ! NC (Z0) interactions
35271 K(4,2) = K(1,2)
35272**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35273* Delta0 for neutron (LTARG=2)
35274C IF (LTARG .EQ. 1) THEN
35275C K(5,2) = 2114
35276C ELSE
35277C K(5,2) = 2214
35278C ENDIF
35279 IF (LTARG .EQ. 1) THEN
35280 K(5,2) = 2214
35281 ELSE
35282 K(5,2) = 2114
35283 ENDIF
35284**
35285 ENDIF
35286
35287C...4-momentum initial lepton
35288 P(1,5) = 0.
35289 P(1,4) = ENU
35290 P(1,1) = 0.
35291 P(1,2) = 0.
35292 P(1,3) = ENU
35293C...4-momentum initial nucleon
35294 P(2,5) = AMN(LTARG)
35295C P(2,4) = P(2,5)
35296C P(2,1) = 0.
35297C P(2,2) = 0.
35298C P(2,3) = 0.
35299 P(2,1) = P21
35300 P(2,2) = P22
35301 P(2,3) = P23
35302 P(2,4) = P24
35303 P(2,5) = P25
35304 N=2
35305 beta1=-p(2,1)/p(2,4)
35306 beta2=-p(2,2)/p(2,4)
35307 beta3=-p(2,3)/p(2,4)
35308 N=2
35309
35310 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35311
35312C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35313
35314 phi11=atan(p(1,2)/p(1,3))
35315 pi(1)=p(1,1)
35316 pi(2)=p(1,2)
35317 pi(3)=p(1,3)
35318
35319 CALL DT_TESTROT(PI,Po,PHI11,1)
35320 DO ll=1,3
35321 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35322 END DO
35323 p(1,1)=po(1)
35324 p(1,2)=po(2)
35325 p(1,3)=po(3)
35326 phi12=atan(p(1,1)/p(1,3))
35327
35328 pi(1)=p(1,1)
35329 pi(2)=p(1,2)
35330 pi(3)=p(1,3)
35331 CALL DT_TESTROT(Pi,Po,PHI12,2)
35332 DO ll=1,3
35333 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35334 END DO
35335 p(1,1)=po(1)
35336 p(1,2)=po(2)
35337 p(1,3)=po(3)
35338
35339 ENUU=P(1,4)
35340
35341C...Generate the Mass of the Delta
35342 NTRY = 0
35343100 R = PYR(0)
35344 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35345 NTRY = NTRY + 1
35346 IF (NTRY .GT. 1000) THEN
35347 LBAD = 1
35348 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35349 RETURN
35350 ENDIF
35351 IF (AMD .LT. AMDMIN) GOTO 100
35352 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35353 IF (ENUU .LT. ET) GOTO 100
35354
35355C...Kinematical limits in Q**2
35356 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35357 SQS = SQRT(S)
35358 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35359 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35360 PLF = SQRT(ELF**2 - AML2)
35361 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35362 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35363 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35364
35365 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35366200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35367 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35368 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35369
35370C...Generate the kinematics of the final particles
35371 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35372 GAM = EISTAR/AMN(LTARG)
35373 BET = PSTAR/EISTAR
35374 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35375 EL = GAM*(ELF + BET*PLF*CTSTAR)
35376 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35377 PL = SQRT(EL**2 - AML2)
35378 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35379 PHI = 6.28319*PYR(0)
35380 P(4,1) = PLT*COS(PHI)
35381 P(4,2) = PLT*SIN(PHI)
35382 P(4,3) = PLZ
35383 P(4,4) = EL
35384 P(4,5) = AML
35385
35386C...4-momentum of Delta
35387 P(5,1) = -P(4,1)
35388 P(5,2) = -P(4,2)
35389 P(5,3) = ENUU-P(4,3)
35390 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35391 P(5,5) = AMD
35392
35393C...4-momentum of intermediate boson
35394 P(3,5) = -Q2
35395 P(3,4) = P(1,4)-P(4,4)
35396 P(3,1) = P(1,1)-P(4,1)
35397 P(3,2) = P(1,2)-P(4,2)
35398 P(3,3) = P(1,3)-P(4,3)
35399 N=5
35400
35401 DO kw=1,5
35402 pi(1)=p(kw,1)
35403 pi(2)=p(kw,2)
35404 pi(3)=p(kw,3)
35405 CALL DT_TESTROT(Pi,Po,PHI12,3)
35406 DO ll=1,3
35407 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35408 END DO
35409 p(kw,1)=po(1)
35410 p(kw,2)=po(2)
35411 p(kw,3)=po(3)
35412 END DO
35413
35414c********************************************
35415
35416 DO kw=1,5
35417 pi(1)=p(kw,1)
35418 pi(2)=p(kw,2)
35419 pi(3)=p(kw,3)
35420 CALL DT_TESTROT(Pi,Po,PHI11,4)
35421 DO ll=1,3
35422 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35423 END DO
35424 p(kw,1)=po(1)
35425 p(kw,2)=po(2)
35426 p(kw,3)=po(3)
35427 END DO
35428c********************************************
35429C transform back into Lab.
35430
35431 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35432
35433C WRITE(6,*)' Lab fram ( fermi incl.) '
35434 N=5
35435 CALL PYEXEC
35436
35437 RETURN
354381001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35439 END
35440
35441*$ CREATE DT_DSIGMA_DELTA.FOR
35442*COPY DT_DSIGMA_DELTA
35443*
35444*===dsigma_delta=======================================================*
35445*
35446 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35447
35448 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35449 SAVE
35450
35451C...Reaction nu + N -> lepton + Delta
35452C. returns the cross section
35453C. dsigma/dt
35454C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35455C. QQ = t (always negative) GeV**2
35456C. S = (c.m energy)**2 GeV**2
35457C. OUTPUT = 10**-38 cm+2/GeV**2
35458C-----------------------------------------------------
35459 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35460 DATA MN /0.938/
35461 DATA PI /3.1415926/
35462
35463 GF = (1.1664 * 1.97)
35464 GF2 = GF*GF
35465 MN2 = MN*MN
35466 MN4 = MN2*MN2
35467 MD2 = MD*MD
35468 MD4 = MD2*MD2
35469 AML2 = AML*AML
35470 AML4 = AML2*AML2
35471 VQ = (MN2 - MD2 - QQ)/2.
35472 VPI = (MN2 + MD2 - QQ)/2.
35473 VK = (S + QQ - MN2 - AML2)/2.
35474 PIK = (S - MN2)/2.
35475 QK = (AML2 - QQ)/2.
35476 PIQ = (QQ + MN2 - MD2)/2.
35477 Q = SQRT(-QQ)
35478 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35479 C3 = SQRT(3.)*C3V/MN
35480 C4 = -C3/MD ! attenzione al segno
35481 C5A = 1.18/(1.-QQ/0.4225)**2
35482 C32 = C3**2
35483 C42 = C4**2
35484 C5A2 = C5A**2
35485
35486 IF (LNU .EQ. 1) THEN
35487 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35488 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35489 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35490 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35491 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35492 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35493 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35494 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35495 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35496 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35497 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35498 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35499 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35500 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35501 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35502 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35503 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35504 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35505 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35506 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35507 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35508 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35509 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35510 ELSE
35511 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35512 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35513 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35514 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35515 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35516 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35517 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35518 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35519 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35520 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35521 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35522 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35523 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35524 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35525 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35526 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35527 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35528 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35529 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35530 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35531 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35532 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35533 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35534 ENDIF
35535 ANS1=32.*ANS2
35536 ANS=ANS1/(3.*MD2)
35537 P1CM = (S-MN2)/(2.*SQRT(S))
35538 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35539
35540 RETURN
35541 END
35542
35543*$ CREATE DT_QGAUS.FOR
35544*COPY DT_QGAUS
35545*
35546*===qgaus==============================================================*
35547*
35548 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35549
35550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35551 SAVE
35552
35553 DIMENSION X(5),W(5)
35554 DATA X/.1488743389D0,.4333953941D0,
35555 & .6794095682D0,.8650633666D0,.9739065285D0
35556 */
35557 DATA W/.2955242247D0,.2692667193D0,
35558 & .2190863625D0,.1494513491D0,.0666713443D0
35559 */
35560 XM=0.5D0*(B+A)
35561 XR=0.5D0*(B-A)
35562 SS=0
35563 DO 11 J=1,5
35564 DX=XR*X(J)
35565 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35566 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3556711 CONTINUE
35568 SS=XR*SS
35569
35570 RETURN
35571 END
35572*$ CREATE DT_DIQBRK.FOR
35573*COPY DT_DIQBRK
35574*
35575*===diqbrk=============================================================*
35576*
35577 SUBROUTINE DT_DIQBRK
35578
35579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35580 SAVE
35581
35582* event history
35583
35584 PARAMETER (NMXHKK=200000)
35585
35586 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35587 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35588 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35589
35590* extended event history
35591 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35592 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35593 & IHIST(2,NMXHKK)
35594
35595* event flag
35596 COMMON /DTEVNO/ NEVENT,ICASCA
35597
35598C IF(DT_RNDM(VV).LE.0.5D0)THEN
35599C CALL GSQBS1(NHKK)
35600C CALL GSQBS2(NHKK)
35601C CALL USQBS1(NHKK)
35602C CALL USQBS2(NHKK)
35603C CALL GSABS1(NHKK)
35604C CALL GSABS2(NHKK)
35605C CALL USABS1(NHKK)
35606C CALL USABS2(NHKK)
35607C ELSE
35608C CALL GSQBS2(NHKK)
35609C CALL GSQBS1(NHKK)
35610C CALL USQBS2(NHKK)
35611C CALL USQBS1(NHKK)
35612C CALL GSABS2(NHKK)
35613C CALL GSABS1(NHKK)
35614C CALL USABS2(NHKK)
35615C CALL USABS1(NHKK)
35616C ENDIF
35617
35618 IF(DT_RNDM(VV).LE.0.5D0) THEN
35619 CALL DT_DBREAK(1)
35620 CALL DT_DBREAK(2)
35621 CALL DT_DBREAK(3)
35622 CALL DT_DBREAK(4)
35623 CALL DT_DBREAK(5)
35624 CALL DT_DBREAK(6)
35625 CALL DT_DBREAK(7)
35626 CALL DT_DBREAK(8)
35627 ELSE
35628 CALL DT_DBREAK(2)
35629 CALL DT_DBREAK(1)
35630 CALL DT_DBREAK(4)
35631 CALL DT_DBREAK(3)
35632 CALL DT_DBREAK(6)
35633 CALL DT_DBREAK(5)
35634 CALL DT_DBREAK(8)
35635 CALL DT_DBREAK(7)
35636 ENDIF
35637
35638 RETURN
35639 END
35640
35641*$ CREATE MUSQBS2.FOR
35642*COPY MUSQBS2
35643C
35644C
35645C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35646 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35647 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35648C
35649C USQBS-2 diagram (split target diquark)
35650C
35651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35652 SAVE
35653
35654 PARAMETER ( LINP = 10 ,
35655 & LOUT = 6 ,
35656 & LDAT = 9 )
35657
35658* event history
35659
35660 PARAMETER (NMXHKK=200000)
35661
35662 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35663 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35664 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35665
35666* extended event history
35667 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35668 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35669 & IHIST(2,NMXHKK)
35670
35671* Lorentz-parameters of the current interaction
35672 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35673 & UMO,PPCM,EPROJ,PPROJ
35674
35675* diquark-breaking mechanism
35676 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35677
35678C
35679 PARAMETER (NTMHKK= 300)
35680 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35681 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35682 +(4,NTMHKK)
35683*KEEP,XSEADI.
35684 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35685 +SSMIMQ,VVMTHR
35686*KEEP,DPRIN.
35687 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35688 COMMON /EVFLAG/ NUMEV
35689C
35690C USQBS-2 diagram (split target diquark)
35691C
35692C
35693C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35694C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35695C
35696C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35697C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35698C
35699C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35700C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35701C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35702C
35703C
35704C Put new chains into COMMON /HKKTMP/
35705C
35706 IIGLU1=NC1T-NC1P-1
35707 IIGLU2=NC2T-NC2P-1
35708 IGCOUN=0
35709C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35710 CVQ=1.D0
35711 IREJ=0
35712 IF(IPIP.EQ.2)THEN
35713C IF(NUMEV.EQ.-324)THEN
35714C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35715C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35716C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35717C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35718 ENDIF
35719C
35720C
35721C
35722C determine x-values of NC1T diquark
35723 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35724 XVQP=PHKK(4,NC1P)*2.D0/UMO
35725C
35726C determine x-values of sea quark pair
35727C
35728 IPCO=1
35729 ICOU=0
35730 2234 CONTINUE
35731 ICOU=ICOU+1
35732 IF(ICOU.GE.500)THEN
35733 IREJ=1
35734 IF(ISQ.EQ.3)IREJ=3
35735 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35736 IPCO=0
35737 RETURN
35738 ENDIF
35739 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35740 * UMO, XDIQT,XVQP
35741 XSQ=0.D0
35742 XSAQ=0.D0
35743**NEW
35744C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35745 IF (IPIP.EQ.1) THEN
35746 XQMAX = XDIQT/2.0D0
35747 XAQMAX = 2.D0*XVQP/3.0D0
35748 ELSE
35749 XQMAX = 2.D0*XVQP/3.0D0
35750 XAQMAX = XDIQT/2.0D0
35751 ENDIF
35752 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35753 ISAQ = 6+ISQ
35754C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35755**
35756 IF(IPCO.GE.3)
35757 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35758 IF(IREJ.GE.1)THEN
35759 IF(IPCO.GE.3)
35760 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35761 IPCO=0
35762 RETURN
35763 ENDIF
35764 IF(IPIP.EQ.1)THEN
35765 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35766 ELSEIF(IPIP.EQ.2)THEN
35767 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35768 ENDIF
35769 IF(IPCO.GE.3)THEN
35770 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35771 & XDIQT,XVQP,XSQ,XSAQ
35772 ENDIF
35773C
35774C subtract xsq,xsaq from NC1T diquark and NC1P quark
35775C
35776C XSQ=0.D0
35777 IF(IPIP.EQ.1)THEN
35778 XDIQT=XDIQT-XSQ
35779 XVQP =XVQP -XSAQ
35780 ELSEIF(IPIP.EQ.2)THEN
35781 XDIQT=XDIQT-XSAQ
35782 XVQP =XVQP -XSQ
35783 ENDIF
35784 IF(IPCO.GE.3)
35785 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35786C
35787C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35788C
35789 XVTHRO=CVQ/UMO
35790 IVTHR=0
35791 3466 CONTINUE
35792 IF(IVTHR.EQ.10)THEN
35793 IREJ=1
35794 IF(ISQ.EQ.3)IREJ=3
35795 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35796 IPCO=0
35797 RETURN
35798 ENDIF
35799 IVTHR=IVTHR+1
35800 XVTHR=XVTHRO/(201-IVTHR)
35801 UNOPRV=UNON
35802 380 CONTINUE
35803 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35804 IREJ=1
35805 IF(ISQ.EQ.3)IREJ=3
35806 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35807 * XVTHR
35808 IPCO=0
35809 RETURN
35810 ENDIF
35811 IF(DT_RNDM(V).LT.0.5D0)THEN
35812 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35813 XVTQII=XDIQT-XVTQI
35814 ELSE
35815 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35816 XVTQI=XDIQT-XVTQII
35817 ENDIF
35818 IF(IPCO.GE.3)THEN
35819 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35820 ENDIF
35821C
35822C Prepare 4 momenta of new chains and chain ends
35823C
35824C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35825C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35826C +(4,NTMHKK)
35827C
35828C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35829C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35830C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35831C
35832C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35833C * IP1,IP21,IP22,IPP1,IPP2)
35834C
35835 IF(IPIP.EQ.1)THEN
35836 XSQ1=XSQ
35837 XSAQ1=XSAQ
35838 ISQ1=ISQ
35839 ISAQ1=ISAQ
35840 ELSEIF(IPIP.EQ.2)THEN
35841 XSQ1=XSAQ
35842 XSAQ1=XSQ
35843 ISQ1=ISAQ
35844 ISAQ1=ISQ
35845 ENDIF
35846 IDHKT(1) =IPP1
35847 ISTHKT(1) =951
35848 JMOHKT(1,1)=NC2P
35849 JMOHKT(2,1)=0
35850 JDAHKT(1,1)=3+IIGLU1
35851 JDAHKT(2,1)=0
35852C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35853 PHKT(1,1) =PHKK(1,NC2P)
35854 PHKT(2,1) =PHKK(2,NC2P)
35855 PHKT(3,1) =PHKK(3,NC2P)
35856 PHKT(4,1) =PHKK(4,NC2P)
35857C PHKT(5,1) =PHKK(5,NC2P)
35858 XMIST =(PHKT(4,1)**2-
35859 * PHKT(3,1)**2-PHKT(2,1)**2-
35860 *PHKT(1,1)**2)
35861 IF(XMIST.GT.0.D0)THEN
35862 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35863 *PHKT(1,1)**2)
35864 ELSE
35865C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35866 PHKT(5,1)=0.D0
35867 ENDIF
35868 VHKT(1,1) =VHKK(1,NC2P)
35869 VHKT(2,1) =VHKK(2,NC2P)
35870 VHKT(3,1) =VHKK(3,NC2P)
35871 VHKT(4,1) =VHKK(4,NC2P)
35872 WHKT(1,1) =WHKK(1,NC2P)
35873 WHKT(2,1) =WHKK(2,NC2P)
35874 WHKT(3,1) =WHKK(3,NC2P)
35875 WHKT(4,1) =WHKK(4,NC2P)
35876C Add here IIGLU1 gluons to this chaina
35877 PG1=0.D0
35878 PG2=0.D0
35879 PG3=0.D0
35880 PG4=0.D0
35881 IF(IIGLU1.GE.1)THEN
35882 JJG=NC1P
35883 DO 61 IIG=2,2+IIGLU1-1
35884 KKG=JJG+IIG-1
35885 IDHKT(IIG) =IDHKK(KKG)
35886 ISTHKT(IIG) =921
35887 JMOHKT(1,IIG)=KKG
35888 JMOHKT(2,IIG)=0
35889 JDAHKT(1,IIG)=3+IIGLU1
35890 JDAHKT(2,IIG)=0
35891 PHKT(1,IIG)=PHKK(1,KKG)
35892 PG1=PG1+ PHKT(1,IIG)
35893 PHKT(2,IIG)=PHKK(2,KKG)
35894 PG2=PG2+ PHKT(2,IIG)
35895 PHKT(3,IIG)=PHKK(3,KKG)
35896 PG3=PG3+ PHKT(3,IIG)
35897 PHKT(4,IIG)=PHKK(4,KKG)
35898 PG4=PG4+ PHKT(4,IIG)
35899 PHKT(5,IIG)=PHKK(5,KKG)
35900 VHKT(1,IIG) =VHKK(1,KKG)
35901 VHKT(2,IIG) =VHKK(2,KKG)
35902 VHKT(3,IIG) =VHKK(3,KKG)
35903 VHKT(4,IIG) =VHKK(4,KKG)
35904 WHKT(1,IIG) =WHKK(1,KKG)
35905 WHKT(2,IIG) =WHKK(2,KKG)
35906 WHKT(3,IIG) =WHKK(3,KKG)
35907 WHKT(4,IIG) =WHKK(4,KKG)
35908 61 CONTINUE
35909 ENDIF
35910 IDHKT(2+IIGLU1) =IP21
35911 ISTHKT(2+IIGLU1) =952
35912 JMOHKT(1,2+IIGLU1)=NC1T
35913 JMOHKT(2,2+IIGLU1)=0
35914 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35915 JDAHKT(2,2+IIGLU1)=0
35916 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35917 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35918 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35919 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35920C PHKT(5,2) =PHKK(5,NC1T)
35921 XMIST =(PHKT(4,2+IIGLU1)**2-
35922 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35923 *PHKT(1,2+IIGLU1)**2)
35924 IF(XMIST.GT.0.D0)THEN
35925 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35926 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35927 *PHKT(1,2+IIGLU1)**2)
35928 ELSE
35929C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35930 PHKT(5,5+IIGLU1)=0.D0
35931 ENDIF
35932 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35933 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35934 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35935 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35936 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35937 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35938 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35939 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35940 IDHKT(3+IIGLU1) =88888
35941 ISTHKT(3+IIGLU1) =95
35942 JMOHKT(1,3+IIGLU1)=1
35943 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35944 JDAHKT(1,3+IIGLU1)=0
35945 JDAHKT(2,3+IIGLU1)=0
35946 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35947 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35948 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35949 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35950 XMIST
35951 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35952 * -PHKT(3,3+IIGLU1)**2)
35953 IF(XMIST.GT.0.D0)THEN
35954 PHKT(5,3+IIGLU1)
35955 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35956 * -PHKT(3,3+IIGLU1)**2)
35957 ELSE
35958C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35959 PHKT(5,5+IIGLU1)=0.D0
35960 ENDIF
35961 IF(IPIP.GE.2)THEN
35962C IF(NUMEV.EQ.-324)THEN
35963C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35964C * JDAHKT(1,1),
35965C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35966 DO 71 IIG=2,2+IIGLU1-1
35967C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35968C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35969C * JDAHKT(1,IIG),
35970C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35971 71 CONTINUE
35972C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35973C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35974C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35975C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35976C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35977C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35978 ENDIF
35979 CHAMAL=CHAM1
35980 IF(IPIP.EQ.1)THEN
35981 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35982 ELSEIF(IPIP.EQ.2)THEN
35983 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35984 ENDIF
35985 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35986C IREJ=1
35987 IPCO=0
35988C RETURN
35989C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35990 GO TO 3466
35991 ENDIF
35992 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35993 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35994 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35995 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35996 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35997 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35998 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35999 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36000 IF(IPIP.EQ.1)THEN
36001 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36002 ELSEIF(IPIP.EQ.2)THEN
36003 IDHKT(4+IIGLU1) =ISAQ1
36004 ENDIF
36005 ISTHKT(4+IIGLU1) =951
36006 JMOHKT(1,4+IIGLU1)=NC1P
36007 JMOHKT(2,4+IIGLU1)=0
36008 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36009 JDAHKT(2,4+IIGLU1)=0
36010C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36011 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36012 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36013 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36014 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36015C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36016 XMIST =(PHKT(4,4+IIGLU1)**2-
36017 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36018 *PHKT(1,4+IIGLU1)**2)
36019 IF(XMIST.GT.0.D0)THEN
36020 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36021 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36022 *PHKT(1,4+IIGLU1)**2)
36023 ELSE
36024C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36025 PHKT(5,4+IIGLU1)=0.D0
36026 ENDIF
36027 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36028 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36029 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36030 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36031 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36032 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36033 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36034 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36035 IDHKT(5+IIGLU1) =IP22
36036 ISTHKT(5+IIGLU1) =952
36037 JMOHKT(1,5+IIGLU1)=NC1T
36038 JMOHKT(2,5+IIGLU1)=0
36039 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36040 JDAHKT(2,5+IIGLU1)=0
36041 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36042 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36043 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36044 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36045C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36046 XMIST =(PHKT(4,5+IIGLU1)**2-
36047 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36048 *PHKT(1,5+IIGLU1)**2)
36049 IF(XMIST.GT.0.D0)THEN
36050 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36051 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36052 *PHKT(1,5+IIGLU1)**2)
36053 ELSE
36054C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36055 PHKT(5,5+IIGLU1)=0.D0
36056 ENDIF
36057 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36058 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36059 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36060 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36061 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36062 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36063 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36064 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36065 IDHKT(6+IIGLU1) =88888
36066 ISTHKT(6+IIGLU1) =95
36067 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36068 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36069 JDAHKT(1,6+IIGLU1)=0
36070 JDAHKT(2,6+IIGLU1)=0
36071 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36072 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36073 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36074 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36075 XMIST
36076 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36077 * -PHKT(3,6+IIGLU1)**2)
36078 IF(XMIST.GT.0.D0)THEN
36079 PHKT(5,6+IIGLU1)
36080 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36081 * -PHKT(3,6+IIGLU1)**2)
36082 ELSE
36083C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36084 PHKT(5,5+IIGLU1)=0.D0
36085 ENDIF
36086C IF(IPIP.GE.2)THEN
36087C IF(NUMEV.EQ.-324)THEN
36088C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36089C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36090C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36091C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36092C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36093C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36094C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36095C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36096C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36097C ENDIF
36098 CHAMAL=CHAM1
36099 IF(IPIP.EQ.1)THEN
36100 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36101 ELSEIF(IPIP.EQ.2)THEN
36102 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36103 ENDIF
36104 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36105C IREJ=1
36106 IPCO=0
36107C RETURN
36108C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36109C * CHAMAL,PHKT(5,6+IIGLU1)
36110 GO TO 3466
36111 ENDIF
36112 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36113 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36114 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36115 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36116 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36117 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36118 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36119 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36120C IDHKT(7) =1000*IPP1+100*ISQ+1
36121 IDHKT(7+IIGLU1) =IP1
36122 ISTHKT(7+IIGLU1) =951
36123 JMOHKT(1,7+IIGLU1)=NC1P
36124 JMOHKT(2,7+IIGLU1)=0
36125**NEW
36126C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36127 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36128**
36129 JDAHKT(2,7+IIGLU1)=0
36130 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36131 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36132 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36133 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36134C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36135 XMIST =(PHKT(4,7+IIGLU1)**2-
36136 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36137 *PHKT(1,7+IIGLU1)**2)
36138 IF(XMIST.GT.0.D0)THEN
36139 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36140 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36141 *PHKT(1,7+IIGLU1)**2)
36142 ELSE
36143C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36144 PHKT(5,7+IIGLU1)=0.D0
36145 ENDIF
36146 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36147 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36148 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36149 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36150 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36151 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36152 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36153 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36154C Insert here the IIGLU2 gluons
36155 PG1=0.D0
36156 PG2=0.D0
36157 PG3=0.D0
36158 PG4=0.D0
36159 IF(IIGLU2.GE.1)THEN
36160 JJG=NC2P
36161 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36162 KKG=JJG+IIG-7-IIGLU1
36163 IDHKT(IIG) =IDHKK(KKG)
36164 ISTHKT(IIG) =921
36165 JMOHKT(1,IIG)=KKG
36166 JMOHKT(2,IIG)=0
36167 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36168 JDAHKT(2,IIG)=0
36169 PHKT(1,IIG)=PHKK(1,KKG)
36170 PG1=PG1+ PHKT(1,IIG)
36171 PHKT(2,IIG)=PHKK(2,KKG)
36172 PG2=PG2+ PHKT(2,IIG)
36173 PHKT(3,IIG)=PHKK(3,KKG)
36174 PG3=PG3+ PHKT(3,IIG)
36175 PHKT(4,IIG)=PHKK(4,KKG)
36176 PG4=PG4+ PHKT(4,IIG)
36177 PHKT(5,IIG)=PHKK(5,KKG)
36178 VHKT(1,IIG) =VHKK(1,KKG)
36179 VHKT(2,IIG) =VHKK(2,KKG)
36180 VHKT(3,IIG) =VHKK(3,KKG)
36181 VHKT(4,IIG) =VHKK(4,KKG)
36182 WHKT(1,IIG) =WHKK(1,KKG)
36183 WHKT(2,IIG) =WHKK(2,KKG)
36184 WHKT(3,IIG) =WHKK(3,KKG)
36185 WHKT(4,IIG) =WHKK(4,KKG)
36186 81 CONTINUE
36187 ENDIF
36188 IF(IPIP.EQ.1)THEN
36189 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36190 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36191 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36192 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36193 ELSEIF(IPIP.EQ.2)THEN
36194 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36195 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36196 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36197 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36198 ENDIF
36199 ISTHKT(8+IIGLU1+IIGLU2) =952
36200 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36201 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36202 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36203 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36204 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36205 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36206 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36207 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36208 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36209 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36210 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36211 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36212C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36213C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36214 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36215C IREJ=1
36216C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36217C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36218 IPCO=0
36219C RETURN
36220 GO TO 3466
36221 ENDIF
36222C PHKT(5,8) =PHKK(5,NC2T)
36223 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36224 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36225 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36226 IF(XMIST.GT.0.D0)THEN
36227 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36228 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36229 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36230 ELSE
36231C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36232 PHKT(5,5+IIGLU1)=0.D0
36233 ENDIF
36234 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36235 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36236 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36237 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36238 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36239 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36240 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36241 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36242 IDHKT(9+IIGLU1+IIGLU2) =88888
36243 ISTHKT(9+IIGLU1+IIGLU2) =95
36244 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36245 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36246 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36247 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36248**NEW
36249C PHKT(1,9+IIGLU1+IIGLU2)
36250C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36251C PHKT(2,9+IIGLU1+IIGLU2)
36252C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36253C PHKT(3,9+IIGLU1+IIGLU2)
36254C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36255C PHKT(4,9+IIGLU1+IIGLU2)
36256C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36257 PHKT(1,9+IIGLU1+IIGLU2)
36258 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36259 PHKT(2,9+IIGLU1+IIGLU2)
36260 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36261 PHKT(3,9+IIGLU1+IIGLU2)
36262 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36263 PHKT(4,9+IIGLU1+IIGLU2)
36264 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36265**
36266 XMIST
36267 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36268 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36269 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36270 IF(XMIST.GT.0.D0)THEN
36271 PHKT(5,9+IIGLU1+IIGLU2)
36272 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36273 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36274 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36275 ELSE
36276C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36277 PHKT(5,5+IIGLU1)=0.D0
36278 ENDIF
36279 IF(IPIP.GE.2)THEN
36280C IF(NUMEV.EQ.-324)THEN
36281C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36282C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36283C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36284C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36285C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36286C * JDAHKT(1,IIG),
36287C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36288C 91 CONTINUE
36289C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36290C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36291C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36292C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36293C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36294C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36295C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36296C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36297 ENDIF
36298 CHAMAL=CHAB1
36299 IF(IPIP.EQ.1)THEN
36300 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36301 ELSEIF(IPIP.EQ.2)THEN
36302 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36303 ENDIF
36304 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36305C IREJ=1
36306 IPCO=0
36307C RETURN
36308C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36309C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36310 GO TO 3466
36311 ENDIF
36312 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36313 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36314 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36315 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36316 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36317 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36318 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36319 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36320C
36321 IPCO=0
36322 IGCOUN=9+IIGLU1+IIGLU2
36323 RETURN
36324 END
36325
36326*$ CREATE MGSQBS2.FOR
36327*COPY MGSQBS2
36328C
36329C
36330C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36331 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36332 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36333C
36334C GSQBS-2 diagram (split target diquark)
36335C
36336 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36337 SAVE
36338
36339 PARAMETER ( LINP = 10 ,
36340 & LOUT = 6 ,
36341 & LDAT = 9 )
36342
36343* event history
36344
36345 PARAMETER (NMXHKK=200000)
36346
36347 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36348 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36349 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36350
36351* extended event history
36352 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36353 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36354 & IHIST(2,NMXHKK)
36355
36356* Lorentz-parameters of the current interaction
36357 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36358 & UMO,PPCM,EPROJ,PPROJ
36359
36360* diquark-breaking mechanism
36361 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36362
36363C
36364 PARAMETER (NTMHKK= 300)
36365 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36366 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36367 +(4,NTMHKK)
36368
36369*KEEP,XSEADI.
36370 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36371 +SSMIMQ,VVMTHR
36372*KEEP,DPRIN.
36373 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36374C
36375C GSQBS-2 diagram (split target diquark)
36376C
36377C
36378C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36379C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36380C
36381C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36382C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36383C
36384C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36385C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36386C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36387C
36388C
36389C
36390C Put new chains into COMMON /HKKTMP/
36391C
36392 IIGLU1=NC1T-NC1P-1
36393 IIGLU2=NC2T-NC2P-1
36394 IGCOUN=0
36395C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36396 CVQ=1.D0
36397 IREJ=0
36398C IF(IPIP.EQ.2)THEN
36399C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36400C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36401C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36402C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36403C ENDIF
36404C
36405C
36406C
36407C determine x-values of NC1T diquark
36408 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36409 XVQP=PHKK(4,NC1P)*2.D0/UMO
36410C
36411C determine x-values of sea quark pair
36412C
36413 IPCO=1
36414 ICOU=0
36415 2234 CONTINUE
36416 ICOU=ICOU+1
36417 IF(ICOU.GE.500)THEN
36418 IREJ=1
36419 IF(ISQ.EQ.3)IREJ=3
36420 IF(IPCO.GE.3)
36421 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36422 IPCO=0
36423 RETURN
36424 ENDIF
36425 IF(IPCO.GE.3)
36426 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36427 * UMO, XDIQT,XVQP
36428 XSQ=0.D0
36429 XSAQ=0.D0
36430**NEW
36431C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36432 IF (IPIP.EQ.1) THEN
36433 XQMAX = XDIQT/2.0D0
36434 XAQMAX = 2.D0*XVQP/3.0D0
36435 ELSE
36436 XQMAX = 2.D0*XVQP/3.0D0
36437 XAQMAX = XDIQT/2.0D0
36438 ENDIF
36439 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36440 ISAQ = 6+ISQ
36441C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36442**
36443 IF(IPCO.GE.3)
36444 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36445 IF(IREJ.GE.1)THEN
36446 IF(IPCO.GE.3)
36447 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36448 IPCO=0
36449 RETURN
36450 ENDIF
36451 IF(IPIP.EQ.1)THEN
36452 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36453 ELSEIF(IPIP.EQ.2)THEN
36454 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36455 ENDIF
36456 IF(IPCO.GE.3)THEN
36457 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36458 & XDIQT,XVQP,XSQ,XSAQ
36459 ENDIF
36460C
36461C subtract xsq,xsaq from NC1T diquark and NC1P quark
36462C
36463C XSQ=0.D0
36464 IF(IPIP.EQ.1)THEN
36465 XDIQT=XDIQT-XSQ
36466 XVQP =XVQP -XSAQ
36467 ELSEIF(IPIP.EQ.2)THEN
36468 XDIQT=XDIQT-XSAQ
36469 XVQP =XVQP -XSQ
36470 ENDIF
36471 IF(IPCO.GE.3)
36472 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36473C
36474C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36475C
36476 XVTHRO=CVQ/UMO
36477 IVTHR=0
36478 3466 CONTINUE
36479 IF(IVTHR.EQ.10)THEN
36480 IREJ=1
36481 IF(ISQ.EQ.3)IREJ=3
36482 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36483 IPCO=0
36484 RETURN
36485 ENDIF
36486 IVTHR=IVTHR+1
36487 XVTHR=XVTHRO/(201-IVTHR)
36488 UNOPRV=UNON
36489 380 CONTINUE
36490 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36491 IREJ=1
36492 IF(ISQ.EQ.3)IREJ=3
36493 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36494 * XVTHR
36495 IPCO=0
36496 RETURN
36497 ENDIF
36498 IF(DT_RNDM(V).LT.0.5D0)THEN
36499 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36500 XVTQII=XDIQT-XVTQI
36501 ELSE
36502 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36503 XVTQI=XDIQT-XVTQII
36504 ENDIF
36505 IF(IPCO.GE.3)THEN
36506 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36507 ENDIF
36508C
36509C Prepare 4 momenta of new chains and chain ends
36510C
36511C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36512C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36513C +(4,NTMHKK)
36514C
36515C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36516C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36517C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36518C
36519C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36520C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36521C
36522 IF(IPIP.EQ.1)THEN
36523 XSQ1=XSQ
36524 XSAQ1=XSAQ
36525 ISQ1=ISQ
36526 ISAQ1=ISAQ
36527 ELSEIF(IPIP.EQ.2)THEN
36528 XSQ1=XSAQ
36529 XSAQ1=XSQ
36530 ISQ1=ISAQ
36531 ISAQ1=ISQ
36532 ENDIF
36533 KK11=IP21
36534C IDHKT(1) =1000*IPP11+100*IPP12+1
36535 KK21=IPP11
36536 KK22=IPP12
36537 XGIVE=0.D0
36538 IF(IPIP.EQ.1)THEN
36539 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36540 ELSEIF(IPIP.EQ.2)THEN
36541 IDHKT(4+IIGLU1) =ISAQ1
36542 ENDIF
36543 ISTHKT(4+IIGLU1) =961
36544 JMOHKT(1,4+IIGLU1)=NC1P
36545 JMOHKT(2,4+IIGLU1)=0
36546 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36547 JDAHKT(2,4+IIGLU1)=0
36548C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36549 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36550 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36551 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36552 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36553C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36554 XXMIST=(PHKT(4,4+IIGLU1)**2-
36555 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36556 *PHKT(1,4+IIGLU1)**2)
36557 IF(XXMIST.GT.0.D0)THEN
36558 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36559 ELSE
36560 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36561 XXMIST=ABS(XXMIST)
36562 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36563 ENDIF
36564 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36565 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36566 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36567 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36568 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36569 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36570 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36571 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36572 IDHKT(5+IIGLU1) =IP22
36573 ISTHKT(5+IIGLU1) =962
36574 JMOHKT(1,5+IIGLU1)=NC1T
36575 JMOHKT(2,5+IIGLU1)=0
36576 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36577 JDAHKT(2,5+IIGLU1)=0
36578 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36579 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36580 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36581 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36582C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36583 XXMIST=(PHKT(4,5+IIGLU1)**2-
36584 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36585 *PHKT(1,5+IIGLU1)**2)
36586 IF(XXMIST.GT.0.D0)THEN
36587 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36588 ELSE
36589 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36590 XXMIST=ABS(XXMIST)
36591 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36592 ENDIF
36593 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36594 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36595 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36596 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36597 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36598 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36599 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36600 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36601 IDHKT(6+IIGLU1) =88888
36602 ISTHKT(6+IIGLU1) =96
36603 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36604 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36605 JDAHKT(1,6+IIGLU1)=0
36606 JDAHKT(2,6+IIGLU1)=0
36607 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36608 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36609 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36610 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36611 PHKT(5,6+IIGLU1)
36612 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36613 * -PHKT(3,6+IIGLU1)**2)
36614 CHAMAL=CHAM1
36615 IF(IPIP.EQ.1)THEN
36616 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36617 ELSEIF(IPIP.EQ.2)THEN
36618 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36619 ENDIF
36620C---------------------------------------------------
36621 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36622 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36623C we drop chain 6 and give the energy to chain 3
36624 IDHKT(6+IIGLU1)=22888
36625 XGIVE=1.D0
36626C WRITE(6,*)' drop chain 6 xgive=1'
36627 GO TO 7788
36628 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36629C we drop chain 6 and give the energy to chain 3
36630C and change KK11 to IDHKT(5)
36631 IDHKT(6+IIGLU1)=22888
36632 XGIVE=1.D0
36633C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36634 KK11=IDHKT(5+IIGLU1)
36635 GO TO 7788
36636 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36637C we drop chain 6 and give the energy to chain 3
36638C and change KK21 to IDHKT(5+IIGLU1)
36639C IDHKT(1) =1000*IPP11+100*IPP12+1
36640 IDHKT(6+IIGLU1)=22888
36641 XGIVE=1.D0
36642C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36643 KK21=IDHKT(5+IIGLU1)
36644 GO TO 7788
36645 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36646C we drop chain 6 and give the energy to chain 3
36647C and change KK22 to IDHKT(5)
36648C IDHKT(1) =1000*IPP11+100*IPP12+1
36649 IDHKT(6+IIGLU1)=22888
36650 XGIVE=1.D0
36651C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36652 KK22=IDHKT(5+IIGLU1)
36653 GO TO 7788
36654 ENDIF
36655C IREJ=1
36656 IPCO=0
36657C RETURN
36658 GO TO 3466
36659 ENDIF
36660 7788 CONTINUE
36661C---------------------------------------------------
36662 IF(IPIP.GE.3)THEN
36663 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36664 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36665 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36666 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36667 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36668 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36669 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36670 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36671 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36672 ENDIF
36673 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36674 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36675 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36676 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36677 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36678 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36679 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36680 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36681C IDHKT(1) =1000*IPP11+100*IPP12+1
36682 IF(IPIP.EQ.1)THEN
36683 IDHKT(1) =1000*KK21+100*KK22+3
36684 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36685 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36686 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36687 ELSEIF(IPIP.EQ.2)THEN
36688 IDHKT(1) =1000*KK21+100*KK22-3
36689 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36690 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36691 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36692 ENDIF
36693 ISTHKT(1) =961
36694 JMOHKT(1,1)=NC2P
36695 JMOHKT(2,1)=0
36696 JDAHKT(1,1)=3+IIGLU1
36697 JDAHKT(2,1)=0
36698C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36699 PHKT(1,1) =PHKK(1,NC2P)
36700 *+XGIVE*PHKT(1,4+IIGLU1)
36701 PHKT(2,1) =PHKK(2,NC2P)
36702 *+XGIVE*PHKT(2,4+IIGLU1)
36703 PHKT(3,1) =PHKK(3,NC2P)
36704 *+XGIVE*PHKT(3,4+IIGLU1)
36705 PHKT(4,1) =PHKK(4,NC2P)
36706 *+XGIVE*PHKT(4,4+IIGLU1)
36707C PHKT(5,1) =PHKK(5,NC2P)
36708 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36709 *PHKT(1,1)**2
36710 IF(XXMIST.GT.0.D0)THEN
36711 PHKT(5,1) =SQRT(XXMIST)
36712 ELSE
36713 WRITE(LOUT,*)'MGSQBS2',XXMIST
36714 XXMIST=ABS(XXMIST)
36715 PHKT(5,1) =SQRT(XXMIST)
36716 ENDIF
36717 VHKT(1,1) =VHKK(1,NC2P)
36718 VHKT(2,1) =VHKK(2,NC2P)
36719 VHKT(3,1) =VHKK(3,NC2P)
36720 VHKT(4,1) =VHKK(4,NC2P)
36721 WHKT(1,1) =WHKK(1,NC2P)
36722 WHKT(2,1) =WHKK(2,NC2P)
36723 WHKT(3,1) =WHKK(3,NC2P)
36724 WHKT(4,1) =WHKK(4,NC2P)
36725C Add here IIGLU1 gluons to this chaina
36726 PG1=0.D0
36727 PG2=0.D0
36728 PG3=0.D0
36729 PG4=0.D0
36730 IF(IIGLU1.GE.1)THEN
36731 JJG=NC1P
36732 DO 61 IIG=2,2+IIGLU1-1
36733 KKG=JJG+IIG-1
36734 IDHKT(IIG) =IDHKK(KKG)
36735 ISTHKT(IIG) =921
36736 JMOHKT(1,IIG)=KKG
36737 JMOHKT(2,IIG)=0
36738 JDAHKT(1,IIG)=3+IIGLU1
36739 JDAHKT(2,IIG)=0
36740 PHKT(1,IIG)=PHKK(1,KKG)
36741 PG1=PG1+ PHKT(1,IIG)
36742 PHKT(2,IIG)=PHKK(2,KKG)
36743 PG2=PG2+ PHKT(2,IIG)
36744 PHKT(3,IIG)=PHKK(3,KKG)
36745 PG3=PG3+ PHKT(3,IIG)
36746 PHKT(4,IIG)=PHKK(4,KKG)
36747 PG4=PG4+ PHKT(4,IIG)
36748 PHKT(5,IIG)=PHKK(5,KKG)
36749 VHKT(1,IIG) =VHKK(1,KKG)
36750 VHKT(2,IIG) =VHKK(2,KKG)
36751 VHKT(3,IIG) =VHKK(3,KKG)
36752 VHKT(4,IIG) =VHKK(4,KKG)
36753 WHKT(1,IIG) =WHKK(1,KKG)
36754 WHKT(2,IIG) =WHKK(2,KKG)
36755 WHKT(3,IIG) =WHKK(3,KKG)
36756 WHKT(4,IIG) =WHKK(4,KKG)
36757 61 CONTINUE
36758 ENDIF
36759C IDHKT(2) =IP21
36760 IDHKT(2+IIGLU1) =KK11
36761 ISTHKT(2+IIGLU1) =962
36762 JMOHKT(1,2+IIGLU1)=NC1T
36763 JMOHKT(2,2+IIGLU1)=0
36764 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36765 JDAHKT(2,2+IIGLU1)=0
36766 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36767C * +0.5D0*PHKK(1,NC2T)
36768 *+XGIVE*PHKT(1,5+IIGLU1)
36769 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36770C *+0.5D0*PHKK(2,NC2T)
36771 *+XGIVE*PHKT(2,5+IIGLU1)
36772 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36773C *+0.5D0*PHKK(3,NC2T)
36774 *+XGIVE*PHKT(3,5+IIGLU1)
36775 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36776C *+0.5D0*PHKK(4,NC2T)
36777 *+XGIVE*PHKT(4,5+IIGLU1)
36778C PHKT(5,2) =PHKK(5,NC1T)
36779 XXMIST=(PHKT(4,2+IIGLU1)**2-
36780 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36781 *PHKT(1,2+IIGLU1)**2)
36782 IF(XXMIST.GT.0.D0)THEN
36783 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36784 ELSE
36785 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36786 XXMIST=ABS(XXMIST)
36787 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36788 ENDIF
36789 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36790 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36791 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36792 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36793 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36794 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36795 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36796 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36797 IDHKT(3+IIGLU1) =88888
36798 ISTHKT(3+IIGLU1) =96
36799 JMOHKT(1,3+IIGLU1)=1
36800 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36801 JDAHKT(1,3+IIGLU1)=0
36802 JDAHKT(2,3+IIGLU1)=0
36803 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36804 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36805 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36806 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36807 PHKT(5,3+IIGLU1)
36808 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36809 * -PHKT(3,3+IIGLU1)**2)
36810 IF(IPIP.EQ.3)THEN
36811 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36812 * JDAHKT(1,1),
36813 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36814 DO 71 IIG=2,2+IIGLU1-1
36815 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36816 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36817 * JDAHKT(1,IIG),
36818 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36819 71 CONTINUE
36820 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36821 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36822 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36823 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36824 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36825 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36826 ENDIF
36827 CHAMAL=CHAB1
36828 IF(IPIP.EQ.1)THEN
36829 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36830 ELSEIF(IPIP.EQ.2)THEN
36831 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36832 ENDIF
36833 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36834C IREJ=1
36835 IPCO=0
36836C RETURN
36837 GO TO 3466
36838 ENDIF
36839 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36840 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36841 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36842 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36843 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36844 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36845 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36846 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36847C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36848 IDHKT(7+IIGLU1) =IP1
36849 ISTHKT(7+IIGLU1) =961
36850 JMOHKT(1,7+IIGLU1)=NC1P
36851 JMOHKT(2,7+IIGLU1)=0
36852 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36853 JDAHKT(2,7+IIGLU1)=0
36854 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36855 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36856 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36857 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36858C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36859 XXMIST=(PHKT(4,7+IIGLU1)**2-
36860 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36861 *PHKT(1,7+IIGLU1)**2)
36862 IF(XXMIST.GT.0.D0)THEN
36863 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36864 ELSE
36865 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36866 XXMIST=ABS(XXMIST)
36867 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36868 ENDIF
36869 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36870 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36871 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36872 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36873 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36874 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36875 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36876 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36877C IDHKT(7) =1000*IPP1+100*ISQ+1
36878C Insert here the IIGLU2 gluons
36879 PG1=0.D0
36880 PG2=0.D0
36881 PG3=0.D0
36882 PG4=0.D0
36883 IF(IIGLU2.GE.1)THEN
36884 JJG=NC2P
36885 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36886 KKG=JJG+IIG-7-IIGLU1
36887 IDHKT(IIG) =IDHKK(KKG)
36888 ISTHKT(IIG) =921
36889 JMOHKT(1,IIG)=KKG
36890 JMOHKT(2,IIG)=0
36891 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36892 JDAHKT(2,IIG)=0
36893 PHKT(1,IIG)=PHKK(1,KKG)
36894 PG1=PG1+ PHKT(1,IIG)
36895 PHKT(2,IIG)=PHKK(2,KKG)
36896 PG2=PG2+ PHKT(2,IIG)
36897 PHKT(3,IIG)=PHKK(3,KKG)
36898 PG3=PG3+ PHKT(3,IIG)
36899 PHKT(4,IIG)=PHKK(4,KKG)
36900 PG4=PG4+ PHKT(4,IIG)
36901 PHKT(5,IIG)=PHKK(5,KKG)
36902 VHKT(1,IIG) =VHKK(1,KKG)
36903 VHKT(2,IIG) =VHKK(2,KKG)
36904 VHKT(3,IIG) =VHKK(3,KKG)
36905 VHKT(4,IIG) =VHKK(4,KKG)
36906 WHKT(1,IIG) =WHKK(1,KKG)
36907 WHKT(2,IIG) =WHKK(2,KKG)
36908 WHKT(3,IIG) =WHKK(3,KKG)
36909 WHKT(4,IIG) =WHKK(4,KKG)
36910 81 CONTINUE
36911 ENDIF
36912 IF(IPIP.EQ.1)THEN
36913 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
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 ELSEIF(IPIP.EQ.2)THEN
36918**NEW
36919C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36920 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36921**
36922 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36923 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36924 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36925 ENDIF
36926 ISTHKT(8+IIGLU1+IIGLU2) =962
36927 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36928 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36929 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36930 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36931C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36932C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36933C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36934C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36935 PHKT(1,8+IIGLU1+IIGLU2) =
36936 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36937 PHKT(2,8+IIGLU1+IIGLU2) =
36938 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36939 PHKT(3,8+IIGLU1+IIGLU2) =
36940 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36941 PHKT(4,8+IIGLU1+IIGLU2) =
36942 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36943C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36944C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36945 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36946C IREJ=1
36947C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36948 IPCO=0
36949C RETURN
36950 GO TO 3466
36951 ENDIF
36952C PHKT(5,8) =PHKK(5,NC2T)
36953 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36954 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36955 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36956 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36957 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36958 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36959 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36960 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36961 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36962 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36963 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36964 IDHKT(9+IIGLU1+IIGLU2) =88888
36965 ISTHKT(9+IIGLU1+IIGLU2) =96
36966 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36967 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36968 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36969 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36970 PHKT(1,9+IIGLU1+IIGLU2)
36971 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36972 PHKT(2,9+IIGLU1+IIGLU2)
36973 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36974 PHKT(3,9+IIGLU1+IIGLU2)
36975 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36976 PHKT(4,9+IIGLU1+IIGLU2)
36977 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36978 PHKT(5,9+IIGLU1+IIGLU2)
36979 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36980 * PHKT(2,9+IIGLU1+IIGLU2)**2
36981 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36982 IF(IPIP.GE.3)THEN
36983 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36984 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36985 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36986 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36987 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36988 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36989 * JDAHKT(1,IIG),
36990 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36991 91 CONTINUE
36992 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36993 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36994 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36995 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36996 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36997 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36998 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36999 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37000 ENDIF
37001 CHAMAL=CHAB1
37002 IF(IPIP.EQ.1)THEN
37003 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37004 ELSEIF(IPIP.EQ.2)THEN
37005 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37006 ENDIF
37007 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37008C IREJ=1
37009 IPCO=0
37010C RETURN
37011 GO TO 3466
37012 ENDIF
37013 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37014 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37015 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37016 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37017 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37018 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37019 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37020 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37021C
37022 IPCO=0
37023 IGCOUN=9+IIGLU1+IIGLU2
37024 RETURN
37025 END
37026
37027*$ CREATE MUSQBS1.FOR
37028*COPY MUSQBS1
37029C
37030C
37031C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37032 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37033 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37034C
37035C USQBS-1 diagram (split projectile diquark)
37036C
37037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37038 SAVE
37039
37040 PARAMETER ( LINP = 10 ,
37041 & LOUT = 6 ,
37042 & LDAT = 9 )
37043
37044* event history
37045
37046 PARAMETER (NMXHKK=200000)
37047
37048 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37049 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37050 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37051
37052* extended event history
37053 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37054 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37055 & IHIST(2,NMXHKK)
37056
37057* Lorentz-parameters of the current interaction
37058 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37059 & UMO,PPCM,EPROJ,PPROJ
37060
37061* diquark-breaking mechanism
37062 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37063
37064C
37065 PARAMETER (NTMHKK= 300)
37066 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37067 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37068 +(4,NTMHKK)
37069*KEEP,XSEADI.
37070 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37071 +SSMIMQ,VVMTHR
37072*KEEP,DPRIN.
37073 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37074 COMMON /EVFLAG/ NUMEV
37075C
37076C USQBS-1 diagram (split projectile diquark)
37077C
37078C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37079C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37080C
37081C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37082C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37083C
37084C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37085C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37086C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37087C
37088C Put new chains into COMMON /HKKTMP/
37089C
37090 IIGLU1=NC1T-NC1P-1
37091 IIGLU2=NC2T-NC2P-1
37092 IGCOUN=0
37093C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37094 CVQ=1.D0
37095 IREJ=0
37096 IF(IPIP.EQ.3)THEN
37097C IF(NUMEV.EQ.-324)THEN
37098 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37099 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37100 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37101 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37102 ENDIF
37103C
37104C
37105C
37106C determine x-values of NC1P diquark
37107 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37108 XVQT=PHKK(4,NC1T)*2.D0/UMO
37109C
37110C determine x-values of sea quark pair
37111C
37112 IPCO=1
37113 ICOU=0
37114 2234 CONTINUE
37115 ICOU=ICOU+1
37116 IF(ICOU.GE.500)THEN
37117 IREJ=1
37118 IF(ISQ.EQ.3)IREJ=3
37119 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37120 IPCO=0
37121 RETURN
37122 ENDIF
37123 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37124 * UMO, XDIQP,XVQT
37125 XSQ=0.D0
37126 XSAQ=0.D0
37127**NEW
37128C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37129 IF (IPIP.EQ.1) THEN
37130 XQMAX = XDIQP/2.0D0
37131 XAQMAX = 2.D0*XVQT/3.0D0
37132 ELSE
37133 XQMAX = 2.D0*XVQT/3.0D0
37134 XAQMAX = XDIQP/2.0D0
37135 ENDIF
37136 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37137 ISAQ = 6+ISQ
37138C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37139**
37140 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37141 IF(IREJ.GE.1)THEN
37142 IF(IPCO.GE.3)
37143 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37144 IPCO=0
37145 RETURN
37146 ENDIF
37147 IF(IPIP.EQ.1)THEN
37148 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37149 ELSEIF(IPIP.EQ.2)THEN
37150 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37151 ENDIF
37152 IF(IPCO.GE.3)THEN
37153 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37154 & XDIQP,XVQT,XSQ,XSAQ
37155 ENDIF
37156C
37157C subtract xsq,xsaq from NC1P diquark and NC1T quark
37158C
37159C XSQ=0.D0
37160 IF(IPIP.EQ.1)THEN
37161 XDIQP=XDIQP-XSQ
37162 XVQT =XVQT -XSAQ
37163 ELSEIF(IPIP.EQ.2)THEN
37164 XDIQP=XDIQP-XSAQ
37165 XVQT =XVQT -XSQ
37166 ENDIF
37167 IF(IPCO.GE.3)
37168 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37169C
37170C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37171C
37172 XVTHRO=CVQ/UMO
37173 IVTHR=0
37174 3466 CONTINUE
37175 IF(IVTHR.EQ.10)THEN
37176 IREJ=1
37177 IF(ISQ.EQ.3)IREJ=3
37178 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37179 IPCO=0
37180 RETURN
37181 ENDIF
37182 IVTHR=IVTHR+1
37183 XVTHR=XVTHRO/(201-IVTHR)
37184 UNOPRV=UNON
37185 380 CONTINUE
37186 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37187 IREJ=1
37188 IF(ISQ.EQ.3)IREJ=3
37189 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37190 * XVTHR
37191 IPCO=0
37192 RETURN
37193 ENDIF
37194 IF(DT_RNDM(V).LT.0.5D0)THEN
37195 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37196 XVPQII=XDIQP-XVPQI
37197 ELSE
37198 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37199 XVPQI=XDIQP-XVPQII
37200 ENDIF
37201 IF(IPCO.GE.3)THEN
37202 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37203 ENDIF
37204C
37205C Prepare 4 momenta of new chains and chain ends
37206C
37207C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37208C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37209C +(4,NTMHKK)
37210C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37211C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37212C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37213 IF(IPIP.EQ.1)THEN
37214 XSQ1=XSQ
37215 XSAQ1=XSAQ
37216 ISQ1=ISQ
37217 ISAQ1=ISAQ
37218 ELSEIF(IPIP.EQ.2)THEN
37219 XSQ1=XSAQ
37220 XSAQ1=XSQ
37221 ISQ1=ISAQ
37222 ISAQ1=ISQ
37223 ENDIF
37224 IDHKT(1) =IP11
37225 ISTHKT(1) =931
37226 JMOHKT(1,1)=NC1P
37227 JMOHKT(2,1)=0
37228 JDAHKT(1,1)=3+IIGLU1
37229 JDAHKT(2,1)=0
37230C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37231 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37232 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37233 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37234 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37235C PHKT(5,1) =PHKK(5,NC1P)
37236 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37237 *PHKT(1,1)**2)
37238 IF(XMIST.GE.0.D0)THEN
37239 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37240 *PHKT(1,1)**2)
37241 ELSE
37242C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37243 PHKT(5,1)=0.D0
37244 ENDIF
37245 VHKT(1,1) =VHKK(1,NC1P)
37246 VHKT(2,1) =VHKK(2,NC1P)
37247 VHKT(3,1) =VHKK(3,NC1P)
37248 VHKT(4,1) =VHKK(4,NC1P)
37249 WHKT(1,1) =WHKK(1,NC1P)
37250 WHKT(2,1) =WHKK(2,NC1P)
37251 WHKT(3,1) =WHKK(3,NC1P)
37252 WHKT(4,1) =WHKK(4,NC1P)
37253C Add here IIGLU1 gluons to this chaina
37254 PG1=0.D0
37255 PG2=0.D0
37256 PG3=0.D0
37257 PG4=0.D0
37258 IF(IIGLU1.GE.1)THEN
37259 JJG=NC1P
37260 DO 61 IIG=2,2+IIGLU1-1
37261 KKG=JJG+IIG-1
37262 IDHKT(IIG) =IDHKK(KKG)
37263 ISTHKT(IIG) =921
37264 JMOHKT(1,IIG)=KKG
37265 JMOHKT(2,IIG)=0
37266 JDAHKT(1,IIG)=3+IIGLU1
37267 JDAHKT(2,IIG)=0
37268 PHKT(1,IIG)=PHKK(1,KKG)
37269 PG1=PG1+ PHKT(1,IIG)
37270 PHKT(2,IIG)=PHKK(2,KKG)
37271 PG2=PG2+ PHKT(2,IIG)
37272 PHKT(3,IIG)=PHKK(3,KKG)
37273 PG3=PG3+ PHKT(3,IIG)
37274 PHKT(4,IIG)=PHKK(4,KKG)
37275 PG4=PG4+ PHKT(4,IIG)
37276 PHKT(5,IIG)=PHKK(5,KKG)
37277 VHKT(1,IIG) =VHKK(1,KKG)
37278 VHKT(2,IIG) =VHKK(2,KKG)
37279 VHKT(3,IIG) =VHKK(3,KKG)
37280 VHKT(4,IIG) =VHKK(4,KKG)
37281 WHKT(1,IIG) =WHKK(1,KKG)
37282 WHKT(2,IIG) =WHKK(2,KKG)
37283 WHKT(3,IIG) =WHKK(3,KKG)
37284 WHKT(4,IIG) =WHKK(4,KKG)
37285 61 CONTINUE
37286 ENDIF
37287 IDHKT(2+IIGLU1) =IPP2
37288 ISTHKT(2+IIGLU1) =932
37289 JMOHKT(1,2+IIGLU1)=NC2T
37290 JMOHKT(2,2+IIGLU1)=0
37291 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37292 JDAHKT(2,2+IIGLU1)=0
37293 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37294 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37295 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37296 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37297C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37298 XMIST=(PHKT(4,2+IIGLU1)**2-
37299 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37300 *PHKT(1,2+IIGLU1)**2)
37301 IF(XMIST.GT.0.D0)THEN
37302 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37303 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37304 *PHKT(1,2+IIGLU1)**2)
37305 ELSE
37306C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37307 PHKT(5,2+IIGLU1)=0.D0
37308 ENDIF
37309 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37310 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37311 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37312 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37313 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37314 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37315 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37316 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37317 IDHKT(3+IIGLU1) =88888
37318 ISTHKT(3+IIGLU1) =94
37319 JMOHKT(1,3+IIGLU1)=1
37320 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37321 JDAHKT(1,3+IIGLU1)=0
37322 JDAHKT(2,3+IIGLU1)=0
37323 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37324 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37325 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37326 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37327 XMIST
37328 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37329 * -PHKT(3,3+IIGLU1)**2)
37330 IF(XMIST.GE.0.D0)THEN
37331 PHKT(5,3+IIGLU1)
37332 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37333 * -PHKT(3,3+IIGLU1)**2)
37334 ELSE
37335C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37336 PHKT(5,1)=0.D0
37337 ENDIF
37338 IF(IPIP.GE.3)THEN
37339C IF(NUMEV.EQ.-324)THEN
37340 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37341 * JMOHKT(2,1),JDAHKT(1,1),
37342 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37343 DO 71 IIG=2,2+IIGLU1-1
37344 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37345 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37346 * JDAHKT(1,IIG),
37347 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37348 71 CONTINUE
37349 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37350 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37351 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37352 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37353 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37354 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37355 ENDIF
37356 CHAMAL=CHAM1
37357 IF(IPIP.EQ.1)THEN
37358 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37359 ELSEIF(IPIP.EQ.2)THEN
37360 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37361 ENDIF
37362 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37363C IREJ=1
37364 IPCO=0
37365C RETURN
37366C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37367 GO TO 3466
37368 ENDIF
37369 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37370 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37371 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37372 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37373 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37374 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37375 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37376 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37377 IDHKT(4+IIGLU1) =IP12
37378 ISTHKT(4+IIGLU1) =931
37379 JMOHKT(1,4+IIGLU1)=NC1P
37380 JMOHKT(2,4+IIGLU1)=0
37381 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37382 JDAHKT(2,4+IIGLU1)=0
37383C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37384 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37385 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37386 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37387 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37388C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37389 XMIST =(PHKT(4,4+IIGLU1)**2-
37390 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37391 *PHKT(1,4+IIGLU1)**2)
37392 IF(XMIST.GT.0.D0)THEN
37393 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37394 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37395 *PHKT(1,4+IIGLU1)**2)
37396 ELSE
37397C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37398 PHKT(5,4+IIGLU1)=0.D0
37399 ENDIF
37400 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37401 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37402 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37403 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37404 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37405 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37406 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37407 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37408 IF(IPIP.EQ.1)THEN
37409 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37410 ELSEIF(IPIP.EQ.2)THEN
37411 IDHKT(5+IIGLU1) =ISAQ1
37412 ENDIF
37413 ISTHKT(5+IIGLU1) =932
37414 JMOHKT(1,5+IIGLU1)=NC1T
37415 JMOHKT(2,5+IIGLU1)=0
37416 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37417 JDAHKT(2,5+IIGLU1)=0
37418 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37419 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37420 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37421 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37422C IF( PHKT(4,5).EQ.0.D0)THEN
37423C IREJ=1
37424CIPCO=0
37425CRETURN
37426C ENDIF
37427C PHKT(5,5) =PHKK(5,NC1T)
37428 XMIST=(PHKT(4,5+IIGLU1)**2-
37429 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37430 *PHKT(1,5+IIGLU1)**2)
37431 IF(XMIST.GT.0.D0)THEN
37432 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37433 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37434 *PHKT(1,5+IIGLU1)**2)
37435 ELSE
37436C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37437 PHKT(5,5+IIGLU1)=0.D0
37438 ENDIF
37439 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37440 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37441 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37442 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37443 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37444 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37445 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37446 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37447 IDHKT(6+IIGLU1) =88888
37448 ISTHKT(6+IIGLU1) =94
37449 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37450 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37451 JDAHKT(1,6+IIGLU1)=0
37452 JDAHKT(2,6+IIGLU1)=0
37453 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37454 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37455 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37456 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37457 XMIST
37458 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37459 * -PHKT(3,6+IIGLU1)**2)
37460 IF(XMIST.GE.0.D0)THEN
37461 PHKT(5,6+IIGLU1)
37462 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37463 * -PHKT(3,6+IIGLU1)**2)
37464 ELSE
37465C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37466 PHKT(5,1)=0.D0
37467 ENDIF
37468C IF(IPIP.EQ.3)THEN
37469 CHAMAL=CHAM1
37470 IF(IPIP.EQ.1)THEN
37471 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37472 ELSEIF(IPIP.EQ.2)THEN
37473 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37474 ENDIF
37475 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37476C IREJ=1
37477 IPCO=0
37478C RETURN
37479C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37480C & CHAMAL,PHKT(5,6+IIGLU1)
37481 GO TO 3466
37482 ENDIF
37483 IF(IPIP.GE.3)THEN
37484C IF(NUMEV.EQ.-324)THEN
37485 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37486 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37487 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37488 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37489 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37490 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37491 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37492 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37493 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37494 ENDIF
37495 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37496 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37497 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37498 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37499 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37500 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37501 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37502 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37503 IF(IPIP.EQ.1)THEN
37504 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37505 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37506 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37507 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37508 ELSEIF(IPIP.EQ.2)THEN
37509 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37510 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37511 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37512 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37513C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37514 ENDIF
37515 ISTHKT(7+IIGLU1) =931
37516 JMOHKT(1,7+IIGLU1)=NC2P
37517 JMOHKT(2,7+IIGLU1)=0
37518 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37519 JDAHKT(2,7+IIGLU1)=0
37520C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37521 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37522 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37523 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37524 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37525C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37526C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37527 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37528C IREJ=1
37529C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37530 IPCO=0
37531C RETURN
37532 GO TO 3466
37533 ENDIF
37534C PHKT(5,7) =PHKK(5,NC2P)
37535 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37536 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37537 *PHKT(1,7+IIGLU1)**2)
37538 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37539 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37540 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37541 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37542 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37543 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37544 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37545 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37546C Insert here the IIGLU2 gluons
37547 PG1=0.D0
37548 PG2=0.D0
37549 PG3=0.D0
37550 PG4=0.D0
37551 IF(IIGLU2.GE.1)THEN
37552 JJG=NC2P
37553 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37554 KKG=JJG+IIG-7-IIGLU1
37555 IDHKT(IIG) =IDHKK(KKG)
37556 ISTHKT(IIG) =921
37557 JMOHKT(1,IIG)=KKG
37558 JMOHKT(2,IIG)=0
37559 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37560 JDAHKT(2,IIG)=0
37561 PHKT(1,IIG)=PHKK(1,KKG)
37562 PG1=PG1+ PHKT(1,IIG)
37563 PHKT(2,IIG)=PHKK(2,KKG)
37564 PG2=PG2+ PHKT(2,IIG)
37565 PHKT(3,IIG)=PHKK(3,KKG)
37566 PG3=PG3+ PHKT(3,IIG)
37567 PHKT(4,IIG)=PHKK(4,KKG)
37568 PG4=PG4+ PHKT(4,IIG)
37569 PHKT(5,IIG)=PHKK(5,KKG)
37570 VHKT(1,IIG) =VHKK(1,KKG)
37571 VHKT(2,IIG) =VHKK(2,KKG)
37572 VHKT(3,IIG) =VHKK(3,KKG)
37573 VHKT(4,IIG) =VHKK(4,KKG)
37574 WHKT(1,IIG) =WHKK(1,KKG)
37575 WHKT(2,IIG) =WHKK(2,KKG)
37576 WHKT(3,IIG) =WHKK(3,KKG)
37577 WHKT(4,IIG) =WHKK(4,KKG)
37578 81 CONTINUE
37579 ENDIF
37580 IDHKT(8+IIGLU1+IIGLU2) =IP2
37581 ISTHKT(8+IIGLU1+IIGLU2) =932
37582 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37583 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37584 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37585 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37586 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37587 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37588 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37589 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37590C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37591 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37592 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37593 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37594 IF(XMIST.GT.0.D0)THEN
37595 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37596 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37597 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37598 ELSE
37599C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37600 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37601 ENDIF
37602 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37603 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37604 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37605 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37606 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37607 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37608 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37609 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37610 IDHKT(9+IIGLU1+IIGLU2) =88888
37611 ISTHKT(9+IIGLU1+IIGLU2) =94
37612 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37613 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37614 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37615 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37616 PHKT(1,9+IIGLU1+IIGLU2)
37617 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37618 PHKT(2,9+IIGLU1+IIGLU2)
37619 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37620 PHKT(3,9+IIGLU1+IIGLU2)
37621 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37622 PHKT(4,9+IIGLU1+IIGLU2)
37623 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37624 XMIST
37625 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37626 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37627 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37628 IF(XMIST.GE.0.D0)THEN
37629 PHKT(5,9+IIGLU1+IIGLU2)
37630 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37631 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37632 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37633 ELSE
37634C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37635 PHKT(5,1)=0.D0
37636 ENDIF
37637 IF(IPIP.GE.3)THEN
37638C IF(NUMEV.EQ.-324)THEN
37639 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37640 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37641 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37642 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37643 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37644 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37645 * JDAHKT(1,IIG),
37646 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37647 91 CONTINUE
37648 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37649 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37650 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37651 *JDAHKT(1,8+IIGLU1+IIGLU2),
37652 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37653 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37654 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37655 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37656 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37657 ENDIF
37658 CHAMAL=CHAB1
37659 IF(IPIP.EQ.1)THEN
37660 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37661 ELSEIF(IPIP.EQ.2)THEN
37662 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37663 ENDIF
37664 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37665C IREJ=1
37666 IPCO=0
37667C RETURN
37668C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37669C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37670 GO TO 3466
37671 ENDIF
37672 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37673 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37674 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37675 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37676 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37677 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37678 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37679 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37680C
37681 IPCO=0
37682 IGCOUN=9+IIGLU1+IIGLU2
37683 RETURN
37684 END
37685
37686*$ CREATE MGSQBS1.FOR
37687*COPY MGSQBS1
37688C
37689C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37690 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37691 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37692C
37693C GSQBS-1 diagram (split projectile diquark)
37694C
37695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37696 SAVE
37697
37698 PARAMETER ( LINP = 10 ,
37699 & LOUT = 6 ,
37700 & LDAT = 9 )
37701
37702* event history
37703
37704 PARAMETER (NMXHKK=200000)
37705
37706 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37707 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37708 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37709
37710* extended event history
37711 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37712 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37713 & IHIST(2,NMXHKK)
37714
37715* Lorentz-parameters of the current interaction
37716 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37717 & UMO,PPCM,EPROJ,PPROJ
37718
37719* diquark-breaking mechanism
37720 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37721
37722C
37723 PARAMETER (NTMHKK= 300)
37724 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37725 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37726 +(4,NTMHKK)
37727*KEEP,XSEADI.
37728 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37729 +SSMIMQ,VVMTHR
37730*KEEP,DPRIN.
37731 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37732C
37733C GSQBS-1 diagram (split projectile diquark)
37734C
37735C
37736C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37737C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37738C
37739C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37740C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37741C
37742C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37743C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37744C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37745C
37746C Put new chains into COMMON /HKKTMP/
37747C
37748 IIGLU1=NC1T-NC1P-1
37749 IIGLU2=NC2T-NC2P-1
37750 IGCOUN=0
37751C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37752 CVQ=1.D0
37753 NNNC1=IDHKK(NC1)/1000
37754 MMMC1=IDHKK(NC1)-NNNC1*1000
37755 KKKC1=ISTHKK(NC1)
37756 NNNC2=IDHKK(NC2)/1000
37757 MMMC2=IDHKK(NC2)-NNNC2*1000
37758 KKKC2=ISTHKK(NC2)
37759 IREJ=0
37760 IF(IPIP.EQ.3)THEN
37761 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37762 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37763 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37764 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37765 ENDIF
37766C
37767C
37768C
37769C determine x-values of NC1P diquark
37770 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37771 XVQT=PHKK(4,NC1T)*2.D0/UMO
37772C
37773C determine x-values of sea quark pair
37774C
37775 IPCO=1
37776 ICOU=0
37777 2234 CONTINUE
37778 ICOU=ICOU+1
37779 IF(ICOU.GE.500)THEN
37780 IREJ=1
37781 IF(ISQ.EQ.3)IREJ=3
37782 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37783 IPCO=0
37784 RETURN
37785 ENDIF
37786 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37787 * UMO, XDIQP,XVQT
37788 XSQ=0.D0
37789 XSAQ=0.D0
37790**NEW
37791C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37792 IF (IPIP.EQ.1) THEN
37793 XQMAX = XDIQP/2.0D0
37794 XAQMAX = 2.D0*XVQT/3.0D0
37795 ELSE
37796 XQMAX = 2.D0*XVQT/3.0D0
37797 XAQMAX = XDIQP/2.0D0
37798 ENDIF
37799 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37800 ISAQ = 6+ISQ
37801C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37802**
37803 IF(IPCO.GE.3)
37804 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37805 IF(IREJ.GE.1)THEN
37806 IF(IPCO.GE.3)
37807 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37808 IPCO=0
37809 RETURN
37810 ENDIF
37811 IF(IPIP.EQ.1)THEN
37812 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37813 ELSEIF(IPIP.EQ.2)THEN
37814 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37815 ENDIF
37816 IF(IPCO.GE.3)THEN
37817 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37818 & XDIQP,XVQT,XSQ,XSAQ
37819 ENDIF
37820C
37821C subtract xsq,xsaq from NC1P diquark and NC1T quark
37822C
37823C XSQ=0.D0
37824 IF(IPIP.EQ.1)THEN
37825 XDIQP=XDIQP-XSQ
37826**NEW
37827C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37828**
37829 XVQT =XVQT -XSAQ
37830 ELSEIF(IPIP.EQ.2)THEN
37831 XDIQP=XDIQP-XSAQ
37832 XVQT =XVQT -XSQ
37833 ENDIF
37834 IF(IPCO.GE.3)
37835 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37836C
37837C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37838C
37839 XVTHRO=CVQ/UMO
37840 IVTHR=0
37841 3466 CONTINUE
37842 IF(IVTHR.EQ.10)THEN
37843 IREJ=1
37844 IF(ISQ.EQ.3)IREJ=3
37845 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37846 IPCO=0
37847 RETURN
37848 ENDIF
37849 IVTHR=IVTHR+1
37850 XVTHR=XVTHRO/(201-IVTHR)
37851 UNOPRV=UNON
37852 380 CONTINUE
37853 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37854 IREJ=1
37855 IF(ISQ.EQ.3)IREJ=3
37856 IF(IPCO.GE.3)
37857 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37858 * XVTHR
37859 IPCO=0
37860 RETURN
37861 ENDIF
37862 IF(DT_RNDM(V).LT.0.5D0)THEN
37863 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37864 XVPQII=XDIQP-XVPQI
37865 ELSE
37866 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37867 XVPQI=XDIQP-XVPQII
37868 ENDIF
37869 IF(IPCO.GE.3)THEN
37870 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37871 & XVTHR,XDIQP,XVPQI,XVPQII
37872 ENDIF
37873C
37874C Prepare 4 momenta of new chains and chain ends
37875C
37876C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37877C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37878C +(4,NTMHKK)
37879C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37880C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37881C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37882 IF(IPIP.EQ.1)THEN
37883 XSQ1=XSQ
37884 XSAQ1=XSAQ
37885 ISQ1=ISQ
37886 ISAQ1=ISAQ
37887 ELSEIF(IPIP.EQ.2)THEN
37888 XSQ1=XSAQ
37889 XSAQ1=XSQ
37890 ISQ1=ISAQ
37891 ISAQ1=ISQ
37892 ENDIF
37893 KK11=IP11
37894C IDHKT(2) =1000*IPP21+100*IPP22+1
37895 KK21= IPP21
37896 KK22= IPP22
37897 XGIVE=0.D0
37898 IDHKT(4+IIGLU1) =IP12
37899 ISTHKT(4+IIGLU1) =921
37900 JMOHKT(1,4+IIGLU1)=NC1P
37901 JMOHKT(2,4+IIGLU1)=0
37902 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37903 JDAHKT(2,4+IIGLU1)=0
37904**NEW
37905 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37906 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37907**
37908 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37909 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37910 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37911 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37912C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37913 XXMIST=(PHKT(4,4+IIGLU1)**2-
37914 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37915 * PHKT(1,4+IIGLU1)**2)
37916 IF(XXMIST.GT.0.D0)THEN
37917 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37918 ELSE
37919 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37920 XXMIST=ABS(XXMIST)
37921 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37922 ENDIF
37923 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37924 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37925 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37926 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37927 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37928 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37929 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37930 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37931 IF(IPIP.EQ.1)THEN
37932 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37933 ELSEIF(IPIP.EQ.2)THEN
37934 IDHKT(5+IIGLU1) =ISAQ1
37935 ENDIF
37936 ISTHKT(5+IIGLU1) =922
37937 JMOHKT(1,5+IIGLU1)=NC1T
37938 JMOHKT(2,5+IIGLU1)=0
37939 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37940 JDAHKT(2,5+IIGLU1)=0
37941**NEW
37942 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37943 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37944**
37945 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37946 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37947 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37948 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37949C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37950 XMIST=(PHKT(4,5+IIGLU1)**2-
37951 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37952 *PHKT(1,5+IIGLU1)**2)
37953 IF(XMIST.GT.0.D0)THEN
37954 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37955 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37956 *PHKT(1,5+IIGLU1)**2)
37957 ELSE
37958C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37959 PHKT(5,5+IIGLU1)=0.D0
37960 ENDIF
37961 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37962 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37963 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37964 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37965 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37966 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37967 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37968 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37969 IDHKT(6+IIGLU1) =88888
37970C IDHKT(6) =1000*NNNC1+MMMC1
37971 ISTHKT(6+IIGLU1) =93
37972C ISTHKT(6) =KKKC1
37973 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37974 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37975 JDAHKT(1,6+IIGLU1)=0
37976 JDAHKT(2,6+IIGLU1)=0
37977 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37978 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37979 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37980 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37981 PHKT(5,6+IIGLU1)
37982 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37983 * -PHKT(3,6+IIGLU1)**2)
37984 CHAMAL=CHAM1
37985 IF(IPIP.EQ.1)THEN
37986 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37987 ELSEIF(IPIP.EQ.2)THEN
37988 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37989 ENDIF
37990 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37991 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37992C we drop chain 6 and give the energy to chain 3
37993 IDHKT(6+IIGLU1)=33888
37994 XGIVE=1.D0
37995C WRITE(6,*)' drop chain 6 xgive=1'
37996 GO TO 7788
37997 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37998C we drop chain 6 and give the energy to chain 3
37999C and change KK11 to IDHKT(4)
38000 IDHKT(6+IIGLU1)=33888
38001 XGIVE=1.D0
38002C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
38003 KK11=IDHKT(4+IIGLU1)
38004 GO TO 7788
38005 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38006C we drop chain 6 and give the energy to chain 3
38007C and change KK21 to IDHKT(4)
38008C IDHKT(2) =1000*IPP21+100*IPP22+1
38009 IDHKT(6+IIGLU1)=33888
38010 XGIVE=1.D0
38011C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38012 KK21=IDHKT(4+IIGLU1)
38013 GO TO 7788
38014 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38015C we drop chain 6 and give the energy to chain 3
38016C and change KK22 to IDHKT(4)
38017C IDHKT(2) =1000*IPP21+100*IPP22+1
38018 IDHKT(6+IIGLU1)=33888
38019 XGIVE=1.D0
38020C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38021 KK22=IDHKT(4+IIGLU1)
38022 GO TO 7788
38023 ENDIF
38024C IREJ=1
38025 IPCO=0
38026C RETURN
38027C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38028 GO TO 3466
38029 ENDIF
38030 7788 CONTINUE
38031 IF(IPIP.GE.3)THEN
38032 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38033 * JMOHKT(1,4+IIGLU1),
38034 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38035 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38036 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38037 * JMOHKT(1,5+IIGLU1),
38038 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38039 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38040 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38041 * JMOHKT(1,6+IIGLU1),
38042 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38043 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38044 ENDIF
38045 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38046 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38047 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38048 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38049 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38050 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38051 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38052 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38053C IDHKT(1) =IP11
38054 IDHKT(1) =KK11
38055 ISTHKT(1) =921
38056 JMOHKT(1,1)=NC1P
38057 JMOHKT(2,1)=0
38058 JDAHKT(1,1)=3+IIGLU1
38059 JDAHKT(2,1)=0
38060 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38061C * +0.5D0*PHKK(1,NC2P)
38062 *+XGIVE*PHKT(1,4+IIGLU1)
38063 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38064C * +0.5D0*PHKK(2,NC2P)
38065 *+XGIVE*PHKT(2,4+IIGLU1)
38066 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38067C * +0.5D0*PHKK(3,NC2P)
38068 *+XGIVE*PHKT(3,4+IIGLU1)
38069 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38070C * +0.5D0*PHKK(4,NC2P)
38071 *+XGIVE*PHKT(4,4+IIGLU1)
38072C PHKT(5,1) =PHKK(5,NC1P)
38073 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38074 *PHKT(1,1)**2)
38075 IF(XMIST.GE.0.D0)THEN
38076 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38077 *PHKT(1,1)**2)
38078 ELSE
38079C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38080 PHKT(5,1)=0.D0
38081 ENDIF
38082 VHKT(1,1) =VHKK(1,NC1P)
38083 VHKT(2,1) =VHKK(2,NC1P)
38084 VHKT(3,1) =VHKK(3,NC1P)
38085 VHKT(4,1) =VHKK(4,NC1P)
38086 WHKT(1,1) =WHKK(1,NC1P)
38087 WHKT(2,1) =WHKK(2,NC1P)
38088 WHKT(3,1) =WHKK(3,NC1P)
38089 WHKT(4,1) =WHKK(4,NC1P)
38090C Add here IIGLU1 gluons to this chaina
38091 PG1=0.D0
38092 PG2=0.D0
38093 PG3=0.D0
38094 PG4=0.D0
38095 IF(IIGLU1.GE.1)THEN
38096 JJG=NC1P
38097 DO 61 IIG=2,2+IIGLU1-1
38098 KKG=JJG+IIG-1
38099 IDHKT(IIG) =IDHKK(KKG)
38100 ISTHKT(IIG) =921
38101 JMOHKT(1,IIG)=KKG
38102 JMOHKT(2,IIG)=0
38103 JDAHKT(1,IIG)=3+IIGLU1
38104 JDAHKT(2,IIG)=0
38105 PHKT(1,IIG)=PHKK(1,KKG)
38106 PG1=PG1+ PHKT(1,IIG)
38107 PHKT(2,IIG)=PHKK(2,KKG)
38108 PG2=PG2+ PHKT(2,IIG)
38109 PHKT(3,IIG)=PHKK(3,KKG)
38110 PG3=PG3+ PHKT(3,IIG)
38111 PHKT(4,IIG)=PHKK(4,KKG)
38112 PG4=PG4+ PHKT(4,IIG)
38113 PHKT(5,IIG)=PHKK(5,KKG)
38114 VHKT(1,IIG) =VHKK(1,KKG)
38115 VHKT(2,IIG) =VHKK(2,KKG)
38116 VHKT(3,IIG) =VHKK(3,KKG)
38117 VHKT(4,IIG) =VHKK(4,KKG)
38118 WHKT(1,IIG) =WHKK(1,KKG)
38119 WHKT(2,IIG) =WHKK(2,KKG)
38120 WHKT(3,IIG) =WHKK(3,KKG)
38121 WHKT(4,IIG) =WHKK(4,KKG)
38122 61 CONTINUE
38123 ENDIF
38124C IDHKT(2) =1000*IPP21+100*IPP22+1
38125 IF(IPIP.EQ.1)THEN
38126 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38127 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38128 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38129 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38130 ELSEIF(IPIP.EQ.2)THEN
38131 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38132 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38133 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38134 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38135 ENDIF
38136 ISTHKT(2+IIGLU1) =922
38137 JMOHKT(1,2+IIGLU1)=NC2T
38138 JMOHKT(2,2+IIGLU1)=0
38139 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38140 JDAHKT(2,2+IIGLU1)=0
38141 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38142 *+XGIVE*PHKT(1,5+IIGLU1)
38143 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38144 *+XGIVE*PHKT(2,5+IIGLU1)
38145 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38146 *+XGIVE*PHKT(3,5+IIGLU1)
38147 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38148 *+XGIVE*PHKT(4,5+IIGLU1)
38149C PHKT(5,2) =PHKK(5,NC2T)
38150 XMIST=(PHKT(4,2+IIGLU1)**2-
38151 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38152 *PHKT(1,2+IIGLU1)**2)
38153 IF(XMIST.GT.0.D0)THEN
38154 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38155 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38156 *PHKT(1,2+IIGLU1)**2)
38157 ELSE
38158C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38159 PHKT(5,2+IIGLU1)=0.D0
38160 ENDIF
38161 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38162 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38163 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38164 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38165 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38166 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38167 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38168 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38169 IDHKT(3+IIGLU1) =88888
38170C IDHKT(3) =1000*NNNC1+MMMC1+10
38171 ISTHKT(3+IIGLU1) =93
38172C ISTHKT(3) =KKKC1
38173 JMOHKT(1,3+IIGLU1)=1
38174 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38175 JDAHKT(1,3+IIGLU1)=0
38176 JDAHKT(2,3+IIGLU1)=0
38177 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38178 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38179 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38180 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38181 PHKT(5,3+IIGLU1)
38182 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38183 * -PHKT(3,3+IIGLU1)**2)
38184 IF(IPIP.GE.3)THEN
38185 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38186 * JDAHKT(1,1),
38187 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38188 DO 71 IIG=2,2+IIGLU1-1
38189 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38190 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38191 * JDAHKT(1,IIG),
38192 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38193 71 CONTINUE
38194 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38195 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38196 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38197 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38198 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38199 * JMOHKT(1,3+IIGLU1),
38200 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38201 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38202 ENDIF
38203 CHAMAL=CHAB1
38204**NEW
38205C IF(IPIP.EQ.1)THEN
38206C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38207C ELSEIF(IPIP.EQ.2)THEN
38208C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38209C ENDIF
38210 IF(IPIP.EQ.1)THEN
38211 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38212 ELSEIF(IPIP.EQ.2)THEN
38213 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38214 ENDIF
38215**
38216 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38217C IREJ=1
38218 IPCO=0
38219C RETURN
38220C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38221 GO TO 3466
38222 ENDIF
38223 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38224 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38225 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38226 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38227 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38228 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38229 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38230 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38231 IF(IPIP.EQ.1)THEN
38232 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38233 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38234 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38235 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38236 ELSEIF(IPIP.EQ.2)THEN
38237 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38238 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38239 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38240 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38241C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38242 ENDIF
38243 ISTHKT(7+IIGLU1) =921
38244 JMOHKT(1,7+IIGLU1)=NC2P
38245 JMOHKT(2,7+IIGLU1)=0
38246 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38247 JDAHKT(2,7+IIGLU1)=0
38248C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38249C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38250C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38251C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38252**NEW
38253 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38254 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38255**
38256 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38257 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38258 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38259 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38260C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38261C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38262 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38263C IREJ=1
38264C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38265 IPCO=0
38266C RETURN
38267 GO TO 3466
38268 ENDIF
38269C PHKT(5,7) =PHKK(5,NC2P)
38270 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38271 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38272 *PHKT(1,7+IIGLU1)**2)
38273 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38274 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38275 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38276 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38277 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38278 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38279 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38280 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38281C Insert here the IIGLU2 gluons
38282 PG1=0.D0
38283 PG2=0.D0
38284 PG3=0.D0
38285 PG4=0.D0
38286 IF(IIGLU2.GE.1)THEN
38287 JJG=NC2P
38288 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38289 KKG=JJG+IIG-7-IIGLU1
38290 IDHKT(IIG) =IDHKK(KKG)
38291 ISTHKT(IIG) =921
38292 JMOHKT(1,IIG)=KKG
38293 JMOHKT(2,IIG)=0
38294 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38295 JDAHKT(2,IIG)=0
38296 PHKT(1,IIG)=PHKK(1,KKG)
38297 PG1=PG1+ PHKT(1,IIG)
38298 PHKT(2,IIG)=PHKK(2,KKG)
38299 PG2=PG2+ PHKT(2,IIG)
38300 PHKT(3,IIG)=PHKK(3,KKG)
38301 PG3=PG3+ PHKT(3,IIG)
38302 PHKT(4,IIG)=PHKK(4,KKG)
38303 PG4=PG4+ PHKT(4,IIG)
38304 PHKT(5,IIG)=PHKK(5,KKG)
38305 VHKT(1,IIG) =VHKK(1,KKG)
38306 VHKT(2,IIG) =VHKK(2,KKG)
38307 VHKT(3,IIG) =VHKK(3,KKG)
38308 VHKT(4,IIG) =VHKK(4,KKG)
38309 WHKT(1,IIG) =WHKK(1,KKG)
38310 WHKT(2,IIG) =WHKK(2,KKG)
38311 WHKT(3,IIG) =WHKK(3,KKG)
38312 WHKT(4,IIG) =WHKK(4,KKG)
38313 81 CONTINUE
38314 ENDIF
38315 IDHKT(8+IIGLU1+IIGLU2) =IP2
38316 ISTHKT(8+IIGLU1+IIGLU2) =922
38317 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38318 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38319 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38320 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38321**NEW
38322 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38323 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38324**
38325 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38326 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38327 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38328 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38329C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38330 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38331 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38332 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38333 IF(XMIST.GT.0.D0)THEN
38334 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38335 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38336 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38337 ELSE
38338C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38339 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38340 ENDIF
38341 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38342 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38343 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38344 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38345 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38346 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38347 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38348 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38349 IDHKT(9+IIGLU1+IIGLU2) =88888
38350C IDHKT(9) =1000*NNNC2+MMMC2+10
38351 ISTHKT(9+IIGLU1+IIGLU2) =93
38352C ISTHKT(9) =KKKC2
38353 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38354 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38355 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38356 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38357 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38358 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38359 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38360 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38361 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38362 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38363 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38364 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38365 PHKT(5,9+IIGLU1+IIGLU2)
38366 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38367 * PHKT(2,9+IIGLU1+IIGLU2)**2
38368 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38369 IF(IPIP.GE.3)THEN
38370 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38371 * JMOHKT(1,7+IIGLU1),
38372 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38373 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38374 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38375 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38376 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38377 * JDAHKT(1,IIG),
38378 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38379 91 CONTINUE
38380 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38381 * IDHKT(8+IIGLU1+IIGLU2),
38382 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38383 * JDAHKT(1,8+IIGLU1+IIGLU2),
38384 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38385 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38386 * IDHKT(9+IIGLU1+IIGLU2),
38387 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38388 * JDAHKT(1,9+IIGLU1+IIGLU2),
38389 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38390 ENDIF
38391 CHAMAL=CHAB1
38392 IF(IPIP.EQ.1)THEN
38393 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38394 ELSEIF(IPIP.EQ.2)THEN
38395 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38396 ENDIF
38397 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38398C IREJ=1
38399 IPCO=0
38400C RETURN
38401C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38402C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38403 GO TO 3466
38404 ENDIF
38405 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38406 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38407 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38408 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38409 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38410 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38411 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38412 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38413C
38414 IGCOUN=9+IIGLU1+IIGLU2
38415 IPCO=0
38416 RETURN
38417 END
38418
38419*$ CREATE HKKHKT.FOR
38420*COPY HKKHKT
38421C
38422C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38423C
38424 SUBROUTINE HKKHKT(I,J)
38425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38426 SAVE
38427
38428* event history
38429
38430 PARAMETER (NMXHKK=200000)
38431
38432 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38433 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38434 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38435
38436* extended event history
38437 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38438 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38439 & IHIST(2,NMXHKK)
38440
38441 PARAMETER (NTMHKK= 300)
38442 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38443 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38444 +(4,NTMHKK)
38445C
38446 ISTHKK(I) =ISTHKT(J)
38447 IDHKK(I) =IDHKT(J)
38448C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38449 IF(IDHKK(I).EQ.88888)THEN
38450C JMOHKK(1,I)=I-2
38451C JMOHKK(2,I)=I-1
38452 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38453 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38454 ELSE
38455 JMOHKK(1,I)=JMOHKT(1,J)
38456 JMOHKK(2,I)=JMOHKT(2,J)
38457 ENDIF
38458 JDAHKK(1,I)=JDAHKT(1,J)
38459 JDAHKK(2,I)=JDAHKT(2,J)
38460C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38461C JDAHKK(1,I)=I+2
38462C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38463C JDAHKK(1,I)=I+1
38464C ENDIF
38465 IF(JDAHKT(1,J).GT.0)THEN
38466 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38467 ENDIF
38468 PHKK(1,I) =PHKT(1,J)
38469 PHKK(2,I) =PHKT(2,J)
38470 PHKK(3,I) =PHKT(3,J)
38471 PHKK(4,I) =PHKT(4,J)
38472 PHKK(5,I) =PHKT(5,J)
38473 VHKK(1,I) =VHKT(1,J)
38474 VHKK(2,I) =VHKT(2,J)
38475 VHKK(3,I) =VHKT(3,J)
38476 VHKK(4,I) =VHKT(4,J)
38477 WHKK(1,I) =WHKT(1,J)
38478 WHKK(2,I) =WHKT(2,J)
38479 WHKK(3,I) =WHKT(3,J)
38480 WHKK(4,I) =WHKT(4,J)
38481 RETURN
38482 END
38483
38484*$ CREATE DT_DBREAK.FOR
38485*COPY DT_DBREAK
38486*
38487*===dbreak=============================================================*
38488*
38489 SUBROUTINE DT_DBREAK(MODE)
38490
38491************************************************************************
38492* This is the steering subroutine for the different diquark breaking *
38493* mechanisms. *
38494* *
38495* MODE = 1 breaking of projectile diquark in qq-q chain using *
38496* a sea quark (q-qq chain) of the same projectile *
38497* = 2 breaking of target diquark in q-qq chain using *
38498* a sea quark (qq-q chain) of the same target *
38499* = 3 breaking of projectile diquark in qq-q chain using *
38500* a sea quark (q-aq chain) of the same projectile *
38501* = 4 breaking of target diquark in q-qq chain using *
38502* a sea quark (aq-q chain) of the same target *
38503* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38504* a sea anti-quark (aq-aqaq chain) of the same projectile *
38505* = 6 breaking of target anti-diquark in aq-aqaq chain using *
38506* a sea anti-quark (aqaq-aq chain) of the same target *
38507* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38508* a sea anti-quark (aq-q chain) of the same projectile *
38509* = 8 breaking of target anti-diquark in aq-aqaq chain using *
38510* a sea anti-quark (q-aq chain) of the same target *
38511* *
38512* Original version by J. Ranft. *
38513* This version dated 17.5.00 is written by S. Roesler. *
38514************************************************************************
38515
38516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38517 SAVE
38518
38519 PARAMETER ( LINP = 10 ,
38520 & LOUT = 6 ,
38521 & LDAT = 9 )
38522
38523* event history
38524
38525 PARAMETER (NMXHKK=200000)
38526
38527 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38528 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38529 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38530
38531* extended event history
38532 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38533 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38534 & IHIST(2,NMXHKK)
38535
38536* flags for input different options
38537 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38538 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38539 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38540
38541* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38542 PARAMETER (MAXCHN=10000)
38543 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38544
38545* diquark-breaking mechanism
38546 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38547
38548* flags for particle decays
38549 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38550 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38551 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38552
38553*
38554* chain identifiers
38555* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38556* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38557 DIMENSION IDCHN1(8),IDCHN2(8)
38558 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38559 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38560*
38561* parton identifiers
38562* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38563* +-51/52 = unitarity-sea, +-61/62 = gluons )
38564 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38565 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38566 & 31, 31, 31, 31, 31, 31, 31, 31,
38567 & 41, 41, 41, 41, 51, 51, 51, 51/
38568 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38569 & 32, 32, 32, 32, 32, 32, 32, 32,
38570 & 42, 42, 42, 42, 52, 52, 52, 52/
38571 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38572 & 51, 31, 41, 41, 31, 31, 31, 31,
38573 & 0, 41, 51, 51, 51, 51, 51, 51/
38574 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38575 & 32, 52, 42, 42, 32, 32, 32, 32,
38576 & 42, 0, 52, 52, 52, 52, 52, 52/
38577
38578 IF (NCHAIN.LE.0) RETURN
38579 DO 1 I=1,NCHAIN
38580 IDX1 = IDXCHN(1,I)
38581 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38582 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38583 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38584 & .AND.
38585 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38586 & (IS1P.EQ.ISP1P(MODE,3)))
38587 & .AND.
38588 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38589 & (IS1T.EQ.ISP1T(MODE,3)))
38590 & ) THEN
38591 DO 2 J=1,NCHAIN
38592 IDX2 = IDXCHN(1,J)
38593 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38594 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38595 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38596 & .AND.
38597 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38598 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38599 & .AND.
38600 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38601 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38602 & ) THEN
38603* find mother nucleons of the diquark to be splitted and of the
38604* sea-quark and reject this combination if it is not the same
38605 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38606 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38607 IANCES = 1
38608 ELSE
38609 IANCES = 2
38610 ENDIF
38611 IDXMO1 = JMOHKK(IANCES,IDX1)
38612 4 CONTINUE
38613 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38614 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38615 IANC = IANCES
38616 ELSE
38617 IANC = 1
38618 ENDIF
38619 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38620 IDXMO1 = JMOHKK(IANC,IDXMO1)
38621 GOTO 4
38622 ENDIF
38623 IDXMO2 = JMOHKK(IANCES,IDX2)
38624 5 CONTINUE
38625 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38626 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38627 IANC = IANCES
38628 ELSE
38629 IANC = 1
38630 ENDIF
38631 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38632 IDXMO2 = JMOHKK(IANC,IDXMO2)
38633 GOTO 5
38634 ENDIF
38635 IF (IDXMO1.NE.IDXMO2) GOTO 2
38636* quark content of projectile parton
38637 IP1 = IDHKK(JMOHKK(1,IDX1))
38638 IP11 = IP1/1000
38639 IP12 = (IP1-1000*IP11)/100
38640 IP2 = IDHKK(JMOHKK(2,IDX1))
38641 IP21 = IP2/1000
38642 IP22 = (IP2-1000*IP21)/100
38643* quark content of target parton
38644 IT1 = IDHKK(JMOHKK(1,IDX2))
38645 IT11 = IT1/1000
38646 IT12 = (IT1-1000*IT11)/100
38647 IT2 = IDHKK(JMOHKK(2,IDX2))
38648 IT21 = IT2/1000
38649 IT22 = (IT2-1000*IT21)/100
38650* split diquark and form new chains
38651 IF (MODE.EQ.1) THEN
38652 IF (IT1.EQ.4) GOTO 2
38653 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38654 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38655 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38656 ELSEIF (MODE.EQ.2) THEN
38657 IF (IT2.EQ.4) GOTO 2
38658 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38659 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38660 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38661 ELSEIF (MODE.EQ.3) THEN
38662 IF (IT1.EQ.4) GOTO 2
38663 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38664 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38665 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38666 ELSEIF (MODE.EQ.4) THEN
38667 IF (IT2.EQ.4) GOTO 2
38668 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38671 ELSEIF (MODE.EQ.5) THEN
38672 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38675 ELSEIF (MODE.EQ.6) THEN
38676 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38679 ELSEIF (MODE.EQ.7) THEN
38680 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38681 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38682 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38683 ELSEIF (MODE.EQ.8) THEN
38684 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38685 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38686 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38687 ENDIF
38688 IF (IREJ.GE.1) THEN
38689 if ((ipq.lt.0).or.(ipq.ge.4))
38690 & write(LOUT,*) 'ipq !!!',ipq,mode
38691 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38692* accept or reject new chains corresponding to PDBSEA
38693 ELSE
38694 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38695 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38696 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38697 ELSEIF (IPQ.EQ.3) THEN
38698 ACC = DBRKA(3,MODE)
38699 REJ = DBRKR(3,MODE)
38700 ELSE
38701 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38702 STOP
38703 ENDIF
38704 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38705 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38706 IACC = 1
38707 ELSE
38708 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38709 IACC = 0
38710 ENDIF
38711* new chains have been accepted and are now copied into HKKEVT
38712 IF (IACC.EQ.1) THEN
38713 IF (LEMCCK) THEN
38714 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38715 & PHKK(3,IDX1),PHKK(4,IDX1),
38716 & 1,IDUM1,IDUM2)
38717 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38718 & PHKK(3,IDX2),PHKK(4,IDX2),
38719 & 2,IDUM1,IDUM2)
38720 ENDIF
38721 IDHKK(IDX1) = 99888
38722 IDHKK(IDX2) = 99888
38723 IDXCHN(2,I) = -1
38724 IDXCHN(2,J) = -1
38725 DO 3 K=1,IGCOUN
38726 NHKK = NHKK+1
38727 CALL HKKHKT(NHKK,K)
38728 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38729 PX = -PHKK(1,NHKK)
38730 PY = -PHKK(2,NHKK)
38731 PZ = -PHKK(3,NHKK)
38732 PE = -PHKK(4,NHKK)
38733 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38734 ENDIF
38735 3 CONTINUE
38736 IF (LEMCCK) THEN
38737 CHKLEV = 0.1D0
38738 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38739 & IREJ)
38740 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38741 ENDIF
38742 GOTO 1
38743 ENDIF
38744 ENDIF
38745 ENDIF
38746 2 CONTINUE
38747 ENDIF
38748 1 CONTINUE
38749 RETURN
38750 END
38751
38752*$ CREATE DT_CQPAIR.FOR
38753*COPY DT_CQPAIR
38754*
38755*===cqpair=============================================================*
38756*
38757 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38758
38759************************************************************************
38760* This subroutine Creates a Quark-antiquark PAIR from the sea. *
38761* *
38762* XQMAX maxium energy fraction of quark (input) *
38763* XAQMAX maxium energy fraction of antiquark (input) *
38764* XQ energy fraction of quark (output) *
38765* XAQ energy fraction of antiquark (output) *
38766* IFLV quark flavour (- antiquark flavor) (output) *
38767* *
38768* This version dated 14.5.00 is written by S. Roesler. *
38769************************************************************************
38770
38771 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38772 SAVE
38773
38774 PARAMETER ( LINP = 10 ,
38775 & LOUT = 6 ,
38776 & LDAT = 9 )
38777
38778* Lorentz-parameters of the current interaction
38779 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38780 & UMO,PPCM,EPROJ,PPROJ
38781
38782*
38783 IREJ = 0
38784 XQ = 0.0D0
38785 XAQ = 0.0D0
38786*
38787* sample quark flavour
38788*
38789* set seasq here (the one from DTCHAI should be used in the future)
38790 SEASQ = 0.5D0
38791 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38792*
38793* sample energy fractions of sea pair
38794* we first sample the energy fraction of a gluon and then split the gluon
38795*
38796* maximum energy fraction of the gluon forced via input
38797 XGMAXI = XQMAX+XAQMAX
38798* minimum energy fraction of the gluon
38799 XTHR1 = 4.0D0 /UMO**2
38800 XTHR2 = 0.54D0/UMO**1.5D0
38801 XGMIN = MAX(XTHR1,XTHR2)
38802* maximum energy fraction of the gluon
38803 XGMAX = 0.3D0
38804 XGMAX = MIN(XGMAXI,XGMAX)
38805 IF (XGMIN.GE.XGMAX) THEN
38806 IREJ = 1
38807 RETURN
38808 ENDIF
38809*
38810* sample energy fraction of the gluon
38811 NLOOP = 0
38812 1 CONTINUE
38813 NLOOP = NLOOP+1
38814 IF (NLOOP.GE.50) THEN
38815 IREJ = 1
38816 RETURN
38817 ENDIF
38818 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38819 EGLUON = XGLUON*UMO/2.0D0
38820*
38821* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38822 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38823 ZMAX = 1.0D0-ZMIN
38824 RZ = DT_RNDM(ZMAX)
38825 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38826 RQ = DT_RNDM(ZMAX)
38827 IF (RQ.LT.0.5D0) THEN
38828 XQ = XGLUON*XHLP
38829 XAQ = XGLUON-XQ
38830 ELSE
38831 XAQ = XGLUON*XHLP
38832 XQ = XGLUON-XAQ
38833 ENDIF
38834 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38835
38836 RETURN
38837 END